/usr/lib/R/site-library/XML/examples/xmlSource.R is in r-cran-xml 3.98-1.10-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 | xmlSource <-
#
# This is equivalent to source() but works
# on an XML file with special tags.
# See xml2tex.Sxml or promptXML.Sxml
# for an early example.
#
function(file, env = globalenv(), include=character(0), validate = F, ..., trim=F)
{
# This handler will convert a XMLNode tag <fragment>....</fragment>
# into one with the additional class XMLFragmentNode, and
# a reference to a fragment <fragmentRef id="?">
# to an object of class XMLFragmentRefNode
h <- list(fragment=function(x, attr){ class(x) <- c("XMLFragmentNode", class(x))
x
},
fragmentRef=function(x, attr){ class(x) <- c("XMLFragmentRefNode", class(x))
x
},
defRef=function(x, attr){ class(x) <- c("XMLFunctionDefNode", class(x))
x
},
Sexpression=function(x, attr){ class(x) <- c("XMLSExpressionNode", class(x))
x
})
# Parse the tree, using the handlers above.
doc <- xmlTreeParse(file, handlers=h, validate=as.logical(validate), ..., trim=trim, asTree=T)
r <- xmlRoot(doc)
# Get all the top-level fragment elements from the document
# and massage them into a usable form. This means forming
# a named list whose elements are the fragment contents/definitions
# and whose names are the ids of the fragments.
fragments <- xmlChildren(r)[names(r) == "fragment"]
tmp <- sapply(fragments, function(x) xmlAttrs(x)["id"])
# fragments <- sapply(fragments, function(x) xmlValue(x[[1]]))
names(fragments) <- tmp
# Process all the children in the document. An apply..?
# Perhaps a closure so that we can append the
# functions that are defined to a list....
funs <- character(0)
for(i in xmlChildren(r)[names(r) != "fragment"]) {
# if the node is a processing instruction for R (<?R ...?>),
# evaluate its contents as an R expression.
if(inherits(i, "XMLProcessingInstruction") & xmlName(i) == "R")
eval(parse(text=xmlValue(i)))
else if(inherits(i, "XMLTextNode")) {
# Otherwise, if it is a text node, just print it.
print(xmlValue(i)); cat("\n")
} else if(inherits(i, "XMLSExpressionNode")) {
xmlExpressionEval(i, r, env, fragments)
} else {
# Now, let's handle the other tags via switch statment.
# Function definitions are handed to xmlFunctionDef() along
# with the document itself, the list of fragments in which
# chunk/fragment references can be resolved and finally the
# environment in which to assign the function definition.
obj <- switch(xmlName(i), "function" = xmlFunctionDef(i, r, env, fragments, include))
funs <- c(funs, obj)
}
}
invisible(list(doc=r, defs = funs, file=file))
}
xmlExpressionEval <-
#
# Need to resolve the references here.
#
function(node, root, env = globalenv(), fragments = NULL)
{
txt <- paste(unlist(xmlSApply(node, xmlValue)), collapse=" ")
eval(parse(text=txt), envir=env)
}
xmlFunctionDef <-
#
# This takes a function definition in XML form and
# resolves any fragment references and so generates
# a complete textual version of the function body and
# argument list.
# It grabs the name from the <name> tag assumed to be
# at the top of the function definition.
#
#
# Needs to handle cross-references.
# That's why we need the entire document here.
#
function(node, root, env = globalenv(), fragments = NULL, includes=character(0))
{
# First determine if this can run or not.
isR <- length(xmlAttrs(node)) == 0 | is.na(match("lang", names(xmlAttrs(node))))
if(!isR) {
lang <- xmlAttrs(node)["lang"]
isR <- lang== "S" | lang=="R"
}
if(!isR){
warning(paste("Skipping function", xmlAttrs(node)["lang"]))
return(F)
}
# What about multiple chunks within the definition
def <- node[["def"]]
if(is.null(def))
return(NULL)
def <- xmlFunctionDef.XMLFunctionDefNode(def, root, env, fragments)
if(!is.na(match("sname", names(node)))) {
name <- xmlValue(node[["sname"]][[1]])
if(length(includes)) {
if(is.na(match(name, includes)))
warning(paste("Skipping function", name))
}
# cat("Defining function",name,"\n")
assign(name, def, envir=env)
return(name)
} else {
return(def)
}
}
xmlFunctionDef.XMLFunctionDefNode <-
#
# This attempts to convert the contents of a <def>...</def>
# element into a function definition. It does so by converting each
# element within this <def> to text, resolving any fragment references
# and converting them to text recursively.
#
function(node, root, env = globalenv(), fragments = NULL)
{
txt <- character(0)
for(i in xmlChildren(node)) {
if(inherits(i, "XMLFragmentRefNode"))
txt <- c(txt, xmlResolveFragmentRefs(i, root, fragments))
else {
txt <- c(txt, " ", xmlValue(i))
}
}
#cat("Parsing.... ",paste(txt, collapse=""), "\n")
obj <- eval(parse(text=paste(txt, collapse="")), envir = env)
invisible(obj)
}
xmlResolveFragmentRefs <-
function(body, root, fragments = NULL)
{
UseMethod("xmlResolveFragmentRefs")
}
xmlResolveFragmentRefs.XMLFragmentRefNode <-
function(body, root, fragments = NULL)
{
id <- xmlAttrs(body)["id"]
v <- xmlValue(fragments[[id]][[1]])
return(v)
}
xmlResolveFragmentRefs.XMLNode <-
function(body, root, fragments = NULL)
{
v <- xmlSApply(body, function(x, fragments) {
if(inherits(x, "XMLFragmentRefNode")) {
id <- xmlAttrs(x)["id"]
# print(class(fragments[[id]]));print(xmlSize(fragments[[id]]));print(fragments[[id]])
v <- xmlSApply(fragments[[id]], function(x, root, fragments) {
print(class(x))
if(inherits(x,"XMLFragmentRefNode")) {
print(x)
xmlResolveFragmentRefs(x, root, fragments)
} else if(inherits(x,"XMLNode"))
xmlValue(x)
else
x
}, root=root, fragments=fragments)
v <- paste(as.character(unlist(v)), collapse=" ")
#print(v)
} else
v <- c("\n",xmlValue(x))
v
}, fragments = fragments)
paste(as.character(unlist(v)), collapse="")
}
|