# Copyright 2011-2022 Meik Michalke <meik.michalke@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
#' @description \code{XiMpLe.XML} is a class union for objects of classes \code{XiMpLe_node} and \code{XiMpLe_doc}.
#' @rdname node
#' @export
setClassUnion(
"XiMpLe.XML",
members=c(
"XiMpLe_node",
"XiMpLe_doc",
"XiMpLe.node",
"XiMpLe.doc"
)
)
#' @rdname node
#' @aliases
#' node,-methods
#' node,XiMpLe_doc-method
#' node,XiMpLe_node-method
#' 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)
},
USE.NAMES=FALSE
)
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))
},
USE.NAMES=FALSE
)
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(XiMpLe_node()), "@path", "obj@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@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)
}
)
#' @param value The value to set.
#' @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.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@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 <- unlist(sapply(
all.node.children,
function(this.child){
if(
all(
identical(slot(this.child, "name"), ""),
isTRUE(nchar(slot(this.child, "value")) > 0)
)
){
return(TRUE)
} else {
return(FALSE)
}
},
USE.NAMES=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, ",
"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)
}
)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.