[rkward-cvs] SF.net SVN: rkward-code:[4773] trunk/rkward/packages/XiMpLe
m-eik at users.sf.net
m-eik at users.sf.net
Wed Mar 5 00:57:34 UTC 2014
Revision: 4773
http://sourceforge.net/p/rkward/code/4773
Author: m-eik
Date: 2014-03-05 00:57:33 +0000 (Wed, 05 Mar 2014)
Log Message:
-----------
code cleanup and regenereating the docs, trying to get roxygen2 3.1.0 to work... S4 is still a mess.
Modified Paths:
--------------
trunk/rkward/packages/XiMpLe/ChangeLog
trunk/rkward/packages/XiMpLe/DESCRIPTION
trunk/rkward/packages/XiMpLe/NAMESPACE
trunk/rkward/packages/XiMpLe/R/XMLNode.R
trunk/rkward/packages/XiMpLe/R/XMLTree.R
trunk/rkward/packages/XiMpLe/R/XiMpLe-internal.R
trunk/rkward/packages/XiMpLe/R/XiMpLe-internal.roxy.all.R
trunk/rkward/packages/XiMpLe/R/XiMpLe-package.R
trunk/rkward/packages/XiMpLe/R/parseXMLTree.R
trunk/rkward/packages/XiMpLe/R/pasteXMLTag.R
trunk/rkward/packages/XiMpLe/R/zzz_is_get_utils.R
trunk/rkward/packages/XiMpLe/debian/changelog
trunk/rkward/packages/XiMpLe/debian/control
trunk/rkward/packages/XiMpLe/debian/copyright
trunk/rkward/packages/XiMpLe/debian/rules
trunk/rkward/packages/XiMpLe/inst/CITATION
trunk/rkward/packages/XiMpLe/inst/NEWS.Rd
trunk/rkward/packages/XiMpLe/man/XMLGetters-methods.Rd
trunk/rkward/packages/XiMpLe/man/XMLNode.Rd
trunk/rkward/packages/XiMpLe/man/XMLTree.Rd
trunk/rkward/packages/XiMpLe/man/XiMpLe-package.Rd
trunk/rkward/packages/XiMpLe/man/node.Rd
trunk/rkward/packages/XiMpLe/man/parseXMLTree.Rd
trunk/rkward/packages/XiMpLe/man/pasteXML-methods.Rd
trunk/rkward/packages/XiMpLe/man/pasteXMLTag.Rd
trunk/rkward/packages/XiMpLe/man/show-methods.Rd
Added Paths:
-----------
trunk/rkward/packages/XiMpLe/R/00_class_01_XiMpLe.node.R
trunk/rkward/packages/XiMpLe/R/00_class_02_XiMpLe.doc.R
trunk/rkward/packages/XiMpLe/R/01_method_01_pasteXML.R
trunk/rkward/packages/XiMpLe/R/01_method_02_node.R
trunk/rkward/packages/XiMpLe/R/01_method_03_show.R
Removed Paths:
-------------
trunk/rkward/packages/XiMpLe/R/XiMpLe.doc-class.R
trunk/rkward/packages/XiMpLe/R/XiMpLe.node-class.R
trunk/rkward/packages/XiMpLe/R/node.R
trunk/rkward/packages/XiMpLe/R/pasteXML-methods.R
trunk/rkward/packages/XiMpLe/R/show-methods.R
Modified: trunk/rkward/packages/XiMpLe/ChangeLog
===================================================================
--- trunk/rkward/packages/XiMpLe/ChangeLog 2013-12-21 19:33:05 UTC (rev 4772)
+++ trunk/rkward/packages/XiMpLe/ChangeLog 2014-03-05 00:57:33 UTC (rev 4773)
@@ -1,6 +1,6 @@
ChangeLog for package XiMpLe
-changes in version 0.03-21 (2013-12-21)
+changes in version 0.03-22 (2014-03-05)
added:
- new attribute "as.list" added to XMLScan(), if TRUE forces the return
value to be a list of length 1 (default is still to directly return the
Modified: trunk/rkward/packages/XiMpLe/DESCRIPTION
===================================================================
--- trunk/rkward/packages/XiMpLe/DESCRIPTION 2013-12-21 19:33:05 UTC (rev 4772)
+++ trunk/rkward/packages/XiMpLe/DESCRIPTION 2014-03-05 00:57:33 UTC (rev 4773)
@@ -19,19 +19,19 @@
URL: http://reaktanz.de/?c=hacking&s=XiMpLe
Authors at R: c(person(given="Meik", family="Michalke",
email="meik.michalke at hhu.de", role=c("aut", "cre")))
-Version: 0.03-21
-Date: 2013-12-21
+Version: 0.03-22
+Date: 2014-03-05
Collate:
+ '00_class_01_XiMpLe.node.R'
+ '00_class_02_XiMpLe.doc.R'
+ '01_method_01_pasteXML.R'
'XiMpLe-internal.R'
- 'XiMpLe.node-class.R'
- 'XiMpLe.doc-class.R'
- 'node.R'
+ '01_method_02_node.R'
+ '01_method_03_show.R'
+ 'XMLNode.R'
+ 'XMLTree.R'
+ 'XiMpLe-internal.roxy.all.R'
+ 'XiMpLe-package.R'
'parseXMLTree.R'
- 'pasteXML-methods.R'
'pasteXMLTag.R'
- 'show-methods.R'
- 'XiMpLe-internal.roxy.all.R'
- 'XiMpLe-package.R'
- 'XMLNode.R'
- 'XMLTree.R'
'zzz_is_get_utils.R'
Modified: trunk/rkward/packages/XiMpLe/NAMESPACE
===================================================================
--- trunk/rkward/packages/XiMpLe/NAMESPACE 2013-12-21 19:33:05 UTC (rev 4772)
+++ trunk/rkward/packages/XiMpLe/NAMESPACE 2014-03-05 00:57:33 UTC (rev 4773)
@@ -1,32 +1,32 @@
+export("node<-")
+export(XMLNode)
+export(XMLTree)
+export(is.XiMpLe.doc)
+export(is.XiMpLe.node)
+export(node)
+export(parseXMLTree)
+export(pasteXML)
+export(pasteXMLNode)
+export(pasteXMLTag)
+export(pasteXMLTree)
exportClasses(XiMpLe.doc)
exportClasses(XiMpLe.node)
-export(is.XiMpLe.doc)
-export(is.XiMpLe.node)
-exportMethods(node)
-exportMethods("node<-")
-exportMethods(pasteXML)
-exportMethods(show)
-exportMethods(XMLAttrs)
exportMethods("XMLAttrs<-")
-exportMethods(XMLChildren)
exportMethods("XMLChildren<-")
-exportMethods(XMLDecl)
+exportMethods("XMLDTD<-")
exportMethods("XMLDecl<-")
+exportMethods("XMLFile<-")
+exportMethods("XMLName<-")
+exportMethods("XMLScan<-")
+exportMethods("XMLValue<-")
+exportMethods(XMLAttrs)
+exportMethods(XMLChildren)
exportMethods(XMLDTD)
-exportMethods("XMLDTD<-")
+exportMethods(XMLDecl)
exportMethods(XMLFile)
-exportMethods("XMLFile<-")
exportMethods(XMLName)
-exportMethods("XMLName<-")
exportMethods(XMLScan)
-exportMethods("XMLScan<-")
exportMethods(XMLScanDeep)
exportMethods(XMLValue)
-exportMethods("XMLValue<-")
-export(parseXMLTree)
-export(pasteXMLNode)
-export(pasteXMLTag)
-export(pasteXMLTree)
-export(XMLNode)
-export(XMLTree)
+exportMethods(show)
import(methods)
Added: trunk/rkward/packages/XiMpLe/R/00_class_01_XiMpLe.node.R
===================================================================
--- trunk/rkward/packages/XiMpLe/R/00_class_01_XiMpLe.node.R (rev 0)
+++ trunk/rkward/packages/XiMpLe/R/00_class_01_XiMpLe.node.R 2014-03-05 00:57:33 UTC (rev 4773)
@@ -0,0 +1,88 @@
+# Copyright 2011-2014 Meik Michalke <meik.michalke at hhu.de>
+#
+# This file is part of the R package XiMpLe.
+#
+# XiMpLe is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# XiMpLe is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with XiMpLe. If not, see <http://www.gnu.org/licenses/>.
+
+
+# Class XiMpLe.node
+#
+# This class is used to create DOM trees of XML documents, like objects that are returned
+# by \code{\link[XiMpLe:parseXMLTree]{parseXMLTree}}.
+#
+# There are certain special values predefined for the \code{name} slot to easily create special XML elements:
+# \describe{
+# \item{\code{name=""}}{If the name is an empty character string, a pseudo node is created,
+# \code{\link[XiMpLe:pasteXMLNode]{pasteXMLNode}} will paste its \code{value} as plain text.}
+# \item{\code{name="!--"}}{Creates a comment tag, i.e., this will comment out all its \code{children}.}
+# \item{\code{name="![CDATA["}}{Creates a CDATA section and places all its \code{children} in it.}
+# \item{\code{name="*![CDATA["}}{Creates a CDATA section and places all its \code{children} in it, where the CDATA markers are
+# commented out by \code{/* */}, as is used for JavaScript in XHTML.}
+# }
+#
+# @slot name Name of the node (i.e., the XML tag identifier). For special names see details.
+# @slot attributes A list of named character values, representing the attributes of this node.
+# @slot children A list of further objects of class XiMpLe.node, representing child nodes of this node.
+# @slot value Plain text to be used as the enclosed value of this node. Set to \code{value=""} if you
+# want a childless node to be forced into an non-empty pair of start and end tags by \code{\link[XiMpLe:pasteXMLNode]{pasteXMLNode}}.
+# @name XiMpLe.node,-class
+# @aliases XiMpLe.node-class XiMpLe.node,-class
+#' @import methods
+# @keywords classes
+# @rdname XiMpLe.node-class
+#' @export
+
+setClass("XiMpLe.node",
+ representation=representation(
+ name="character",
+ attributes="list",
+ children="list",
+ value="character"
+ ),
+ prototype(
+ name=character(),
+ attributes=list(),
+ children=list(),
+ value=character()
+ )
+)
+
+setValidity("XiMpLe.node", function(object){
+ obj.name <- object at name
+ obj.attributes <- object at attributes
+ obj.children <- object at children
+ obj.value <- object at value
+
+ if(isTRUE(!nchar(obj.name) > 0) & isTRUE(!nchar(obj.value) > 0)){
+ print(str(object))
+ stop(simpleError("Invalid object: A node must at least have a name or a value!"))
+ } else {}
+
+ obj.attributes.names <- names(obj.attributes)
+ # if there are attributes, check that they all have names
+ if(length(obj.attributes) > 0){
+ if(length(obj.attributes) != length(obj.attributes.names)){
+ stop(simpleError("Invalid object: All attributes must have names!"))
+ } else {}
+ } else {}
+
+ # check content of children
+ if(length(obj.children) > 0){
+ child.nodes <- sapply(obj.children, function(this.child){is.XiMpLe.node(this.child)})
+ if(!all(child.nodes)){
+ stop(simpleError("Invalid object: All list elements of children must be of class XiMpLe.node!"))
+ } else {}
+ } else {}
+ return(TRUE)
+})
Added: trunk/rkward/packages/XiMpLe/R/00_class_02_XiMpLe.doc.R
===================================================================
--- trunk/rkward/packages/XiMpLe/R/00_class_02_XiMpLe.doc.R (rev 0)
+++ trunk/rkward/packages/XiMpLe/R/00_class_02_XiMpLe.doc.R 2014-03-05 00:57:33 UTC (rev 4773)
@@ -0,0 +1,77 @@
+# Copyright 2011-2014 Meik Michalke <meik.michalke at hhu.de>
+#
+# This file is part of the R package XiMpLe.
+#
+# XiMpLe is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# XiMpLe is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with XiMpLe. If not, see <http://www.gnu.org/licenses/>.
+
+
+# Class XiMpLe.doc
+#
+# This class is used for objects that are returned by \code{\link[XiMpLe:parseXMLTree]{parseXMLTree}}.
+#
+# @slot file Character string, Name of the file.
+# @slot xml A named list, XML declaration of the file.
+# @slot dtd A named list, Doctype definition of the file.
+# @slot children A list of objects of class XiMpLe.node, representing the DOM structure of the XML document.
+# @name XiMpLe.doc,-class
+# @aliases XiMpLe.doc-class XiMpLe.doc,-class
+#' @include 00_class_01_XiMpLe.node.R
+#' @import methods
+# @keywords classes
+# @rdname XiMpLe.doc-class
+#' @export
+
+setClass("XiMpLe.doc",
+ representation=representation(
+ file="character",
+ xml="list",
+ dtd="list",
+ children="list"
+ ),
+ prototype(
+ file=character(),
+ xml=list(),
+ dtd=list(),
+ children=list()
+ )
+)
+
+setValidity("XiMpLe.doc", function(object){
+ obj.xml <- object at xml
+ obj.dtd <- object at dtd
+ obj.children <- object at children
+
+ obj.xml.names <- names(obj.xml)
+ obj.dtd.names <- names(obj.dtd)
+ # if there are declarations, check that they all have names
+ if(length(obj.xml) > 0){
+ if(length(obj.xml) != length(obj.xml.names)){
+ stop(simpleError("Invalid object: All xml declarations must have names!"))
+ } else {}
+ } else {}
+ if(length(obj.dtd) > 0){
+ if(length(obj.dtd) != length(obj.dtd.names)){
+ stop(simpleError("Invalid object: All doctype declarations must have names!"))
+ } else {}
+ } else {}
+
+ # check content of children
+ if(length(obj.children) > 0){
+ child.nodes <- sapply(obj.children, function(this.child){is.XiMpLe.node(this.child)})
+ if(!all(child.nodes)){
+ stop(simpleError("Invalid object: All list elements of children must be of class XiMpLe.node!"))
+ } else {}
+ } else {}
+ return(TRUE)
+})
Added: trunk/rkward/packages/XiMpLe/R/01_method_01_pasteXML.R
===================================================================
--- trunk/rkward/packages/XiMpLe/R/01_method_01_pasteXML.R (rev 0)
+++ trunk/rkward/packages/XiMpLe/R/01_method_01_pasteXML.R 2014-03-05 00:57:33 UTC (rev 4773)
@@ -0,0 +1,156 @@
+# Copyright 2011-2014 Meik Michalke <meik.michalke at hhu.de>
+#
+# This file is part of the R package XiMpLe.
+#
+# XiMpLe is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# XiMpLe is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with XiMpLe. If not, see <http://www.gnu.org/licenses/>.
+
+
+#' Paste methods for XiMpLe XML objects
+#'
+#' These methods can be used to paste objects if class \code{\link[XiMpLe:XiMpLe.node-class]{XiMpLe.node}}
+#' or \code{\link[XiMpLe:XiMpLe.doc-class]{XiMpLe.doc}}.
+#'
+#' @note The functions pasteXMLNode() and pasteXMLTree() have been replaced by the pasteXML methods.
+#' They should no longer be used.
+#'
+#' @param obj An object of class \code{XiMpLe.node} or \code{XiMpLe.doc}.
+#' @aliases
+#' pasteXML,-methods
+#' pasteXML,XiMpLe.doc-method
+#' pasteXMLNode
+#' pasteXMLTree
+#' @seealso \code{\link[XiMpLe:XiMpLe.node-class]{XiMpLe.node}},
+#' \code{\link[XiMpLe:XiMpLe.doc-class]{XiMpLe.doc}}
+#' @keywords methods
+#' @rdname pasteXML-methods
+#' @include 00_class_01_XiMpLe.node.R
+#' @include 00_class_02_XiMpLe.doc.R
+#' @docType methods
+#' @export
+setGeneric("pasteXML", function(obj, ...) standardGeneric("pasteXML"))
+
+#' @param level Indentation level.
+#' @param shine Integer, controlling if the output should be formatted for better readability. Possible values:
+#' \describe{
+#' \item{0}{No formatting.}
+#' \item{1}{Nodes will be indented.}
+#' \item{2}{Nodes will be indented and each attribute gets a new line.}
+#' }
+#' @param indent.by A charachter string defining how indentation should be done. Defaults to tab.
+#' @param tidy Logical, if \code{TRUE} the special characters "<" and ">" will be replaced with the entities
+#' "<" and "gt;" in attributes and text values.
+#' @rdname pasteXML-methods
+#' @aliases
+#' pasteXML,XiMpLe.node-method
+setMethod("pasteXML",
+ signature=signature(obj="XiMpLe.node"),
+ function(obj, level=1, shine=1, indent.by="\t", tidy=TRUE){
+
+ new.indent <- ifelse(shine > 0, indent(level+1, by=indent.by), "")
+ new.node <- ifelse(shine > 0, "\n", "")
+
+ # get the slot contents
+ node.name <- slot(obj, "name")
+ node.attr <- slot(obj, "attributes")
+ node.chld <- slot(obj, "children")
+ node.val <- slot(obj, "value")
+
+ if(!length(node.attr) > 0){
+ node.attr <- NULL
+ } else {}
+
+ if(length(node.chld) > 0){
+ node.chld <- paste0(unlist(sapply(node.chld, function(this.node){
+ if(slot(this.node, "name") == ""){
+ this.node.pasted <- paste0(new.indent, pasteXML(this.node, level=level, shine=shine, indent.by=indent.by, tidy=tidy))
+ } else {
+ this.node.pasted <- pasteXML(this.node, level=(level + 1), shine=shine, indent.by=indent.by, tidy=tidy)
+ }
+ return(this.node.pasted)})), collapse="")
+ node.empty <- FALSE
+ } else {
+ node.chld <- NULL
+ node.empty <- TRUE
+ }
+
+ # take care of text value
+ if(length(node.val) > 0){
+ node.empty <- FALSE
+ if(nchar(node.val) > 0){
+ if(isTRUE(tidy)){
+ node.val <- sapply(node.val, xml.tidy)
+ } else {}
+ node.chld <- paste0(node.chld, paste(node.val, new.node, collapse=" "))
+ } else {}
+ } else {}
+
+ pasted.node <- pasteXMLTag(node.name, attr=node.attr, child=node.chld, empty=node.empty, level=level, allow.empty=TRUE, rename=NULL, shine=shine, indent.by=indent.by, tidy=tidy)
+
+ return(pasted.node)
+ }
+)
+#' @rdname pasteXML-methods
+setMethod("pasteXML",
+ signature=signature(obj="XiMpLe.doc"),
+ function(obj, shine=1, indent.by="\t", tidy=TRUE){
+
+ filename <- slot(obj, "file")
+ tree.xml <- slot(obj, "xml")
+ tree.doctype <- slot(obj, "dtd")
+ tree.nodes <- slot(obj, "children")
+
+ if(any(nchar(unlist(tree.xml)) > 0)) {
+ doc.xml <- pasteXMLTag("?xml", attr=tree.xml, child=NULL, empty=TRUE, level=1, allow.empty=FALSE, rename=NULL, shine=min(1, shine), indent.by=indent.by, tidy=tidy)
+ doc.xml <- gsub("/>", "\\?>", doc.xml)
+ } else {
+ doc.xml <- ""
+ }
+
+ if(any(nchar(unlist(tree.doctype)) > 0)) {
+ new.node <- ifelse(shine > 0, "\n", "")
+ doc.doctype <- paste("<!DOCTYPE", tree.doctype[["doctype"]], tree.doctype[["decl"]], sep=" ")
+ for (elmt in c("id", "refer")){
+ if(length(tree.doctype[[elmt]]) > 0) {
+ if(nchar(tree.doctype[[elmt]]) > 0){
+ doc.doctype <- paste0(doc.doctype, " \"",tree.doctype[[elmt]], "\"")
+ } else {}
+ } else {}
+ }
+ doc.doctype <- paste0(doc.doctype, ">", new.node)
+ } else {
+ doc.doctype <- ""
+ }
+
+ if(length(tree.nodes) > 0) {
+ doc.nodes <- paste0(unlist(sapply(tree.nodes, function(this.node){
+ return(pasteXML(this.node, level=1, shine=shine, indent.by=indent.by, tidy=tidy))})), collapse="")
+ } else {
+ doc.nodes <- ""
+ }
+
+ doc.all <- paste0(doc.xml, doc.doctype, doc.nodes, collapse="")
+
+ return(doc.all)
+ }
+)
+
+# for compatibility reasons, deploy wrapper functions
+#' @export
+pasteXMLNode <- function(node, level=1, shine=1, indent.by="\t", tidy=TRUE){
+ pasteXML(node, level=level, shine=shine, indent.by=indent.by, tidy=tidy)
+}
+#' @export
+pasteXMLTree <- function(obj, shine=1, indent.by="\t", tidy=TRUE){
+ pasteXML(obj, shine=shine, indent.by=indent.by, tidy=tidy)
+}
Added: trunk/rkward/packages/XiMpLe/R/01_method_02_node.R
===================================================================
--- trunk/rkward/packages/XiMpLe/R/01_method_02_node.R (rev 0)
+++ trunk/rkward/packages/XiMpLe/R/01_method_02_node.R 2014-03-05 00:57:33 UTC (rev 4773)
@@ -0,0 +1,242 @@
+# Copyright 2011-2014 Meik Michalke <meik.michalke at hhu.de>
+#
+# This file is part of the R package XiMpLe.
+#
+# XiMpLe is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# XiMpLe is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with XiMpLe. If not, see <http://www.gnu.org/licenses/>.
+
+
+#' Extract/manipulate a node or parts of it from an XML tree
+#'
+#' This method can be used to get parts of a parsed XML tree object, or to fill it with new values.
+#'
+#' @include 00_class_01_XiMpLe.node.R
+#' @include 00_class_02_XiMpLe.doc.R
+#' @include XiMpLe-internal.R
+#' @import methods
+#' @examples
+#' \dontrun{
+#' node(my.xml.tree, node=list("html","body"), what="attributes")
+#' node(my.xml.tree, node=list("html","head","title"), what="value") <- "foobar"
+#' }
+#' @docType methods
+#' @rdname node
+#' @export
+setGeneric("node", function(obj, node=list(), what=NULL, cond.attr=NULL, cond.value=NULL, element=NULL){standardGeneric("node")})
+
+# define class union to make life easier
+#' @export
+setClassUnion("XiMpLe.XML", members=c("XiMpLe.node", "XiMpLe.doc"))
+
+#' @rdname node
+#' @aliases
+#' node,-methods
+#' node,XiMpLe.doc-method
+#' node,XiMpLe.node-method
+#' node,XiMpLe.XML-method
+#' @param obj An object of class \code{\link[XiMpLe:XiMpLe.doc-class]{XiMpLe.doc}} or
+#' \code{\link[XiMpLe:XiMpLe.node-class]{XiMpLe.node}}.
+#' @param node A list of node names (or their numeric values), where each element is
+#' the child of its previous element. duplicate matches will be returned as a list.
+#' @param what A character string, must be a valid slot name of class \code{\link[XiMpLe:XiMpLe.node-class]{XiMpLe.node}}, like
+#' \code{"attributes"} or \code{"value"}. If not \code{NULL}, only that part of a node will be returned.
+#' There's also two special properties for this option: \code{what="@@path"} will not return the
+#' node or it's contents, but a character string with the "path" to it in the object; \code{what="obj@@path"}
+#' is the same but won't have \code{obj} substituted with the object's name.
+#' @param cond.attr A named character string, to further filter the returned results.
+#' If not \code{NULL}, only nodes with fully matching attributes will be considered.
+#' @param cond.value A character string, similar to \code{cond.attr}, but is matched
+#' against the value between a pair of tags.
+#' @param element A character string naming one list element of the node slot. If \code{NULL}, all
+#' elements will be returned.
+setMethod("node",
+ signature(obj="XiMpLe.XML"),
+ function(obj, node=list(), what=NULL, cond.attr=NULL, cond.value=NULL, element=NULL){
+
+ # check top level if this is a node, not a tree
+ if(is.XiMpLe.node(obj)){
+ got.this <- identical(slot(obj, "name"), node[[1]])
+ if(!isTRUE(got.this)){
+ # apparently, this node doesn't exist
+ stop(simpleError(paste0("Can't find node ", node[[1]], " in ", sQuote(deparse(substitute(obj))), "!")))
+ } else {
+ # remove first element in list node
+ node[[1]] <- NULL
+ }
+ } else {}
+ result.node.path <- "obj"
+ for (this.node in node){
+ for (this.path in result.node.path){
+ this.node.part <- eval(parse(text=this.path))
+ got.this <- lapply(slot(this.node.part, "children"), function(this.child){slot(this.child, "name")}) %in% this.node
+ if(!any(got.this)){
+ # apparently, this node doesn't exist
+ stop(simpleError(paste0("Can't find node ", sQuote(this.node), " in ", sQuote(deparse(substitute(obj))), "!")))
+ } else {
+ result.node.path <- unique(paste0(result.node.path, paste0("@children[[",which(got.this),"]]")))
+ }
+ }
+ }
+
+ # filter by attributes
+ if(!is.null(cond.attr)){
+ filter <- names(cond.attr)
+ filtered.paths <- c()
+ for (this.path in result.node.path){
+ this.node.part <- eval(parse(text=this.path))
+ this.attrs <- slot(this.node.part, "attributes")
+ attr.found <- filter %in% names(this.attrs)
+ # were the wanted attributes found at all?
+ if(all(attr.found)){
+ # check if they're all equal
+ found.this <- sapply(filter, function(this.attr){
+ results <- unlist(cond.attr[this.attr]) == unlist(this.attrs[this.attr])
+ return(results)
+ })
+ if(all(found.this)){
+ filtered.paths <- unique(c(filtered.paths, this.path))
+ } else {}
+ } else {}
+ }
+ result.node.path <- filtered.paths
+ } else {}
+ # create a list with matching node objects
+ result.cond <- sapply(result.node.path, function(this.path){eval(parse(text=this.path))})
+ names(result.cond) <- NULL
+
+ if(!is.null(cond.value)){
+ stopifnot(length(cond.value) == 1)
+ filtered.paths <- c()
+ for (this.path in result.node.path){
+ this.node.part <- eval(parse(text=this.path))
+ this.value <- slot(this.node.part, "value")
+ if(identical(this.value, cond.value)){
+ filtered.paths <- unique(c(filtered.paths, this.path))
+ } else {}
+ }
+ result.node.path <- filtered.paths
+ } else {}
+
+ if(!is.null(what)){
+ stopifnot(length(what) == 1)
+ if(!what %in% c(slotNames(new("XiMpLe.node")), "@path", "obj at path")){
+ stop(simpleError(paste0("Invalid slot for class XiMpLe.node:", paste(sQuote(what), collapse=", "), "!")))
+ } else {}
+ if(identical(what, "@path")){
+ ## return subtituted path info
+ result.node.path <- gsub("^obj", paste(deparse(substitute(obj))), result.node.path)
+ return(result.node.path)
+ } else if(identical(what, "obj at path")){
+ ## return path info
+ return(result.node.path)
+ } else {}
+ result <- unlist(lapply(result.node.path, function(this.path){
+ this.node <- eval(parse(text=this.path))
+ results <- slot(this.node, what)
+ # special case: text values can either be directly in the value slot of a node,
+ # or in a pseudo tag as a child node, so we check both
+ if(identical(what, "value")){
+ for (this.child in slot(this.node, "children")){
+ if(identical(slot(this.child, "name"), "") & isTRUE(nchar(slot(this.child, "value")) > 0))
+ results <- paste(slot(this.child, "value"), results, sep=" ")
+ }
+ } else {}
+ if(!is.null(element)){
+ results <- results[element]
+ } else {}
+ return(results)
+ }))
+ # turn from vector to list for attributes, so they can be reached with "$"
+ if(identical(what, "attributes")){
+ result <- as.list(result)
+ } else {}
+ } else {
+ result <- unlist(lapply(result.node.path, function(this.path){
+ return(eval(parse(text=this.path)))
+ }))
+ }
+
+ # no need for a list if it's inly one node
+ if(length(result) == 1){
+ if(is.XiMpLe.node(result[[1]]) | !is.null(element)){
+ result <- result[[1]]
+ } else {}
+ } else {}
+
+ return(result)
+ }
+)
+
+#' @export
+#' @rdname node
+setGeneric("node<-", function(obj, node=list(), what=NULL, cond.attr=NULL, cond.value=NULL, element=NULL, value){standardGeneric("node<-")})
+
+#' @rdname node
+#' @aliases
+#' node<-,-methods
+#' node<-,XiMpLe.doc-method
+#' node<-,XiMpLe.node-method
+#' node<-,XiMpLe.XML-method
+setMethod("node<-",
+ signature(obj="XiMpLe.XML"),
+ function(obj, node=list(), what=NULL, cond.attr=NULL, cond.value=NULL, element=NULL, value){
+
+ # get path to node in object
+ obj.paths <- node(obj, node=node, what="obj at path", cond.attr=cond.attr, cond.value=cond.value)
+ if(is.null(obj.paths)){
+ # seems we need to create this node
+ stop(simpleError("Node not found."))
+ } else {}
+ for (this.node in obj.paths){
+ if(!is.null(what)){
+ # special case: text values can either be directly in the value slot of a node,
+ # or in a pseudo tag as a child node, so we check both and remove all
+ if(identical(what, "value")){
+ eval(parse(text=paste0(this.node, "@value <- character()")))
+ all.node.children <- slot(eval(parse(text=this.node)), "children")
+ child.is.value <- sapply(all.node.children, function(this.child){
+ if(identical(slot(this.child, "name"), "") & isTRUE(nchar(slot(this.child, "value")) > 0)){
+ return(TRUE)
+ } else {
+ return(FALSE)
+ }
+ })
+ # if we have a mix of pseudo and actual tags, we probably messed up the markup
+ if(length(all.node.children) != length(child.is.value)){
+ warning("a child node contained text values and other nodes, we probably messed up the markup!")
+ } else {}
+ remove.nodes <- paste0(this.node, "@children[child.is.value] <- NULL")
+ eval(parse(text=remove.nodes))
+
+ # paste new value into a single pseudo node
+ pseudo.node <- paste0(this.node, "@children <- append(", this.node, "@children, ",
+ "new(\"XiMpLe.node\", name=\"\", value=\"", value, "\"), after=0)")
+ eval(parse(text=pseudo.node))
+
+ # now return the object
+ return(obj)
+ } else {
+ this.node <- paste0(this.node, "@", what)
+ }
+
+ if(!is.null(element)){
+ this.node <- paste0(this.node, "[[\"",element,"\"]]")
+ } else {}
+ } else {}
+
+ eval(parse(text=paste0(this.node, " <- ", deparse(value))))
+ }
+
+ return(obj)
+ }
+)
Added: trunk/rkward/packages/XiMpLe/R/01_method_03_show.R
===================================================================
--- trunk/rkward/packages/XiMpLe/R/01_method_03_show.R (rev 0)
+++ trunk/rkward/packages/XiMpLe/R/01_method_03_show.R 2014-03-05 00:57:33 UTC (rev 4773)
@@ -0,0 +1,41 @@
+# Copyright 2011-2014 Meik Michalke <meik.michalke at hhu.de>
+#
+# This file is part of the R package XiMpLe.
+#
+# XiMpLe is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# XiMpLe is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with XiMpLe. If not, see <http://www.gnu.org/licenses/>.
+
+
+#' Show method for S4 objects of XiMpLe XML classes
+#'
+#' Used to display objects of class \code{\link[XiMpLe:XiMpLe.doc-class]{XiMpLe.doc}}
+#' and \code{\link[XiMpLe:XiMpLe.node-class]{XiMpLe.node}}
+#'
+#' @param object An object of class \code{XiMpLe.doc} or \code{XiMpLe.node}
+#' @aliases
+#' show,-methods
+#' show,XiMpLe.doc-method
+#' show,XiMpLe.node-method
+#' show,XiMpLe.XML-method
+#' @seealso
+#' \code{\link[XiMpLe:XiMpLe.doc-class]{XiMpLe.doc}}
+#' \code{\link[XiMpLe:XiMpLe.node-class]{XiMpLe.node}}
+#' @keywords methods
+#' @docType methods
+#' @exportMethod show
+#' @rdname show-methods
+#' @include 00_class_01_XiMpLe.node.R
+#' @include 00_class_02_XiMpLe.doc.R
+setMethod("show", signature(object="XiMpLe.XML"), function(object){
+ cat(pasteXML(object))
+})
Modified: trunk/rkward/packages/XiMpLe/R/XMLNode.R
===================================================================
--- trunk/rkward/packages/XiMpLe/R/XMLNode.R 2013-12-21 19:33:05 UTC (rev 4772)
+++ trunk/rkward/packages/XiMpLe/R/XMLNode.R 2014-03-05 00:57:33 UTC (rev 4773)
@@ -1,4 +1,4 @@
-# Copyright 2011-2013 Meik Michalke <meik.michalke at hhu.de>
+# Copyright 2011-2014 Meik Michalke <meik.michalke at hhu.de>
#
# This file is part of the R package XiMpLe.
#
@@ -24,16 +24,16 @@
#'
#' @param name Character string, the tag name.
#' @param ... Optional children for the tag. Must be either objects of class XiMpLe.node or character strings,
-#' which are treated as simple text values. If this is empty, the tag will be treated as an empty tag. To
-#' force a closing tag, supply an empty string, i.e. \code{""}.
+#' which are treated as simple text values. If this is empty, the tag will be treated as an empty tag. To
+#' force a closing tag, supply an empty string, i.e. \code{""}.
#' @param attrs An optional named list of attributes.
#' @param namespace Currently ignored.
#' @param namespaceDefinitions Currently ignored.
#' @param .children Alternative way of specifying children, if you have them already as a list.
#' @return An object of class \code{\link[XiMpLe:XiMpLe.node-class]{XiMpLe.node}}.
#' @seealso
-#' \code{\link[XiMpLe:XMLTree]{XMLTree}},
-#' \code{\link[XiMpLe:pasteXML]{pasteXML}}
+#' \code{\link[XiMpLe:XMLTree]{XMLTree}},
+#' \code{\link[XiMpLe:pasteXML]{pasteXML}}
#' @export
#' @rdname XMLNode
#' @examples
@@ -43,36 +43,36 @@
XMLNode <- function(name, ..., attrs=NULL, namespace="", namespaceDefinitions=NULL, .children=list(...)){
- all.children <- list()
+ all.children <- list()
- # text node?
- if(identical(name, "") &
- (all(unlist(lapply(.children, is.character)))) |
- all(unlist(lapply(.children, is.numeric)))){
- value <- paste(..., sep=" ")
- } else if(identical(.children, list(""))){
- value <- ""
- } else {
- # remove NULLs
- .children <- .children[unlist(lapply(.children, length) != 0)]
- # check for text values
- all.children <- sapply(child.list(.children), function(this.child){
- if(is.character(this.child) | is.numeric(this.child)){
- this.child <- new("XiMpLe.node",
- name="",
- value=as.character(this.child)
- )
- } else {}
- return(this.child)
- })
- value <- character()
- }
+ # text node?
+ if(identical(name, "") &
+ (all(unlist(lapply(.children, is.character)))) |
+ all(unlist(lapply(.children, is.numeric)))){
+ value <- paste(..., sep=" ")
+ } else if(identical(.children, list(""))){
+ value <- ""
+ } else {
+ # remove NULLs
+ .children <- .children[unlist(lapply(.children, length) != 0)]
+ # check for text values
+ all.children <- sapply(child.list(.children), function(this.child){
+ if(is.character(this.child) | is.numeric(this.child)){
+ this.child <- new("XiMpLe.node",
+ name="",
+ value=as.character(this.child)
+ )
+ } else {}
+ return(this.child)
+ })
+ value <- character()
+ }
- newNode <- new("XiMpLe.node",
- name=name,
- attributes=as.list(attrs),
- children=all.children,
- value=value)
+ newNode <- new("XiMpLe.node",
+ name=name,
+ attributes=as.list(attrs),
+ children=all.children,
+ value=value)
- return(newNode)
+ return(newNode)
}
Modified: trunk/rkward/packages/XiMpLe/R/XMLTree.R
===================================================================
--- trunk/rkward/packages/XiMpLe/R/XMLTree.R 2013-12-21 19:33:05 UTC (rev 4772)
+++ trunk/rkward/packages/XiMpLe/R/XMLTree.R 2014-03-05 00:57:33 UTC (rev 4773)
@@ -1,4 +1,4 @@
-# Copyright 2011-2013 Meik Michalke <meik.michalke at hhu.de>
+# Copyright 2011-2014 Meik Michalke <meik.michalke at hhu.de>
#
# This file is part of the R package XiMpLe.
#
@@ -21,17 +21,17 @@
#' Can be used to create full XML trees.
#'
#' @param ... Optional children for the XML tree. Must be either objects of class
-#' \code{\link[XiMpLe:XiMpLe.node-class]{XiMpLe.node}} or character strings,
-#' which are treated as simple text values.
+#' \code{\link[XiMpLe:XiMpLe.node-class]{XiMpLe.node}} or character strings,
+#' which are treated as simple text values.
#' @param xml A named list, XML declaration of the XML tree. Currently just pasted, no checking is done.
#' @param dtd A named list, doctype definition of the XML tree. Valid elements are \code{doctype} (root element), \code{decl}
#' ("PUBLIC" or "SYSTEM"), \code{id} (the identifier) and \code{refer} (URI to .dtd).
-#' Currently just pasted, no checking is done.
+#' Currently just pasted, no checking is done.
#' @param .children Alternative way of specifying children, if you have them already as a list.
#' @return An object of class \code{\link[XiMpLe:XiMpLe.doc-class]{XiMpLe.doc}}
#' @seealso
-#' \code{\link[XiMpLe:XMLNode]{XMLNode}},
-#' \code{\link[XiMpLe:pasteXML]{pasteXML}}
+#' \code{\link[XiMpLe:XMLNode]{XMLNode}},
+#' \code{\link[XiMpLe:pasteXML]{pasteXML}}
#' @export
#' @rdname XMLTree
#' @examples
@@ -49,32 +49,32 @@
XMLTree <- function(..., xml=NULL, dtd=NULL, .children=list(...)){
- # remove NULLs
- .children <- .children[unlist(lapply(.children, length) != 0)]
+ # remove NULLs
+ .children <- .children[unlist(lapply(.children, length) != 0)]
- # check for text values
- all.children <- sapply(child.list(.children), function(this.child){
- if(is.character(this.child)){
- this.child <- new("XiMpLe.node",
- name="",
- value=this.child
- )
- } else {}
- return(this.child)
- })
+ # check for text values
+ all.children <- sapply(child.list(.children), function(this.child){
+ if(is.character(this.child)){
+ this.child <- new("XiMpLe.node",
+ name="",
+ value=this.child
+ )
+ } else {}
+ return(this.child)
+ })
- if(is.null(xml)){
- xml <- list()
- } else {}
- if(is.null(dtd)){
- dtd <- list()
- } else {}
-
- newTree <- new("XiMpLe.doc",
- xml=xml,
- dtd=dtd,
- children=all.children
- )
+ if(is.null(xml)){
+ xml <- list()
+ } else {}
+ if(is.null(dtd)){
+ dtd <- list()
+ } else {}
+
+ newTree <- new("XiMpLe.doc",
+ xml=xml,
+ dtd=dtd,
+ children=all.children
+ )
- return(newTree)
+ return(newTree)
}
\ No newline at end of file
Modified: trunk/rkward/packages/XiMpLe/R/XiMpLe-internal.R
===================================================================
--- trunk/rkward/packages/XiMpLe/R/XiMpLe-internal.R 2013-12-21 19:33:05 UTC (rev 4772)
+++ trunk/rkward/packages/XiMpLe/R/XiMpLe-internal.R 2014-03-05 00:57:33 UTC (rev 4773)
@@ -1,4 +1,4 @@
-# Copyright 2011-2013 Meik Michalke <meik.michalke at hhu.de>
+# Copyright 2011-2014 Meik Michalke <meik.michalke at hhu.de>
#
# This file is part of the R package XiMpLe.
#
@@ -20,70 +20,70 @@
## wrapper for paste0() needed?
if(isTRUE(R_system_version(getRversion()) < 2.15)){
- # if this is an older R version, we need a wrapper function for paste0()
- # which was introduced with R 2.15 as a more efficient shortcut to paste(..., sep="")
- paste0 <- function(..., collapse=NULL){
- return(paste(..., sep="", collapse=collapse))
- }
+ # if this is an older R version, we need a wrapper function for paste0()
+ # which was introduced with R 2.15 as a more efficient shortcut to paste(..., sep="")
+ paste0 <- function(..., collapse=NULL){
+ return(paste(..., sep="", collapse=collapse))
+ }
} else {}
## function child.list()
# convenience function to let single children be provided without list()
child.list <- function(children){
- if(is.XiMpLe.node(children)){
- children <- list(children)
- } else {
- # if already a list, check if it's a list in a list and get it out
- if(inherits(children, "list") & length(children) == 1){
- if(inherits(children[[1]], "list")){
- children <- children[[1]]
- } else {}
- } else {}
- }
- return(children)
+ if(is.XiMpLe.node(children)){
+ children <- list(children)
+ } else {
+ # if already a list, check if it's a list in a list and get it out
+ if(inherits(children, "list") & length(children) == 1){
+ if(inherits(children[[1]], "list")){
+ children <- children[[1]]
+ } else {}
+ } else {}
+ }
+ return(children)
} ## end function child.list()
## function split.chars()
# used to split a character string into parts at each occurrence of the start and end of a regex pattern
split.chars <- function(txt, pattern, perl=FALSE){
- found.pattern <- gregexpr(pattern, text=txt, perl=perl)
- found.pattern.start <- found.pattern[[1]]
- found.pattern.end <- found.pattern.start + attr(found.pattern[[1]], "match.length") - 1
- # returned -1 if pattern wasn't found
- if(found.pattern.start[1] == -1){
- return(txt)
- } else {
- txt.length <- nchar(txt)
- num.found.patterns <- length(found.pattern.start)
- result <- unlist(sapply(0:num.found.patterns, function(pat.idx){
- # 0: chars before first match
- if(pat.idx == 0){
- if(found.pattern.start[1] > 1){
- return(substr(txt, 1, found.pattern.start[1] - 1))
- } else {}
- } else {
- result.match <- substr(txt, found.pattern.start[pat.idx], found.pattern.end[pat.idx])
- # check if there's stuff between two matches
- aft.match <- found.pattern.end[pat.idx] + 1
- if(pat.idx < num.found.patterns){
- nxt.match <- found.pattern.start[pat.idx + 1]
- } else {
- nxt.match <- txt.length + 1
- }
- if(aft.match < nxt.match){
- result.aft.match <- trim(substr(txt, aft.match, nxt.match - 1))
- # remove empty space
- if(!identical("", result.aft.match)){
- result.match <- c(result.match, result.aft.match)
- } else {}
- } else {}
- return(result.match)
- }
- }), use.names=FALSE)
- return(result)
- }
+ found.pattern <- gregexpr(pattern, text=txt, perl=perl)
+ found.pattern.start <- found.pattern[[1]]
+ found.pattern.end <- found.pattern.start + attr(found.pattern[[1]], "match.length") - 1
+ # returned -1 if pattern wasn't found
+ if(found.pattern.start[1] == -1){
+ return(txt)
+ } else {
+ txt.length <- nchar(txt)
+ num.found.patterns <- length(found.pattern.start)
+ result <- unlist(sapply(0:num.found.patterns, function(pat.idx){
+ # 0: chars before first match
+ if(pat.idx == 0){
+ if(found.pattern.start[1] > 1){
+ return(substr(txt, 1, found.pattern.start[1] - 1))
+ } else {}
+ } else {
+ result.match <- substr(txt, found.pattern.start[pat.idx], found.pattern.end[pat.idx])
+ # check if there's stuff between two matches
+ aft.match <- found.pattern.end[pat.idx] + 1
+ if(pat.idx < num.found.patterns){
+ nxt.match <- found.pattern.start[pat.idx + 1]
+ } else {
+ nxt.match <- txt.length + 1
+ }
+ if(aft.match < nxt.match){
+ result.aft.match <- trim(substr(txt, aft.match, nxt.match - 1))
+ # remove empty space
+ if(!identical("", result.aft.match)){
+ result.match <- c(result.match, result.aft.match)
+ } else {}
+ } else {}
+ return(result.match)
+ }
+ }), use.names=FALSE)
+ return(result)
+ }
} ## end function split.chars()
@@ -92,50 +92,50 @@
# - tree: The XML tree, must be character.
# - drop: A character vector with the possible contens \code{c("comments","declarations","cdata","value")}
XML.single.tags <- function(tree, drop=NULL){
- if(!is.character(tree)){
- stop(simpleError("'tree' must be character!"))
- } else {}
- if(length(tree) > 1) {
- # force tree into one string
- tree <- paste(tree, collapse="")
- } else {}
- # remove space at beginning (and end)
- tree <- trim(tree)
+ if(!is.character(tree)){
+ stop(simpleError("'tree' must be character!"))
+ } else {}
+ if(length(tree) > 1) {
+ # force tree into one string
+ tree <- paste(tree, collapse="")
+ } else {}
+ # remove space at beginning (and end)
+ tree <- trim(tree)
- ## the main splitting process
- # CDATA or comments can contain stuff which might ruin the outcome. we'll deal with those parts first.
- tree <- split.chars(txt=tree, pattern="<!\\[CDATA\\[((?s).*?)\\]\\]>|/\\*[[:space:]]*<!\\[CDATA\\[[[:space:]]*\\*/((?s).*?)/\\*[[:space:]]*\\]\\]>[[:space:]]*\\*/|<!--((?s).*?)-->", perl=TRUE)
- # now do the splitting
- single.tags <- sapply(tree, function(this.tree){
- # exclude the already cut our comments an CDATA entries
- if(XML.comment(this.tree) | XML.cdata(this.tree) | XML.commcdata(this.tree)){
- return(this.tree)
- } else {
- these.tags <- unlist(split.chars(txt=this.tree, "<((?s).*?)>", perl=TRUE), use.names=FALSE)
- # remove probably troublesome content like newlines
- these.tags[!XML.value(these.tags)] <- gsub("[[:space:]]+", " ", these.tags[!XML.value(these.tags)])
- return(these.tags)
- }
- })
- single.tags <- unlist(single.tags, use.names=FALSE)
- single.tags <- as.character(single.tags)
+ ## the main splitting process
+ # CDATA or comments can contain stuff which might ruin the outcome. we'll deal with those parts first.
+ tree <- split.chars(txt=tree, pattern="<!\\[CDATA\\[((?s).*?)\\]\\]>|/\\*[[:space:]]*<!\\[CDATA\\[[[:space:]]*\\*/((?s).*?)/\\*[[:space:]]*\\]\\]>[[:space:]]*\\*/|<!--((?s).*?)-->", perl=TRUE)
+ # now do the splitting
+ single.tags <- sapply(tree, function(this.tree){
+ # exclude the already cut our comments an CDATA entries
+ if(XML.comment(this.tree) | XML.cdata(this.tree) | XML.commcdata(this.tree)){
+ return(this.tree)
+ } else {
+ these.tags <- unlist(split.chars(txt=this.tree, "<((?s).*?)>", perl=TRUE), use.names=FALSE)
+ # remove probably troublesome content like newlines
+ these.tags[!XML.value(these.tags)] <- gsub("[[:space:]]+", " ", these.tags[!XML.value(these.tags)])
+ return(these.tags)
+ }
+ })
+ single.tags <- unlist(single.tags, use.names=FALSE)
+ single.tags <- as.character(single.tags)
- colnames(single.tags) <- NULL
- if("comments" %in% drop){
- single.tags <- single.tags[!XML.comment(single.tags)]
- } else {}
- if("declarations" %in% drop){
- single.tags <- single.tags[!XML.declaration(single.tags)]
- } else {}
- if("doctype" %in% drop){
- single.tags <- single.tags[!XML.doctype(single.tags)]
- } else {}
- if("cdata" %in% drop){
- single.tags <- single.tags[!XML.cdata(single.tags)]
- } else {}
- # force garbage collection
- gc()
- return(single.tags)
+ colnames(single.tags) <- NULL
+ if("comments" %in% drop){
+ single.tags <- single.tags[!XML.comment(single.tags)]
+ } else {}
+ if("declarations" %in% drop){
+ single.tags <- single.tags[!XML.declaration(single.tags)]
+ } else {}
+ if("doctype" %in% drop){
+ single.tags <- single.tags[!XML.doctype(single.tags)]
+ } else {}
+ if("cdata" %in% drop){
+ single.tags <- single.tags[!XML.cdata(single.tags)]
+ } else {}
+ # force garbage collection
+ gc()
+ return(single.tags)
} ## end function XML.single.tags()
@@ -143,26 +143,26 @@
# takes a string, determines the minimum number of grouped \t strings,
# and adjusts it globally to the given level
setMinIndent <- function(tag, level=1, indent.by="\t", shine=0){
- if(shine > 0){
- tag <- gsub("\n([^\t])", "\n\t\\1", tag, perl=TRUE)
- } else {}
- currentMinIndent <- min(nchar(unlist(strsplit(tag, "[^\t]+"), use.names=FALSE)))
- indentDiff <- currentMinIndent - level
- # if currentMinIndent is greater than level, reduce indentation
- if(indentDiff > 0){
- tag <- gsub(paste0("(^|\n)(\t){", indentDiff, "}"), "\\1", tag, perl=TRUE)
- } else if(indentDiff < 0){
- tag <- gsub("(^|\n)(\t)", paste0("\\1", indent(level + 1, by=indent.by)), tag, perl=TRUE)
- } else {}
+ if(shine > 0){
+ tag <- gsub("\n([^\t])", "\n\t\\1", tag, perl=TRUE)
+ } else {}
+ currentMinIndent <- min(nchar(unlist(strsplit(tag, "[^\t]+"), use.names=FALSE)))
+ indentDiff <- currentMinIndent - level
+ # if currentMinIndent is greater than level, reduce indentation
+ if(indentDiff > 0){
+ tag <- gsub(paste0("(^|\n)(\t){", indentDiff, "}"), "\\1", tag, perl=TRUE)
+ } else if(indentDiff < 0){
+ tag <- gsub("(^|\n)(\t)", paste0("\\1", indent(level + 1, by=indent.by)), tag, perl=TRUE)
+ } else {}
- return(tag)
+ return(tag)
} ## end function setMinIndent()
## function indent()
# will create tabs to format the output
indent <- function(level, by="\t"){
- paste(rep(by, level-1), collapse="")
+ paste(rep(by, level-1), collapse="")
} ## end function indent()
@@ -170,12 +170,12 @@
# replace special character < and > from attributes or text values
# with harmless entities
xml.tidy <- function(text){
- if(is.character(text)){
- tidy.text <- gsub("<", "<", gsub(">", ">", gsub("&([#[:alnum:]]{7}[^;]|[[:space:]]|[^;]*$)", "&\\1", text, perl=TRUE)))
- } else {
- return(text)
- }
- return(tidy.text)
+ if(is.character(text)){
+ tidy.text <- gsub("<", "<", gsub(">", ">", gsub("&([#[:alnum:]]{7}[^;]|[[:space:]]|[^;]*$)", "&\\1", text, perl=TRUE)))
+ } else {
+ return(text)
+ }
+ return(tidy.text)
} ## function xml.tidy()
@@ -183,380 +183,380 @@
# takes the original input element names and returns
# the according XML attribute name
lookupAttrName <- function(tag, attr, rename){
- if(is.null(tag)){
- attr.name <- attr
- } else {
- attr.name <- rename[[tag]][[attr]]
- }
- return(attr.name)
+ if(is.null(tag)){
+ attr.name <- attr
+ } else {
+ attr.name <- rename[[tag]][[attr]]
+ }
+ return(attr.name)
} ## end function lookupAttrName()
## function pasteXMLAttr()
# pastes all attributes in a nicely readable way
pasteXMLAttr <- function(attr=NULL, tag=NULL, level=1, rename=NULL, shine=2, indent.by="\t", tidy=FALSE){
- if(is.null(attr)){
- return("")
- } else {}
+ if(is.null(attr)){
+ return("")
+ } else {}
- if(isTRUE(tidy)){
- attr <- sapply(attr, xml.tidy)
- } else {}
+ if(isTRUE(tidy)){
+ attr <- sapply(attr, xml.tidy)
+ } else {}
- new.indent <- ifelse(shine > 1, indent(level+1, by=indent.by), "")
- new.attr <- ifelse(shine > 1, "\n", " ")
+ new.indent <- ifelse(shine > 1, indent(level+1, by=indent.by), "")
+ new.attr <- ifelse(shine > 1, "\n", " ")
- # only use formatting if more than one attribute
- if(length(attr) > 1){
- full.attr <- c()
- for (this.attr in names(attr)){
- # skip empty elements
- if(is.null(attr[[this.attr]])){next}
- if(nchar(attr[[this.attr]]) > 0){
- if(!is.null(rename)){
- # look up attribute name to paste
- attr.name <- lookupAttrName(tag, this.attr, rename=rename)
- } else {
- attr.name <- this.attr
- }
- full.attr <- trim(paste0(full.attr, new.attr, new.indent, attr.name, "=\"", attr[[this.attr]], "\""))
- } else {}
- }
- } else {
- if(!is.null(rename)){
- # look up attribute name to paste
- attr.name <- lookupAttrName(tag, names(attr), rename=rename)
- } else {
- attr.name <- names(attr)
- }
- # look up attribute name to paste
- full.attr <- paste0(attr.name, "=\"", attr[[1]], "\"")
- }
- return(full.attr)
+ # only use formatting if more than one attribute
+ if(length(attr) > 1){
+ full.attr <- c()
+ for (this.attr in names(attr)){
+ # skip empty elements
+ if(is.null(attr[[this.attr]])){next}
+ if(nchar(attr[[this.attr]]) > 0){
+ if(!is.null(rename)){
+ # look up attribute name to paste
+ attr.name <- lookupAttrName(tag, this.attr, rename=rename)
+ } else {
+ attr.name <- this.attr
+ }
+ full.attr <- trim(paste0(full.attr, new.attr, new.indent, attr.name, "=\"", attr[[this.attr]], "\""))
+ } else {}
+ }
+ } else {
+ if(!is.null(rename)){
+ # look up attribute name to paste
+ attr.name <- lookupAttrName(tag, names(attr), rename=rename)
+ } else {
+ attr.name <- names(attr)
+ }
+ # look up attribute name to paste
+ full.attr <- paste0(attr.name, "=\"", attr[[1]], "\"")
+ }
+ return(full.attr)
} ## end function pasteXMLAttr()
## function parseXMLAttr()
# takes a whole XML tag and returns a named list with its attributes
parseXMLAttr <- function(tag){
- if(XML.doctype(tag)){
- stripped.tag <- gsub("<!((?i)DOCTYPE)[[:space:]]+([^[:space:]]+)[[:space:]]*([^\"[:space:]]*)[[:space:]]*.*>",
- "doctype=\"\\2\", decl=\"\\3\"", tag)
- stripped.tag2 <- eval(parse(text=paste("c(",gsub("[^\"]*[\"]?([^\"]*)[\"]?[^\"]*", "\"\\1\",", tag),"NULL)")))
- is.dtd <- grepl("\\.dtd", stripped.tag2)
- doct.decl <- ifelse(sum(!is.dtd) > 0, paste0(stripped.tag2[!is.dtd][1]), paste0(""))
- doct.ref <- ifelse(sum(is.dtd) > 0, paste0(stripped.tag2[is.dtd][1]), paste0(""))
- parsed.list <- eval(parse(text=paste0("list(", stripped.tag, ", id=\"", doct.decl,"\"", ", refer=\"", doct.ref,"\")")))
- } else if(XML.endTag(tag) | XML.comment(tag) |XML.cdata(tag)){
- # end tags, comments and CDATA don't have attributes
- parsed.list <- ""
- } else {
- # first strip of start and end characters
- stripped.tag <- gsub("<([?[:space:]]*)[^[:space:]]+[[:space:]]*(.*)", "\\2", tag, perl=TRUE)
- stripped.tag <- gsub("[/?]*>$", "", stripped.tag, perl=TRUE)
- # fill in commas, so we can evaluate this as elements of a named list
- separated.tag <- gsub("=[[:space:]]*\"([^\"]*)\"[[:space:]]+([^[:space:]=]+)", "=\"\\1\", \\2", stripped.tag, perl=TRUE)
- # to be on the safe side, escape all list names, in case there's unexpected special characters in them
- separated.tag <- gsub("( ,)?([^[:space:],\"]*)=\"", "\\1\"\\2\"=\"", separated.tag, perl=TRUE)
- ###################################################################################
- ## TODO:
- ## empty attributes are not valid, force them into atrribute="attribute"
- ## does only work partially it the empty attribute is the last in line
- ## and still causes *problems* in matching string in the value of other attributes!
- # separated.tag <- gsub("(, |\\A)([^[:space:],\"=][[:alnum:]]*)", "\\1\"\\2\"=\"\\2\"", separated.tag, perl=TRUE)
- ###################################################################################
- parsed.list <- eval(parse(text=paste("list(", separated.tag, ")")))
- }
- if(XML.declaration(tag)){
- valid.attr <- c("version", "encoding", "standalone")
- parsed.list <- parsed.list[tolower(names(parsed.list)) %in% valid.attr]
- for (miss.attr in valid.attr[!valid.attr %in% tolower(names(parsed.list))]){
- parsed.list[[miss.attr]] <- ""
- }
- } else {}
+ if(XML.doctype(tag)){
+ stripped.tag <- gsub("<!((?i)DOCTYPE)[[:space:]]+([^[:space:]]+)[[:space:]]*([^\"[:space:]]*)[[:space:]]*.*>",
+ "doctype=\"\\2\", decl=\"\\3\"", tag)
+ stripped.tag2 <- eval(parse(text=paste("c(",gsub("[^\"]*[\"]?([^\"]*)[\"]?[^\"]*", "\"\\1\",", tag),"NULL)")))
+ is.dtd <- grepl("\\.dtd", stripped.tag2)
+ doct.decl <- ifelse(sum(!is.dtd) > 0, paste0(stripped.tag2[!is.dtd][1]), paste0(""))
+ doct.ref <- ifelse(sum(is.dtd) > 0, paste0(stripped.tag2[is.dtd][1]), paste0(""))
+ parsed.list <- eval(parse(text=paste0("list(", stripped.tag, ", id=\"", doct.decl,"\"", ", refer=\"", doct.ref,"\")")))
+ } else if(XML.endTag(tag) | XML.comment(tag) |XML.cdata(tag)){
+ # end tags, comments and CDATA don't have attributes
+ parsed.list <- ""
+ } else {
+ # first strip of start and end characters
+ stripped.tag <- gsub("<([?[:space:]]*)[^[:space:]]+[[:space:]]*(.*)", "\\2", tag, perl=TRUE)
+ stripped.tag <- gsub("[/?]*>$", "", stripped.tag, perl=TRUE)
+ # fill in commas, so we can evaluate this as elements of a named list
+ separated.tag <- gsub("=[[:space:]]*\"([^\"]*)\"[[:space:]]+([^[:space:]=]+)", "=\"\\1\", \\2", stripped.tag, perl=TRUE)
+ # to be on the safe side, escape all list names, in case there's unexpected special characters in them
+ separated.tag <- gsub("( ,)?([^[:space:],\"]*)=\"", "\\1\"\\2\"=\"", separated.tag, perl=TRUE)
+ ###################################################################################
+ ## TODO:
+ ## empty attributes are not valid, force them into atrribute="attribute"
+ ## does only work partially it the empty attribute is the last in line
+ ## and still causes *problems* in matching string in the value of other attributes!
+ # separated.tag <- gsub("(, |\\A)([^[:space:],\"=][[:alnum:]]*)", "\\1\"\\2\"=\"\\2\"", separated.tag, perl=TRUE)
+ ###################################################################################
+ parsed.list <- eval(parse(text=paste("list(", separated.tag, ")")))
+ }
+ if(XML.declaration(tag)){
+ valid.attr <- c("version", "encoding", "standalone")
+ parsed.list <- parsed.list[tolower(names(parsed.list)) %in% valid.attr]
+ for (miss.attr in valid.attr[!valid.attr %in% tolower(names(parsed.list))]){
+ parsed.list[[miss.attr]] <- ""
+ }
+ } else {}
- return(parsed.list)
+ return(parsed.list)
} ## end function parseXMLAttr()
## function trim()
# cuts off space at start and end of a character string
trim <- function(char){
- char <- gsub("^[[:space:]]*", "", char)
- char <- gsub("[[:space:]]*$", "", char)
- return(char)
+ char <- gsub("^[[:space:]]*", "", char)
+ char <- gsub("[[:space:]]*$", "", char)
+ return(char)
} ## end function trim()
## function XML.emptyTag()
# checks if a tag is a pair of start/end tags or an empty tag;
# returns either TRUE/FALSE, or the tag name if it is an empty tag and get=TRUE
XML.emptyTag <- function(tag, get=FALSE){
- empty.tags <- sapply(tag, function(this.tag){
- empty <- grepl("/>$", this.tag)
- if(isTRUE(get)){
- result <- ifelse(isTRUE(empty), XML.tagName(this.tag), "")
- } else {
- result <- empty
- }
- return(result)
- })
- names(empty.tags) <- NULL
- return(empty.tags)
+ empty.tags <- sapply(tag, function(this.tag){
+ empty <- grepl("/>$", this.tag)
+ if(isTRUE(get)){
+ result <- ifelse(isTRUE(empty), XML.tagName(this.tag), "")
+ } else {
+ result <- empty
+ }
+ return(result)
+ })
+ names(empty.tags) <- NULL
+ return(empty.tags)
} ## end function XML.emptyTag()
## function XML.endTag()
# checks if a tag an end tag;
# returns either TRUE/FALSE, or the tag name if it is an end tag and get=TRUE
XML.endTag <- function(tag, get=FALSE){
- end.tags <- sapply(tag, function(this.tag){
- end <- grepl("^</", this.tag)
- if(isTRUE(get)){
- result <- ifelse(isTRUE(end), XML.tagName(this.tag), "")
- } else {
- result <- end
- }
- return(result)
- })
- names(end.tags) <- NULL
- return(end.tags)
+ end.tags <- sapply(tag, function(this.tag){
+ end <- grepl("^</", this.tag)
+ if(isTRUE(get)){
+ result <- ifelse(isTRUE(end), XML.tagName(this.tag), "")
+ } else {
+ result <- end
+ }
+ return(result)
+ })
+ names(end.tags) <- NULL
+ return(end.tags)
} ## end function XML.endTag()
## function XML.comment()
# checks if a tag is a comment, returns TRUE or FALSE, or the comment (TRUE & get=TRUE)
XML.comment <- function(tag, get=FALSE, trim=TRUE){
- comment.tags <- sapply(tag, function(this.tag){
- comment <- grepl("<!--((?s).*)-->", this.tag, perl=TRUE)
- if(isTRUE(get)){
- result <- ifelse(isTRUE(comment), gsub("<!--((?s).*)-->", "\\1", this.tag, perl=TRUE), "")
- if(isTRUE(trim)){result <- trim(result)} else {}
- } else {
- result <- comment
- }
- return(result)
- })
- names(comment.tags) <- NULL
- return(comment.tags)
+ comment.tags <- sapply(tag, function(this.tag){
+ comment <- grepl("<!--((?s).*)-->", this.tag, perl=TRUE)
+ if(isTRUE(get)){
+ result <- ifelse(isTRUE(comment), gsub("<!--((?s).*)-->", "\\1", this.tag, perl=TRUE), "")
+ if(isTRUE(trim)){result <- trim(result)} else {}
+ } else {
+ result <- comment
+ }
+ return(result)
+ })
+ names(comment.tags) <- NULL
+ return(comment.tags)
} ## end function XML.comment()
## function XML.cdata()
# checks if a tag is a CDATA declaration, returns TRUE or FALSE, or the data (TRUE & get=TRUE)
XML.cdata <- function(tag, get=FALSE, trim=TRUE){
- cdata.tags <- sapply(tag, function(this.tag){
- cdata <- grepl("<!\\[CDATA\\[((?s).*)\\]\\]>", this.tag, perl=TRUE)
- if(isTRUE(get)){
- result <- ifelse(isTRUE(cdata), gsub("<!\\[CDATA\\[((?s).*)\\]\\]>", "\\1", this.tag, perl=TRUE), "")
- if(isTRUE(trim)){result <- trim(result)} else {}
- } else {
- result <- cdata
- }
- return(result)
- })
- names(cdata.tags) <- NULL
- return(cdata.tags)
+ cdata.tags <- sapply(tag, function(this.tag){
+ cdata <- grepl("<!\\[CDATA\\[((?s).*)\\]\\]>", this.tag, perl=TRUE)
+ if(isTRUE(get)){
+ result <- ifelse(isTRUE(cdata), gsub("<!\\[CDATA\\[((?s).*)\\]\\]>", "\\1", this.tag, perl=TRUE), "")
+ if(isTRUE(trim)){result <- trim(result)} else {}
+ } else {
+ result <- cdata
+ }
+ return(result)
+ })
+ names(cdata.tags) <- NULL
+ return(cdata.tags)
} ## end function XML.cdata()
## function XML.commcdata()
# checks if a tag is a /* CDATA */ declaration, returns TRUE or FALSE, or the data (TRUE & get=TRUE)
XML.commcdata <- function(tag, get=FALSE, trim=TRUE){
- commcdata.tags <- sapply(tag, function(this.tag){
- commcdata <- grepl("/\\*[[:space:]]*<!\\[CDATA\\[[[:space:]]*\\*/((?s).*?)/\\*[[:space:]]*\\]\\]>[[:space:]]*\\*/", this.tag, perl=TRUE)
- if(isTRUE(get)){
- result <- ifelse(isTRUE(commcdata), gsub("/\\*[[:space:]]*<!\\[CDATA\\[[[:space:]]*\\*/((?s).*?)/\\*[[:space:]]*\\]\\]>[[:space:]]*\\*/", "\\1", this.tag, perl=TRUE), "")
- if(isTRUE(trim)){result <- trim(result)} else {}
- } else {
- result <- commcdata
- }
- return(result)
- })
- names(commcdata.tags) <- NULL
- return(commcdata.tags)
+ commcdata.tags <- sapply(tag, function(this.tag){
+ commcdata <- grepl("/\\*[[:space:]]*<!\\[CDATA\\[[[:space:]]*\\*/((?s).*?)/\\*[[:space:]]*\\]\\]>[[:space:]]*\\*/", this.tag, perl=TRUE)
+ if(isTRUE(get)){
+ result <- ifelse(isTRUE(commcdata), gsub("/\\*[[:space:]]*<!\\[CDATA\\[[[:space:]]*\\*/((?s).*?)/\\*[[:space:]]*\\]\\]>[[:space:]]*\\*/", "\\1", this.tag, perl=TRUE), "")
+ if(isTRUE(trim)){result <- trim(result)} else {}
+ } else {
+ result <- commcdata
+ }
+ return(result)
+ })
+ names(commcdata.tags) <- NULL
+ return(commcdata.tags)
} ## end function XML.commcdata()
## function XML.value()
# checks if 'tag' is actually not a tag but value/content/data. returns TRUE or FALSE, or the value (TRUE & get=TRUE)
XML.value <- function(tag, get=FALSE, trim=TRUE){
- all.values <- sapply(tag, function(this.tag){
- value <- grepl("^[[:space:]]*[^<]", this.tag)
- if(isTRUE(get)){
- result <- ifelse(isTRUE(value), this.tag, "")
- if(isTRUE(trim)){result <- trim(result)} else {}
- } else {
- result <- value
- }
- return(result)
- })
- names(all.values) <- NULL
- return(all.values)
+ all.values <- sapply(tag, function(this.tag){
+ value <- grepl("^[[:space:]]*[^<]", this.tag)
+ if(isTRUE(get)){
+ result <- ifelse(isTRUE(value), this.tag, "")
+ if(isTRUE(trim)){result <- trim(result)} else {}
+ } else {
+ result <- value
+ }
+ return(result)
+ })
+ names(all.values) <- NULL
+ return(all.values)
} ## end function XML.value()
## function XML.declaration()
# checks for a declaration, like <?xml bar?>
XML.declaration <- function(tag, get=FALSE){
- decl.tags <- sapply(tag, function(this.tag){
- declaration <- grepl("<\\?((?i)xml).*\\?>", this.tag, perl=TRUE)
- if(isTRUE(get)){
- result <- ifelse(isTRUE(declaration), XML.tagName(this.tag), "")
- } else {
- result <- declaration
- }
- return(result)
- })
- names(decl.tags) <- NULL
- return(decl.tags)
+ decl.tags <- sapply(tag, function(this.tag){
+ declaration <- grepl("<\\?((?i)xml).*\\?>", this.tag, perl=TRUE)
+ if(isTRUE(get)){
+ result <- ifelse(isTRUE(declaration), XML.tagName(this.tag), "")
+ } else {
+ result <- declaration
+ }
+ return(result)
+ })
+ names(decl.tags) <- NULL
+ return(decl.tags)
} ## end function XML.declaration()
## function XML.doctype()
# checks for a doctype declaration, like <!DOCTYPE foo>
XML.doctype <- function(tag, get=FALSE){
- decl.tags <- sapply(tag, function(this.tag){
- declaration <- grepl("<!((?i)DOCTYPE).*>", this.tag, perl=TRUE)
- if(isTRUE(get)){
- result <- ifelse(isTRUE(declaration), XML.tagName(this.tag), "")
- } else {
- result <- declaration
- }
- return(result)
- })
- names(decl.tags) <- NULL
- return(decl.tags)
+ decl.tags <- sapply(tag, function(this.tag){
+ declaration <- grepl("<!((?i)DOCTYPE).*>", this.tag, perl=TRUE)
+ if(isTRUE(get)){
+ result <- ifelse(isTRUE(declaration), XML.tagName(this.tag), "")
+ } else {
+ result <- declaration
+ }
+ return(result)
+ })
+ names(decl.tags) <- NULL
+ return(decl.tags)
} ## end function XML.doctype()
## function XML.def()
XML.def <- function(tag, get=FALSE){
- decl.tags <- sapply(tag, function(this.tag){
- declaration <- grepl("<[!?]+[^-]*>", this.tag)
- if(isTRUE(get)){
- result <- ifelse(isTRUE(declaration), XML.tagName(this.tag), "")
- } else {
- result <- declaration
- }
- return(result)
- })
- names(decl.tags) <- NULL
- return(decl.tags)
+ decl.tags <- sapply(tag, function(this.tag){
+ declaration <- grepl("<[!?]+[^-]*>", this.tag)
+ if(isTRUE(get)){
+ result <- ifelse(isTRUE(declaration), XML.tagName(this.tag), "")
+ } else {
+ result <- declaration
+ }
+ return(result)
+ })
+ names(decl.tags) <- NULL
+ return(decl.tags)
} ## end function XML.def()
## function XML.tagName()
XML.tagName <- function(tag){
- tag.names <- sapply(tag, function(this.tag){
- tagName <- gsub("<([[:space:]!?/]*)([^[:space:]>/]+).*", "\\2", this.tag, perl=TRUE)
- return(tagName)
- })
- names(tag.names) <- NULL
- return(tag.names)
+ tag.names <- sapply(tag, function(this.tag){
+ tagName <- gsub("<([[:space:]!?/]*)([^[:space:]>/]+).*", "\\2", this.tag, perl=TRUE)
+ return(tagName)
+ })
+ names(tag.names) <- NULL
+ return(tag.names)
} ## end function XML.tagName()
## function parseXMLTag()
parseXMLTag <- function(tag){
- tag.name <- XML.tagName(tag)
- tag.attr <- parseXMLAttr(tag)
- if(!is.null(tag.attr)){
- parsed.tag <- list()
- parsed.tag[[tag.name]] <- list(attr=tag.attr)
- } else {
- parsed.tag <- list()
- parsed.tag[[tag.name]] <- list()
- }
- return(parsed.tag)
+ tag.name <- XML.tagName(tag)
+ tag.attr <- parseXMLAttr(tag)
+ if(!is.null(tag.attr)){
+ parsed.tag <- list()
+ parsed.tag[[tag.name]] <- list(attr=tag.attr)
+ } else {
+ parsed.tag <- list()
+ parsed.tag[[tag.name]] <- list()
+ }
+ return(parsed.tag)
} ## end function parseXMLTag()
## function XML.nodes()
XML.nodes <- function(single.tags, end.here=NA, start=1){
- # to save memory, we'll put the single.tags object into an environment
- # and pass that on to all iterations
- if(is.environment(single.tags)){
- single.tags.env <- single.tags
- num.all.tags <- length(get("single.tags", envir=single.tags.env))
- } else {
- single.tags.env <- new.env()
- assign("single.tags", single.tags, envir=single.tags.env)
- num.all.tags <- length(single.tags)
- }
- # try to iterate through the single tags
- children <- list()
- tag.no <- start
- ## uncomment to debug:
- # cat(start,"\n")
- while (tag.no <= num.all.tags){
- ## uncomment to debug:
- # time.spent <- system.time({
- this.tag <- get("single.tags", envir=single.tags.env)[tag.no]
- nxt.child <- length(children) + 1
- child.name <- XML.tagName(this.tag)
- child.end.tag <- paste0("</[[:space:]]*", end.here,"[[:space:]>]+.*")
- if(isTRUE(grepl(child.end.tag, this.tag))){
- ## uncomment to debug:
- # cat(this.tag, ": break (",tag.no,")\n")
- break
- } else {}
- # we must test for commented CDATA first, because XML.value() would be TRUE, too
- if(XML.commcdata(this.tag)){
- children[nxt.child] <- new("XiMpLe.node",
- name="*![CDATA[",
- value=XML.commcdata(this.tag, get=TRUE))
- names(children)[nxt.child] <- "*![CDATA["
- tag.no <- tag.no + 1
- next
- } else {}
- if(XML.value(this.tag)){
- children[nxt.child] <- new("XiMpLe.node",
- name="",
- value=XML.value(this.tag, get=TRUE))
- names(children)[nxt.child] <- "!value!"
- tag.no <- tag.no + 1
- next
- } else {
- child.attr <- parseXMLAttr(this.tag)
- }
- if(XML.declaration(this.tag)){
- children[nxt.child] <- new("XiMpLe.node",
- name=child.name,
- attributes=child.attr)
- names(children)[nxt.child] <- child.name
- tag.no <- tag.no + 1
- next
- } else {}
- if(XML.comment(this.tag)){
- children[nxt.child] <- new("XiMpLe.node",
- name="!--",
- value=XML.comment(this.tag, get=TRUE))
- names(children)[nxt.child] <- "!--"
- tag.no <- tag.no + 1
- next
- } else {}
- if(XML.cdata(this.tag)){
- children[nxt.child] <- new("XiMpLe.node",
- name="![CDATA[",
- value=XML.cdata(this.tag, get=TRUE))
- names(children)[nxt.child] <- "![CDATA["
- tag.no <- tag.no + 1
- next
- } else {}
- if(XML.endTag(this.tag)){
- break
- } else {}
- if(!XML.emptyTag(this.tag)){
- ## uncomment to debug:
- # cat(child.name, ":", tag.no, "-", child.end.tag,"\n")
- rec.nodes <- XML.nodes(single.tags.env, end.here=child.name, start=tag.no + 1)
- children[nxt.child] <- new("XiMpLe.node",
- name=child.name,
- attributes=child.attr,
- children=rec.nodes$children,
- # this value will force the node to remain non-empty if it had no children,
- # it would be turned into an empty tag otherwise
- value="")
- names(children)[nxt.child] <- child.name
- tag.no <- rec.nodes$tag.no + 1
- next
- } else {
- children[nxt.child] <- new("XiMpLe.node",
- name=child.name,
- attributes=child.attr)
- names(children)[nxt.child] <- child.name
- tag.no <- tag.no + 1
- next
- }
- ## uncomment to debug:
- # })
- # cat("system.time:", time.spent, "\n")
- }
- return(list(children=children, tag.no=tag.no))
+ # to save memory, we'll put the single.tags object into an environment
+ # and pass that on to all iterations
+ if(is.environment(single.tags)){
+ single.tags.env <- single.tags
+ num.all.tags <- length(get("single.tags", envir=single.tags.env))
+ } else {
+ single.tags.env <- new.env()
+ assign("single.tags", single.tags, envir=single.tags.env)
+ num.all.tags <- length(single.tags)
+ }
+ # try to iterate through the single tags
+ children <- list()
+ tag.no <- start
+ ## uncomment to debug:
+ # cat(start,"\n")
+ while (tag.no <= num.all.tags){
+ ## uncomment to debug:
+ # time.spent <- system.time({
+ this.tag <- get("single.tags", envir=single.tags.env)[tag.no]
+ nxt.child <- length(children) + 1
+ child.name <- XML.tagName(this.tag)
+ child.end.tag <- paste0("</[[:space:]]*", end.here,"[[:space:]>]+.*")
+ if(isTRUE(grepl(child.end.tag, this.tag))){
+ ## uncomment to debug:
+ # cat(this.tag, ": break (",tag.no,")\n")
+ break
+ } else {}
+ # we must test for commented CDATA first, because XML.value() would be TRUE, too
+ if(XML.commcdata(this.tag)){
+ children[nxt.child] <- new("XiMpLe.node",
+ name="*![CDATA[",
+ value=XML.commcdata(this.tag, get=TRUE))
+ names(children)[nxt.child] <- "*![CDATA["
+ tag.no <- tag.no + 1
+ next
+ } else {}
+ if(XML.value(this.tag)){
+ children[nxt.child] <- new("XiMpLe.node",
+ name="",
+ value=XML.value(this.tag, get=TRUE))
+ names(children)[nxt.child] <- "!value!"
+ tag.no <- tag.no + 1
+ next
+ } else {
+ child.attr <- parseXMLAttr(this.tag)
+ }
+ if(XML.declaration(this.tag)){
+ children[nxt.child] <- new("XiMpLe.node",
+ name=child.name,
+ attributes=child.attr)
+ names(children)[nxt.child] <- child.name
+ tag.no <- tag.no + 1
+ next
+ } else {}
+ if(XML.comment(this.tag)){
+ children[nxt.child] <- new("XiMpLe.node",
+ name="!--",
+ value=XML.comment(this.tag, get=TRUE))
+ names(children)[nxt.child] <- "!--"
+ tag.no <- tag.no + 1
+ next
+ } else {}
+ if(XML.cdata(this.tag)){
+ children[nxt.child] <- new("XiMpLe.node",
+ name="![CDATA[",
+ value=XML.cdata(this.tag, get=TRUE))
+ names(children)[nxt.child] <- "![CDATA["
+ tag.no <- tag.no + 1
+ next
+ } else {}
+ if(XML.endTag(this.tag)){
+ break
+ } else {}
+ if(!XML.emptyTag(this.tag)){
+ ## uncomment to debug:
+ # cat(child.name, ":", tag.no, "-", child.end.tag,"\n")
+ rec.nodes <- XML.nodes(single.tags.env, end.here=child.name, start=tag.no + 1)
+ children[nxt.child] <- new("XiMpLe.node",
+ name=child.name,
+ attributes=child.attr,
+ children=rec.nodes$children,
+ # this value will force the node to remain non-empty if it had no children,
+ # it would be turned into an empty tag otherwise
+ value="")
+ names(children)[nxt.child] <- child.name
+ tag.no <- rec.nodes$tag.no + 1
+ next
+ } else {
+ children[nxt.child] <- new("XiMpLe.node",
+ name=child.name,
+ attributes=child.attr)
+ names(children)[nxt.child] <- child.name
+ tag.no <- tag.no + 1
+ next
+ }
+ ## uncomment to debug:
+ # })
+ # cat("system.time:", time.spent, "\n")
+ }
+ return(list(children=children, tag.no=tag.no))
} ## end function XML.nodes()
Modified: trunk/rkward/packages/XiMpLe/R/XiMpLe-internal.roxy.all.R
===================================================================
--- trunk/rkward/packages/XiMpLe/R/XiMpLe-internal.roxy.all.R 2013-12-21 19:33:05 UTC (rev 4772)
+++ trunk/rkward/packages/XiMpLe/R/XiMpLe-internal.roxy.all.R 2014-03-05 00:57:33 UTC (rev 4773)
@@ -1,4 +1,4 @@
-# Copyright 2011-2013 Meik Michalke <meik.michalke at hhu.de>
+# Copyright 2011-2014 Meik Michalke <meik.michalke at hhu.de>
#
# This file is part of the R package XiMpLe.
#
@@ -20,22 +20,22 @@
# this internal object can be used by the package roxyPackage to
# automatically create/update DESCRIPTION and CITATION files
pckg.dscrptn <- data.frame(
- Package="XiMpLe",
- Type="Package",
- Title="A simple XML tree parser and generator",
- Author="m.eik michalke",
- AuthorsR="c(person(given=\"Meik\", family=\"Michalke\", email=\"meik.michalke at hhu.de\",
- role=c(\"aut\", \"cre\")))",
- Maintainer="m.eik michalke <meik.michalke at hhu.de>",
- Depends="R (>= 2.9.0),methods",
- Suggests="testthat",
- Enhances="rkward",
- Description="This package provides a simple XML tree parser/generator. It includes functions to read XML files into R objects,
- get information out of and into nodes, and write R objects back to XML code.
- It's not as powerful as the XML package and doesn't aim to be, but for simple XML handling
- it could be useful. It was originally programmed for RKWard.",
- License="GPL (>= 3)",
- Encoding="UTF-8",
- LazyLoad="yes",
- URL="http://reaktanz.de/?c=hacking&s=XiMpLe",
- stringsAsFactors=FALSE)
+ Package="XiMpLe",
+ Type="Package",
+ Title="A simple XML tree parser and generator",
+ Author="m.eik michalke",
+ AuthorsR="c(person(given=\"Meik\", family=\"Michalke\", email=\"meik.michalke at hhu.de\",
+ role=c(\"aut\", \"cre\")))",
+ Maintainer="m.eik michalke <meik.michalke at hhu.de>",
+ Depends="R (>= 2.9.0),methods",
+ Suggests="testthat",
+ Enhances="rkward",
+ Description="This package provides a simple XML tree parser/generator. It includes functions to read XML files into R objects,
+ get information out of and into nodes, and write R objects back to XML code.
+ It's not as powerful as the XML package and doesn't aim to be, but for simple XML handling
+ it could be useful. It was originally programmed for RKWard.",
+ License="GPL (>= 3)",
+ Encoding="UTF-8",
+ LazyLoad="yes",
+ URL="http://reaktanz.de/?c=hacking&s=XiMpLe",
+ stringsAsFactors=FALSE)
Modified: trunk/rkward/packages/XiMpLe/R/XiMpLe-package.R
===================================================================
--- trunk/rkward/packages/XiMpLe/R/XiMpLe-package.R 2013-12-21 19:33:05 UTC (rev 4772)
+++ trunk/rkward/packages/XiMpLe/R/XiMpLe-package.R 2014-03-05 00:57:33 UTC (rev 4773)
@@ -3,8 +3,8 @@
#' \tabular{ll}{
#' Package: \tab XiMpLe\cr
#' Type: \tab Package\cr
-#' Version: \tab 0.03-21\cr
-#' Date: \tab 2013-12-21\cr
+#' Version: \tab 0.03-22\cr
+#' Date: \tab 2014-03-05\cr
#' Depends: \tab R (>= 2.9.0),methods\cr
#' Enhances: \tab rkward\cr
#' Encoding: \tab UTF-8\cr
Deleted: trunk/rkward/packages/XiMpLe/R/XiMpLe.doc-class.R
===================================================================
--- trunk/rkward/packages/XiMpLe/R/XiMpLe.doc-class.R 2013-12-21 19:33:05 UTC (rev 4772)
+++ trunk/rkward/packages/XiMpLe/R/XiMpLe.doc-class.R 2014-03-05 00:57:33 UTC (rev 4773)
@@ -1,83 +0,0 @@
-# Copyright 2011-2013 Meik Michalke <meik.michalke at hhu.de>
-#
-# This file is part of the R package XiMpLe.
-#
-# XiMpLe is free software: you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation, either version 3 of the License, or
-# (at your option) any later version.
-#
-# XiMpLe is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with XiMpLe. If not, see <http://www.gnu.org/licenses/>.
-
-
-## temporarily turned off most of the roxygen comments
-## class docs will remain static until roxygen2 supports "@slot"
-
-# Class XiMpLe.doc
-#
-# This class is used for objects that are returned by \code{\link[XiMpLe:parseXMLTree]{parseXMLTree}}.
-#
-# @title S4 class XiMpLe.doc
-# @slot file Character string, Name of the file.
-# @slot xml A named list, XML declaration of the file.
-# @slot dtd A named list, Doctype definition of the file.
-# @slot children A list of objects of class XiMpLe.node, representing the DOM structure of the XML document.
-# @name XiMpLe.doc,-class
-# @aliases XiMpLe.doc-class XiMpLe.doc,-class
-#' @include XiMpLe.node-class.R
-#' @import methods
-# @keywords classes
-#' @noRd
-# @rdname XiMpLe.doc-class
-# @exportClass XiMpLe.doc
-#' @export
-
-setClass("XiMpLe.doc",
- representation=representation(
- file="character",
- xml="list",
- dtd="list",
- children="list"
- ),
- prototype(
- file=character(),
- xml=list(),
- dtd=list(),
- children=list()
- )
-)
-
-setValidity("XiMpLe.doc", function(object){
- obj.xml <- object at xml
- obj.dtd <- object at dtd
- obj.children <- object at children
-
- obj.xml.names <- names(obj.xml)
- obj.dtd.names <- names(obj.dtd)
- # if there are declarations, check that they all have names
- if(length(obj.xml) > 0){
- if(length(obj.xml) != length(obj.xml.names)){
- stop(simpleError("Invalid object: All xml declarations must have names!"))
- } else {}
- } else {}
- if(length(obj.dtd) > 0){
- if(length(obj.dtd) != length(obj.dtd.names)){
- stop(simpleError("Invalid object: All doctype declarations must have names!"))
- } else {}
- } else {}
-
- # check content of children
- if(length(obj.children) > 0){
- child.nodes <- sapply(obj.children, function(this.child){is.XiMpLe.node(this.child)})
- if(!all(child.nodes)){
- stop(simpleError("Invalid object: All list elements of children must be of class XiMpLe.node!"))
- } else {}
- } else {}
- return(TRUE)
-})
Deleted: trunk/rkward/packages/XiMpLe/R/XiMpLe.node-class.R
===================================================================
--- trunk/rkward/packages/XiMpLe/R/XiMpLe.node-class.R 2013-12-21 19:33:05 UTC (rev 4772)
+++ trunk/rkward/packages/XiMpLe/R/XiMpLe.node-class.R 2014-03-05 00:57:33 UTC (rev 4773)
@@ -1,92 +0,0 @@
-# Copyright 2011-2013 Meik Michalke <meik.michalke at hhu.de>
-#
-# This file is part of the R package XiMpLe.
-#
-# XiMpLe is free software: you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation, either version 3 of the License, or
-# (at your option) any later version.
-#
-# XiMpLe is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with XiMpLe. If not, see <http://www.gnu.org/licenses/>.
-
-
-# Class XiMpLe.node
-#
-# This class is used to create DOM trees of XML documents, like objects that are returned
-# by \code{\link[XiMpLe:parseXMLTree]{parseXMLTree}}.
-#
-# There are certain special values predefined for the \code{name} slot to easily create special XML elements:
-# \describe{
-# \item{\code{name=""}}{If the name is an empty character string, a pseudo node is created,
-# \code{\link[XiMpLe:pasteXMLNode]{pasteXMLNode}} will paste its \code{value} as plain text.}
-# \item{\code{name="!--"}}{Creates a comment tag, i.e., this will comment out all its \code{children}.}
-# \item{\code{name="![CDATA["}}{Creates a CDATA section and places all its \code{children} in it.}
-# \item{\code{name="*![CDATA["}}{Creates a CDATA section and places all its \code{children} in it, where the CDATA markers are
-# commented out by \code{/* */}, as is used for JavaScript in XHTML.}
-# }
-#
-# @title S4 class XiMpLe.node
-# @slot name Name of the node (i.e., the XML tag identifier). For special names see details.
-# @slot attributes A list of named character values, representing the attributes of this node.
-# @slot children A list of further objects of class XiMpLe.node, representing child nodes of this node.
-# @slot value Plain text to be used as the enclosed value of this node. Set to \code{value=""} if you
-# want a childless node to be forced into an non-empty pair of start and end tags by \code{\link[XiMpLe:pasteXMLNode]{pasteXMLNode}}.
-# @name XiMpLe.node,-class
-# @aliases XiMpLe.node-class XiMpLe.node,-class
-#' @import methods
-# @keywords classes
-#' @noRd
-# @rdname XiMpLe.node-class
-#' @include XiMpLe.doc-class.R
-# @exportClass XiMpLe.node
-#' @export
-
-setClass("XiMpLe.node",
- representation=representation(
- name="character",
- attributes="list",
- children="list",
- value="character"
- ),
- prototype(
- name=character(),
- attributes=list(),
- children=list(),
- value=character()
- )
-)
-
-setValidity("XiMpLe.node", function(object){
- obj.name <- object at name
- obj.attributes <- object at attributes
- obj.children <- object at children
- obj.value <- object at value
-
- if(isTRUE(!nchar(obj.name) > 0) & isTRUE(!nchar(obj.value) > 0)){
- print(str(object))
- stop(simpleError("Invalid object: A node must at least have a name or a value!"))
- } else {}
-
- obj.attributes.names <- names(obj.attributes)
- # if there are attributes, check that they all have names
- if(length(obj.attributes) > 0){
- if(length(obj.attributes) != length(obj.attributes.names)){
- stop(simpleError("Invalid object: All attributes must have names!"))
- } else {}
- } else {}
-
- # check content of children
- if(length(obj.children) > 0){
- child.nodes <- sapply(obj.children, function(this.child){is.XiMpLe.node(this.child)})
- if(!all(child.nodes)){
- stop(simpleError("Invalid object: All list elements of children must be of class XiMpLe.node!"))
- } else {}
- } else {}
- return(TRUE)
-})
Deleted: trunk/rkward/packages/XiMpLe/R/node.R
===================================================================
--- trunk/rkward/packages/XiMpLe/R/node.R 2013-12-21 19:33:05 UTC (rev 4772)
+++ trunk/rkward/packages/XiMpLe/R/node.R 2014-03-05 00:57:33 UTC (rev 4773)
@@ -1,240 +0,0 @@
-# Copyright 2011-2013 Meik Michalke <meik.michalke at hhu.de>
-#
-# This file is part of the R package XiMpLe.
-#
-# XiMpLe is free software: you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation, either version 3 of the License, or
-# (at your option) any later version.
-#
-# XiMpLe is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with XiMpLe. If not, see <http://www.gnu.org/licenses/>.
-
-
-#' Extract/manipulate a node or parts of it from an XML tree
-#'
-#' This method can be used to get parts of a parsed XML tree object, or to fill it with new values.
-#'
-#' @include XiMpLe.doc-class.R
-#' @include XiMpLe.node-class.R
-#' @include XiMpLe-internal.R
-#' @import methods
-#' @examples
-#' \dontrun{
-#' node(my.xml.tree, node=list("html","body"), what="attributes")
-#' node(my.xml.tree, node=list("html","head","title"), what="value") <- "foobar"
-#' }
-#' @docType methods
-#' @rdname node
-#' @export
-setGeneric("node", function(obj, node=list(), what=NULL, cond.attr=NULL, cond.value=NULL, element=NULL){standardGeneric("node")})
-
-# define class union to make life easier
-setClassUnion("XiMpLe.XML", members=c("XiMpLe.node", "XiMpLe.doc"))
-
-#' @rdname node
-#' @aliases
-#' node,-methods
-#' node,XiMpLe.doc-method
-#' node,XiMpLe.node-method
-#' node,XiMpLe.XML-method
-#' @param obj An object of class \code{\link[XiMpLe:XiMpLe.doc-class]{XiMpLe.doc}} or
-#' \code{\link[XiMpLe:XiMpLe.node-class]{XiMpLe.node}}.
-#' @param node A list of node names (or their numeric values), where each element is
-#' the child of its previous element. duplicate matches will be returned as a list.
-#' @param what A character string, must be a valid slot name of class \code{\link[XiMpLe:XiMpLe.node-class]{XiMpLe.node}}, like
-#' \code{"attributes"} or \code{"value"}. If not \code{NULL}, only that part of a node will be returned.
-#' There's also two special properties for this option: \code{what="@@path"} will not return the
-#' node or it's contents, but a character string with the "path" to it in the object; \code{what="obj@@path"}
-#' is the same but won't have \code{obj} substituted with the object's name.
-#' @param cond.attr A named character string, to further filter the returned results.
-#' If not \code{NULL}, only nodes with fully matching attributes will be considered.
-#' @param cond.value A character string, similar to \code{cond.attr}, but is matched
-#' against the value between a pair of tags.
-#' @param element A character string naming one list element of the node slot. If \code{NULL}, all
-#' elements will be returned.
-setMethod("node",
- signature(obj="XiMpLe.XML"),
- function(obj, node=list(), what=NULL, cond.attr=NULL, cond.value=NULL, element=NULL){
-
- # check top level if this is a node, not a tree
- if(is.XiMpLe.node(obj)){
- got.this <- identical(slot(obj, "name"), node[[1]])
- if(!isTRUE(got.this)){
- # apparently, this node doesn't exist
- stop(simpleError(paste0("Can't find node ", node[[1]], " in ", sQuote(deparse(substitute(obj))), "!")))
- } else {
- # remove first element in list node
- node[[1]] <- NULL
- }
- } else {}
- result.node.path <- "obj"
- for (this.node in node){
- for (this.path in result.node.path){
- this.node.part <- eval(parse(text=this.path))
- got.this <- lapply(slot(this.node.part, "children"), function(this.child){slot(this.child, "name")}) %in% this.node
- if(!any(got.this)){
- # apparently, this node doesn't exist
- stop(simpleError(paste0("Can't find node ", sQuote(this.node), " in ", sQuote(deparse(substitute(obj))), "!")))
- } else {
- result.node.path <- unique(paste0(result.node.path, paste0("@children[[",which(got.this),"]]")))
- }
- }
- }
-
- # filter by attributes
- if(!is.null(cond.attr)){
- filter <- names(cond.attr)
- filtered.paths <- c()
- for (this.path in result.node.path){
- this.node.part <- eval(parse(text=this.path))
- this.attrs <- slot(this.node.part, "attributes")
- attr.found <- filter %in% names(this.attrs)
- # were the wanted attributes found at all?
- if(all(attr.found)){
- # check if they're all equal
- found.this <- sapply(filter, function(this.attr){
- results <- unlist(cond.attr[this.attr]) == unlist(this.attrs[this.attr])
- return(results)
- })
- if(all(found.this)){
- filtered.paths <- unique(c(filtered.paths, this.path))
- } else {}
- } else {}
- }
- result.node.path <- filtered.paths
- } else {}
- # create a list with matching node objects
- result.cond <- sapply(result.node.path, function(this.path){eval(parse(text=this.path))})
- names(result.cond) <- NULL
-
- if(!is.null(cond.value)){
- stopifnot(length(cond.value) == 1)
- filtered.paths <- c()
- for (this.path in result.node.path){
- this.node.part <- eval(parse(text=this.path))
- this.value <- slot(this.node.part, "value")
- if(identical(this.value, cond.value)){
- filtered.paths <- unique(c(filtered.paths, this.path))
- } else {}
- }
- result.node.path <- filtered.paths
- } else {}
-
- if(!is.null(what)){
- stopifnot(length(what) == 1)
- if(!what %in% c(slotNames(new("XiMpLe.node")), "@path", "obj at path")){
- stop(simpleError(paste0("Invalid slot for class XiMpLe.node:", paste(sQuote(what), collapse=", "), "!")))
- } else {}
- if(identical(what, "@path")){
- ## return subtituted path info
- result.node.path <- gsub("^obj", paste(deparse(substitute(obj))), result.node.path)
- return(result.node.path)
- } else if(identical(what, "obj at path")){
- ## return path info
- return(result.node.path)
- } else {}
- result <- unlist(lapply(result.node.path, function(this.path){
- this.node <- eval(parse(text=this.path))
- results <- slot(this.node, what)
- # special case: text values can either be directly in the value slot of a node,
- # or in a pseudo tag as a child node, so we check both
- if(identical(what, "value")){
- for (this.child in slot(this.node, "children")){
- if(identical(slot(this.child, "name"), "") & isTRUE(nchar(slot(this.child, "value")) > 0))
- results <- paste(slot(this.child, "value"), results, sep=" ")
- }
- } else {}
- if(!is.null(element)){
- results <- results[element]
- } else {}
- return(results)
- }))
- # turn from vector to list for attributes, so they can be reached with "$"
- if(identical(what, "attributes")){
- result <- as.list(result)
- } else {}
- } else {
- result <- unlist(lapply(result.node.path, function(this.path){
- return(eval(parse(text=this.path)))
- }))
- }
-
- # no need for a list if it's inly one node
- if(length(result) == 1){
- if(is.XiMpLe.node(result[[1]]) | !is.null(element)){
- result <- result[[1]]
- } else {}
- } else {}
-
- return(result)
- }
-)
-
-#' @export
-setGeneric("node<-", function(obj, node=list(), what=NULL, cond.attr=NULL, cond.value=NULL, element=NULL, value){standardGeneric("node<-")})
-
-#' @rdname node
-#' @aliases
-#' node<-,-methods
-#' node<-,XiMpLe.doc-method
-#' node<-,XiMpLe.node-method
-#' node<-,XiMpLe.XML-method
-setMethod("node<-",
- signature(obj="XiMpLe.XML"),
- function(obj, node=list(), what=NULL, cond.attr=NULL, cond.value=NULL, element=NULL, value){
-
- # get path to node in object
- obj.paths <- node(obj, node=node, what="obj at path", cond.attr=cond.attr, cond.value=cond.value)
- if(is.null(obj.paths)){
- # seems we need to create this node
- stop(simpleError("Node not found."))
- } else {}
- for (this.node in obj.paths){
- if(!is.null(what)){
- # special case: text values can either be directly in the value slot of a node,
- # or in a pseudo tag as a child node, so we check both and remove all
- if(identical(what, "value")){
- eval(parse(text=paste0(this.node, "@value <- character()")))
- all.node.children <- slot(eval(parse(text=this.node)), "children")
- child.is.value <- sapply(all.node.children, function(this.child){
- if(identical(slot(this.child, "name"), "") & isTRUE(nchar(slot(this.child, "value")) > 0)){
- return(TRUE)
- } else {
- return(FALSE)
- }
- })
- # if we have a mix of pseudo and actual tags, we probably messed up the markup
- if(length(all.node.children) != length(child.is.value)){
- warning("a child node contained text values and other nodes, we probably messed up the markup!")
- } else {}
- remove.nodes <- paste0(this.node, "@children[child.is.value] <- NULL")
- eval(parse(text=remove.nodes))
-
- # paste new value into a single pseudo node
- pseudo.node <- paste0(this.node, "@children <- append(", this.node, "@children, ",
- "new(\"XiMpLe.node\", name=\"\", value=\"", value, "\"), after=0)")
- eval(parse(text=pseudo.node))
-
- # now return the object
- return(obj)
- } else {
- this.node <- paste0(this.node, "@", what)
- }
-
- if(!is.null(element)){
- this.node <- paste0(this.node, "[[\"",element,"\"]]")
- } else {}
- } else {}
-
- eval(parse(text=paste0(this.node, " <- ", deparse(value))))
- }
-
- return(obj)
- }
-)
Modified: trunk/rkward/packages/XiMpLe/R/parseXMLTree.R
===================================================================
--- trunk/rkward/packages/XiMpLe/R/parseXMLTree.R 2013-12-21 19:33:05 UTC (rev 4772)
+++ trunk/rkward/packages/XiMpLe/R/parseXMLTree.R 2014-03-05 00:57:33 UTC (rev 4773)
@@ -1,4 +1,4 @@
-# Copyright 2011-2013 Meik Michalke <meik.michalke at hhu.de>
+# Copyright 2011-2014 Meik Michalke <meik.michalke at hhu.de>
#
# This file is part of the R package XiMpLe.
#
@@ -20,22 +20,22 @@
#'
#' @param file Character string, valid path to the XML file which should be parsed.
#' @param drop Character vector with the possible values \code{"comments"}, \code{"cdata"}
-#' \code{"declarations"} and \code{"doctype"}, defining element classes to be dropped
-#' from the resulting object.
+#' \code{"declarations"} and \code{"doctype"}, defining element classes to be dropped
+#' from the resulting object.
#' @param object Logical, if \code{TRUE}, \code{file} will not be treated as a path name but as a
-#' character vector to be parsed as XML directly.
+#' character vector to be parsed as XML directly.
#' @return An object of class \code{\link[XiMpLe:XiMpLe.doc-class]{XiMpLe.doc}} with four slots:
-#' \describe{
-#' \item{\code{file}:}{Full path to the parsed file, or \code{"object"} if \code{object=TRUE}.}
-#' \item{\code{xml}:}{XML declaration, if found.}
-#' \item{\code{dtd}:}{Doctype definition, if found.}
-#' \item{\code{children}:}{A list of objects of class \code{XiMpLe.node}, with the elements
-#' \code{"name"} (the node name), \code{"attributes"} (list of attributes, if found),
-#' \code{"children"} (list of \code{XiMpLe.node} object, if found) and \code{"value"}
-#' (text value between a pair of start/end tags, if found).}
-#' }
+#' \describe{
+#' \item{\code{file}:}{Full path to the parsed file, or \code{"object"} if \code{object=TRUE}.}
+#' \item{\code{xml}:}{XML declaration, if found.}
+#' \item{\code{dtd}:}{Doctype definition, if found.}
+#' \item{\code{children}:}{A list of objects of class \code{XiMpLe.node}, with the elements
+#' \code{"name"} (the node name), \code{"attributes"} (list of attributes, if found),
+#' \code{"children"} (list of \code{XiMpLe.node} object, if found) and \code{"value"}
+#' (text value between a pair of start/end tags, if found).}
+#' }
#' @seealso \code{\link[XiMpLe:XiMpLe.node-class]{XiMpLe.node}},
-#' \code{\link[XiMpLe:XiMpLe.doc-class]{XiMpLe.doc}}
+#' \code{\link[XiMpLe:XiMpLe.doc-class]{XiMpLe.doc}}
#' @export
#' @examples
#' \dontrun{
@@ -43,46 +43,46 @@
#' }
parseXMLTree <- function(file, drop=NULL, object=FALSE){
- if(isTRUE(object)){
- xml.raw <- paste(file, collapse="\n")
- filePath <- "object"
- } else if(inherits(file, "connection")){
- xml.raw <- paste(readLines(file), collapse="\n")
- # is there a way to get the friggin' "description" out of a connection object?!
- filePath <- "connection"
- } else {
- xml.raw <- paste(readLines(file), collapse="\n")
- # try to detect if 'file' is like a weblink, not a regular file
- if(grepl("^[[:alpha:]]+://", file, ignore.case=TRUE)){
- filePath <- file
- } else {
- filePath <- normalizePath(file)
- }
- }
+ if(isTRUE(object)){
+ xml.raw <- paste(file, collapse="\n")
+ filePath <- "object"
+ } else if(inherits(file, "connection")){
+ xml.raw <- paste(readLines(file), collapse="\n")
+ # is there a way to get the friggin' "description" out of a connection object?!
+ filePath <- "connection"
+ } else {
+ xml.raw <- paste(readLines(file), collapse="\n")
+ # try to detect if 'file' is like a weblink, not a regular file
+ if(grepl("^[[:alpha:]]+://", file, ignore.case=TRUE)){
+ filePath <- file
+ } else {
+ filePath <- normalizePath(file)
+ }
+ }
- single.tags <- XML.single.tags(xml.raw, drop=drop)
+ single.tags <- XML.single.tags(xml.raw, drop=drop)
- # check for XML declaration and doctype first
- if(XML.declaration(single.tags[1])){
- XML.decl <- parseXMLAttr(single.tags[1])
- single.tags <- single.tags[-1]
- } else {
- XML.decl <- list(version="", encoding="", standalone="")
- }
- if(any(XML.doctype(single.tags[1]))){
- XML.doct <- parseXMLAttr(single.tags[1])
- single.tags <- single.tags[-1]
- } else {
- XML.doct <- list(doctype="", id="", decl="", refer="")
- }
- # try to iterate through the single tags
- children <- XML.nodes(single.tags)[["children"]]
-
- results <- new("XiMpLe.doc",
- file=filePath,
- xml=XML.decl,
- dtd=XML.doct,
- children=children)
-
- return(results)
+ # check for XML declaration and doctype first
+ if(XML.declaration(single.tags[1])){
+ XML.decl <- parseXMLAttr(single.tags[1])
+ single.tags <- single.tags[-1]
+ } else {
+ XML.decl <- list(version="", encoding="", standalone="")
+ }
+ if(any(XML.doctype(single.tags[1]))){
+ XML.doct <- parseXMLAttr(single.tags[1])
+ single.tags <- single.tags[-1]
+ } else {
+ XML.doct <- list(doctype="", id="", decl="", refer="")
+ }
+ # try to iterate through the single tags
+ children <- XML.nodes(single.tags)[["children"]]
+
+ results <- new("XiMpLe.doc",
+ file=filePath,
+ xml=XML.decl,
+ dtd=XML.doct,
+ children=children)
+
+ return(results)
}
Deleted: trunk/rkward/packages/XiMpLe/R/pasteXML-methods.R
===================================================================
--- trunk/rkward/packages/XiMpLe/R/pasteXML-methods.R 2013-12-21 19:33:05 UTC (rev 4772)
+++ trunk/rkward/packages/XiMpLe/R/pasteXML-methods.R 2014-03-05 00:57:33 UTC (rev 4773)
@@ -1,161 +0,0 @@
-# Copyright 2011-2013 Meik Michalke <meik.michalke at hhu.de>
-#
-# This file is part of the R package XiMpLe.
-#
-# XiMpLe is free software: you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation, either version 3 of the License, or
-# (at your option) any later version.
-#
-# XiMpLe is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with XiMpLe. If not, see <http://www.gnu.org/licenses/>.
-
-
-#' Paste methods for XiMpLe XML objects
-#'
-#' These methods can be used to paste objects if class \code{\link[XiMpLe:XiMpLe.node-class]{XiMpLe.node}}
-#' or \code{\link[XiMpLe:XiMpLe.doc-class]{XiMpLe.doc}}.
-#'
-#' @note The functions pasteXMLNode() and pasteXMLTree() have been replaced by the pasteXML methods.
-#' They should no longer be used.
-#'
-#' @param obj An object of class \code{XiMpLe.node} or \code{XiMpLe.doc}.
-#' @param level Indentation level.
-#' @param shine Integer, controlling if the output should be formatted for better readability. Possible values:
-#' \describe{
-#' \item{0}{No formatting.}
-#' \item{1}{Nodes will be indented.}
-#' \item{2}{Nodes will be indented and each attribute gets a new line.}
-#' }
-#' @param indent.by A charachter string defining how indentation should be done. Defaults to tab.
-#' @param tidy Logical, if \code{TRUE} the special characters "<" and ">" will be replaced with the entities
-#' "<" and "gt;" in attributes and text values.
-#' @aliases
-#' pasteXML,-methods
-#' pasteXML,XiMpLe.doc-method
-#' pasteXMLNode
-#' pasteXMLTree
-#' @seealso \code{\link[XiMpLe:XiMpLe.node-class]{XiMpLe.node}},
-#' \code{\link[XiMpLe:XiMpLe.doc-class]{XiMpLe.doc}}
-#' @keywords methods
-#' @rdname pasteXML-methods
-#' @include XiMpLe.node-class.R
-#' @include XiMpLe.doc-class.R
-#' @exportMethod pasteXML
-setGeneric("pasteXML", function(obj, ...) standardGeneric("pasteXML"))
-
-#' @usage pasteXML(obj, level=1, shine=1, indent.by="\t", tidy=TRUE)
-#' @rdname pasteXML-methods
-#' @aliases
-#' pasteXML,XiMpLe.node-method
-#' @export
-setMethod("pasteXML",
- signature=signature(obj="XiMpLe.node"),
- function(obj, level=1, shine=1, indent.by="\t", tidy=TRUE){
-
- new.indent <- ifelse(shine > 0, indent(level+1, by=indent.by), "")
- new.node <- ifelse(shine > 0, "\n", "")
-
- # get the slot contents
- node.name <- slot(obj, "name")
- node.attr <- slot(obj, "attributes")
- node.chld <- slot(obj, "children")
- node.val <- slot(obj, "value")
-
- if(!length(node.attr) > 0){
- node.attr <- NULL
- } else {}
-
- if(length(node.chld) > 0){
- node.chld <- paste0(unlist(sapply(node.chld, function(this.node){
- if(slot(this.node, "name") == ""){
- this.node.pasted <- paste0(new.indent, pasteXML(this.node, level=level, shine=shine, indent.by=indent.by, tidy=tidy))
- } else {
- this.node.pasted <- pasteXML(this.node, level=(level + 1), shine=shine, indent.by=indent.by, tidy=tidy)
- }
- return(this.node.pasted)})), collapse="")
- node.empty <- FALSE
- } else {
- node.chld <- NULL
- node.empty <- TRUE
- }
-
- # take care of text value
- if(length(node.val) > 0){
- node.empty <- FALSE
- if(nchar(node.val) > 0){
- if(isTRUE(tidy)){
- node.val <- sapply(node.val, xml.tidy)
- } else {}
- node.chld <- paste0(node.chld, paste(node.val, new.node, collapse=" "))
- } else {}
- } else {}
-
- pasted.node <- pasteXMLTag(node.name, attr=node.attr, child=node.chld, empty=node.empty, level=level, allow.empty=TRUE, rename=NULL, shine=shine, indent.by=indent.by, tidy=tidy)
-
- return(pasted.node)
- }
-)
-#' @usage
-#' # S4 method for objects of class XiMpLe.doc
-#' pasteXML(obj, shine=1, indent.by="\t", tidy=TRUE)
-#' @rdname pasteXML-methods
-#' @export
-setMethod("pasteXML",
- signature=signature(obj="XiMpLe.doc"),
- function(obj, shine=1, indent.by="\t", tidy=TRUE){
-
- filename <- slot(obj, "file")
- tree.xml <- slot(obj, "xml")
- tree.doctype <- slot(obj, "dtd")
- tree.nodes <- slot(obj, "children")
-
- if(any(nchar(unlist(tree.xml)) > 0)) {
- doc.xml <- pasteXMLTag("?xml", attr=tree.xml, child=NULL, empty=TRUE, level=1, allow.empty=FALSE, rename=NULL, shine=min(1, shine), indent.by=indent.by, tidy=tidy)
- doc.xml <- gsub("/>", "\\?>", doc.xml)
- } else {
- doc.xml <- ""
- }
-
- if(any(nchar(unlist(tree.doctype)) > 0)) {
- new.node <- ifelse(shine > 0, "\n", "")
- doc.doctype <- paste("<!DOCTYPE", tree.doctype[["doctype"]], tree.doctype[["decl"]], sep=" ")
- for (elmt in c("id", "refer")){
- if(length(tree.doctype[[elmt]]) > 0) {
- if(nchar(tree.doctype[[elmt]]) > 0){
- doc.doctype <- paste0(doc.doctype, " \"",tree.doctype[[elmt]], "\"")
- } else {}
- } else {}
- }
- doc.doctype <- paste0(doc.doctype, ">", new.node)
- } else {
- doc.doctype <- ""
- }
-
- if(length(tree.nodes) > 0) {
- doc.nodes <- paste0(unlist(sapply(tree.nodes, function(this.node){
- return(pasteXML(this.node, level=1, shine=shine, indent.by=indent.by, tidy=tidy))})), collapse="")
- } else {
- doc.nodes <- ""
- }
-
- doc.all <- paste0(doc.xml, doc.doctype, doc.nodes, collapse="")
-
- return(doc.all)
- }
-)
-
-# for compatibility reasons, deploy wrapper functions
-#' @export
-pasteXMLNode <- function(node, level=1, shine=1, indent.by="\t", tidy=TRUE){
- pasteXML(node, level=level, shine=shine, indent.by=indent.by, tidy=tidy)
-}
-#' @export
-pasteXMLTree <- function(obj, shine=1, indent.by="\t", tidy=TRUE){
- pasteXML(obj, shine=shine, indent.by=indent.by, tidy=tidy)
-}
Modified: trunk/rkward/packages/XiMpLe/R/pasteXMLTag.R
===================================================================
--- trunk/rkward/packages/XiMpLe/R/pasteXMLTag.R 2013-12-21 19:33:05 UTC (rev 4772)
+++ trunk/rkward/packages/XiMpLe/R/pasteXMLTag.R 2014-03-05 00:57:33 UTC (rev 4773)
@@ -1,4 +1,4 @@
-# Copyright 2011-2013 Meik Michalke <meik.michalke at hhu.de>
+# Copyright 2011-2014 Meik Michalke <meik.michalke at hhu.de>
#
# This file is part of the R package XiMpLe.
#
@@ -23,8 +23,8 @@
#' with this one function.
#'
#' @note However, you will probably not want to use this function at all, as it is much more
-#' comfortable to create XML nodes or even nested trees with \code{\link[XiMpLe:XMLNode]{XMLNode}} and
-#' \code{\link[XiMpLe:XMLTree]{XMLTree}}, and then feed the result to \code{\link[XiMpLe:pasteXML]{pasteXML}}.
@@ Diff output truncated at 100000 characters. @@
More information about the rkward-tracker
mailing list