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