Code owners
Assign users and groups as approvers for specific file changes. Learn more.
read_in_utils.R 9.36 KiB
#===== XML validation =====
#' validate_read_in_xml
#' @description Utility function, tries parsing the provided file as an XML
#' document
#' @param path string: A file to be parsed as XML
#' @return The parsed XML file (as class object of type
#' \code{xml2::xml_document})
#' @noRd
validate_read_in_xml <- function(path){
assertthat::assert_that(assertthat::is.string(path))
#Attempt to read in file
xml_doc <- tryCatch(
{
return(invisible(xml2::read_xml(path, encoding="ISO-8859-1")))
},
error = function(e){
print(e)
stop(paste("Could not find file (see error message above),",
"aborting call."), call. = FALSE)
}
)
}
#===== General read_in utility =====
#' read_in
#' @description Reads in elements from a file
#' @param ogs6_obj A OGS6 class object
#' @param path string: Path to file XML elements should be read from
#' @param xpath string: An XPath expression (should be absolute!)
#' @noRd
read_in <- function(ogs6_obj,
path,
xpath){
assertthat::assert_that("OGS6" %in% class(ogs6_obj))
xml_doc <- validate_read_in_xml(path)
assertthat::assert_that(assertthat::is.string(xpath))
split_path <- unlist(strsplit(xpath, "/", fixed = TRUE))
child_name <- split_path[[length(split_path)]]
nodes <- xml2::xml_find_all(xml_doc, xpath)
if(length(nodes) == 0){
return(invisible(NULL))
}
# Remove root expression for better readability
xpath <- stringr::str_remove(xpath, "\\/[A-Za-z_]*\\/")
prj_obj <- NULL
#Parse all children
for (i in seq_len(length(nodes))) {
prj_obj <- node_to_prj_class_object(nodes[[i]],
xpath)
#Add prj_obj with code snippet
eval(parse(text = "ogs6_obj$add(prj_obj)"))
}
return(invisible(prj_obj))
}
#' node_to_prj_class_object
#' @description Takes an XML node and turns it into a class object
#' @param xml_node xml2::xml_node: XML node
#' @param xpath string: XPath expression (for subclass differentiation)
#' @noRd
node_to_prj_class_object <- function(xml_node,
xpath){
assertthat::assert_that(class(xml_node) == "xml_node")
parameter_nodes <- xml2::xml_children(xml_node)
parameters <- c(list(), xml2::xml_attrs(xml_node))
for(i in seq_len(length(parameter_nodes))){
new_xpath <- paste0(xpath,
"/",
xml2::xml_name(parameter_nodes[[i]]))
#Guess R representation of node, add it to parameter list
parameters <- c(parameters, list(node_to_object(parameter_nodes[[i]],
new_xpath)))
#Name parameter after the xml_node child name
names(parameters)[[length(parameters)]] <-
xml2::xml_name(parameter_nodes[[i]])
}
class_name <- get_class_from_xpath(xpath)
ordered_parameters <- order_parameters(parameters, class_name)
param_call_strs <- character()
seen <- numeric()
for(i in seq_len(length(ordered_parameters))){
name <- names(ordered_parameters)[[i]]
if(length(ordered_parameters[names(ordered_parameters) == name]) == 1){
param_call_str <- paste0("ordered_parameters[[\"", name, "\"]]")
}else{
if(!name %in% names(seen)){
seen[[name]] <- 1
}
param_call_str <-
paste0("ordered_parameters[names(ordered_parameters) == \"",
name, "\"][[",
seen[[name]], "]]")
seen[[name]] <- seen[[name]] + 1
}
param_call_strs <- c(param_call_strs, param_call_str)
}
#Construct the call to the prj_object helper
class_constructor_call <-
paste0(class_name,
ifelse(grepl("OGS6", class_name), "$new", ""),
"(",
paste(
names(ordered_parameters), param_call_strs,
sep = " = ",
collapse = ", "
),
")")
#Evaluate the constructed call
prj_obj <- eval(parse(text = class_constructor_call))
return(invisible(prj_obj))
}
#' node_to_object
#' @description Returns representation of an XML node. This is a recursive
#' function.
#' ASSUMPTIONS:
#' 1) Leaf nodes will never be prj_* objects
#' 2) Wrapper nodes are represented as lists
#' 3) Parent nodes whose children have no children are represented as lists
#' @param xml_node xml2::xml_node: XML node
#' @param xpath string: XPath expression (for subclass differentiation)
#' @noRd
node_to_object <- function(xml_node,
xpath = ""){
assertthat::assert_that("xml_node" %in% class(xml_node))
assertthat::assert_that(assertthat::is.string(xpath))
node_name <- xml2::xml_name(xml_node)
#Node is leaf
if(length(xml2::xml_children(xml_node)) == 0){
xml_text_clean <-
stringr::str_remove_all(xml2::xml_text(xml_node),
"[\n|[:space:]]")
if(xml_text_clean != "" &&
length(xml2::xml_attrs(xml_node)) != 0){
return(invisible(c(xml2::xml_attrs(xml_node),
xml_text = xml2::xml_text(xml_node))))
}
if(xml_text_clean != ""){
return(invisible(xml2::xml_text(xml_node)))
}
return(invisible(xml2::xml_attrs(xml_node)))
}
#Node is represented by subclass
if(!is.null(get_class_from_xpath(xpath))){
return(invisible(node_to_prj_class_object(xml_node,
xpath)))
}
#Node has children but is not represented by subclass
wrapper_list <- list()
for (i in seq_len(length((xml2::xml_children(xml_node))))) {
child_node <- xml2::xml_children(xml_node)[[i]]
child_name <- xml2::xml_name(child_node)
list_content <- NULL
new_xpath <- paste0(xpath,
"/",
child_name)
if (!is.null(get_class_from_xpath(new_xpath))) {
list_content <- node_to_prj_class_object(child_node,
new_xpath)
} else{
list_content <- node_to_object(child_node,
new_xpath)
}
wrapper_list <- c(wrapper_list, list(list_content))
names(wrapper_list)[[length(wrapper_list)]] <- child_name
}
return(invisible(wrapper_list))
}
#' get_class_args
#' @description Gets class arguments
#' @param class_name string: The name of a class
#' @return character: Named vector of class arguments
#' @noRd
get_class_args <- function(class_name){
assertthat::assert_that(assertthat::is.string(class_name))
formals_call <- ifelse(grepl("OGS6", class_name, fixed = TRUE),
paste0(class_name,
"$public_methods$initialize"),
class_name)
class_args <- names(as.list(formals(eval(parse(text = formals_call)))))
return(invisible(class_args))
}
#' order_parameters
#' @description Orders a list of parameters corresponding to the argument order
#' of a class
#' @param parameters list: Parameters
#' @param class_name string: The name of a class
#' @return list: Parameters ordered by argument order of class
#' @noRd
order_parameters <- function(parameters, class_name){
assertthat::assert_that(is.list(parameters))
assertthat::assert_that(assertthat::is.string(class_name))
ordered_parameters <- list()
class_args <- get_class_args(class_name)
# logical vector of length(parameters) to exclude r2ogs6 specific parameters
standard_parameters <-
names(parameters) %in%
c("xpath", "attr_names", "flatten_on_exp", "unwrap_on_exp")
#Check for length and value mismatches if class does not have Ellipsis
if(!"..." %in% class_args){
assertthat::assert_that(length(parameters[!standard_parameters]) <=
length(class_args))
for(i in seq_len(length(parameters))){
# cat("\n", names(parameters)[[i]], "\n")
assertthat::assert_that(names(parameters)[[i]] %in% class_args,
msg = paste0(names(parameters)[[i]],
" not in class_args of class ",
class_name,
collapse = " ")) }
}
# Order regular arguments
for(i in seq_len(length(class_args))){
if(class_args[[i]] != "..."){
if(!class_args[[i]] %in% names(parameters)){
ordered_parameters[[class_args[[i]]]] <- NULL
}else{
ordered_parameters[[class_args[[i]]]] <-
parameters[[class_args[[i]]]]
}
}
}
# Add ellipsis content at the end
ellipsis_content <- parameters[!names(parameters) %in% class_args]
for(i in seq_len(length(ellipsis_content))){
ordered_parameters[[length(ordered_parameters) + 1]] <-
ellipsis_content[[i]]
names(ordered_parameters)[[length(ordered_parameters)]] <-
names(ellipsis_content)[[i]]
}
return(invisible(ordered_parameters))
}