1
#########################################################################/**
2
# @set class=default
3
# @RdocMethod getAttributes
4
# @aliasmethod getAttribute
5
# @aliasmethod hasAttribute
6
# @aliasmethod setAttributes
7
# @aliasmethod setAttribute
8
# @aliasmethod getMetadata
9
# @aliasmethod setMetadata
10
#
11
# @title "Gets and sets attributes of an object"
12
#
13
# \description{
14
#  @get "title".
15
# }
16
#
17
# @synopsis
18
#
19
# \arguments{
20
#   \item{object}{An object.}
21
#   \item{private}{If @TRUE, attributes starting with a period are
22
#         also returned, otherwise not.}
23
#   \item{...}{Not used.}
24
# }
25
#
26
# \value{
27
#   Returns a named @list, @NULL or a modified object itself.
28
# }
29
#
30
# @author
31
#
32
# @keyword internal
33
#*/#########################################################################
34
setMethodS3("getAttributes", "default", function(object, private=FALSE, ...) {
35 1
  attrs <- attributes(object)
36 1
  keys <- names(attrs)
37 1
  keys <- setdiff(keys, c("class", "names"))
38

39
  # Exclude private attributes?
40 1
  if (!private) {
41 1
    pattern <- sprintf("^[%s]", paste(c(base::letters, base::LETTERS), collapse=""))
42 1
    keys <- keys[regexpr(pattern, keys) != -1L]
43
  }
44

45 1
  attrs <- attrs[keys]
46 1
  attrs
47
})
48

49
setMethodS3("getAttribute", "default", function(object, name, default=NULL, private=TRUE, ...) {
50 1
  attrs <- getAttributes(object, private=private, ...)
51 1
  if (!is.element(name, names(attrs))) {
52 1
    attr <- default
53
  } else {
54 1
    attr <- attrs[[name]]
55
  }
56 1
  attr
57
})
58

59
setMethodS3("hasAttribute", "default", function(object, name, private=TRUE, ...) {
60 1
  attrs <- getAttributes(object, private=private, ...)
61 1
  is.element(name, names(attrs))
62
})
63

64
setMethodS3("setAttributes", "default", function(object, attrs, ...) {
65
  # Argument 'attrs':
66 1
  if (is.null(attrs)) {
67 0
    return(invisible(object))
68
  }
69 1
  if (!is.list(attrs)) {
70 0
    throw("Cannot set attributes. Argument 'attrs' is not a list: ", mode(attrs)[1L])
71
  }
72

73

74
  # Current attributes
75 1
  attrsD <- attributes(object)
76

77
  # Update/add new attributes
78 1
  keys <- names(attrs)
79 1
  keys <- setdiff(keys, c("class", "names"))
80 1
  for (key in keys) {
81 1
    attrsD[[key]] <- attrs[[key]]
82
  }
83

84 1
  attributes(object) <- attrsD
85

86 1
  invisible(object)
87
})
88

89
setMethodS3("setAttribute", "default", function(object, name, value, ...) {
90 1
  attrs <- list(value)
91 1
  names(attrs) <- name
92 1
  setAttributes(object, attrs, ...)
93
})
94

95

96

97

98
setMethodS3("getMetadata", "default", function(object, name=NULL, default=NULL, local=FALSE, ...) {
99 1
  res <- getAttribute(object, "metadata", default=list())
100 1
  if (!local) {
101 1
    isLocal <- is.element(names(res), "source")
102 1
    res <- res[!isLocal]
103
  }
104 1
  if (!is.null(name)) {
105 1
    if (is.element(name, names(res))) {
106 1
      res <- res[[name]]
107
    } else {
108 1
      res <- default
109
    }
110
  }
111 1
  res
112
}, protected=TRUE)
113

114

115
setMethodS3("setMetadata", "default", function(object, metadata=NULL, name, value, ...) {
116 1
  data <- getMetadata(object, local=TRUE)
117

118 1
  if (!is.null(metadata)) {
119 1
    for (name in names(metadata)) {
120 1
      data[[name]] <- metadata[[name]]
121
    }
122
  } else {
123 1
    data[[name]] <- value
124
  }
125

126 1
  setAttribute(object, "metadata", data)
127
}, protected=TRUE)

Read our documentation on viewing source code .

Loading