Commit 81504e6b authored by Johannes Boog's avatar Johannes Boog
Browse files

Merge branch '70-bugfix-value_prj_ph_medium' into 'master'

[bugfix] make all OGS6 benchmarks work.

Closes #70, #63, and #60

See merge request !54
parents 43f1107e 17c864dc
Pipeline #13862 passed with stage
in 6 minutes and 11 seconds
......@@ -10,6 +10,7 @@
^inst/examples/Theis_well_pumping
^JOSS$
^LICENSE.md
^local-bm-test$
^Meta$
^packrat/
^public$
......
Package: r2ogs6
Type: Package
Title: An API to the multi-physics simulator OpenGeoSys-v6
Version: 0.2.0
Version: 0.6.41
Authors@R: c(person(given = "Ruben",
family = "Heinrich",
role = c("aut"),
......@@ -33,27 +33,22 @@ Suggests:
devtools,
ggplot2,
BiocManager,
rhdf5
rhdf5,
rmarkdown
Imports:
purrr,
xml2,
tibble,
R6,
stringr,
readr,
assertthat,
crayon,
utils,
rmarkdown,
curl,
dplyr,
rlang,
doParallel,
reticulate,
config,
sticky,
foreach
RoxygenNote: 7.1.2
RoxygenNote: 7.2.1
VignetteBuilder: knitr
Depends:
R (>= 2.10)
......@@ -67,4 +67,11 @@ export(prj_time_stepping)
export(prj_tl_process)
export(prj_vtkdiff)
export(read_in_prj)
importFrom(R6,R6Class)
importFrom(crayon,green)
importFrom(crayon,red)
importFrom(crayon,yellow)
importFrom(doParallel,registerDoParallel)
importFrom(dplyr,bind_cols)
importFrom(dplyr,bind_rows)
importFrom(foreach,"%dopar%")
......@@ -42,9 +42,16 @@ to_node <- function(object, object_name = "",
object_name %in% attribute_names))){
if(object_name %in% flatten_on_exp){
if(is.list(object)){
ret_list <- list(list(list(paste(object, collapse = " "))))
names(ret_list)[[1]] <- object_name
names(ret_list[[1]])[[1]] <- names(object)[[1]]
}else{
ret_list <- list(list(paste(object, collapse = " ")))
names(ret_list)[[1]] <- object_name
return(invisible(ret_list))
}
return(invisible(ret_list))
}
if(object_name %in% attribute_names){
......@@ -154,6 +161,10 @@ to_node <- function(object, object_name = "",
for(i in seq_len(length(object))){
if(is.null(object[[i]])){
next
}
element_name <- names(object)[[i]]
element_node <- to_node(object[[i]],
......
......@@ -399,7 +399,7 @@ construct_add_call <- function(object, nested_call = FALSE) {
}
#For lists we need to use recursion
if(class(object) == "list"){
if(inherits(object, "list")){
element_strs <- lapply(object, function(x){construct_add_call(x, TRUE)})
......
......@@ -5,6 +5,7 @@
#' OGS6
#' @description Constructor for the \code{OGS6} base class
#' @export
#' @importFrom R6 R6Class
OGS6 <- R6::R6Class("OGS6",
public = list(
......@@ -171,6 +172,9 @@ OGS6 <- R6::R6Class("OGS6",
#' @examples
#' ogs6_obj <- OGS6$new(sim_name = "my_sim", sim_path = "my/path")
#' ogs6_obj$get_status()
#' @importFrom crayon red
#' @importFrom crayon yellow
#' @importFrom crayon green
get_status = function(print_status = TRUE){
assertthat::assert_that(assertthat::is.flag(print_status))
......
......@@ -5,6 +5,7 @@
#'OGS6_Chain
#'@description Constructor for the OGS6_Chain base class
#'@export
#' @importFrom R6 R6Class
OGS6_Chain <- R6::R6Class(
"OGS6_Chain",
......
......@@ -100,6 +100,7 @@ OGS6_Ensemble <- R6::R6Class(
#' This is implementented via the 'parallel' package.
#' @param overwrite flag: Should existing files be overwritten?
#'@param verbose flag
#'@importFrom doParallel registerDoParallel
run_simulation = function(parallel = FALSE,
overwrite = T,
verbose = F){
......@@ -186,6 +187,7 @@ OGS6_Ensemble <- R6::R6Class(
#' Defaults to first timestep.
#'@param end_at_timestep number: Optional: Timestep to end at. Defaults
#' to last timestep.
#'@importFrom dplyr bind_rows
get_point_data = function(pvd_id = 1,
point_ids,
keys,
......
......@@ -24,6 +24,7 @@
#' ))
#' )
#' @export
#' @importFrom R6 R6Class
OGS6_gml <- R6::R6Class(
"OGS6_gml",
public = list(
......
......@@ -3,6 +3,7 @@
#' OGS6_h5
#' @description Small class to wrap \code{h5} data into the \code{r2ogs6} workflow.
#' @export
#' @importFrom R6 R6Class
OGS6_h5 <- R6::R6Class("OGS6_h5",
public = list(
#' @description This function will be called automatically after a
......@@ -78,6 +79,7 @@ OGS6_h5 <- R6::R6Class("OGS6_h5",
#' ogs6_h5 <- OGS6_h5$new(h5_path)
#' df <- ogs6_h5$get_df("/t_0", "pressure")
#' \dontrun{df <- ogs6_obj$h5s[[1]]$get_df("/t_0", "pressure")}
#' @importFrom dplyr bind_cols
get_df = function(group, names = "geometry") {
assertthat::is.string(group)
......
......@@ -3,6 +3,7 @@
#' MSH files are a legacy format from OGS5. It is recommended to switch to VTU
#' files.
#' @export
#' @importFrom R6 R6Class
OGS6_msh <- R6::R6Class("OGS6_msh",
public = list(
#' @description reates new OGS6_vtu object..
......
......@@ -5,6 +5,7 @@
#' OGS6_pvd
#' @description Constructor for the OGS6_pvd base class
#' @export
#' @importFrom R6 R6Class
OGS6_pvd <- R6::R6Class(
"OGS6_pvd",
public = list(
......@@ -260,6 +261,7 @@ OGS6_pvd <- R6::R6Class(
},
# Returns a dataframe with all of the CellData
#' @importFrom dplyr bind_rows
get_data = function(data_type,
ids,
keys,
......
......@@ -5,6 +5,7 @@
#' OGS6_vtu
#' @description Constructor for the `OGS6_vtu` base class
#' @export
#' @importFrom R6 R6Class
OGS6_vtu <- R6::R6Class(
"OGS6_vtu",
public = list(
......@@ -244,7 +245,7 @@ OGS6_vtu <- R6::R6Class(
),
private = list(
#' @importFrom dplyr bind_rows
get_data = function(data_type,
ids,
keys){
......
......@@ -12,7 +12,7 @@
#' @export
prj_curve <- function(name, coords, values){
#Coerce input
if(missing(name)){ name <- NULL }
coords <- coerce_string_to_numeric(coords)
values <- coerce_string_to_numeric(values)
......@@ -22,14 +22,21 @@ prj_curve <- function(name, coords, values){
new_prj_curve <- function(name, coords, values){
assertthat::assert_that(assertthat::is.string(name))
if(!is.null(name)){
assertthat::assert_that(assertthat::is.string(name))
}
assertthat::assert_that(is.numeric(coords))
assertthat::assert_that(is.numeric(values))
structure(list(name = name,
coords = coords,
values = values,
xpath = "curves/curve",
xpath = c("curves/curve",
paste0("processes/process/porous_medium/",
"porous_medium/capillary_pressure/curve"),
paste0("processes/process/material_property/",
"porous_medium/porous_medium/",
"capillary_pressure/curve")),
attr_names = character(),
flatten_on_exp = c("coords", "values")
),
......
......@@ -422,6 +422,8 @@ get_valid_phase_types <- function(){
#' @param exponents Optional:
#' @param lower_saturation_limit Optional:
#' @param upper_saturation_limit Optional:
#' @param tortuosity Optional:
#' @param curve Optional:
#' @param ... independent_variable, dvalue
#' @example man/examples/ex_prj_ph_property.R
#' @export
......@@ -436,6 +438,8 @@ prj_ph_property <- function(name,
exponents = NULL,
lower_saturation_limit = NULL,
upper_saturation_limit = NULL,
tortuosity = NULL,
curve = NULL,
...) {
#Coerce input
......@@ -449,6 +453,7 @@ prj_ph_property <- function(name,
swelling_pressures <- coerce_string_to_numeric(swelling_pressures)
lower_saturation_limit <- coerce_string_to_numeric(lower_saturation_limit)
upper_saturation_limit <- coerce_string_to_numeric(upper_saturation_limit)
tortuosity <- (coerce_string_to_numeric(tortuosity))
ellipsis_list <- list(...)
independent_variable <-
......@@ -467,7 +472,9 @@ prj_ph_property <- function(name,
swelling_pressures,
exponents,
lower_saturation_limit,
upper_saturation_limit)
upper_saturation_limit,
tortuosity,
curve)
}
......@@ -483,7 +490,9 @@ new_prj_ph_property <- function(name,
swelling_pressures = NULL,
exponents = NULL,
lower_saturation_limit = NULL,
upper_saturation_limit = NULL) {
upper_saturation_limit = NULL,
tortuosity = NULL,
curve = NULL) {
are_strings(name,
type)
......@@ -506,22 +515,23 @@ new_prj_ph_property <- function(name,
reference_value,
offset,
lower_saturation_limit,
upper_saturation_limit
upper_saturation_limit,
tortuosity
)
are_null_or_numeric(swelling_pressures,
exponents)
are_null_or_strings(parameter_name)
are_null_or_strings(parameter_name, curve)
if (!is.null(independent_variable)) {
independent_variable <- lapply(independent_variable, function(x){
x <- coerce_names(x,
c("variable_name",
"reference_condition",
"slope"))
})
}
# if (!is.null(independent_variable)) {
# independent_variable <- lapply(independent_variable, function(x){
# x <- coerce_names(x,
# c("variable_name",
# "reference_condition",
# "slope"))
# })
# }
if (!is.null(exponent)) {
exponent <- coerce_names(exponent,
......@@ -543,9 +553,11 @@ new_prj_ph_property <- function(name,
exponents = exponents,
lower_saturation_limit = lower_saturation_limit,
upper_saturation_limit = upper_saturation_limit,
tortuosity = tortuosity,
curve = curve,
xpath = "media/medium/phases/phase/properties/property",
attr_names = character(),
flatten_on_exp = c("exponents",
flatten_on_exp = c("value", "exponents",
"swelling_pressures"),
unwrap_on_exp = c("independent_variable", "dvalue")
),
......
......@@ -144,16 +144,6 @@ new_prj_capillary_pressure <- function(type,
are_null_or_string_flags(has_regularized)
is_null_or_coerce_names(curve, c("coords", "values"))
if(!is.null(curve)){
curve[[1]] <- coerce_string_to_numeric(curve[[1]])
curve[[2]] <- coerce_string_to_numeric(curve[[2]])
assertthat::assert_that(is.numeric(curve[[1]]))
assertthat::assert_that(is.numeric(curve[[2]]))
}
structure(list(type = type,
pd = pd,
sr = sr,
......
......@@ -1012,7 +1012,8 @@ new_prj_jacobian_assembler <- function(type,
relative_epsilons = relative_epsilons,
xpath = "processes/process/jacobian_assembler",
attr_names = character(),
flatten_on_exp = character()
flatten_on_exp = c("component_magnitudes",
"relative_epsilons")
),
class = "prj_jacobian_assembler"
)
......
......@@ -59,8 +59,9 @@ read_in_prj <- function(ogs6_obj,
for(i in seq_along(vtu_ref_nodes)){
vtu_ref <- xml2::xml_text(vtu_ref_nodes[[i]])
vtu_ref <- stringr::str_trim(vtu_ref)
vtu_ref <- stringr::str_remove_all(vtu_ref, "[\n]")
vtu_path <- make_abs_path(vtu_ref, prj_base_path)
# vtu_path <- paste0(dirname(prj_path), "/", vtu_ref)
axisym_val <- xml2::xml_attr(vtu_ref_nodes[[i]], "axially_symmetric")
......
......@@ -177,15 +177,15 @@ node_to_object <- function(xml_node,
xml_attrs <- xml2::xml_attrs(xml_node)
xml_text <- xml2::xml_text(xml_node)
xml_text_clean <- stringr::str_trim(xml_text)
xml_text_clean <-
stringr::str_remove_all(xml_text, "[\n|[:space:]]")
stringr::str_remove_all(xml_text_clean, "[\n]")
if(xml_text_clean != "" && length(xml_attrs) != 0){
return(invisible(c(xml_attrs, xml_text = xml_text)))
return(invisible(c(xml_attrs, xml_text = xml_text_clean)))
}
else if(xml_text_clean != ""){
return(invisible(xml_text))
return(invisible(xml_text_clean))
}
else if(length(xml_attrs) != 0){
return(invisible(xml_attrs))
......
......@@ -8,11 +8,11 @@
#' requires string parsing.
get_xpaths_for_classes <- function(){
ns_exports <- getNamespaceExports("r2ogs6")
all_objects <- ls("package:r2ogs6")
prj_class_constructor_names <-
sort(ns_exports[grepl("^new_prj_", ns_exports)])
sort(all_objects[grepl("^new_prj_", all_objects)])
prj_class_helper_names <-
sort(ns_exports[grepl("^prj_", ns_exports)])
sort(all_objects[grepl("^prj_", all_objects)])
xfc_list <- list()
......
Supports Markdown
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