1# These are functions that examine an XML node and
2# defines a class for each complex type.
3
4#
5# Need to make this work recursively
6#
7
8
9xmlToS4List =
10function(from, class = xmlName(from), type = gsub("s$", "", xmlName(from)))
11{
12  new(class, xmlApply(from, as, type))
13}
14
15setGeneric("xmlToS4",
16function(node, obj = new(xmlName(node)), ...)
17 standardGeneric("xmlToS4")
18)
19
20
21setMethod("xmlToS4", "XMLInternalNode",
22 function(node, obj = new(xmlName(node)), ...)
23{
24  if(is(obj, "character") && !isS4(obj))
25    obj = new(obj)
26
27#  if(xmlSize(node) == 1 && node[[1]])
28#    return(as())
29  ids = names(node)
30  nodes = xmlChildren(node)
31  obj = addXMLAttributes(obj, xmlAttrs(node, addNamespacePrefix = TRUE))
32
33  slotIds = slotNames(obj)
34  slots = getClass(class(obj))@slots
35
36
37if(any(duplicated(ids))) {
38     # experimenting with a different way of doing this.
39     # Group the nodes with the same names and the process those.
40  groupedNodes = split(nodes, ids)
41  ids = intersect(names(groupedNodes), slotIds)
42  for(i in ids) {
43    tmp = groupedNodes[[i]]
44    slot = slots[[i]]
45    if(length(tmp) > 1) {
46      val = lapply(tmp, convertNode, slot)
47      val = if(isAtomicType(slot))
48              unlist(val)
49            else
50              as(val, slot) # may be a specific sub-type of list
51    } else {
52       el = tmp[[1]]
53       val = convertNode(el, slot)
54    }
55    slot(obj, i) <- val
56
57  }
58} else {
59
60  # This was the original mechanism but it doesn't handle multiple nodes of the same name.
61  for(i in seq(along = nodes)) {
62     if(ids[i] %in% slotIds) {
63
64       val = if(slots[[ids[i]]] == "character")
65                 xmlValue(nodes[[i]])
66             else
67                tryCatch(as(nodes[[i]], slots[[ids[i]]]),
68                         error = function(e)
69                                    xmlToS4(nodes[[i]]))
70
71       slot(obj, ids[i]) <- val #    xmlToS4(nodes[[i]])
72     }
73     # obj = addAttributes(obj,  xmlAttrs(nodes[[i]]))
74  }
75}
76
77  obj
78})
79
80convertNode =
81function(el, slot)
82{
83  if(slot == "character")
84    xmlValue(el)
85  else
86    tryCatch(as(el, slot),
87             error = function(e)
88                         xmlToS4(el))
89}
90
91isAtomicType =
92  #
93  # check if className refers to a primitive/atomic type
94  # or not.
95function(className)
96{
97  atomicTypes = c("logical", "integer", "numeric", "character")
98  if(className %in% atomicTypes)
99    return(TRUE)
100
101  k = getClassDef(className)
102  length(intersect(names(k@contains), atomicTypes)) > 0
103}
104
105
106addXMLAttributes =
107function(obj, attrs)
108{
109  slots = getClass(class(obj))@slots
110  i = match(names(attrs), names(slots))
111
112   # handle any namespace prefix
113  if(any(is.na(i))) {
114     w = grepl(":", names(attrs)) & is.na(i)
115     if(any(w))
116       i[which(w)] = match(gsub(".*:", "", names(attrs)[which(w)]), names(slots))
117  }
118
119  m = i
120  if(any(!is.na(i))) {
121    vals = structure(attrs[!is.na(i)], names = names(slots)[i [!is.na(i)] ])
122    for(i in names(vals))
123      slot(obj, i) <- as(vals[i], slots[[i]])
124  }
125
126  obj
127}
128
129
130makeClassTemplate =
131  #
132  # Get the class representation information to represent the contents of
133  # an XML node.
134  #
135  #
136function(xnode, types = character(), default = "ANY", className = xmlName(xnode),
137         where = globalenv())
138{
139  user.types = types
140
141  slots = names(xnode)
142  types =
143    xmlSApply(xnode, function(x) {
144                      if(xmlSize(x) == 0)
145                        default
146                      else if(xmlSize(x) == 1 || is(x, "XMLInternalTextNode"))
147                        "character"
148                      else
149                          xmlName(x)
150                    })
151  names(types) = slots
152  types[names(xmlAttrs(xnode))] = "character"
153
154  if(length(user.types))
155    types[names(user.types)] = user.types
156
157  coerce = sprintf("setAs('XMLAbstractNode', '%s', function(from) xmlToS4(from))", className)
158  def = if(length(types))
159           sprintf("setClass('%s',\n    representation(%s))", className,
160                      paste(sQuote(names(types)), sQuote(types), sep = " = ", collapse = ",\n\t"))
161        else
162          sprintf("setClass('%s')", className)
163
164  if(!is.null(where) && !(is.logical(where) && !where)) {
165    eval(parse(text = def), envir = where)
166    eval(parse(text = coerce), envir = where)
167  }
168
169  list(name = className, slots = types,
170       def = def, coerce = coerce)
171}
172
173
174
175setAs("XMLAbstractNode", "integer",
176      function(from)
177       as.integer(xmlValue(from)))
178
179
180setAs("XMLAbstractNode", "numeric",
181      function(from)
182       as.numeric(xmlValue(from)))
183
184setAs("XMLAbstractNode", "character",
185      function(from)
186        xmlValue(from))
187
188setAs("XMLAbstractNode", "URL",
189      function(from)
190        new("URL", xmlValue(from)))
191
192setAs("XMLAbstractNode", "logical",
193      function(from)
194        as.logical(xmlValue(from)))
195
196setAs("XMLAbstractNode", "Date",
197      function(from)
198        as.Date(xmlValue(from), "%Y-%m-%d"))
199
200setAs("XMLAbstractNode", "POSIXct",
201      function(from)
202        as.POSIXct(strptime(xmlValue(from), "%Y-%m-%d %H:%M:%S")))
203
204
205
206makeXMLClasses =
207function(doc, omit = character(), eval = FALSE)
208{
209  a = getNodeSet(doc, "//*")
210  ids = unique(sapply(a, xmlName))
211  if(length(omit))
212    ids = setdiff(ids, omit)
213  lapply(ids, function(id) makeClassTemplate(getNodeSet(doc, sprintf("//%s", id))[[1]], where = eval))
214}
215