https://github.com/cran/XML
Tip revision: 4551266dc38b9231e60a64700d1004dcdb47ee45 authored by Duncan Temple Lang on 25 April 2007, 00:00:00 UTC
version 1.7-3
version 1.7-3
Tip revision: 4551266
xmlSource.R
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="")
}