Nothing
# 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/>.
#' 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 ... Additional options for the generic method, see options for a specific method, respectively.
#' @aliases
#' pasteXML,-methods
#' pasteXMLNode
#' pasteXMLTree
#' @seealso \code{\link[XiMpLe:XiMpLe_node-class]{XiMpLe_node}},
#' \code{\link[XiMpLe:XiMpLe_doc-class]{XiMpLe_doc}}
#' @keywords methods
#' @import 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.
#' @param tidy.omit A character vector with node names that should be excluded from \code{tidy}.
#' @param as_script Logical, if \code{TRUE}, tags will be pasted as a sketch for a script to be run in conjunction with
#' functions generated by \code{\link[XiMpLe:gen_tag_functions]{gen_tag_functions}}. This script code will most
#' likely not run without adjustments, but is perhaps a good start anyway.
#' @param func_rename Named character vector defining which tags' functions should get a different name.
#' This makes it easier to get functions with valid names that generate special tag nodes.
#' Only used when \code{as_script=TRUE}. Use the same names and values as you used in
#' \code{\link[XiMpLe:gen_tag_functions]{gen_tag_functions}}.
#' @rdname pasteXML-methods
#' @aliases
#' pasteXML,XiMpLe_node-method
setMethod("pasteXML",
signature=signature(obj="XiMpLe_node"),
function(
obj,
level=1,
shine=1,
indent.by=getOption("XiMpLe_indent", "\t"),
tidy=TRUE,
tidy.omit=c("![CDATA[", "*![CDATA["),
as_script=FALSE,
func_rename=c(
"?xml_"="xml_",
"!--_"="comment_",
"![CDATA[_"="CDATA_",
"!DOCTYPE_"="DOCTYPE_"
)
){
if(isTRUE(as_script)){
next_sep <- ","
} else {
next_sep <- ""
}
new_indent <- ifelse(shine > 0, indent(level+1, by=indent.by), "")
new_node <- ifelse(shine > 0, paste0(next_sep, "\n"), paste0(next_sep, " "))
# 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){
# check for shine overwrites, pass it down to children
shine_override <- slot(obj, "extra")[["shine"]]
node_chld <- paste0(unlist(sapply(
node_chld,
function(this_node){
if(slot(this_node, "name") %in% tidy.omit){
tidy <- FALSE
} else {}
if(slot(this_node, "name") == ""){
this_node_pasted <- trim(pasteXML(
this_node,
level=level,
shine=ifelse(length(shine_override) > 0, shine_override, shine),
indent.by=indent.by,
tidy=tidy,
tidy.omit=tidy.omit,
as_script=as_script,
func_rename=func_rename
))
} else {
this_node_pasted <- trim(pasteXML(
this_node,
level=(level + 1),
shine=ifelse(length(shine_override) > 0, shine_override, shine),
indent.by=indent.by,
tidy=tidy,
tidy.omit=tidy.omit,
as_script=as_script,
func_rename=func_rename
))
}
return(this_node_pasted)
},
USE.NAMES=FALSE
)), collapse=paste0(new_node, new_indent))
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(all(isTRUE(tidy), !node_name %in% tidy.omit)){
node_val <- sapply(node_val, xml.tidy, USE.NAMES=FALSE)
} else {}
node_chld <- paste0(
node_chld,
trim(
paste0(
node_val,
collapse=new_node
)
)
)
} else {}
} else {}
result <- 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,
as_script=as_script,
func_rename=func_rename
)
return(result)
}
)
#' @rdname pasteXML-methods
#' @aliases
#' pasteXML,XiMpLe_doc-method
setMethod("pasteXML",
signature=signature(obj="XiMpLe_doc"),
function(
obj,
shine=1,
indent.by=getOption("XiMpLe_indent", "\t"),
tidy=TRUE,
tidy.omit=c("![CDATA[", "*![CDATA["),
as_script=FALSE,
func_rename=c(
"?xml_"="xml_",
"!--_"="comment_",
"![CDATA[_"="CDATA_",
"!DOCTYPE_"="DOCTYPE_"
)
){
filename <- slot(obj, "file")
tree_xml <- slot(obj, "xml")
tree_doctype <- slot(obj, "dtd")
tree_nodes <- slot(obj, "children")
doc_xml <- ""
new_node <- ifelse(shine > 0, "\n", "")
if(all(sapply(tree_xml, is.character, USE.NAMES=FALSE))){
if(any(nchar(unlist(tree_xml)) > 0)) {
doc_xml <- pasteXMLTag(
"?xml",
attr=tree_xml,
empty=TRUE,
level=1,
allow.empty=FALSE,
shine=min(1, shine),
indent.by=indent.by,
tidy=tidy,
as_script=as_script,
func_rename=func_rename
)
} else {}
} else if(all(sapply(tree_xml, is.XiMpLe.node, USE.NAMES=FALSE))){
doc_xml <- paste0(unlist(sapply(
tree_xml,
function(this.decl){
pasteXML(
this.decl,
level=1,
shine=shine,
indent.by=indent.by,
tidy=tidy,
tidy.omit=tidy.omit,
as_script=as_script,
func_rename=func_rename
)
}
)), collapse="")
} else {}
if(length(tree_doctype) > 0) {
if(any(c("doctype", "decl", "id", "refer") %in% names(tree_doctype))){
# convert old syntax
doc_doctype_attrs <- list()
if(isTRUE("doctype" %in% names(tree_doctype))){
doc_doctype_attrs[[tree_doctype[["doctype"]]]] <- character()
} else {}
if(isTRUE("decl" %in% names(tree_doctype))){
doc_doctype_attrs[[tree_doctype[["decl"]]]] <- character()
} else {}
if(isTRUE("id" %in% names(tree_doctype))){
doc_doctype_attrs[[paste0("\"", tree_doctype[["id"]], "\"")]] <- character()
} else {}
if(isTRUE("refer" %in% names(tree_doctype))){
doc_doctype_attrs[[paste0("\"", tree_doctype[["refer"]], "\"")]] <- character()
} else {}
tree_doctype <- doc_doctype_attrs
} else {}
doc_doctype <- pasteXML(
XMLNode(
"!DOCTYPE",
attrs=tree_doctype
),
level=1,
shine=shine,
indent.by=indent.by,
tidy=tidy,
tidy.omit=tidy.omit,
as_script=as_script,
func_rename=func_rename
)
} 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,
tidy.omit=tidy.omit,
as_script=as_script,
func_rename=func_rename
)
)
},
USE.NAMES=FALSE
)), 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=getOption("XiMpLe_indent", "\t"), tidy=TRUE){
.Deprecated("pasteXML")
pasteXML(node, level=level, shine=shine, indent.by=indent.by, tidy=tidy)
}
#' @export
pasteXMLTree <- function(obj, shine=1, indent.by=getOption("XiMpLe_indent", "\t"), tidy=TRUE){
.Deprecated("pasteXML")
pasteXML(obj, shine=shine, indent.by=indent.by, tidy=tidy)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.