Renamed and restructured scripts for reading in data

R/read_in_gml.R

+#Functions to read in data from a .gml file to an OGS6 object
+
+
+#'read_in_gml
+#'@description Wrapper function to read in a whole .gml file
+#'@param ogs6_obj A OGS6 class object
+#'@param gml_path The path to the geometry file that should be read in
+#'@export
+read_in_gml <- function(ogs6_obj, gml_path) {
+
+    assertthat::assert_that(class(ogs6_obj) == "OGS6")
+    xml_doc <- validate_read_in_xml(gml_path)
+
+    name <- xml2::xml_text(xml2::xml_find_first(xml_doc, "//name"))
+    points <- read_in_points(xml_doc)
+    polylines <- read_in_polylines(xml_doc)
+    surfaces <- read_in_surfaces(xml_doc)
+
+    ogs6_obj$add_gml(r2ogs6_gml(name, points, polylines, surfaces))
+}
+
+
+#'read_in_points
+#'@description Reads points from a .gml file
+#'@param xml_doc A parsed XML document (of class 'xml2::xml_document')
+read_in_points <- function(xml_doc) {
+
+    points_tibble <- tibble::tibble(x = c(),
+                                    y = c(),
+                                    z = c(),
+                                    name = c())
+
+    points_nodeset <- xml2::xml_find_all(xml_doc, "//points/*")
+
+    for(i in seq_len(length(points_nodeset))){
+        attrs <- xml2::xml_attrs(points_nodeset[[i]])
+
+        point_name <- ""
+
+        if(length(attrs) == 5){
+            point_name <- attrs[[5]]
+        }
+
+        points_tibble <- tibble::add_row(points_tibble,
+                                        x = as.double(attrs[[2]]),
+                                        y = as.double(attrs[[3]]),
+                                        z = as.double(attrs[[4]]),
+                                        name = point_name,
+                                        )
+    }
+
+    return(invisible(points_tibble))
+}
+
+
+#'read_in_polylines
+#'@description Reads polylines from a .gml file
+#'@param xml_doc A parsed XML document (of class 'xml2::xml_document')
+read_in_polylines <- function(xml_doc) {
+
+    polylines_list <- list()
+
+    polylines_nodeset <- xml2::xml_find_all(xml_doc, "//polylines/*")
+
+    if(class(polylines_nodeset) == "xml_missing"){
+        return(invisible(NULL))
+    }
+
+    for(i in seq_len(length(polylines_nodeset))){
+        attrs <- xml2::xml_attrs(polylines_nodeset[[i]])
+        pnt_nodeset <- xml2::xml_children(polylines_nodeset[[i]])
+        pnt_vector <- c()
+
+        for(j in seq_len(length(pnt_nodeset))){
+            pnt_vector <- c(pnt_vector, xml2::xml_double(pnt_nodeset[[j]]))
+        }
+
+        polyline <- list(name = attrs[[2]], pnt_vector)
+        polylines_list <- c(polylines_list, list(polyline))
+    }
+
+    return(invisible(polylines_list))
+}
+
+
+#'read_in_surfaces
+#'@description Reads surfaces from a .gml file
+#'@param xml_doc A parsed XML document (of class 'xml2::xml_document')
+read_in_surfaces <- function(xml_doc) {
+
+    surfaces_list <- list()
+
+    surfaces_nodeset <- xml2::xml_find_all(xml_doc, "//surfaces/*")
+
+    if(class(surfaces_nodeset) == "xml_missing"){
+        return(invisible(NULL))
+    }
+
+    for(i in seq_len(length(surfaces_nodeset))){
+        attrs <- xml2::xml_attrs(surfaces_nodeset[[i]])
+        element_nodeset <- xml2::xml_children(surfaces_nodeset[[i]])
+
+        element_1 <- as.double(xml2::xml_attrs(element_nodeset[[1]]))
+        element_2 <- as.double(xml2::xml_attrs(element_nodeset[[2]]))
+
+        surface <- list(name = attrs[[2]], element_1, element_2)
+        surfaces_list <- c(surfaces_list, list(surface))
+    }
+
+    return(invisible(surfaces_list))
+}
\ No newline at end of file

