Skip to content
Snippets Groups Projects
Commit e4b2a915 authored by Ruben Heinrich's avatar Ruben Heinrich
Browse files

[base] deleted old read_in code

parent 05c16672
No related branches found
No related tags found
1 merge request!6Merge branch 7 fixed functionality into master
Hide whitespace changes
Inline Side-by-side
Showing
with 113 additions and 185 deletions
R/read_in_utils.R
+ 113
− 185
View file @ e4b2a915
...@@ -25,21 +25,17 @@ validate_read_in_xml <- function(path){ ...@@ -25,21 +25,17 @@ validate_read_in_xml <- function(path){
} }
has_ambiguous_representation <- function(tag_name) { is_actually_subclass <- function(tag_name, xpath_expr) {
is_subclass <- TRUE
ambiguous_tags <- c("material_property", ambiguous_tags <- c("material_property",
"fluid", "fluid",
"porous_medium", "porous_medium",
"relative_permeability", "relative_permeability",
"capillary_pressure") "capillary_pressure")
return(invisible(tag_name %in% ambiguous_tags)) if(tag_name %in% ambiguous_tags){
}
check_could_be_subclass <- function(tag_name, xpath_expr) {
could_be_subclass <- TRUE
if(has_ambiguous_representation(tag_name)){
non_subclass_paths <- non_subclass_paths <-
c("constitutive_relation/material_properties/material_property", c("constitutive_relation/material_properties/material_property",
...@@ -60,17 +56,14 @@ check_could_be_subclass <- function(tag_name, xpath_expr) { ...@@ -60,17 +56,14 @@ check_could_be_subclass <- function(tag_name, xpath_expr) {
unlist(strsplit(xpath_expr, "/", fixed = TRUE)) unlist(strsplit(xpath_expr, "/", fixed = TRUE))
regex_friendly_xpth <- paste(split_xpth, collapse = " ") regex_friendly_xpth <- paste(split_xpth, collapse = " ")
# cat("\n", regex_friendly_ncp, "\n")
# cat("\n", regex_friendly_xpth, "\n")
if(grepl(paste0(regex_friendly_ncp, "$"), regex_friendly_xpth)){ if(grepl(paste0(regex_friendly_ncp, "$"), regex_friendly_xpth)){
could_be_subclass <- FALSE is_subclass <- FALSE
break break
} }
} }
} }
return(invisible(could_be_subclass)) return(invisible(is_subclass))
} }
...@@ -109,12 +102,11 @@ read_in <- function(ogs6_obj, ...@@ -109,12 +102,11 @@ read_in <- function(ogs6_obj,
#Parse all children #Parse all children
for (i in seq_len(length(nodes))) { for (i in seq_len(length(nodes))) {
r2ogs6_obj <- node_to_r2ogs6_obj(nodes[[i]], r2ogs6_obj <- node_to_r2ogs6_class_object(nodes[[i]],
xpath_expr, xpath_expr,
subclasses_names) subclasses_names)
#Add r2ogs6_obj with code snippet #Add r2ogs6_obj with code snippet
# cat("\n", add_call, "\n")
eval(parse(text = add_call)) eval(parse(text = add_call))
} }
...@@ -122,27 +114,20 @@ read_in <- function(ogs6_obj, ...@@ -122,27 +114,20 @@ read_in <- function(ogs6_obj,
} }
#'node_to_r2ogs6_obj #'node_to_r2ogs6_class_object
#'@description Takes an XML node and turns it into a class object #'@description Takes an XML node and turns it into a class object
#'@param xml_node An XML node (of class xml2::xml_node) #'@param xml_node xml2::xml_node: XML node
#'@param xpath_expr An XPath expression (for subclass differentiation) #'@param xpath_expr string: XPath expression (for subclass differentiation)
#'@param subclasses_names Optional: A character vector containing the names of #'@param subclasses_names character: Optional: Names of r2ogs6 subclasses
#' r2ogs6 subclasses (r2ogs6 classes without a method for input_add) #' (r2ogs6 classes without a method for input_add)
node_to_r2ogs6_obj <- function(xml_node, node_to_r2ogs6_class_object <- function(xml_node,
xpath_expr, xpath_expr,
subclasses_names = character()){ subclasses_names = character()){
assertthat::assert_that(class(xml_node) == "xml_node") assertthat::assert_that(class(xml_node) == "xml_node")
parameter_nodes <- xml2::xml_children(xml_node) parameter_nodes <- xml2::xml_children(xml_node)
parameters <- c(list(), xml2::xml_attrs(xml_node))
parameters <- list()
init_prefix <- ""
if(length(xml2::xml_attrs(xml_node)) != 0){
parameters <- c(parameters, xml2::xml_attrs(xml_node))
}
for(i in seq_len(length(parameter_nodes))){ for(i in seq_len(length(parameter_nodes))){
...@@ -151,43 +136,32 @@ node_to_r2ogs6_obj <- function(xml_node, ...@@ -151,43 +136,32 @@ node_to_r2ogs6_obj <- function(xml_node,
xml2::xml_name(parameter_nodes[[i]])) xml2::xml_name(parameter_nodes[[i]]))
#Guess R representation of node, add it to parameter list #Guess R representation of node, add it to parameter list
parameters <- c(parameters, list(guess_structure(parameter_nodes[[i]], parameters <- c(parameters, list(node_to_object(parameter_nodes[[i]],
new_xpath_expr, new_xpath_expr,
subclasses_names))) subclasses_names)))
#Name parameter after the xml_node child name #Name parameter after the xml_node child name
names(parameters)[[length(parameters)]] <- names(parameters)[[length(parameters)]] <-
xml2::xml_name(parameter_nodes[[i]]) xml2::xml_name(parameter_nodes[[i]])
} }
class_name <- ""
tag_name <- xml2::xml_name(xml_node) tag_name <- xml2::xml_name(xml_node)
#If node represented by subclass, get class name #If node represented by subclass, get class name
if(tag_name %in% names(subclasses_names)){ class_name <- ifelse(tag_name %in% names(subclasses_names),
class_name <- select_fitting_subclass(xpath_expr, subclasses_names) select_fitting_subclass(xpath_expr, subclasses_names),
get_tag_class_name(tag_name))
#Else assume class name is r2ogs6_ + node name
}else{
class_name <- get_tag_class_name(tag_name)
}
#If it's an R6 class, we need to alter constructor syntax a bit
if(grepl("OGS6", class_name)){
init_prefix <- "$new"
}
ordered_parameters <- order_parameters(parameters, class_name) ordered_parameters <- order_parameters(parameters, class_name)
param_call_strs <- lapply(names(parameters), function(x){ param_call_strs <- lapply(names(parameters), function(x){
call_str <- paste0("parameters[[\"", x, "\"]]") return(invisible(paste0("parameters[[\"", x, "\"]]")))
return(call_str)
}) })
#Construct the call to the r2ogs6_object helper #Construct the call to the r2ogs6_object helper
class_constructor_call <- class_constructor_call <-
paste0(class_name, paste0(class_name,
init_prefix, ifelse(grepl("OGS6", class_name), "$new", ""),
"(", "(",
paste( paste(
names(parameters), names(parameters),
...@@ -204,17 +178,96 @@ node_to_r2ogs6_obj <- function(xml_node, ...@@ -204,17 +178,96 @@ node_to_r2ogs6_obj <- function(xml_node,
} }
get_class_args <- function(class_name){
assertthat::assert_that(assertthat::is.string(class_name)) #'node_to_object
#'@description Returns representation of an XML node. This is a recursive
#' function.
#'ASSUMPTIONS:
#'1) Leaf nodes will have EITHER a value OR attributes (and will not be missing
#' both, e.g. '<a/>').
#'2) Leaf nodes will never be r2ogs6_* objects
#'3) If there are multiple occurrences of r2ogs6_* class (and subclass)
#' elements on the same level, they have a wrapper node as their parent
#' (e.g. <processes>, <properties>) which will contain ONLY elements of this
#' type
#'4) Wrapper nodes are represented as lists
#'5) Parent nodes whose children have no children are represented as lists
#'@param xml_node xml2::xml_node: XML node
#'@param xpath_expr string: XPath expression (for subclass differentiation)
#'@param subclasses_names character: Optional: Names of `r2ogs6` subclasses
#' (`r2ogs6` classes without a OGS6$add method)
node_to_object <- function(xml_node,
xpath_expr,
subclasses_names = character()){
formals_call <- class_name assertthat::assert_that("xml_node" %in% class(xml_node))
assertthat::assert_that(assertthat::is.string(xpath_expr))
node_name <- xml2::xml_name(xml_node)
#Node is leaf
if(length(xml2::xml_children(xml_node)) == 0){
if(xml2::xml_text(xml_node) != ""){
return(invisible(xml2::xml_text(xml_node)))
}else{
return(invisible(xml2::xml_attrs(xml_node)))
}
}
if(grepl("OGS6", class_name, fixed = TRUE)){ #Node is represented by subclass
formals_call <- paste0(class_name, if(node_name %in% names(subclasses_names) &&
"$public_methods$initialize") is_actually_subclass(node_name, xpath_expr)){
return(invisible(node_to_r2ogs6_class_object(xml_node,
xpath_expr,
subclasses_names)))
} }
#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_expr <- paste0(xpath_expr,
"/",
child_name)
if (child_name %in% names(subclasses_names) &&
is_actually_subclass(child_name, new_xpath_expr)) {
list_content <- node_to_r2ogs6_class_object(child_node,
new_xpath_expr,
subclasses_names)
} else{
list_content <- node_to_object(child_node,
new_xpath_expr,
subclasses_names)
}
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
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))))) class_args <- names(as.list(formals(eval(parse(text = formals_call)))))
return(invisible(class_args)) return(invisible(class_args))
...@@ -226,6 +279,7 @@ get_class_args <- function(class_name){ ...@@ -226,6 +279,7 @@ get_class_args <- function(class_name){
#' of a class #' of a class
#'@param parameters list: Parameters #'@param parameters list: Parameters
#'@param class_name string: The name of a class #'@param class_name string: The name of a class
#'@return list: Parameters ordered by argument order of class
order_parameters <- function(parameters, class_name){ order_parameters <- function(parameters, class_name){
assertthat::assert_that(is.list(parameters)) assertthat::assert_that(is.list(parameters))
...@@ -273,129 +327,3 @@ order_parameters <- function(parameters, class_name){ ...@@ -273,129 +327,3 @@ order_parameters <- function(parameters, class_name){
return(invisible(ordered_parameters)) return(invisible(ordered_parameters))
} }
#===== GUESS STRUCTURE FUNCTIONALITY =====
#'guess_structure
#'@description Guesses the R representation of an XML node and adds it to
#' parameter list. This is a recursive function.
#'ASSUMPTIONS:
#'1) Leaf nodes will have EITHER a value OR attributes (and will not be missing
#' both, e.g. '<a/>').
#'2) Leaf nodes will never be r2ogs6_* objects
#'3) If there are multiple occurrences of r2ogs6_* class (and subclass)
#' elements on the same level, they have a wrapper node as their parent
#' (e.g. <processes>, <properties>) which will contain ONLY elements of this
#' type
#'4) Wrapper nodes are represented as lists
#'5) Parent nodes whose children have no children are represented as lists
#'@param xml_node xml2::xml_node: XML node
#'@param xpath_expr string: XPath expression (for subclass differentiation)
#'@param subclasses_names Optional: character: Names of r2ogs6 subclasses
#' (r2ogs6 classes without a OGS6$add method)
guess_structure <- function(xml_node,
xpath_expr,
subclasses_names = character()){
assertthat::assert_that("xml_node" %in% class(xml_node))
assertthat::assert_that(assertthat::is.string(xpath_expr))
node_name <- xml2::xml_name(xml_node)
# cat("\n", xpath_expr, check_could_be_subclass(node_name, xpath_expr), "\n")
#Node is leaf
if(length(xml2::xml_children(xml_node)) == 0){
if(xml2::xml_text(xml_node) != ""){
return(invisible(xml2::xml_text(xml_node)))
}else{
return(invisible(xml2::xml_attrs(xml_node)))
}
#Node is represented by subclass
}else if(node_name %in% names(subclasses_names) &&
check_could_be_subclass(node_name, xpath_expr)){
return(invisible(node_to_r2ogs6_obj(xml_node,
xpath_expr,
subclasses_names)))
#Node has children but is not represented by subclass
}else{
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_expr <- paste0(xpath_expr,
"/",
child_name)
if (child_name %in% names(subclasses_names) &&
check_could_be_subclass(child_name, new_xpath_expr)) {
list_content <- node_to_r2ogs6_obj(child_node,
new_xpath_expr,
subclasses_names)
}else{
list_content <- guess_structure(child_node,
new_xpath_expr,
subclasses_names)
}
wrapper_list <- c(wrapper_list, list(list_content))
names(wrapper_list)[[length(wrapper_list)]] <- child_name
}
return(invisible(wrapper_list))
}
}
#===== RECURSIVE IMPORT (WIP) =====
#
# to_object <- function(xml_node,
# xpath_expr,
# subclasses_names = character()){
#
#
#
#
# }
#===== FILE HANDLING UTILITY =====
#'check_file_extension
#'@description Helper function to check the extension of a file
#'@param file A file
#'@param expected_extension The expected file extension
check_file_extension <- function(file, expected_extension){
assertthat::assert_that(assertthat::is.string(file))
assertthat::assert_that(assertthat::is.string(expected_extension))
if(tools::file_ext(file) != expected_extension){
stop(paste("File must have extension", expected_extension),
call. = FALSE)
}
}
#Source: https://stackoverflow.com/questions/48218491/os-independent-way-to-
# select-directory-interactively-in-r/48296736
#Helper function for choosing a directory (platform independent!)
choose_directory = function(ini_dir = getwd(),
caption = 'Select data directory') {
if (exists('utils::choose.dir')) {
utils::choose.dir(default = ini_dir, caption = caption)
} else {
tcltk::tk_choose.dir(default = ini_dir, caption = caption)
}
}
\ No newline at end of file
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment