The R Project SVN R-packages

## needed for sanity
.children <- .this <- .nodes <- .parents <- NULL


nodeIdGenerator =
  #
  # Not currently used. See asXMLTreeNode and the alternative default
  #  argument for XMLHashTree instances which would allow us to use
  # this function. But then we'd have to deal XMLFlatListTree differently.
  #
function(suggestion = "", env) {
       # the check to see if suggestion is a name in env is very expensive? Is it?
     if(suggestion == "" || exists(suggestion, env, inherits = FALSE)) 
        as.character(length(objects(env))) # .count + 1) 
     else
        suggestion
  }


asXMLTreeNode =
function(node, env,
         id = get(".nodeIdGenerator", env)(xmlName(node)), # nodeIdGenerator(xmlName(node), env),   
         className = "XMLTreeNode")
{
  node$id = id
  node$env = env
  class(node) = c(className, class(node))
  node
}

addParentNode =
function(node, kids = character())
{
  if(!inherits(node, 'XMLTreeNode')) {
     node = asXMLTreeNode(node, .this)
  }
  id = node$id
  .children[[ id ]] <<-  kids
  .parents[ kids ] <<- id
  .nodes[[ id ]] <<- node

  id
}  


addNode.XMLFlatListTree =
function(node, parent, to, ...)
{
  e = parent$env
  if(!("id" %in% names(unclass(node))))
       node$id = get(".nodeIdGenerator", e)(xmlName(node))

  node$env = parent$env
  
  id = node$id
  nodes <- get(".nodes", e)
  nodes[[ id ]] <- node
  assign(".nodes", nodes, e)  
  
  p = get(".parents", e)
  p[id] = parent$id
  assign(".parents", p, e)

  kids = get(".children", e)
  kids[[ parent$id ]] <- c(kids[[ parent$id ]] , node$id)
  assign(".children", kids, e)  
  
  node
}  




names.XMLFlatTree =
function(x) {
   names(get(".nodes", x))
}

"$.XMLFlatListTree" =
function(x, name) {
  get(".nodes", envir = x)[[name]]
}

xmlRoot.XMLFlatTree =
function(x, skip = TRUE, ...)
{
   p = get(".parents", x)
#XXX   
}  



xmlChildren.XMLTreeNode =
function(x, addNames = TRUE, ...)
{
  e = x$env
  kids = get(".children", e)
  nodes = get(".nodes", e)

  ans = if(x$id %in% names(kids))
            nodes[ kids[[ x$id ]] ]
        else
            list()

  structure(ans, class = "XMLNodeList")
}  

if(useS4)
  setMethod("xmlChildren", "XMLTreeNode", xmlChildren.XMLTreeNode)



setMethod("xmlParent", "XMLTreeNode",
function(x, ...)
{
  p = get(".parents", x$env)
  idx = match(x$id, names(p))
  if(is.na(idx))
      return(NULL)

  get(".nodes", x$env)[[ p[x$id] ]]
})



xmlToList =
function(node, addAttributes = TRUE, simplify = FALSE)
{
  if(is.character(node))
    node = xmlParse(node)

  if(inherits(node, "XMLAbstractDocument"))
    node = xmlRoot(node)

  if(any(inherits(node, c("XMLTextNode", "XMLInternalTextNode"))))
     xmlValue(node)
  else if(xmlSize(node) == 0)
     xmlAttrs(node)
  else {
     if(is.list(node)) {  # inherits(node, "XMLAbstractNode"))
       tmp = vals = xmlSApply(node, xmlToList, addAttributes)
       tt = xmlSApply(node, inherits, c("XMLTextNode", "XMLInternalTextNode"))       
     } else {
        tmp = vals = (if(simplify) xmlSApply else xmlApply)(node, xmlToList, addAttributes)
        tt = xmlSApply(node, inherits, c("XMLTextNode", "XMLInternalTextNode"))
     }
     vals[tt] = (if(simplify) sapply else lapply)(vals[tt], function(x) x[[1]])

     if(length(attrs <- xmlAttrs(node)) > 0) {
       if(addAttributes)
         vals[[".attrs"]] = attrs
       else
         attributes(vals) = as.list(attrs)
     }
     
     if(any(tt) && length(vals) == 1)
       vals[[1]]
     else
       vals
  }
}


indexOfNode =
  #XXX Do this for hash trees.
function(x)
{
  if(!inherits(x, "XMLInternalNode"))
    stop("must be an internal node")
  
  .Call("R_XML_indexOfChild", x, PACKAGE = "XML")
}