R/read_in_prj.R

+#Functions to read in data from a .prj file to an OGS6 object
+
+
+#'read_in_prj
+#'@description Wrapper function to read in a whole .prj file
+#'@param ogs6_obj A OGS6 class object
+#'@param prj_path The path to the project file that should be read in
+#'@export
+read_in_prj <- function(ogs6_obj, prj_path){
+
+    assertthat::assert_that(class(ogs6_obj) == "OGS6")
+    xml_doc <- validate_read_in_xml(prj_path)
+
+    from_other_path <- (dirname(ogs6_obj$sim_path) != dirname(prj_path))
+
+    #Geometry reference
+    gml_ref_node <- xml2::xml_find_first(xml_doc, "//geometry")
+
+    #Meshes references
+    vtu_ref_nodes <- NULL
+
+    if(class(gml_ref_node) != "xml_missing"){
+        gml_path <- paste0(dirname(prj_path), "/", xml2::xml_text(gml_ref_node))
+        read_in_gml(ogs6_obj, gml_path)
+        vtu_ref_nodes <- xml2::xml_find_first(xml_doc, "//mesh")
+    }else{
+        vtu_ref_nodes <- xml2::xml_find_all(xml_doc, "//meshes/*")
+    }
+
+    for(i in seq_len(length(vtu_ref_nodes))){
+        vtu_ref <- xml2::xml_text(vtu_ref_nodes[[i]])
+        ogs6_obj$add_mesh(vtu_ref)
+
+        if(from_other_path){
+            #Copy file into ogs6_obj$sim_path folder
+            file.copy(paste0(dirname(prj_path), "/", vtu_ref), ogs6_obj$sim_path)
+        }
+    }
+
+    read_in_processes(ogs6_obj, prj_path)
+    read_in_media(ogs6_obj, prj_path)
+    read_in_time_loop(ogs6_obj, prj_path)
+    read_in_parameters(ogs6_obj, prj_path)
+    read_in_curves(ogs6_obj, prj_path)
+    read_in_nonlinear_solvers(ogs6_obj, prj_path)
+    read_in_linear_solvers(ogs6_obj, prj_path)
+    read_in_test_definition(ogs6_obj, prj_path)
+}
+
+
+#============================== AUTO GENERATED STUBS ================================
+
+
+#'read_in_processes
+#'@description Reads in process elements from a .prj file
+#'@param ogs6_obj A OGS6 class object
+#'@param prj_path The path to the project file the process elements should be read from
+#'@param process_names Optional: The names of the process elements to be read in
+#'@export
+read_in_processes <- function(ogs6_obj, prj_path, process_names = NULL) {
+    read_in(ogs6_obj, prj_path, "processes", "process", selection_vector = process_names, subclasses_names = NULL)
+}
+
+
+#'read_in_media
+#'@description Reads in medium elements from a .prj file
+#'@param ogs6_obj A OGS6 class object
+#'@param prj_path The path to the project file the medium elements should be read from
+#'@param medium_indices Optional: The indices of the medium elements to be read in
+#'@export
+read_in_media <- function(ogs6_obj, prj_path, medium_indices = NULL) {
+    read_in(ogs6_obj, prj_path, "media", "medium", selection_vector = medium_indices,
+            subclasses_names = c(phase = "r2ogs6_medium_phase", property = "r2ogs6_medium_property"))
+}
+
+
+#'read_in_time_loop
+#'@description Reads in time_loop element from a .prj file
+#'@param ogs6_obj A OGS6 class object
+#'@param prj_path The path to the project file the time_loop element should be read from
+#'@export
+read_in_time_loop <- function(ogs6_obj, prj_path) {
+    read_in(ogs6_obj, prj_path, "OpenGeoSysProject", "time_loop",
+            selection_vector = NULL,
+            subclasses_names = c(process = "r2ogs6_tl_process",
+                                 output = "r2ogs6_tl_output",
+                                 global_processes_coupling = "r2ogs6_global_processes_coupling"))
+}
+
+
+#'read_in_parameters
+#'@description Reads in parameter elements from a .prj file
+#'@param ogs6_obj A OGS6 class object
+#'@param prj_path The path to the project file the parameter elements should be read from
+#'@param parameter_names Optional: The names of the parameter elements to be read in
+#'@export
+read_in_parameters <- function(ogs6_obj, prj_path, parameter_names = NULL) {
+    read_in(ogs6_obj, prj_path, "parameters", "parameter", selection_vector = parameter_names, subclasses_names = NULL)
+}
+
+
+#'read_in_curves
+#'@description Reads in curve elements from a .prj file
+#'@param ogs6_obj A OGS6 class object
+#'@param prj_path The path to the project file the curve elements should be read from
+#'@param curve_names Optional: The names of the curve elements to be read in
+#'@export
+read_in_curves <- function(ogs6_obj, prj_path, curve_names = NULL) {
+    read_in(ogs6_obj, prj_path, "curves", "curve",
+            selection_vector = curve_names, subclasses_names = NULL)
+}
+
+
+#'read_in_process_variables
+#'@description Reads in process_variable elements from a .prj file
+#'@param ogs6_obj A OGS6 class object
+#'@param prj_path The path to the project file the process_variable elements should be read from
+#'@param process_variable_names Optional: The names of the process_variable elements to be read in
+#'@export
+read_in_process_variables <- function(ogs6_obj, prj_path, process_variable_names = NULL) {
+    read_in(ogs6_obj, prj_path, "process_variables", "process_variable",
+            selection_vector = process_variable_names,
+            subclasses_names = c(boundary_condition = "r2ogs6_boundary_condition"))
+}
+
+
+#'read_in_nonlinear_solvers
+#'@description Reads in nonlinear_solver elements from a .prj file
+#'@param ogs6_obj A OGS6 class object
+#'@param prj_path The path to the project file the nonlinear_solver elements should be read from
+#'@param nonlinear_solver_names Optional: The names of the nonlinear_solver elements to be read in
+#'@export
+read_in_nonlinear_solvers <- function(ogs6_obj, prj_path, nonlinear_solver_names = NULL) {
+    read_in(ogs6_obj, prj_path, "nonlinear_solvers", "nonlinear_solver",
+            selection_vector = nonlinear_solver_names, subclasses_names = NULL)
+}
+
+
+#'read_in_linear_solvers
+#'@description Reads in linear_solver elements from a .prj file
+#'@param ogs6_obj A OGS6 class object
+#'@param prj_path The path to the project file the linear_solver elements should be read from
+#'@param linear_solver_names Optional: The names of the linear_solver elements to be read in
+#'@export
+read_in_linear_solvers <- function(ogs6_obj, prj_path, linear_solver_names = NULL) {
+    read_in(ogs6_obj, prj_path, "linear_solvers", "linear_solver",
+            selection_vector = linear_solver_names, subclasses_names = NULL)
+}
+
+
+#'read_in_test_definition
+#'@description Reads in vtkdiff elements from a .prj file
+#'@param ogs6_obj A OGS6 class object
+#'@param prj_path The path to the project file the vtkdiff elements should be read from
+#'@param vtkdiff_indices Optional: The indices of the vtkdiff elements to be read in
+#'@export
+read_in_test_definition <- function(ogs6_obj, prj_path, vtkdiff_indices = NULL) {
+    read_in(ogs6_obj, prj_path, "test_definition", "vtkdiff",
+            selection_vector = vtkdiff_indices, subclasses_names = NULL)
+}

R/read_in_utils.R

+
+#============================== VALIDATION UTILITY ================================
+
+
+#'validate_read_in_xml
+#'@description Utility function, tries parsing the provided file as an XML document
+#'@param file A file to be parsed as XML
+#'@return The parsed XML file (as class object of type xml2::xml_document)
+validate_read_in_xml <- function(file){
+
+    assertthat::assert_that(assertthat::is.string(file))
+
+    #Attempt to read in file
+    xml_doc <- tryCatch(
+        {
+            return(invisible(xml2::read_xml(file, encoding="ISO-8859-1")))
+        },
+        error = function(e){
+            print(e)
+            stop("Could not find file (see error message above), aborting call.", call. = FALSE)
+        }
+    )
+}
+
+
+#============================== GENERAL READ IN UTILITY ================================
+
+
+#'read_in
+#'@description Reads in elements from a .prj file
+#'@param ogs6_obj A OGS6 class object
+#'@param prj_path The path to the project file the elements should be read from
+#'@param element_name The name of the .prj element to be read from (wrapper element, e.g. 'processes')
+#'@param child_name The name of the child elements (e.g. 'process')
+#'@param selection_vector Optional: Either a character vector containing the names of the children
+#' OR a numeric vector containing their wanted indices
+#'@param subclasses_names Optional: A named character vector containing the names of r2ogs6_*
+#' subclasses (r2ogs6_* classes without a method for input_add)
+#' e.g. c(process = "r2ogs6_tl_process") if child_name would be time_loop
+read_in <- function(ogs6_obj, prj_path, element_name, child_name,
+                            selection_vector = NULL, subclasses_names = NULL){
+
+    assertthat::assert_that(class(ogs6_obj) == "OGS6")
+    xml_doc <- validate_read_in_xml(prj_path)
+
+    assertthat::assert_that(assertthat::is.string(element_name))
+    assertthat::assert_that(assertthat::is.string(child_name))
+
+    has_names <- FALSE
+    has_indices <- FALSE
+
+    if(!is.null(selection_vector)){
+        if(is.numeric(selection_vector)){
+            has_indices <- TRUE
+        }else if(is.character(selection_vector)){
+            has_names <- TRUE
+        }else{
+            stop("selection_vector must either be of type 'numeric' or 'character'", call. = FALSE)
+        }
+    }
+
+    if(!is.null(subclasses_names)){
+        assertthat::assert_that(is.character(subclasses_names))
+    }
+
+    element <- xml2::xml_find_first(xml_doc, paste0("//", element_name))
+
+    if(class(element) == "xml_missing"){
+        warning(paste("read_in: Could not find element of name ", element_name,
+                      ". Skipping.", call. = FALSE))
+        return(invisible(FALSE))
+    }
+
+    #For most wrapper classes the child_name parameter is useless
+    #(e.g. they contain only elements of type child_name),
+    #but for time_loop, finding it by name is required instead of just getting all children
+    #because it's parent is the .prj file root node and it'd get the whole document
+    element_children <- xml2::xml_find_all(element, paste0("//", child_name))
+
+    r2ogs6_obj <- NULL
+
+    #If selection_vector was a character vector
+    if(has_names){
+        for(i in seq_len(length(selection_vector))){
+            specified_name <- selection_vector[[i]]
+            regex <- paste0("./", child_name, "[./name = '", specified_name, "']")
+            child <- xml2::xml_find_first(xml_doc, regex)
+            if(class(child) == "xml_missing"){
+                warning(paste("Child with name", xml2::xml_name(child),
+                              "not found. Skipping."), call. = FALSE)
+                next
+            }
+            r2ogs6_obj <- node_to_r2ogs6_obj(child, subclasses_names)
+        }
+
+        #If selection_vector was a numeric vector
+    }else if(has_indices){
+        for(i in seq_len(length(selection_vector))){
+            if(selection_vector[[i]] > length(element_children)){
+                warning(paste("Specified child index", selection_vector[[i]],
+                              "out of range. Skipping."), call. = FALSE)
+                next
+            }
+            child <- element_children[[selection_vector[[i]]]]
+            r2ogs6_obj <- node_to_r2ogs6_obj(child, subclasses_names)
+        }
+
+        #If selection_vector was NULL, parse all children
+    }else{
+        for(i in seq_len(length(element_children))){
+            r2ogs6_obj <- node_to_r2ogs6_obj(element_children[[i]], subclasses_names)
+        }
+    }
+
+    #Add the object to the OGS6 object
+    add_call <- paste0("ogs6_obj.add_", child_name, "(r2ogs6_obj)")
+    eval(parse(text = add_call))
+
+    return(invisible(TRUE))
+}
+
+
+#'node_to_r2ogs6_obj
+#'@description Takes an XML node and turns it into a class object
+#'@param xml_node An XML node (of class xml2::xml_node)
+#'@param subclasses_names Optional: A character vector containing the names of r2ogs6_*
+#' subclasses (r2ogs6_* classes without a method for input_add)
+node_to_r2ogs6_obj <- function(xml_node, subclasses_names = NULL){
+
+    assertthat::assert_that(class(xml_node) == "xml_node")
+
+
+
+    parameter_nodes <- xml2::xml_children(xml_node)
+    parameters <- list()
+
+    for(i in seq_len(length(parameter_nodes))){
+
+        #Guesses the R representation of the node and adds it to parameter list
+        parameters <- c(parameters, list(guess_structure(parameter_nodes[[i]])))
+
+        #Names the parameter after the xml_node child name
+        names(parameters)[[length(parameters)]] <- xml2::xml_name(parameter_nodes[[i]])
+    }
+
+    ordered_parameters <- order_parameters(parameters)
+
+    class_name <- ""
+
+    #If the node is a subclass, get its class name from the subclasses_names vector
+    if(xml2::xml_name(xml_node) %in% names(subclasses_names)){
+        class_name <- paste0(subclasses_names[[xml2::xml_name(xml_node)]])
+        #Else just assume the class name is r2ogs6_ + the node name
+    }else{
+        class_name <- paste0("r2ogs6_", xml2::xml_name(xml_node))
+    }
+
+    #Construct the call to the r2ogs6_object helper
+    param_str <- paste(names(ordered_parameters), ordered_parameters, sep = " = ", collapse = ", ")
+    constr_call <- paste0(class_name, "(", param_str, ")")
+
+    #Evaluate the constructed call
+    r2ogs6_obj <- eval(parse(text = constr_call))
+
+    return(invisible(r2ogs6_obj))
+}
+
+
+#'order_parameters
+#'@description Orders a list of parameters corresponding to the argument order of a class
+#'@param parameter_list A list of parameters
+#'@param class_name The name of a class
+order_parameters <- function(parameter_list, class_name){
+
+    assertthat::assert_that(is.list(parameter_list))
+    assertthat::assert_that(assertthat::is.string(class_name))
+
+    ordered_parameters <- list()
+
+    #Gets the class parameters in the correct order
+    class_args <- names(as.list(formals(class_name)))
+
+    #Check for length mismatches
+    if(length(parameter_list) > length(class_args)){
+        stop(paste0("order_parameters: More parameters in parameter_list",
+                    "than parameters in definition of class '", class_name,
+                    "'. Please check the class definition!"), call. = FALSE)
+    }
+
+    #Check for value mismatches
+    for(i in seq_len(parameter_list)){
+        if(!names(parameter_list)[[i]] %in% class_args){
+            stop(paste0("order_parameters: Found element named '",
+                        names(parameter_list)[[i]],
+                        "', in parameter_list.",
+                        " This element is not a parameter of class '", class_name,
+                        "'. Please check the class definition!"), call. = FALSE)
+        }
+    }
+
+    for(i in seq_len(length(class_args))){
+        if(!class_args[[i]] %in% names(parameter_list)){
+            ordered_parameters[[class_args[[i]]]] <- NULL
+        }else{
+            ordered_parameters[[class_args[[i]]]] <- parameter_list[[class_args[[i]]]]
+        }
+    }
+
+    return(invisible(ordered_parameters))
+}
+
+
+
+#'guess_structure
+#'@description Guesses the R representation of an XML node and adds it to parameter list
+#'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 An XML node (of class xml2::xml_node)
+#'@param subclasses_names Optional: A character vector containing the names of r2ogs6_*
+#' subclasses (r2ogs6_* classes without a method for input_add)
+guess_structure <- function(xml_node, subclasses_names = NULL){
+
+    assertthat::assert_that(class(xml_node) == "xml_node")
+
+    #Return values for leaf nodes
+    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 the node is represented by a subclass
+    }else if(xml2::xml_name(xml_node) %in% names(subclasses_names)){
+        #Call another instance of node_to_r2ogs6_obj for the subclass
+        return(invisible(node_to_r2ogs6_obj(xml_node)))
+
+        #If the node has children that are represented by a subclass
+    }else if(xml2::xml_name(xml2::xml_children(xml_node)[[1]]) %in% names(subclasses_names)){
+        #WIP(for loop)
+        return(invisible(node_to_r2ogs6_obj(xml_node)))
+
+        #Return values for parent nodes whose children have no children
+    }else if(any(length(xml2::xml_children(xml2::xml_children(xml_node))) > 0)){
+        return(invisible(vector_from_nodeset(xml2::xml_children(xml_node))))
+
+        #If the structure goes deeper than that, abort mission
+    }else{
+        stop(paste0("Could not guess the structure of node with name '",
+                    xml2::xml_name(xml_node), "', please read the ",
+                    "documentation for guess_structure() and which ",
+                    "assumptions it is based on."), call. = FALSE)
+    }
+}
+
+
+#'vector_from_nodeset
+#'@description Creates a named vector from a nodeset
+#'@param xml_nodeset An XML nodeset (of class xml2::xml_nodeset)
+vector_from_nodeset <- function(xml_nodeset){
+    assertthat::assert_that(class(xml_nodeset) == "xml_nodeset")
+
+    my_vector <- character()
+
+    for(i in seq_len(length(xml_nodeset))){
+        if(xml2::xml_text(xml_nodeset[[i]]) != ""){
+            my_vector <- c(my_vector, character(xml2::xml_text(xml_nodeset[[i]])))
+        }else{
+            my_vector <- c(my_vector, character(xml2::xml_attrs(xml_nodeset[[i]])))
+        }
+
+        names(my_vector)[[length(my_vector)]] <- xml2::xml_name(xml_nodeset[[i]])
+    }
+
+    return(invisible(my_vector))
+}
+
+
+#============================== 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

R/read_in_vtu.R

+#Functions to read in data from a .vtu file to an OGS6 object
+#WIP, so far only creates the reference for the project file, might add analysis functions later!
+
+
+#'pick_vtu_file
+#'@description Lets the user pick a .vtu file and adds it to the specified OGS6 class object
+#'@param ogs6_obj A OGS6 class object
+#'@export
+pick_vtu_file <- function(ogs6_obj) {
+
+    assertthat::assert_that(class(ogs6_obj) == "OGS6")
+
+    file <- file.choose()
+    check_file_extension(file, "vtu")
+
+    ogs6_obj$add_mesh(basename(file))
+    file.copy(file, ogs6_obj$sim_path)
+}
+
+#'read_in_vtu
+#'@description Wrapper function to read in a whole .vtu file
+#'@param ogs6_obj A OGS6 class object
+#'@param vtu_path The path to the mesh file that should be read in
+#'@export
+read_in_vtu <- function(ogs6_obj, vtu_path) {
+
+    assertthat::assert_that(class(ogs6_obj) == "OGS6")
+    xml_doc <- validate_read_in_xml(vtu_path)
+
+    #...
+}
\ No newline at end of file