R/xml_utilities.R
In carlopacioni/HexSimR: an R package for post HexSim simulation analysis
Defines functions
xml.cond.replacement
LHS.scenarios
workspace.path.modifier
scenarios.batch.modifier
is.attribs
make.Xpaths
make.Xpath
Documented in
is.attribs
LHS.scenarios
make.Xpath
make.Xpaths
scenarios.batch.modifier
workspace.path.modifier
xml.cond.replacement
#' Build a Xpath
#'
#' This function builds a Xpath to search nodes in HexSim xml files. It is used
#' internally by hexSimR. When used in the LHS.scenarios function, it constructs
#' the path "/.../name[text()='...']" when param_node is not NA,
#' param_identifier is FALSE and is.LHS is TRUE. Addtional details on arguments
#' are in the scenarios.batch.modifier.
#'
#' @param node_path The node_path
#' @param identifier The identifier of the node
#' @param attrib Whether the identifier is an attribute
#' @param param_node Whether the parameter is contained in an internal node
#' @param is.LHS Whether the Xpath being built is for a LHS
#' @return A character vector with the Xpath
#' @export
make.Xpath <- function(node_path, identifier, attrib,
param_node=NA, param_identifier=FALSE, is.LHS=FALSE) {
last_slash <- gregexpr("/", node_path)
if(is.na(param_node) && is.LHS && !is.na(as.logical(param_identifier))) {
Xpath <- paste0(x=node_path, "[text()='", identifier, "']")
} else {
identifier_name <- substr(node_path, start=max(last_slash[[1]]) + 1,
stop=nchar(node_path))
Xpath <- paste0(sub(pattern=paste0("/", identifier_name),
replacement="",
x=node_path),
paste0("[", if(attrib) "@", identifier_name,
"='", identifier, "']"))
}
return(Xpath)
}
#----------------------------------------------------------------------------#
#' Check conditions and pass the right arguments to make.Xpath
#'
#' See scenarios.batch.modifier for addtional details on arguments
#'
#' @param node_paths A character vector of node_paths
#' @param Xpaths A empty list of length = length(node_paths)
#' @param identifiers A character vector of node identifiers
#' @param attribs A logical vector as to whether the identifiers are attributes
#' @param param_nodes A character vector if the parameters are contained in
#' internal nodes, NA otherwise
#' @param param_node_identifiers A character vector if the param_nodes have
#' identifiers, FALSE otherwise
#' @param param_identifiers A character vector if the params have identifiers
#' (it is assumed these are attributes), FALSE otherwise
#' @param is.LHS A logical vector whether the Xpaths being built are for a LHS
#' @return A list (Xpaths) of character vectors with the Xpaths
#' @export
make.Xpaths <- function(node_paths, Xpaths, identifiers, attribs,
param_nodes=NA, param_node_identifiers=FALSE,
param_node_attributes=FALSE,
param_identifiers=FALSE, is.LHS=FALSE) {
suppressWarnings(
if(is.na(param_nodes) && length(param_nodes) == 1)
param_nodes <- rep(NA, length(node_paths))
)
suppressWarnings(
if(is.na(param_identifiers) && length(param_identifiers) == 1)
param_identifiers <- rep(FALSE, length(node_paths))
)
suppressWarnings(
if(is.na(param_node_identifiers) && length(param_node_identifiers) == 1)
param_node_identifiers <- rep(FALSE, length(node_paths))
)
suppressWarnings(
if(is.na(param_node_attributes) && length(param_node_attributes) == 1)
param_node_attributes <- rep(FALSE, length(node_paths))
)
param_node_Xpaths <- vector("character", length(node_paths))
for(i in seq_along(node_paths)) {
if(is.na(as.logical(identifiers[i]))) {
Xpaths[i] <- make.Xpath(node_paths[i], identifiers[i], attribs[i],
param_node=param_nodes[i],
param_identifier=param_identifiers[i],
is.LHS=TRUE)
if(!is.na(param_nodes[i])) {
if(is.na(as.logical(param_node_identifiers[i]))) {
param_node_Xpaths[i] <- make.Xpath(param_nodes[i],
param_node_identifiers[i],
param_node_attributes[i],
param_identifier=param_identifiers[i],
is.LHS=TRUE)
} else {
param_node_Xpaths[i] <- param_nodes[i]
}
Xpaths[i] <- paste0(Xpaths[i], param_node_Xpaths[i])
}
} else {
Xpaths[i] <- node_paths[i]
}
}
return(Xpaths)
}
#----------------------------------------------------------------------------#
#' Check whether the param is an attribute or a node
#'
#' Check whether the param being changed by LHS.scenarios or
#' xml.cond.replacement is an attribute or a node. This function is used
#' internally by HexSimR.
#'
#' @param attrib Whether the identifier is an attribute
#' @param param_node_identifier Whether param_node has an identifier
#' @param param_node_attribute Whether the param_node identifier is an attribute
#' @param param_identifier Whether the param has an identifier (it is assumed
#' this is an attribute)
#' @return A logical vector with the Xpathof length=1
#' @export
is.attribs <- function(attrib,
param_node_attribute, param_node_identifier,
param_identifier){
chk <- is.na(as.logical(param_identifier)) |
(!is.na(as.logical(param_identifier)) && param_node_attribute) |
(!is.na(as.logical(param_identifier)) &&
!is.na(as.logical(param_node_identifier)) &&
attrib)
return(chk)
}
#----------------------------------------------------------------------------#
#' Batch modification of scenarios
#'
#' Modify several scenarios at once by replacing, deleting or adding nodes (e.g.
#' events) in scenario .xml files.
#'
#' If several scenarios have been developed in HexSim and later the user
#' realises that there are some modifications that need to be applied to several
#' or all of them, this function can help automate this task. It involves
#' generating a scenario with the correct/new events and parameters. This
#' scenario is used then as template and the nodes that need to be added,
#' replaced or deleted are identified using a .csv file. Some setting up is
#' required and it may not be worthwhile for only one or two scenarios. To use
#' this function some understanding of the xml file structure in HexSim is
#' necessary. The easiest is to open the xml file and have a look at the
#' structure. Using a source code editor like Notepad++ (that colour-code
#' different element of the text based on the language used) can help to
#' understand the structure. Briefly, each of the settings and parameters in
#' HexSim is set by a node in the xml file. Some nodes have a unique identifier,
#' which can be an attribute (generally name="\emph{attribute_value}"), or a
#' text element value (e.g. <name> \emph{node_name} </name>). To this end,
#' identifiers are considered element that make the node unique. For example,
#' accumulate events have all the same structure, but they can be identified by
#' the value given to the node <name>. On the contrary, there are nodes that are
#' unique and can be simply identified by the node's name. One example of such
#' nodes is <initializationSpatialData>, which is unique, so a search in the xml
#' file for the path: "/scenario/population/initializationSpatialData" will
#' return one node only. From a practical point of view, the easiest way to work
#' out of to complete the setting up for this function is to create or modify a
#' scenario with the correct events/parameters. Save it and then comparing this
#' with one of the one that needs to be modified using, for example, the plug in
#' "compare" in Notepad++, or Winmerge (on Windows). For more information see
#' the vignette: \bold{Latin Hypercube Sampling and (batch) modification of
#' scenarios and maps}.
#'
#' If \code{path.scenarios=NULL}, an interactive dialog box is used to select
#' the path where the scenario xml files are located.
#'
#' If \code{scenarios="all"} (default), all scenarios are processed, otherwise
#' it is possible to select a subset of scenarios using a character vector, e.g.
#' scenarios=c("scen1", "scen2"). \bold{Note:} when a \code{xml.template} is
#' passed, this is assumed to be in the \code{path.scenarios} directory and it
#' is removed from the list of scenarios to be modified.
#'
#' A back up of the folder \code{path.scenarios} is copied in the the folder
#' "Scenarios_bkup", one level up from \code{path.scenarios}.
#'
#' The .csv file essentially provides the information on how to locate the nodes
#' that need to be modified, and what type of actions need to be carried out.The
#' .csv must be located in the scenario folder and the name should be passed
#' with \code{csv.in} as a character vector. The file must have the following
#' headings: nodes, identifier, attribute, mode, ref, ref_identifier, and
#' ref_attribute. \code{scenarios.batch.modifier} will parse the file and use
#' these columns as arguments. See \code{system.file("extdata", "test_csv.csv",
#' package="HexSimR")} for an example file.
#'
#' The column with heading \bold{nodes} is the path to the node to be searched
#' in the \code{xml.template} file, except when the \bold{mode} is "delete", in
#' which case the nodes are searched in the scenario file and then deleted. The
#' path starts at the root of the xml file ("scenario") and progresses until the
#' node's name or identifier. It must start with a "/", and must not have a "/"
#' at the end. For example, for an accumulator, the path in the column "nodes"
#' would be: "/scenario/population/accumulators/accumulator/name".
#'
#' \bold{identifier} is used to indicate whether the node has an identifier. If
#' it does (e.g. name="\emph{attribute_value}"), the name (or the value if an
#' attribute) of the identifier needs to be in this column (e.g.
#' \emph{attribute_value}), otherwise FALSE must be used.
#'
#' \bold{attribute} indicates whether the identifier is an attribute (TRUE) or
#' not (FALSE).
#'
#' \bold{mode} indicates the type of action that needs to be performed. Possible
#' options are "add", "before", "after", "replace" or "delete". If "add" the
#' node is added as last child of the parent node. If the node needs to be added
#' in a specific position (events generally do), "before" and "after" should be
#' used to indicate the position respect to the \bold{ref} node (i.e. whether
#' the new node goes before or after the node \bold{ref}. Note that the
#' \bold{ref} node is searched in the scenario file, not the
#' \code{xml.template}. If the option "delete" is used, the node is searched and
#' deleted from the scenario file. When "replace" is used, the \bold{ref} node
#' must be provided, even when the node is the same. This is because there might
#' be situations where what it is being changed is the name of the node. In
#' these cases, \code{scenarios.batch.modifier} would not find the original node
#' in the scenario file.
#'
#' \bold{ref} needs to be passed when the options "before", "after" or "replace"
#' are used in \bold{mode}. When not relevant, \code{NA} is used. When
#' \bold{ref} is used, then a search is performed in the scenario xml file and
#' the fields \bold{ref_identifier} and \bold{ref_attribute} must also be passed
#' when relevant. \bold{ref_identifier} and \bold{ref_attribute} have the same
#' meaning as \bold{identifier} and \bold{attribute}, but they refer to the
#' \bold{ref} node. Use FALSE when these are not relevant.
#'
#' @param path.scenarios The path to the 'Scenarios' folder
#' @param xml.template The name of the xml file to use as template for the new
#' nodes
#' @param csv.in The name of the .csv file in the "Scenarios" folder with the
#' information on the nodes that need to be modified (or checked in case of
#' xml.cond.replacement)
#' @inheritParams collate.census
#' @import xml2
#' @importFrom tcltk tk_choose.dir
#' @export
#' @examples
#' # locate and copy example files
#' new <- system.file("extdata", "MRVC_4BaitYr_ThreeCells.xml", package="HexSimR")
#' old <- system.file("extdata", "MRVC_4BaitYr_ThreeCells_old.xml", package="HexSimR")
#' csv.in <- system.file("extdata", "test_csv.csv", package="HexSimR")
#' testFolder <- tempdir(check = TRUE)
#' file.copy(c(new, old, csv.in), testFolder)
#'
#' XMLTest <- scenarios.batch.modifier(
#' path.scenarios=testFolder,
#' scenarios="MRVC_4BaitYr_ThreeCells_old.xml",
#' xml.template="MRVC_4BaitYr_ThreeCells.xml",
#' csv.in="test_csv.csv")
#'
#' # Clean up
#' files <- list.files(testFolder, full.names=TRUE)
#' file.remove(files)
#' unlink(file.path(dirname(testFolder), '/Scenarios_bkup'), recursive=TRUE)
scenarios.batch.modifier <- function(
path.scenarios=NULL,
scenarios="all",
xml.template=NULL,
csv.in) {
#### Setting arguments ####
txt <- "Please, select the 'Scenarios' folder within the workspace"
if(is.null(path.scenarios)) path.scenarios <- tk_choose.dir(caption=txt)
suppressWarnings(if(scenarios == "all")
scenarios <- list.files(path=path.scenarios, pattern=".xml$",
full.names=FALSE, recursive=FALSE))
if(!is.null(xml.template)){
scenarios <- scenarios[!scenarios %in% xml.template]
}
csv_file <- read.csv(file=file.path(path.scenarios, csv.in), stringsAsFactors=FALSE)
node_paths <- csv_file[, "nodes"]
modes <- csv_file[, "mode"]
identifiers <- csv_file[, "identifier"]
attribs <- csv_file[, "attribute"]
refs <- csv_file[, "ref"]
ref_identifiers <- csv_file[, "ref_identifier"]
ref_attribs <- csv_file[, "ref_attribute"]
#### Creating new nodes and ref Xpaths ####
nodes <- vector("list", length(node_paths))
Xpaths <- vector("character", length(node_paths))
if(sum(!is.na(refs))) ref_Xpaths <- vector("character", length(node_paths))
if(!is.null(xml.template))
xml_template <- read_xml(file.path(path.scenarios, xml.template), options="")
for(i in seq_along(node_paths)) {
if(is.na(as.logical(identifiers[i]))) {
Xpaths[i] <- make.Xpath(node_paths[i], identifiers[i], attribs[i])
} else {
Xpaths[i] <- node_paths[i]
}
if(modes[i] != "delete") {
nodes[[i]] <- xml_find_all(xml_template, Xpaths[i])
if(length(nodes[[i]]) == 0)
stop(paste("Can't find the node path:",
Xpaths[i], "in the file", xml.template))
if(grepl(pattern = "Event", x = xml_path(nodes[[i]]))) {
nodes[[i]] <- xml_parent(nodes[[i]])
}
}
if(length(nodes[[i]]) > 1) {
stop(paste(
"More than one node identified with the node path:",
node_paths[[i]], "in the file", xml.template))
}
# ref Xpaths
if(!is.na(refs[i])) {
if(is.na(as.logical(ref_identifiers[i]))) {
ref_Xpaths[i] <- make.Xpath (refs[i], ref_identifiers[i], ref_attribs[i])
} else {
ref_Xpaths[i] <- refs[i]
}
}
}
#### Backing up the scenario files
d <- paste(dirname(path.scenarios), "Scenarios_bkup", sep="/")
suppressWarnings(dir.create(path = d))
file.copy(from = path.scenarios, to = d, recursive = TRUE, copy.date = TRUE)
#### Processing modifications ####
for(scenario in scenarios) {
xml_scenario <- read_xml(file.path(path.scenarios, scenario))
if(sum(!is.na(refs))) ref_nodes <- vector("list", length(node_paths))
for(i in seq_along(node_paths)) {
if(modes[i] == "add") {
p <- xml_find_all(xml_scenario, xml_path(xml_parent(nodes[[i]])))
xml_add_child(p, nodes[[i]])
} else {
if(modes[i] %in% c("before", "after", "replace")) {
ref_nodes[[i]] <- xml_find_all(xml_scenario, ref_Xpaths[i])
if(length(ref_nodes[[i]]) == 0)
stop(paste("Can't find the node path:",
ref_Xpaths[i], "in the file", scenario))
if(grepl(pattern = "Event", x = xml_path(ref_nodes[[i]]))) {
ref_nodes[[i]] <- xml_parent(ref_nodes[[i]])
}
if(length(ref_nodes[[i]]) > 1) {
stop(paste(
"More than one node identified with the node path:",
ref_Xpaths[i], "in the file", scenario))
}
if(modes[i] %in% c("before", "after")) {
xml_add_sibling(ref_nodes[[i]], nodes[[i]], .where=modes[i])
} else {
xml_replace(ref_nodes[[i]], nodes[[i]])
}
} else {
if(modes[i] == "delete") {
nodes[[i]] <- xml_find_all(xml_scenario, Xpaths[i])
if(length(nodes[[i]]) == 0)
stop(paste("Can't find the node path:",
Xpaths[i], "in the file", scenario))
if(grepl(pattern = "Event", x = xml_path(Xpaths[i]))) {
nodes[[i]] <- xml_parent(Xpaths[i])
}
xml_remove(nodes[[i]])
} else {
stop(paste("Don't know what to do with mode", modes[i]))
}
}
}
}
write_xml(x = xml_scenario, file=file.path(path.scenarios, scenario))
}
}
#' Modify the path of the workspace and grid file in all scenario files
#'
#' When a HexSim workspace is copied to a new location, the path to the root of
#' the workspace and the grid file that is stored in the scenario files need to
#' be updated. When the simulations are run manually via the GUI, HexSim picks
#' this up and asks the user to re-save the scenario. However, when simulations
#' are run via command-line, an error occurs unless the path and the grid file
#' exist. This function updates all the xml scenario files with the new path
#' passed with: \code{new.grid.path}.
#'
#' \bold{WARNING:} Currently, xml scenario files saved by \code{HexSimR} trigger
#' a request by HexSim to re-save the files. This is due to very minor
#' differences in the file formatting, which do not affect the simulations.
#' These files run with no problems when run via the command-line (i.e.
#' batchRunner.exe)
#'
#' @param new.grid.path The fully qualified (i.e. including the full path) of
#' the grid file, including extension
#' @inheritParams collate.census
#' @inheritParams scenarios.batch.modifier
#' @import xml2
#' @importFrom tcltk tk_choose.dir
#' @export
workspace.path.modifier <- function(
path.scenarios=NULL,
scenarios="all",
new.grid.path) {
txt <- "Please, select the 'Scenarios' folder within the workspace"
if(is.null(path.scenarios)) path.scenarios <- tk_choose.dir(caption=txt)
suppressWarnings(if(scenarios == "all")
scenarios <- list.files(path=path.scenarios, pattern=".xml$",
full.names=FALSE, recursive=FALSE))
for(scenario in scenarios) {
xml_scenario <- read_xml(file.path(path.scenarios, scenario))
workspace <- xml_find_all(xml_scenario, "/scenario/workspace")
grid <- xml_find_all(xml_scenario, "/scenario/hexagonGrid/filename")
xml_text(workspace) <- dirname(new.grid.path)
xml_text(grid) <- new.grid.path
write_xml(x = xml_scenario, file=file.path(path.scenarios, scenario))
}
}
#' Generate LHS scenarios
#'
#' This function is used to generate scenarios whose parameter combinations
#' follow a Latin Hypercupe Sampling design. Parameter values can be drawn from
#' normal, lognormal, binomial, beta or uniform distributions or have a set of
#' fixed values.
#'
#' An xml file is passed (with \code{xml.template}) to build the LHS scenarios,
#' which are saved in the same \code{path.scenarios} where the template is.
#'
#' If \code{generate} is FALSE, then the function quits after generating the
#' hypercube matrix.
#'
#' An .csv file needs to be created, must be located in the scenario folder and
#' the name should be passed with \code{csv.in} as a character vector (see
#' \code{system.file("extdata", "test_csv_LHS.csv", package="HexSimR")} for an
#' example).
#'
#' The .csv must have the following headings: nodes, identifier, attribute,
#' param_node, param_node_identifier, param_node_attribute, param_identifier,
#' param_name, type, value, distribution. See documentation for
#' \code{scenarios.batch.modifier} on the meaning of nodes, identifier,
#' attribute. When \code{generate=FALSE} only the last four are mandatory.
#'
#' There might be situation where the parameter values to be changed are in an
#' internal node respect to the node identifier. In order to identify uniquely
#' this parameter, the identifier of the parameter node needs to be indicated.
#' This is best explained with an example. An accumulateTrait is identified by
#' the name attribute (i.e. <accumulateTrait name="XXX">), however the parameter
#' values are contained in the <value> node within the accumulateTrait. The node
#' <value> is itself identified by a name attribute, but the parameters are
#' stored under a "threshold" attribute. To avoid multiple hit \bold{nodes},
#' \bold{identifier} and \bold{attribute} are used to identify uniquely the
#' parent node where the parameter is contained.
#' \bold{param_node}, \bold{param_node_identifier}, and
#' \bold{param_node_attribute} are used to identify the node where the parameter
#' values are contained (if necessary, use NA for \bold{param_node} and FALSE
#' for the others columns if not relevant), and \bold{param_identifier} is used
#' to identify the actual parameter values that need to be changed, when this is
#' stored as an attribute. Use FALSE when the latter is not relevant (e.g. if
#' the node identifier is the parameter that needs to be changed).
#'
#' \bold{type} refers to the type of parameter. It can take exactly one of the
#' following: "integer", "numeric" or "character". \bold{value} refers to the
#' parameters of the distribution from which values are drawn (separated by a
#' comma) if one is used: mean and sd for normal, meanlog and sdlog for
#' lognormal, shape1 and shape2 for beta, prob for binomial and min and max for
#' uniform, otherwise a collection of values if \bold{distribution}="fixed".
#' When \bold{distribution}="fixed" or \bold{type}="character" the elements in
#' \bold{value} have equal probability.
#'
#' \bold{param_name} is the name of the parameter that is being changed. These
#' are used as labels (headers) in the hypercube matrix that it is saved to disk
#' and returned as an object.
#'
#' When \code{generate=TRUE}, the second element of the list returned contains
#' the nodes found in the template. It is probably a good idea to scan through
#' these to check whether these were the expected ones and most importantly that
#' none are empty!
#'
#' @param samples The number of LHS samples (i.e. parameter combinations)
#' @param generate Whether generate (TRUE) the xml files or stop after having
#' created the hypercube matrix (FALSE)
#' @inheritParams scenarios.batch.modifier
#' @return A list where the first element is the hyercube matrix and the second
#' are the nodes found in the template (if generate = TRUE). A csv file with
#' the hypercube matrix is saved to disk and, when generate = TRUE, the LHS
#' xml files are also saved to disk.
#' @import xml2
#' @importFrom lhs randomLHS
#' @importFrom stats qbeta qbinom qlnorm qnorm qunif
#' @export
#' @examples
#' # Locate the template file
#' template <- system.file("extdata", "MRVC_4BaitYr_ThreeCells.xml", package="HexSimR")
#'
#' # Locate the .csv file
#' csv.LHS.in <- system.file("extdata", "test_csv_LHS.csv", package="HexSimR")
#'
#' # Create a temp dir
#' testFolder <- tempdir(check = TRUE)
#'
#' # copy example files
#' file.copy(c(template, csv.LHS.in), testFolder)
#'
#' # Exexute the function
#' LHS <- LHS.scenarios(
#' path.scenarios=testFolder,
#' xml.template="MRVC_4BaitYr_ThreeCells.xml",
#' samples=9,
#' csv.in ="test_csv_LHS.csv",
#' generate=TRUE)
LHS.scenarios <- function(
path.scenarios=NULL,
xml.template=NULL,
samples,
csv.in,
generate=TRUE) {
#----------------------------------------------------------------------------#
# Helper functions
#----------------------------------------------------------------------------#
distribute <- list(
uniform=function(p, argums) qunif(p, as.numeric(argums[1]), as.numeric(argums[2])),
beta=function(p, argums) qbeta(p, as.numeric(argums[1]), as.numeric(argums[2])),
binom=function(p, argums) qbinom(p, size=1, prob=as.numeric(argums[1])),
lnorm=function(p, argums) qlnorm(p, as.numeric(argums[1]), as.numeric(argums[2])),
norm=function(p, argums) qnorm(p, as.numeric(argums[1]), as.numeric(argums[2])),
fixed=function(p, argums) {
br <- seq(0, by=1/length(argums), length.out=length(argums) + 1)
p <- as.numeric(argums[cut(p, br, labels=FALSE)])
return(p)
}
)
#----------------------------------------------------------------------------#
#### Setting arguments ####
txt <- "Please, select the 'Scenarios' folder within the workspace"
if(is.null(path.scenarios)) path.scenarios <- choose.dir(caption=txt)
csv_file <- read.csv(file=file.path(path.scenarios, csv.in),
stringsAsFactors=FALSE)
pnames <- csv_file[, "param_name"]
types <- csv_file[, "type"]
values <- strsplit(csv_file[, "value"], ",")
distrbs <- csv_file[, "distribution"]
k <- nrow(csv_file)
if(!is.null(xml.template)) {
root_name <- substr(xml.template, start=1, stop=nchar(xml.template) - 4)
} else {
root_name <- NULL
}
#### write hypercube matrix ####
hypercube <- as.data.frame(randomLHS(n=samples, k=k))
for(i in seq_along(types)) {
if(types[i] == "character") {
br <- seq(0, by=1/length(values[[i]]), length.out=length(values[[i]]) + 1)
hypercube[, i] <- values[[i]][cut(hypercube[, i], br, labels=FALSE)]
} else {
hypercube[, i] <- distribute[[distrbs[[i]]]](hypercube[, i], values[[i]])
if(types[i] == "integer") hypercube[, i] <- round(hypercube[, i])
}
}
names(hypercube) <- pnames
write.csv(hypercube, row.names=FALSE,
file=file.path(path.scenarios,
paste0(root_name,
if(!is.null(xml.template)) "_",
"hypercube.csv"))
)
#### generate xml files ####
if(generate) {
# Setting arguments
node_paths <- csv_file[, "nodes"]
identifiers <- csv_file[, "identifier"]
attribs <- csv_file[, "attribute"]
param_nodes <- csv_file[, "param_node"]
param_node_identifiers <- csv_file[, "param_node_identifier"]
param_node_attributes <- csv_file[, "param_node_attribute"]
param_identifiers <- csv_file[, "param_identifier"]
Xpaths <- vector("character", length(node_paths))
# Create Xpaths
Xpaths <- make.Xpaths(node_paths, Xpaths, identifiers, attribs,
param_nodes=param_nodes,
param_node_identifiers=param_node_identifiers,
param_node_attributes=param_node_attributes,
param_identifiers=param_identifiers, is.LHS=TRUE)
xml_template <- read_xml(file.path(path.scenarios, xml.template), options="")
#### Modify nodes ####
nodes <- vector("list", length(node_paths))
for(i in seq_along(node_paths)) {
nodes[[i]] <- xml_find_all(xml_template, Xpaths[i])
}
for(r in 1:samples) {
for(i in seq_along(node_paths)) {
if(is.attribs(attrib=attribs[i],
param_node_attribute=param_node_attributes[i],
param_node_identifier=param_node_identifiers[i],
param_identifier=param_identifiers[i])
) {
xml_attr(nodes[[i]], param_identifiers[i]) <- as.character(hypercube[r,i])
} else {
xml_text(nodes[[i]]) <- as.character(hypercube[r,i])
}
}
write_xml(x=xml_template, file=file.path(path.scenarios,
paste0(root_name, "_LHS", r, ".xml")))
}
}
return(list(hypercube=hypercube, if(generate) nodes=nodes))
}
#' Conditional replacement of xml elements
#'
#' This function replaces values in specific element nodes of xml scenario files
#' if a condition is satisfied. This may be useful when, for example, a few
#' resource maps have been used to generate scenarios for a LHS analysis. When
#' this occurs, all the nodes (events) that use the resource map need to match
#' the value in the node that was used to generate the LHS matrix. If the name
#' of the map is unique, it may be possible to simply search and replace for a
#' text string within all files. However, this approach will cause problem if
#' the same string is used in different components of the xml file (for example,
#' if there is a trait that is named as the resource map is).
#'
#' The file \code{csv.in}, which is constructed in the same way as in
#' \code{LHS.scenarios}, identifies element nodes whose value needs to be
#' satisfied. That is, a search is performed to identify a node and its values
#' is compared to the value reported in the column 'value' in \code{csv.in}. For
#' each row in \code{csv.in}, a \code{lookup} csv file needs to be present,
#' where a list of nodes that need to be modified and their new values is
#' stored. These values are applied in the xml files where the condition in the
#' relevant row of \code{csv.in} is met.
#'
#' @inheritParams scenarios.batch.modifier
#' @param lookup character vector with the csv file names of the element values
#' to changed. One file for each row of csv.in
#' @param verbose Whether report to screen nodes found and changed (default: TRUE)
#' @import xml2
#' @export
xml.cond.replacement <- function (path.scenarios=NULL,
scenarios="all",
csv.in,
lookup,
verbose=TRUE) {
#### Setting arguments ####
txt <- "Please, select the 'Scenarios' folder within the workspace"
if(is.null(path.scenarios)) path.scenarios <- choose.dir(caption=txt)
suppressWarnings(if(scenarios == "all")
scenarios <- list.files(path=path.scenarios, pattern=".xml$",
full.names=FALSE, recursive=FALSE))
csv_file <- read.csv(file=file.path(path.scenarios, csv.in),
stringsAsFactors=FALSE)
node_paths <- csv_file[, "nodes"]
identifiers <- csv_file[, "identifier"]
attribs <- csv_file[, "attribute"]
param_nodes <- csv_file[, "param_node"]
param_node_identifiers <- csv_file[, "param_node_identifier"]
param_node_attributes <- csv_file[, "param_node_attribute"]
param_identifiers <- csv_file[, "param_identifier"]
param_attributes <- csv_file[, "param_attribute"]
Xpaths <- vector("character", length(node_paths))
values <- csv_file[, "value"]
# Create Xpaths
Xpaths <- make.Xpaths(node_paths, Xpaths, identifiers, attribs,
param_nodes=param_nodes,
param_node_identifiers=param_node_identifiers,
param_node_attributes=param_node_attributes,
param_identifiers=param_identifiers, is.LHS=TRUE)
for(scenario in scenarios) {
xml_scenario <- read_xml(file.path(path.scenarios, scenario))
nodes <- vector("list", length(node_paths))
for(i in seq_along(node_paths)) {
lookup_file <- read.csv(file=file.path(path.scenarios, lookup[i]),
stringsAsFactors=FALSE)
nodes[[i]] <- xml_find_all(xml_scenario, Xpaths[i])
if(length(nodes[[i]]) > 0) {
if(is.attribs(attrib=attribs[i],
param_node_attribute=param_node_attributes[i],
param_node_identifier=param_node_identifiers[i],
param_identifier=param_identifiers[i])
) {
chk <- xml_attr(nodes[[i]], param_identifiers[i])
} else {
chk <- xml_text(nodes[[i]])
}
if(chk == values[i]) {
message(paste("Found a node for", Xpaths[i], "in", scenario))
message(paste("The node value is", chk))
rep_node_paths <- lookup_file[, "nodes"]
rep_identifiers <- lookup_file[, "identifier"]
rep_attribs <- lookup_file[, "attribute"]
rep_param_nodes <- lookup_file[, "param_node"]
rep_param_node_identifiers <- lookup_file[, "param_node_identifier"]
rep_param_node_attributes <- lookup_file[, "param_node_attribute"]
rep_param_identifiers <- lookup_file[, "param_identifier"]
rep_Xpaths <- vector("character", length(rep_node_paths))
rep_nodes <- vector("list", length(rep_node_paths))
rep_values <- lookup_file[, "value"]
# Create rep_Xpaths
rep_Xpaths <- make.Xpaths(node_paths=rep_node_paths,
Xpaths=rep_Xpaths,
identifiers=rep_identifiers,
attribs=rep_attribs,
param_nodes=rep_param_nodes,
param_identifiers=rep_param_identifiers,
param_node_identifiers=rep_param_node_identifiers,
param_node_attributes=rep_param_node_attributes,
is.LHS=TRUE)
for(r in seq_along(rep_node_paths)) {
rep_nodes[[r]] <- xml_find_all(xml_scenario, rep_Xpaths[r])
if(is.attribs(attrib=rep_attribs[r],
param_node_attribute=rep_param_node_attributes[r],
param_node_identifier=rep_param_node_identifiers[r],
param_identifier=rep_param_identifiers[r])
) {
if(verbose) {
message(paste("Found node", rep_Xpaths[r], "in", scenario))
message(paste("Replacing the value",
xml_attr(rep_nodes[[r]], rep_param_identifiers[r]),
"with",
as.character(rep_values[r])))
}
xml_attr(rep_nodes[[r]], rep_param_identifiers[r]) <- as.character(rep_values[r])
} else {
if(verbose) {
message(paste("Found node", rep_Xpaths[r], "in", scenario))
message(paste("Replacing the value",
xml_text(rep_nodes[[r]]),
"with",
as.character(rep_values[r])))
}
xml_text(rep_nodes[[r]]) <- as.character(rep_values[r])
}
}
}
}
}
write_xml(x = xml_scenario, file=file.path(path.scenarios, scenario))
}
}
carlopacioni/HexSimR documentation built on Nov. 11, 2018, 8:33 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
As an Amazon Associate I earn from qualifying purchases.
Defines functions xml.cond.replacement LHS.scenarios workspace.path.modifier scenarios.batch.modifier is.attribs make.Xpaths make.Xpath
Documented in is.attribs LHS.scenarios make.Xpath make.Xpaths scenarios.batch.modifier workspace.path.modifier xml.cond.replacement
#' Build a Xpath
#'
#' This function builds a Xpath to search nodes in HexSim xml files. It is used
#' internally by hexSimR. When used in the LHS.scenarios function, it constructs
#' the path "/.../name[text()='...']" when param_node is not NA,
#' param_identifier is FALSE and is.LHS is TRUE. Addtional details on arguments
#' are in the scenarios.batch.modifier.
#'
#' @param node_path The node_path
#' @param identifier The identifier of the node
#' @param attrib Whether the identifier is an attribute
#' @param param_node Whether the parameter is contained in an internal node
#' @param is.LHS Whether the Xpath being built is for a LHS
#' @return A character vector with the Xpath
#' @export
make.Xpath <- function(node_path, identifier, attrib,
param_node=NA, param_identifier=FALSE, is.LHS=FALSE) {
last_slash <- gregexpr("/", node_path)
if(is.na(param_node) && is.LHS && !is.na(as.logical(param_identifier))) {
Xpath <- paste0(x=node_path, "[text()='", identifier, "']")
} else {
identifier_name <- substr(node_path, start=max(last_slash[[1]]) + 1,
stop=nchar(node_path))
Xpath <- paste0(sub(pattern=paste0("/", identifier_name),
replacement="",
x=node_path),
paste0("[", if(attrib) "@", identifier_name,
"='", identifier, "']"))
}
return(Xpath)
}
#----------------------------------------------------------------------------#
#' Check conditions and pass the right arguments to make.Xpath
#'
#' See scenarios.batch.modifier for addtional details on arguments
#'
#' @param node_paths A character vector of node_paths
#' @param Xpaths A empty list of length = length(node_paths)
#' @param identifiers A character vector of node identifiers
#' @param attribs A logical vector as to whether the identifiers are attributes
#' @param param_nodes A character vector if the parameters are contained in
#' internal nodes, NA otherwise
#' @param param_node_identifiers A character vector if the param_nodes have
#' identifiers, FALSE otherwise
#' @param param_identifiers A character vector if the params have identifiers
#' (it is assumed these are attributes), FALSE otherwise
#' @param is.LHS A logical vector whether the Xpaths being built are for a LHS
#' @return A list (Xpaths) of character vectors with the Xpaths
#' @export
make.Xpaths <- function(node_paths, Xpaths, identifiers, attribs,
param_nodes=NA, param_node_identifiers=FALSE,
param_node_attributes=FALSE,
param_identifiers=FALSE, is.LHS=FALSE) {
suppressWarnings(
if(is.na(param_nodes) && length(param_nodes) == 1)
param_nodes <- rep(NA, length(node_paths))
)
suppressWarnings(
if(is.na(param_identifiers) && length(param_identifiers) == 1)
param_identifiers <- rep(FALSE, length(node_paths))
)
suppressWarnings(
if(is.na(param_node_identifiers) && length(param_node_identifiers) == 1)
param_node_identifiers <- rep(FALSE, length(node_paths))
)
suppressWarnings(
if(is.na(param_node_attributes) && length(param_node_attributes) == 1)
param_node_attributes <- rep(FALSE, length(node_paths))
)
param_node_Xpaths <- vector("character", length(node_paths))
for(i in seq_along(node_paths)) {
if(is.na(as.logical(identifiers[i]))) {
Xpaths[i] <- make.Xpath(node_paths[i], identifiers[i], attribs[i],
param_node=param_nodes[i],
param_identifier=param_identifiers[i],
is.LHS=TRUE)
if(!is.na(param_nodes[i])) {
if(is.na(as.logical(param_node_identifiers[i]))) {
param_node_Xpaths[i] <- make.Xpath(param_nodes[i],
param_node_identifiers[i],
param_node_attributes[i],
param_identifier=param_identifiers[i],
is.LHS=TRUE)
} else {
param_node_Xpaths[i] <- param_nodes[i]
}
Xpaths[i] <- paste0(Xpaths[i], param_node_Xpaths[i])
}
} else {
Xpaths[i] <- node_paths[i]
}
}
return(Xpaths)
}
#----------------------------------------------------------------------------#
#' Check whether the param is an attribute or a node
#'
#' Check whether the param being changed by LHS.scenarios or
#' xml.cond.replacement is an attribute or a node. This function is used
#' internally by HexSimR.
#'
#' @param attrib Whether the identifier is an attribute
#' @param param_node_identifier Whether param_node has an identifier
#' @param param_node_attribute Whether the param_node identifier is an attribute
#' @param param_identifier Whether the param has an identifier (it is assumed
#' this is an attribute)
#' @return A logical vector with the Xpathof length=1
#' @export
is.attribs <- function(attrib,
param_node_attribute, param_node_identifier,
param_identifier){
chk <- is.na(as.logical(param_identifier)) |
(!is.na(as.logical(param_identifier)) && param_node_attribute) |
(!is.na(as.logical(param_identifier)) &&
!is.na(as.logical(param_node_identifier)) &&
attrib)
return(chk)
}
#----------------------------------------------------------------------------#
#' Batch modification of scenarios
#'
#' Modify several scenarios at once by replacing, deleting or adding nodes (e.g.
#' events) in scenario .xml files.
#'
#' If several scenarios have been developed in HexSim and later the user
#' realises that there are some modifications that need to be applied to several
#' or all of them, this function can help automate this task. It involves
#' generating a scenario with the correct/new events and parameters. This
#' scenario is used then as template and the nodes that need to be added,
#' replaced or deleted are identified using a .csv file. Some setting up is
#' required and it may not be worthwhile for only one or two scenarios. To use
#' this function some understanding of the xml file structure in HexSim is
#' necessary. The easiest is to open the xml file and have a look at the
#' structure. Using a source code editor like Notepad++ (that colour-code
#' different element of the text based on the language used) can help to
#' understand the structure. Briefly, each of the settings and parameters in
#' HexSim is set by a node in the xml file. Some nodes have a unique identifier,
#' which can be an attribute (generally name="\emph{attribute_value}"), or a
#' text element value (e.g. <name> \emph{node_name} </name>). To this end,
#' identifiers are considered element that make the node unique. For example,
#' accumulate events have all the same structure, but they can be identified by
#' the value given to the node <name>. On the contrary, there are nodes that are
#' unique and can be simply identified by the node's name. One example of such
#' nodes is <initializationSpatialData>, which is unique, so a search in the xml
#' file for the path: "/scenario/population/initializationSpatialData" will
#' return one node only. From a practical point of view, the easiest way to work
#' out of to complete the setting up for this function is to create or modify a
#' scenario with the correct events/parameters. Save it and then comparing this
#' with one of the one that needs to be modified using, for example, the plug in
#' "compare" in Notepad++, or Winmerge (on Windows). For more information see
#' the vignette: \bold{Latin Hypercube Sampling and (batch) modification of
#' scenarios and maps}.
#'
#' If \code{path.scenarios=NULL}, an interactive dialog box is used to select
#' the path where the scenario xml files are located.
#'
#' If \code{scenarios="all"} (default), all scenarios are processed, otherwise
#' it is possible to select a subset of scenarios using a character vector, e.g.
#' scenarios=c("scen1", "scen2"). \bold{Note:} when a \code{xml.template} is
#' passed, this is assumed to be in the \code{path.scenarios} directory and it
#' is removed from the list of scenarios to be modified.
#'
#' A back up of the folder \code{path.scenarios} is copied in the the folder
#' "Scenarios_bkup", one level up from \code{path.scenarios}.
#'
#' The .csv file essentially provides the information on how to locate the nodes
#' that need to be modified, and what type of actions need to be carried out.The
#' .csv must be located in the scenario folder and the name should be passed
#' with \code{csv.in} as a character vector. The file must have the following
#' headings: nodes, identifier, attribute, mode, ref, ref_identifier, and
#' ref_attribute. \code{scenarios.batch.modifier} will parse the file and use
#' these columns as arguments. See \code{system.file("extdata", "test_csv.csv",
#' package="HexSimR")} for an example file.
#'
#' The column with heading \bold{nodes} is the path to the node to be searched
#' in the \code{xml.template} file, except when the \bold{mode} is "delete", in
#' which case the nodes are searched in the scenario file and then deleted. The
#' path starts at the root of the xml file ("scenario") and progresses until the
#' node's name or identifier. It must start with a "/", and must not have a "/"
#' at the end. For example, for an accumulator, the path in the column "nodes"
#' would be: "/scenario/population/accumulators/accumulator/name".
#'
#' \bold{identifier} is used to indicate whether the node has an identifier. If
#' it does (e.g. name="\emph{attribute_value}"), the name (or the value if an
#' attribute) of the identifier needs to be in this column (e.g.
#' \emph{attribute_value}), otherwise FALSE must be used.
#'
#' \bold{attribute} indicates whether the identifier is an attribute (TRUE) or
#' not (FALSE).
#'
#' \bold{mode} indicates the type of action that needs to be performed. Possible
#' options are "add", "before", "after", "replace" or "delete". If "add" the
#' node is added as last child of the parent node. If the node needs to be added
#' in a specific position (events generally do), "before" and "after" should be
#' used to indicate the position respect to the \bold{ref} node (i.e. whether
#' the new node goes before or after the node \bold{ref}. Note that the
#' \bold{ref} node is searched in the scenario file, not the
#' \code{xml.template}. If the option "delete" is used, the node is searched and
#' deleted from the scenario file. When "replace" is used, the \bold{ref} node
#' must be provided, even when the node is the same. This is because there might
#' be situations where what it is being changed is the name of the node. In
#' these cases, \code{scenarios.batch.modifier} would not find the original node
#' in the scenario file.
#'
#' \bold{ref} needs to be passed when the options "before", "after" or "replace"
#' are used in \bold{mode}. When not relevant, \code{NA} is used. When
#' \bold{ref} is used, then a search is performed in the scenario xml file and
#' the fields \bold{ref_identifier} and \bold{ref_attribute} must also be passed
#' when relevant. \bold{ref_identifier} and \bold{ref_attribute} have the same
#' meaning as \bold{identifier} and \bold{attribute}, but they refer to the
#' \bold{ref} node. Use FALSE when these are not relevant.
#'
#' @param path.scenarios The path to the 'Scenarios' folder
#' @param xml.template The name of the xml file to use as template for the new
#' nodes
#' @param csv.in The name of the .csv file in the "Scenarios" folder with the
#' information on the nodes that need to be modified (or checked in case of
#' xml.cond.replacement)
#' @inheritParams collate.census
#' @import xml2
#' @importFrom tcltk tk_choose.dir
#' @export
#' @examples
#' # locate and copy example files
#' new <- system.file("extdata", "MRVC_4BaitYr_ThreeCells.xml", package="HexSimR")
#' old <- system.file("extdata", "MRVC_4BaitYr_ThreeCells_old.xml", package="HexSimR")
#' csv.in <- system.file("extdata", "test_csv.csv", package="HexSimR")
#' testFolder <- tempdir(check = TRUE)
#' file.copy(c(new, old, csv.in), testFolder)
#'
#' XMLTest <- scenarios.batch.modifier(
#' path.scenarios=testFolder,
#' scenarios="MRVC_4BaitYr_ThreeCells_old.xml",
#' xml.template="MRVC_4BaitYr_ThreeCells.xml",
#' csv.in="test_csv.csv")
#'
#' # Clean up
#' files <- list.files(testFolder, full.names=TRUE)
#' file.remove(files)
#' unlink(file.path(dirname(testFolder), '/Scenarios_bkup'), recursive=TRUE)
scenarios.batch.modifier <- function(
path.scenarios=NULL,
scenarios="all",
xml.template=NULL,
csv.in) {
#### Setting arguments ####
txt <- "Please, select the 'Scenarios' folder within the workspace"
if(is.null(path.scenarios)) path.scenarios <- tk_choose.dir(caption=txt)
suppressWarnings(if(scenarios == "all")
scenarios <- list.files(path=path.scenarios, pattern=".xml$",
full.names=FALSE, recursive=FALSE))
if(!is.null(xml.template)){
scenarios <- scenarios[!scenarios %in% xml.template]
}
csv_file <- read.csv(file=file.path(path.scenarios, csv.in), stringsAsFactors=FALSE)
node_paths <- csv_file[, "nodes"]
modes <- csv_file[, "mode"]
identifiers <- csv_file[, "identifier"]
attribs <- csv_file[, "attribute"]
refs <- csv_file[, "ref"]
ref_identifiers <- csv_file[, "ref_identifier"]
ref_attribs <- csv_file[, "ref_attribute"]
#### Creating new nodes and ref Xpaths ####
nodes <- vector("list", length(node_paths))
Xpaths <- vector("character", length(node_paths))
if(sum(!is.na(refs))) ref_Xpaths <- vector("character", length(node_paths))
if(!is.null(xml.template))
xml_template <- read_xml(file.path(path.scenarios, xml.template), options="")
for(i in seq_along(node_paths)) {
if(is.na(as.logical(identifiers[i]))) {
Xpaths[i] <- make.Xpath(node_paths[i], identifiers[i], attribs[i])
} else {
Xpaths[i] <- node_paths[i]
}
if(modes[i] != "delete") {
nodes[[i]] <- xml_find_all(xml_template, Xpaths[i])
if(length(nodes[[i]]) == 0)
stop(paste("Can't find the node path:",
Xpaths[i], "in the file", xml.template))
if(grepl(pattern = "Event", x = xml_path(nodes[[i]]))) {
nodes[[i]] <- xml_parent(nodes[[i]])
}
}
if(length(nodes[[i]]) > 1) {
stop(paste(
"More than one node identified with the node path:",
node_paths[[i]], "in the file", xml.template))
}
# ref Xpaths
if(!is.na(refs[i])) {
if(is.na(as.logical(ref_identifiers[i]))) {
ref_Xpaths[i] <- make.Xpath (refs[i], ref_identifiers[i], ref_attribs[i])
} else {
ref_Xpaths[i] <- refs[i]
}
}
}
#### Backing up the scenario files
d <- paste(dirname(path.scenarios), "Scenarios_bkup", sep="/")
suppressWarnings(dir.create(path = d))
file.copy(from = path.scenarios, to = d, recursive = TRUE, copy.date = TRUE)
#### Processing modifications ####
for(scenario in scenarios) {
xml_scenario <- read_xml(file.path(path.scenarios, scenario))
if(sum(!is.na(refs))) ref_nodes <- vector("list", length(node_paths))
for(i in seq_along(node_paths)) {
if(modes[i] == "add") {
p <- xml_find_all(xml_scenario, xml_path(xml_parent(nodes[[i]])))
xml_add_child(p, nodes[[i]])
} else {
if(modes[i] %in% c("before", "after", "replace")) {
ref_nodes[[i]] <- xml_find_all(xml_scenario, ref_Xpaths[i])
if(length(ref_nodes[[i]]) == 0)
stop(paste("Can't find the node path:",
ref_Xpaths[i], "in the file", scenario))
if(grepl(pattern = "Event", x = xml_path(ref_nodes[[i]]))) {
ref_nodes[[i]] <- xml_parent(ref_nodes[[i]])
}
if(length(ref_nodes[[i]]) > 1) {
stop(paste(
"More than one node identified with the node path:",
ref_Xpaths[i], "in the file", scenario))
}
if(modes[i] %in% c("before", "after")) {
xml_add_sibling(ref_nodes[[i]], nodes[[i]], .where=modes[i])
} else {
xml_replace(ref_nodes[[i]], nodes[[i]])
}
} else {
if(modes[i] == "delete") {
nodes[[i]] <- xml_find_all(xml_scenario, Xpaths[i])
if(length(nodes[[i]]) == 0)
stop(paste("Can't find the node path:",
Xpaths[i], "in the file", scenario))
if(grepl(pattern = "Event", x = xml_path(Xpaths[i]))) {
nodes[[i]] <- xml_parent(Xpaths[i])
}
xml_remove(nodes[[i]])
} else {
stop(paste("Don't know what to do with mode", modes[i]))
}
}
}
}
write_xml(x = xml_scenario, file=file.path(path.scenarios, scenario))
}
}
#' Modify the path of the workspace and grid file in all scenario files
#'
#' When a HexSim workspace is copied to a new location, the path to the root of
#' the workspace and the grid file that is stored in the scenario files need to
#' be updated. When the simulations are run manually via the GUI, HexSim picks
#' this up and asks the user to re-save the scenario. However, when simulations
#' are run via command-line, an error occurs unless the path and the grid file
#' exist. This function updates all the xml scenario files with the new path
#' passed with: \code{new.grid.path}.
#'
#' \bold{WARNING:} Currently, xml scenario files saved by \code{HexSimR} trigger
#' a request by HexSim to re-save the files. This is due to very minor
#' differences in the file formatting, which do not affect the simulations.
#' These files run with no problems when run via the command-line (i.e.
#' batchRunner.exe)
#'
#' @param new.grid.path The fully qualified (i.e. including the full path) of
#' the grid file, including extension
#' @inheritParams collate.census
#' @inheritParams scenarios.batch.modifier
#' @import xml2
#' @importFrom tcltk tk_choose.dir
#' @export
workspace.path.modifier <- function(
path.scenarios=NULL,
scenarios="all",
new.grid.path) {
txt <- "Please, select the 'Scenarios' folder within the workspace"
if(is.null(path.scenarios)) path.scenarios <- tk_choose.dir(caption=txt)
suppressWarnings(if(scenarios == "all")
scenarios <- list.files(path=path.scenarios, pattern=".xml$",
full.names=FALSE, recursive=FALSE))
for(scenario in scenarios) {
xml_scenario <- read_xml(file.path(path.scenarios, scenario))
workspace <- xml_find_all(xml_scenario, "/scenario/workspace")
grid <- xml_find_all(xml_scenario, "/scenario/hexagonGrid/filename")
xml_text(workspace) <- dirname(new.grid.path)
xml_text(grid) <- new.grid.path
write_xml(x = xml_scenario, file=file.path(path.scenarios, scenario))
}
}
#' Generate LHS scenarios
#'
#' This function is used to generate scenarios whose parameter combinations
#' follow a Latin Hypercupe Sampling design. Parameter values can be drawn from
#' normal, lognormal, binomial, beta or uniform distributions or have a set of
#' fixed values.
#'
#' An xml file is passed (with \code{xml.template}) to build the LHS scenarios,
#' which are saved in the same \code{path.scenarios} where the template is.
#'
#' If \code{generate} is FALSE, then the function quits after generating the
#' hypercube matrix.
#'
#' An .csv file needs to be created, must be located in the scenario folder and
#' the name should be passed with \code{csv.in} as a character vector (see
#' \code{system.file("extdata", "test_csv_LHS.csv", package="HexSimR")} for an
#' example).
#'
#' The .csv must have the following headings: nodes, identifier, attribute,
#' param_node, param_node_identifier, param_node_attribute, param_identifier,
#' param_name, type, value, distribution. See documentation for
#' \code{scenarios.batch.modifier} on the meaning of nodes, identifier,
#' attribute. When \code{generate=FALSE} only the last four are mandatory.
#'
#' There might be situation where the parameter values to be changed are in an
#' internal node respect to the node identifier. In order to identify uniquely
#' this parameter, the identifier of the parameter node needs to be indicated.
#' This is best explained with an example. An accumulateTrait is identified by
#' the name attribute (i.e. <accumulateTrait name="XXX">), however the parameter
#' values are contained in the <value> node within the accumulateTrait. The node
#' <value> is itself identified by a name attribute, but the parameters are
#' stored under a "threshold" attribute. To avoid multiple hit \bold{nodes},
#' \bold{identifier} and \bold{attribute} are used to identify uniquely the
#' parent node where the parameter is contained.
#' \bold{param_node}, \bold{param_node_identifier}, and
#' \bold{param_node_attribute} are used to identify the node where the parameter
#' values are contained (if necessary, use NA for \bold{param_node} and FALSE
#' for the others columns if not relevant), and \bold{param_identifier} is used
#' to identify the actual parameter values that need to be changed, when this is
#' stored as an attribute. Use FALSE when the latter is not relevant (e.g. if
#' the node identifier is the parameter that needs to be changed).
#'
#' \bold{type} refers to the type of parameter. It can take exactly one of the
#' following: "integer", "numeric" or "character". \bold{value} refers to the
#' parameters of the distribution from which values are drawn (separated by a
#' comma) if one is used: mean and sd for normal, meanlog and sdlog for
#' lognormal, shape1 and shape2 for beta, prob for binomial and min and max for
#' uniform, otherwise a collection of values if \bold{distribution}="fixed".
#' When \bold{distribution}="fixed" or \bold{type}="character" the elements in
#' \bold{value} have equal probability.
#'
#' \bold{param_name} is the name of the parameter that is being changed. These
#' are used as labels (headers) in the hypercube matrix that it is saved to disk
#' and returned as an object.
#'
#' When \code{generate=TRUE}, the second element of the list returned contains
#' the nodes found in the template. It is probably a good idea to scan through
#' these to check whether these were the expected ones and most importantly that
#' none are empty!
#'
#' @param samples The number of LHS samples (i.e. parameter combinations)
#' @param generate Whether generate (TRUE) the xml files or stop after having
#' created the hypercube matrix (FALSE)
#' @inheritParams scenarios.batch.modifier
#' @return A list where the first element is the hyercube matrix and the second
#' are the nodes found in the template (if generate = TRUE). A csv file with
#' the hypercube matrix is saved to disk and, when generate = TRUE, the LHS
#' xml files are also saved to disk.
#' @import xml2
#' @importFrom lhs randomLHS
#' @importFrom stats qbeta qbinom qlnorm qnorm qunif
#' @export
#' @examples
#' # Locate the template file
#' template <- system.file("extdata", "MRVC_4BaitYr_ThreeCells.xml", package="HexSimR")
#'
#' # Locate the .csv file
#' csv.LHS.in <- system.file("extdata", "test_csv_LHS.csv", package="HexSimR")
#'
#' # Create a temp dir
#' testFolder <- tempdir(check = TRUE)
#'
#' # copy example files
#' file.copy(c(template, csv.LHS.in), testFolder)
#'
#' # Exexute the function
#' LHS <- LHS.scenarios(
#' path.scenarios=testFolder,
#' xml.template="MRVC_4BaitYr_ThreeCells.xml",
#' samples=9,
#' csv.in ="test_csv_LHS.csv",
#' generate=TRUE)
LHS.scenarios <- function(
path.scenarios=NULL,
xml.template=NULL,
samples,
csv.in,
generate=TRUE) {
#----------------------------------------------------------------------------#
# Helper functions
#----------------------------------------------------------------------------#
distribute <- list(
uniform=function(p, argums) qunif(p, as.numeric(argums[1]), as.numeric(argums[2])),
beta=function(p, argums) qbeta(p, as.numeric(argums[1]), as.numeric(argums[2])),
binom=function(p, argums) qbinom(p, size=1, prob=as.numeric(argums[1])),
lnorm=function(p, argums) qlnorm(p, as.numeric(argums[1]), as.numeric(argums[2])),
norm=function(p, argums) qnorm(p, as.numeric(argums[1]), as.numeric(argums[2])),
fixed=function(p, argums) {
br <- seq(0, by=1/length(argums), length.out=length(argums) + 1)
p <- as.numeric(argums[cut(p, br, labels=FALSE)])
return(p)
}
)
#----------------------------------------------------------------------------#
#### Setting arguments ####
txt <- "Please, select the 'Scenarios' folder within the workspace"
if(is.null(path.scenarios)) path.scenarios <- choose.dir(caption=txt)
csv_file <- read.csv(file=file.path(path.scenarios, csv.in),
stringsAsFactors=FALSE)
pnames <- csv_file[, "param_name"]
types <- csv_file[, "type"]
values <- strsplit(csv_file[, "value"], ",")
distrbs <- csv_file[, "distribution"]
k <- nrow(csv_file)
if(!is.null(xml.template)) {
root_name <- substr(xml.template, start=1, stop=nchar(xml.template) - 4)
} else {
root_name <- NULL
}
#### write hypercube matrix ####
hypercube <- as.data.frame(randomLHS(n=samples, k=k))
for(i in seq_along(types)) {
if(types[i] == "character") {
br <- seq(0, by=1/length(values[[i]]), length.out=length(values[[i]]) + 1)
hypercube[, i] <- values[[i]][cut(hypercube[, i], br, labels=FALSE)]
} else {
hypercube[, i] <- distribute[[distrbs[[i]]]](hypercube[, i], values[[i]])
if(types[i] == "integer") hypercube[, i] <- round(hypercube[, i])
}
}
names(hypercube) <- pnames
write.csv(hypercube, row.names=FALSE,
file=file.path(path.scenarios,
paste0(root_name,
if(!is.null(xml.template)) "_",
"hypercube.csv"))
)
#### generate xml files ####
if(generate) {
# Setting arguments
node_paths <- csv_file[, "nodes"]
identifiers <- csv_file[, "identifier"]
attribs <- csv_file[, "attribute"]
param_nodes <- csv_file[, "param_node"]
param_node_identifiers <- csv_file[, "param_node_identifier"]
param_node_attributes <- csv_file[, "param_node_attribute"]
param_identifiers <- csv_file[, "param_identifier"]
Xpaths <- vector("character", length(node_paths))
# Create Xpaths
Xpaths <- make.Xpaths(node_paths, Xpaths, identifiers, attribs,
param_nodes=param_nodes,
param_node_identifiers=param_node_identifiers,
param_node_attributes=param_node_attributes,
param_identifiers=param_identifiers, is.LHS=TRUE)
xml_template <- read_xml(file.path(path.scenarios, xml.template), options="")
#### Modify nodes ####
nodes <- vector("list", length(node_paths))
for(i in seq_along(node_paths)) {
nodes[[i]] <- xml_find_all(xml_template, Xpaths[i])
}
for(r in 1:samples) {
for(i in seq_along(node_paths)) {
if(is.attribs(attrib=attribs[i],
param_node_attribute=param_node_attributes[i],
param_node_identifier=param_node_identifiers[i],
param_identifier=param_identifiers[i])
) {
xml_attr(nodes[[i]], param_identifiers[i]) <- as.character(hypercube[r,i])
} else {
xml_text(nodes[[i]]) <- as.character(hypercube[r,i])
}
}
write_xml(x=xml_template, file=file.path(path.scenarios,
paste0(root_name, "_LHS", r, ".xml")))
}
}
return(list(hypercube=hypercube, if(generate) nodes=nodes))
}
#' Conditional replacement of xml elements
#'
#' This function replaces values in specific element nodes of xml scenario files
#' if a condition is satisfied. This may be useful when, for example, a few
#' resource maps have been used to generate scenarios for a LHS analysis. When
#' this occurs, all the nodes (events) that use the resource map need to match
#' the value in the node that was used to generate the LHS matrix. If the name
#' of the map is unique, it may be possible to simply search and replace for a
#' text string within all files. However, this approach will cause problem if
#' the same string is used in different components of the xml file (for example,
#' if there is a trait that is named as the resource map is).
#'
#' The file \code{csv.in}, which is constructed in the same way as in
#' \code{LHS.scenarios}, identifies element nodes whose value needs to be
#' satisfied. That is, a search is performed to identify a node and its values
#' is compared to the value reported in the column 'value' in \code{csv.in}. For
#' each row in \code{csv.in}, a \code{lookup} csv file needs to be present,
#' where a list of nodes that need to be modified and their new values is
#' stored. These values are applied in the xml files where the condition in the
#' relevant row of \code{csv.in} is met.
#'
#' @inheritParams scenarios.batch.modifier
#' @param lookup character vector with the csv file names of the element values
#' to changed. One file for each row of csv.in
#' @param verbose Whether report to screen nodes found and changed (default: TRUE)
#' @import xml2
#' @export
xml.cond.replacement <- function (path.scenarios=NULL,
scenarios="all",
csv.in,
lookup,
verbose=TRUE) {
#### Setting arguments ####
txt <- "Please, select the 'Scenarios' folder within the workspace"
if(is.null(path.scenarios)) path.scenarios <- choose.dir(caption=txt)
suppressWarnings(if(scenarios == "all")
scenarios <- list.files(path=path.scenarios, pattern=".xml$",
full.names=FALSE, recursive=FALSE))
csv_file <- read.csv(file=file.path(path.scenarios, csv.in),
stringsAsFactors=FALSE)
node_paths <- csv_file[, "nodes"]
identifiers <- csv_file[, "identifier"]
attribs <- csv_file[, "attribute"]
param_nodes <- csv_file[, "param_node"]
param_node_identifiers <- csv_file[, "param_node_identifier"]
param_node_attributes <- csv_file[, "param_node_attribute"]
param_identifiers <- csv_file[, "param_identifier"]
param_attributes <- csv_file[, "param_attribute"]
Xpaths <- vector("character", length(node_paths))
values <- csv_file[, "value"]
# Create Xpaths
Xpaths <- make.Xpaths(node_paths, Xpaths, identifiers, attribs,
param_nodes=param_nodes,
param_node_identifiers=param_node_identifiers,
param_node_attributes=param_node_attributes,
param_identifiers=param_identifiers, is.LHS=TRUE)
for(scenario in scenarios) {
xml_scenario <- read_xml(file.path(path.scenarios, scenario))
nodes <- vector("list", length(node_paths))
for(i in seq_along(node_paths)) {
lookup_file <- read.csv(file=file.path(path.scenarios, lookup[i]),
stringsAsFactors=FALSE)
nodes[[i]] <- xml_find_all(xml_scenario, Xpaths[i])
if(length(nodes[[i]]) > 0) {
if(is.attribs(attrib=attribs[i],
param_node_attribute=param_node_attributes[i],
param_node_identifier=param_node_identifiers[i],
param_identifier=param_identifiers[i])
) {
chk <- xml_attr(nodes[[i]], param_identifiers[i])
} else {
chk <- xml_text(nodes[[i]])
}
if(chk == values[i]) {
message(paste("Found a node for", Xpaths[i], "in", scenario))
message(paste("The node value is", chk))
rep_node_paths <- lookup_file[, "nodes"]
rep_identifiers <- lookup_file[, "identifier"]
rep_attribs <- lookup_file[, "attribute"]
rep_param_nodes <- lookup_file[, "param_node"]
rep_param_node_identifiers <- lookup_file[, "param_node_identifier"]
rep_param_node_attributes <- lookup_file[, "param_node_attribute"]
rep_param_identifiers <- lookup_file[, "param_identifier"]
rep_Xpaths <- vector("character", length(rep_node_paths))
rep_nodes <- vector("list", length(rep_node_paths))
rep_values <- lookup_file[, "value"]
# Create rep_Xpaths
rep_Xpaths <- make.Xpaths(node_paths=rep_node_paths,
Xpaths=rep_Xpaths,
identifiers=rep_identifiers,
attribs=rep_attribs,
param_nodes=rep_param_nodes,
param_identifiers=rep_param_identifiers,
param_node_identifiers=rep_param_node_identifiers,
param_node_attributes=rep_param_node_attributes,
is.LHS=TRUE)
for(r in seq_along(rep_node_paths)) {
rep_nodes[[r]] <- xml_find_all(xml_scenario, rep_Xpaths[r])
if(is.attribs(attrib=rep_attribs[r],
param_node_attribute=rep_param_node_attributes[r],
param_node_identifier=rep_param_node_identifiers[r],
param_identifier=rep_param_identifiers[r])
) {
if(verbose) {
message(paste("Found node", rep_Xpaths[r], "in", scenario))
message(paste("Replacing the value",
xml_attr(rep_nodes[[r]], rep_param_identifiers[r]),
"with",
as.character(rep_values[r])))
}
xml_attr(rep_nodes[[r]], rep_param_identifiers[r]) <- as.character(rep_values[r])
} else {
if(verbose) {
message(paste("Found node", rep_Xpaths[r], "in", scenario))
message(paste("Replacing the value",
xml_text(rep_nodes[[r]]),
"with",
as.character(rep_values[r])))
}
xml_text(rep_nodes[[r]]) <- as.character(rep_values[r])
}
}
}
}
}
write_xml(x = xml_scenario, file=file.path(path.scenarios, scenario))
}
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
As an Amazon Associate I earn from qualifying purchases.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.