Nothing
# Copyright 2016-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/>.
#' Generate XML generator functions from XiMpLe.validity object
#'
#' Takes an object of class \code{\link[XiMpLe:XiMpLe.validity-class]{XiMpLe.validity}}
#' and turns it into a character vector of generator functions for each XML node that
#' was defined.
#'
#' The resulting code follows these rules:
#' \itemize{
#' \item{Each child node gets its own argument, except if there is only one valid child
#' node. It will use the dots element instead then.}
#' \item{Each attribute will also get its own argument.}
#' \item{If \code{CheckValidity=TRUE}, one extra argument named after the value of \code{valParam} will be added.}
#' \item{All arguments are set to \code{NULL} by default.}
#' \item{Only the main level of \code{"allAttrs"} will be taken into account, there's no recursion for this slot.}
#' }
#'
#' @param validity An dobject of class \code{XiMpLe.validity}.
#' @param prefix A character string to be used as a prefix for the resulting function names.
#' @param checkValidity Logical, whether all functions should include a check for valid XML.
#' @param indent.by A charachter string defining how indentation should be done.
#' @param roxygenDocs Logical, whether a skeleton for roxygen2-ish documentation should be added.
#' @param valParam A charachter string, name of the additional parameter to use for validation if
#' \code{checkValidity=TRUE}.
#' @param replaceChar A (single) character to be used as an replacement for invalid characters for
#' \code{R} parameter names.
#' @param dir A charachter string, path to write files to. If \code{dir=NULL}, no files are being
#' written, but the results returned in form of a character vector. If \code{dir} is set and the
#' directory does not yet exist, it will be created.
#' @param overwrite Logical, whether existing files should be replaced when \code{dir} is set.
#' @param oneFile A charachter string. If set, all functions are to be documented in one single *.Rd file,
#' named like the string.
#' @return If \code{dir=NULL} a named vector of character strings. Otherwise one or more files are
#' written do the location specified via \code{dir}.
#' @aliases
#' XMLgenerators,-methods
#' XMLgenerators,XiMpLe.validity-method
#' @seealso
#' \code{\link[XiMpLe:XMLValidity]{XMLValidity}} and
#' \code{\link[XiMpLe:XiMpLe.validity-class]{XiMpLe.validity}}
#' @keywords methods
#' @docType methods
#' @export
#' @rdname XMLgenerators
#' @include 00_class_03_XiMpLe.validity.R
setGeneric("XMLgenerators", function(validity, prefix="XML", checkValidity=TRUE, indent.by=getOption("XiMpLe_indent", "\t"), roxygenDocs=FALSE,
valParam="validity", replaceChar="_", dir=NULL, overwrite=FALSE, oneFile=NULL){standardGeneric("XMLgenerators")})
#' @rdname XMLgenerators
#' @importFrom utils file_test
#' @export
#' @examples
#' HTMLish <- XMLValidity(
#' children=list(
#' body=c("a", "p", "ol", "ul", "strong"),
#' head=c("title"),
#' html=c("head", "body"),
#' li=c("a", "br", "strong"),
#' ol=c("li"),
#' p=c("a", "br", "ol", "ul", "strong"),
#' ul=c("li")
#' ),
#' attrs=list(
#' a=c("href", "name"),
#' p=c("align")
#' ),
#' allChildren=c("!--"),
#' allAttrs=c("id", "class"),
#' empty=c("br")
#' )
#' XMLgenerators(HTMLish)
setMethod("XMLgenerators", signature(validity="XiMpLe.validity"), function(validity, prefix="XML", checkValidity=TRUE,
indent.by="\t", roxygenDocs=FALSE, valParam="validity", replaceChar="_", dir=NULL, overwrite=FALSE, oneFile=NULL){
validitySource <- XMLgenRecursion(validity=validity)
allKnownNodes <- validitySource[["allKnownNodes"]]
children <- validitySource[["children"]]
childNames <- validitySource[["childNames"]]
allChildren <- validitySource[["allChildren"]]
attrs <- validitySource[["attrs"]]
attrNames <- validitySource[["attrNames"]]
allAttrs <- validitySource[["allAttrs"]]
empty <- validitySource[["empty"]]
ignore <- validitySource[["ignore"]]
result <- sapply(
allKnownNodes,
function(thisNode){
thisNodeOptions <- dotsOption <- character()
attrsInNode <- childrenInNode <- functionBodyAttrs <- functionBodyChildren <- functionBodyValidation <- rxdoc <- NULL
genStart <- paste0(prefix, validParamName(thisNode), " <- function(")
# check for child nodes
if(thisNode %in% childNames){
thisNodeChildNames <- c(children[[thisNode]], allChildren)
if(length(thisNodeChildNames) == 1){
# replace the only child node with dots parameter
dotsOption <- "..."
} else {
thisNodeOptions <- paste0(validParamName(thisNodeChildNames), "=NULL")
}
} else if(length(allChildren) > 0){
thisNodeChildNames <- allChildren
thisNodeOptions <- paste0(validParamName(thisNodeChildNames), "=NULL")
} else {
thisNodeChildNames <- character()
}
# check for attributes
haveAttrs <- FALSE
if(thisNode %in% attrNames){
thisNodeAttrNames <- attrs[[thisNode]]
thisNodeOptions <- c(thisNodeOptions, paste0(validParamName(thisNodeAttrNames), "=NULL"))
haveAttrs <- TRUE
} else {
thisNodeAttrNames <- character()
}
if(length(allAttrs) > 0){
haveAttrs <- TRUE
thisNodeAttrNames <- c(thisNodeAttrNames, allAttrs)
thisNodeOptions <- c(thisNodeOptions, paste0(validParamName(allAttrs), "=NULL"))
} else {}
if(isTRUE(haveAttrs)){
functionBodyAttrs <- paste0(indent.by, "attrs.list <- list()")
attrsInNode <- paste0(indent.by, "attrs=attrs.list")
} else {}
if(isTRUE(checkValidity)){
thisNodeOptions <- c(thisNodeOptions, paste0(validParamName(valParam), "=NULL"))
} else {}
genFormals <- paste0(paste0(c(dotsOption, thisNodeOptions), collapse=", "), "){\n")
# function body
for (thisNodeAttr in thisNodeAttrNames){
functionBodyAttrs <- paste(
functionBodyAttrs,
paste0("if(!is.null(", validParamName(thisNodeAttr), ")){"),
paste0(indent.by, "attrs.list[[\"", thisNodeAttr, "\"]] <- ", validParamName(thisNodeAttr)),
"} else {}",
sep=paste0("\n", indent.by)
)
}
if(identical(dotsOption, character())){
if(length(thisNodeChildNames > 1)){
childrenInNode <- paste(
paste0(indent.by, "all.children <- list()"),
paste0("for (thisNode in list(", paste0(validParamName(thisNodeChildNames), collapse=", "), ")){"),
paste0(indent.by, "if(!is.null(thisNode)){"),
paste0(indent.by, indent.by, "all.children <- append(all.children, thisNode)"),
paste0(indent.by, "} else {}"),
"}",
sep=paste0("\n", indent.by)
)
} else {}
functionBodyChildren <- c(
paste0(indent.by, indent.by, "\"", thisNode, "\""),
if(!is.null(attrsInNode)){attrsInNode},
if(!is.null(childrenInNode)){paste0(indent.by, ".children=all.children")}
)
functionBodyChildren <- paste0(indent.by, "results <- XMLNode(\n",
paste0(functionBodyChildren, collapse=paste0(",\n", indent.by)),
"\n", indent.by, ")"
)
} else {
functionBodyChildren <- c(
paste0(indent.by, "results <- XMLNode("),
paste0(indent.by, "\"", thisNode, "\","),
if(!is.null(attrsInNode)){paste0(attrsInNode, ",")},
paste0(indent.by, ".children=list(...)"),
")"
)
functionBodyChildren <- paste0(functionBodyChildren, collapse=paste0("\n", indent.by))
}
if(isTRUE(checkValidity)){
functionBodyValidation <- paste(
paste0(indent.by, "if(!is.null(", validParamName(valParam), ")){"),
paste0(indent.by, "validXML(results, validity=", validParamName(valParam), ")"),
"} else {}",
sep=paste0("\n", indent.by)
)
} else {}
functionBodyReturn <- paste0(indent.by, "return(results)")
functionBody <- c(
if(!is.null(functionBodyAttrs)){functionBodyAttrs},
if(!is.null(childrenInNode)){childrenInNode},
if(!is.null(functionBodyChildren)){functionBodyChildren},
if(!is.null(functionBodyValidation)){functionBodyValidation},
functionBodyReturn
)
functionBody <- paste0(functionBody, collapse="\n\n")
genResult <- paste0(genStart, genFormals, functionBody, "\n}")
# add documentation?
if(isTRUE(roxygenDocs)){
if(identical(dotsOption, character())){
if(length(thisNodeChildNames > 1)){
rxdocChildren <- paste0(
"#' @param ", validParamName(thisNodeChildNames),
" An object of class \\code{XiMpLe_node} (or list of) to define \\code{<", thisNodeChildNames, ">} child nodes for this node. Ignored if \\code{NULL.}"
)
} else {
rxdocChildren <- NULL
}
} else {
rxdocChildren <- paste0(
"#' @param ... ",
" Object(s) of class \\code{XiMpLe_node} to define \\code{<", thisNodeChildNames, ">} child nodes for this node. Ignored if empty."
)
}
if(!identical(thisNodeAttrNames, character())){
rxdocAttrs <- paste0(
"#' @param ", validParamName(thisNodeAttrNames),
" Character string, used to set the \\code{", thisNodeAttrNames,"} attribute of this node. Ignored if \\code{NULL.}"
)
} else {
rxdocAttrs <- NULL
}
rxdocParams <- c(rxdocChildren, rxdocAttrs)
if(isTRUE(checkValidity)){
rxdocParams <- c(rxdocParams,
paste0(
"#' @param ", validParamName(valParam), " ",
" An object of class \\code{XiMpLe.validity} to check the validity of this node. Ignored if \\code{NULL.}"
)
)
} else {}
if(is.null(oneFile)){
rdFile <- paste0(prefix, validParamName(thisNode))
} else {
rdFile <- validParamName(gsub("\\.rd$|\\.Rd$", "", oneFile))
}
rxdoc <- paste(
paste0("#' Generate <", thisNode, "> XML nodes"),
"#'",
paste0("#' Generates an object of class \\code{\\link[XiMpLe:XiMpLe_node-class]{XiMpLe_node}} with node name \\code{<", thisNode, ">}."),
"#'",
paste0(rxdocParams, collapse="\n"),
"#' @return An object of class \\code{\\link[XiMpLe:XiMpLe_node-class]{XiMpLe_node}}.",
paste0("#' @rdname ", rdFile),
"#' @export",
sep="\n"
)
genResult <- paste0(rxdoc, "\n", genResult)
} else {}
return(genResult)
},
USE.NAMES=FALSE
)
if(is.null(dir)){
return(result)
} else {
if(!file_test("-d", dir)){
stopifnot(dir.create(dir, recursive=TRUE))
message(paste0("created directory: ", dir))
} else {}
for (thisFile in names(result)){
thisFileName <- paste0(prefix, validParamName(thisFile), ".R")
thisFilePath <- file.path(dir, thisFileName)
if(file.exists(thisFilePath)){
if(isTRUE(overwrite)){
cat(result[thisFile], file=thisFilePath)
message(paste0("file exists, overwriting: ", thisFilePath))
} else {
warning(paste0("file exists, skipping: ", thisFilePath), call.=FALSE)
}
} else {
cat(result[thisFile], file=thisFilePath)
message(paste0("written new file: ", thisFilePath))
}
}
return(invisible(NULL))
}
}
)
## function XMLgenRecursion()
# helper function to get all child nodes and attributes out of nested validity objects
XMLgenRecursion <- function(validity){
children <- slot(validity, "children")
childrenVal <- which(sapply(children, is.XiMpLe.validity, USE.NAMES=FALSE))
childrenChr <- children[sapply(children, is.character, USE.NAMES=FALSE)]
childNames <- names(children)
attrs <- slot(validity, "attrs")
attrNames <- names(attrs)
allChildren <- slot(validity, "allChildren")
allAttrs <- slot(validity, "allAttrs")
empty <- slot(validity, "empty")
ignore <- slot(validity, "ignore")
allKnownNodes <- unique(c(childNames, unlist(childrenChr), allChildren, attrNames, empty, ignore))
# full recursion
if(length(childrenVal) > 0){
for (thisChildValNum in childrenVal){
recursiveResult <- XMLgenRecursion(validity=children[[thisChildValNum]])
# this adds child nodes for the current node to the list
thisRecNodeName <- childNames[[thisChildValNum]]
if(length(recursiveResult[["childNames"]]) > 0){
childrenChr[[thisRecNodeName]] <- sort(unique(c(childrenChr[[thisRecNodeName]], recursiveResult[["childNames"]])))
} else {}
# this now also adds children's child nodes
for (thisRecChildName in names(recursiveResult[["children"]])){
if(thisRecChildName %in% names(childrenChr)){
childrenChr[[thisRecChildName]] <- sort(unique(c(childrenChr[[thisRecChildName]], recursiveResult[["children"]][[thisRecChildName]])))
} else {
childrenChr <- append(childrenChr, recursiveResult[["children"]][thisRecChildName])
}
}
for (thisRecAttrName in names(recursiveResult[["attrs"]])){
if(thisRecAttrName %in% attrNames){
attrs[[thisRecAttrName]] <- sort(unique(c(attrs[[thisRecAttrName]], recursiveResult[["attrs"]][[thisRecAttrName]])))
} else {
attrs <- append(attrs, recursiveResult[["attrs"]][thisRecAttrName])
}
}
childNames <- unique(c(childNames, recursiveResult[["childNames"]]))
attrNames <- unique(c(attrNames, recursiveResult[["attrNames"]]))
empty <- unique(c(empty, recursiveResult[["empty"]]))
ignore <- unique(c(ignore, recursiveResult[["ignore"]]))
allKnownNodes <- unique(c(allKnownNodes, recursiveResult[["allKnownNodes"]]))
}
} else {}
result <- list(
allKnownNodes=sort(allKnownNodes),
children=childrenChr[sort(names(childrenChr))],
childNames=sort(childNames),
allChildren=sort(allChildren),
attrs=attrs[sort(names(attrs))],
attrNames=sort(attrNames),
allAttrs=sort(allAttrs),
empty=sort(empty),
ignore=sort(ignore)
)
return(result)
} ## end function XMLgenRecursion()
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.