Newer
Older
Ruben Heinrich
committed
#===== OGS6 =====
Ruben Heinrich
committed
#' OGS6
#' @description Constructor for the \code{OGS6} base class
#' @export
Ruben Heinrich
committed
OGS6 <- R6::R6Class("OGS6",
public = list(
#' @description
#' Creates new OGS6 object
#' @param sim_name string: Simulation name
#' @param sim_path string: Path where all files for the simulation will be
#' saved
#' @examples
#' ogs6_obj <- OGS6$new(sim_name = "my_sim", sim_path = "my/path")
Ruben Heinrich
committed
initialize = function(sim_name,
Ruben Heinrich
committed
# Basic validation
self$sim_name <- sim_name
if(missing(sim_path)){
sim_path <- unlist(options("r2ogs6.default_sim_path"))
Ruben Heinrich
committed
},
#' @description
#' Adds a .prj simulation component
#' @examples
#' ogs6_obj <- OGS6$new(sim_name = "my_sim", sim_path = "my/path")
#' ogs6_obj$add(prj_parameter(name = "foo", type = "bar"))
# Assert that class name is in implemented .prj classes for OGS6
ogs6_prj_classes <- ogs6_prj_top_level_classes()
assertthat::assert_that(class(x) %in% ogs6_prj_classes)
# Get name of corresponding OGS6 component
component_name <- names(ogs6_prj_classes)[ogs6_prj_classes == class(x)]
component_class <-
eval(parse(text = paste0("class(self$", component_name, ")")))
ifelse(component_class == "list",
paste0("self$", component_name,
" <- c(self$", component_name, ", list(x))"),
paste0("self$", component_name, " <- x"))
eval(parse(text = active_field_call))
# If class has `name` variable, make it accessable by name
if(component_class == "list" &&
"name" %in% names(as.list(formals(class(x))))){
name_call <- paste0("names(self$", component_name, ")[[length(self$",
component_name, ")]] <- x$name")
eval(parse(text = name_call))
}
#' @description
#' Adds a reference to a file with ending .gml and optionally, a
#' \code{OGS6_gml} object
#' @param gml string | OGS6_gml: Either a path to a file with extension
#' .gml or a OGS6_gml object.
#' @examples
#' ogs6_obj <- OGS6$new(sim_name = "my_sim", sim_path = "my/path")
#' ogs6_obj$add_gml("this_works.gml")
#' \dontrun{ogs6_obj$add_gml("this_doesnt.oops")}
Ruben Heinrich
committed
add_gml = function(gml){
assertthat::assert_that(grepl("\\.gml$", gml))
assertthat::assert_that(inherits(gml, "OGS6_gml"))
private$.geometry <- paste0(self$sim_name, ".gml")
Ruben Heinrich
committed
},
#' @description
#' Adds a reference to a \code{.vtu} file and optionally, a \code{OGS6_vtu}
#' object
#' @param path string: A path
#' @param axisym flag: Is the mesh axially symmetrical?
#' @param read_in_vtu flag: Optional: Should \code{.vtu} file just be
#' copied or read in too?
#' @examples
#' ogs6_obj <- OGS6$new(sim_name = "my_sim", sim_path = "my/path")
#' ogs6_obj$add_vtu("this_works.vtu")
#' \dontrun{ogs6_obj$add_vtu("this_doesnt.oops")}
read_in_vtu = FALSE){
assertthat::assert_that(assertthat::is.string(path))
assertthat::assert_that(grepl("\\.vtu$", path))
assertthat::assert_that(assertthat::is.flag(axisym))
assertthat::assert_that(assertthat::is.flag(read_in_vtu))
self$meshes <- c(self$meshes,
list(mesh = list(path = path,
axially_symmetric = axisym)))
private$.vtus <- c(private$.vtus, list(OGS6_vtu$new(path)))
#' @description
#' Checks if the \code{OGS6} object has all necessary parameters for
#' @param print_status flag: Should the status be printed to the console?
#' @examples
#' ogs6_obj <- OGS6$new(sim_name = "my_sim", sim_path = "my/path")
#' ogs6_obj$get_status()
get_status = function(print_status = TRUE){
assertthat::assert_that(assertthat::is.flag(print_status))
Ruben Heinrich
committed
flag <- TRUE
status_strs <- character()
tag_names <- lapply(get_prj_top_level_tags(), `[[`, 1)
required <- lapply(get_prj_top_level_tags(), `[[`, 2)
for(i in seq_len(length(tag_names))){
is_required <- required[[i]]
prj_obj_call <- paste0("private$.", tag_names[[i]])
prj_obj <- eval(parse(text = prj_obj_call))
if(length(prj_obj) == 0){
if(is_required){
status_str <- crayon::red("\u2717 ")
flag <- FALSE
}else{
status_str <- crayon::yellow("\u2717 ")
}
}else{
status_str <- crayon::green("\u2713 ")
}
status_str <- paste0(status_str,
"'",
tag_names[[i]],
ifelse(!class(prj_obj) == "list",
"' is defined",
"' has at least one element"))
status_strs <- c(status_strs, status_str)
Ruben Heinrich
committed
status <- paste(status_strs, collapse = "\n")
if(print_status){
if(flag){
cat(paste0("Your OGS6 object has all necessary components.\n",
"Note that this calls more validation functions, ",
"so you may not be done just yet.\n"))
}
}
Ruben Heinrich
committed
return(invisible(flag))
#' @description
#' Overrides default printing behaviour
print = function(){
cat("OGS6\n")
cat("simulation name: ", self$sim_name, "\n", sep = "")
cat("simulation path: ", self$sim_path, "\n", sep = "")
cat("\n----- geometry: ", self$geometry, "\n", sep = "")
cat("associated OGS6_gml:\n")
print(self$gml)
cat("\n----- meshes -----\n",
paste(self$meshes, collapse = "\n"),
"\n", sep = "")
prj_tags <- lapply(get_prj_top_level_tags(), function(x){x[["tag_name"]]})
prj_tags <- prj_tags[!prj_tags %in% c("geometry", "mesh", "meshes")]
for(i in seq_len(length(prj_tags))){
tag_name <- prj_tags[[i]]
prj_param_call <- paste0("print(self$", tag_name, ")")
cat("\n----- ", tag_name, " -----\n", sep = "")
eval(parse(text = prj_param_call))
cat("\n", sep = "")
}
invisible(self)
},
#' print_log
#' @description Prints logfile to console (if it exists)
print_log = function(){
if(!is.null(self$logfile)){
writeLines(readLines(self$logfile))
}else{
cat("There is no logfile associated with this OGS6 object.\n")
}
#' @description
#' Clears components from the \code{OGS6} object
#' @param which character: The names of the components (all by default).
#' If you want to delete only some components, run
#' \code{names(ogs6_prj_top_level_classes())} for the available options.
which <- names(ogs6_prj_top_level_classes())
valid_input = names(ogs6_prj_top_level_classes())
null_it <- c("geometry", "time_loop")
for(i in seq_len(length(which))){
if(!which[[i]] %in% valid_input){
warning(paste0("Parameter '", which[[i]],
"' not recognized by OGS6$clear(). ",
"Valid parameters are:\n'",
paste(valid_input, sep = "", collapse = "', '"),
"'\nSkipping."), call. = FALSE)
next
}else{
call_str <- ""
if(which[[i]] %in% null_it){
call_str <- paste0("private$.", which[[i]], " <- NULL")
}else{
call_str <- paste0("private$.", which[[i]], " <- list()")
}
eval(parse(text = call_str))
}
}
Ruben Heinrich
committed
}
),
Ruben Heinrich
committed
active = list(
#' @field sim_name
#' Simulation name. \code{value} must be string
sim_name = function(value) {
if(missing(value)) {
private$.sim_name
}else{
assertthat::assert_that(assertthat::is.string(value))
private$.sim_name <- value
}
Ruben Heinrich
committed
},
#' @field sim_path
#' Simulation path. \code{value} must be string
sim_path = function(value) {
if(missing(value)) {
private$.sim_path
}else{
private$.sim_path <- as_dir_path(value)
},
#' @field logfile
#' Logfile path. \code{value} must be string
logfile = function(value) {
if(missing(value)) {
private$.logfile
}else{
assertthat::assert_that(assertthat::is.string(value))
private$.logfile <- value
}
},
#' @field gml
#' \code{.gml}. read-only
gml = function() {
private$.gml
Ruben Heinrich
committed
},
Ruben Heinrich
committed
#' @field geometry
#' \code{.prj} \code{geometry} tag. \code{value} must be string
geometry = function(value) {
if(missing(value)) {
private$.geometry
}else{
assertthat::assert_that(is.string(value))
private$.geometry <- value
}
#' @field meshes
#' \code{.prj} \code{meshes} tag. \code{value} must be list of strings
meshes = function(value) {
if(missing(value)) {
private$.meshes
}else{
assertthat::assert_that(is.list(value))
lapply(value, function(x){
assertthat::assert_that(is.list(x), length(x) == 2)
assertthat::assert_that(assertthat::is.string(x[[1]]))
assertthat::assert_that(assertthat::is.flag(x[[2]]))
private$.meshes <- value
}
Ruben Heinrich
committed
},
#' @field vtus
#' \code{.vtu}s. \code{value} must be list of \code{OGS6_vtu} objects
vtus = function(value) {
if(missing(value)) {
private$.vtus
}else{
ogs6_prj_top_level_classes()[["vtus"]])
private$.vtus <- value
}
},
#' @field python_script
#' \code{.prj} \code{python_script} tag. \code{value} must be string
python_script = function(value) {
if(missing(value)) {
private$.python_script
}else{
assertthat::assert_that(assertthat::is.string(value))
private$.python_script <- value
}
#' @field search_length_algorithm
#' \code{.prj} \code{search_length_algorithm} tag. \code{value} must be
Ruben Heinrich
committed
search_length_algorithm = function(value) {
if(missing(value)) {
private$.search_length_algorithm
}else{
assertthat::assert_that(
ogs6_prj_top_level_classes()[["search_length_algorithm"]] %in%
Ruben Heinrich
committed
class(value))
private$.search_length_algorithm <- value
}
},
#' @field processes
#' \code{.prj} \code{processes} tag. \code{value} must be list of
processes = function(value) {
if(missing(value)) {
private$.processes
}else{
# If there already is a process element
if(length(private$.processes) > 0){
if(ogs6_prj_top_level_classes()[["processes"]] %in%
class(private$.processes[[1]])){
ogs6_prj_top_level_classes()[["processes"]])
}else{
assertthat::assert_that(assertthat::is.string(value))
value <- list(include = c(file = value))
}
}else{
if(assertthat::is.string(value)){
value <- list(include = c(file = value))
}else{
ogs6_prj_top_level_classes()[["processes"]])
private$.processes <- value
}
Ruben Heinrich
committed
},
#' @field time_loop
#' \code{.prj} \code{time_loop} tag. \code{value} must be
time_loop = function(value) {
if(missing(value)) {
private$.time_loop
}else{
assertthat::assert_that(
ogs6_prj_top_level_classes()[["time_loop"]] %in%
class(value))
private$.time_loop <- value
}
Ruben Heinrich
committed
},
#' @field local_coordinate_system
#' \code{.prj} \code{local_coordinate_system} tag. \code{value} must be
local_coordinate_system = function(value) {
if(missing(value)) {
private$.local_coordinate_system
}else{
assertthat::assert_that(
ogs6_prj_top_level_classes()[["local_coordinate_system"]] %in%
class(value))
private$.local_coordinate_system <- value
}
#' @field media
#' \code{.prj} \code{media} tag. \code{value} must be list of
media = function(value) {
if(missing(value)) {
private$.media
}else{
ogs6_prj_top_level_classes()[["media"]])
private$.media <- value
}
Ruben Heinrich
committed
},
#' @field parameters
#' \code{.prj} \code{parameters} tag. \code{value} must be list of
parameters = function(value) {
if(missing(value)) {
private$.parameters
}else{
ogs6_prj_top_level_classes()[["parameters"]])
private$.parameters <- value
}
Ruben Heinrich
committed
},
#' @field chemical_system
#' \code{.prj} \code{chemical_system} tag. \code{value} must be
chemical_system = function(value) {
if(missing(value)) {
private$.chemical_system
}else{
assertthat::assert_that(
ogs6_prj_top_level_classes()[["chemical_system"]] %in%
class(value))
private$.chemical_system <- value
}
},
#' @field curves
#' \code{.prj} \code{curves} tag. \code{value} must be list of
curves = function(value) {
if(missing(value)) {
private$.curves
}else{
ogs6_prj_top_level_classes()[["curves"]])
private$.curves <- value
}
Ruben Heinrich
committed
},
#' @field process_variables
#' \code{.prj} \code{process_variables} tag. \code{value} must be list of
process_variables = function(value) {
if(missing(value)) {
private$.process_variables
}else{
ogs6_prj_top_level_classes()[["process_variables"]])
private$.process_variables <- value
}
Ruben Heinrich
committed
},
#' @field nonlinear_solvers
#' \code{.prj} \code{nonlinear_solvers} tag. \code{value} must be list of
nonlinear_solvers = function(value) {
if(missing(value)) {
private$.nonlinear_solvers
}else{
ogs6_prj_top_level_classes()[["nonlinear_solvers"]])
private$.nonlinear_solvers <- value
}
Ruben Heinrich
committed
},
#' @field linear_solvers
#' \code{.prj} \code{linear_solvers} tag. \code{value} must be list of
linear_solvers = function(value) {
if(missing(value)) {
private$.linear_solvers
}else{
ogs6_prj_top_level_classes()[["linear_solvers"]])
private$.linear_solvers <- value
}
Ruben Heinrich
committed
},
#' @field test_definition
#' \code{.prj} \code{test_definition} tag. \code{value} must be list of
test_definition = function(value) {
if(missing(value)) {
private$.test_definition
}else{
ogs6_prj_top_level_classes()[["test_definition"]])
private$.test_definition <- value
}
#' @field insitu
#' \code{.prj} \code{insitu} tag. \code{value} must be
insitu = function(value) {
if(missing(value)) {
private$.insitu
}else{
assertthat::assert_that(
ogs6_prj_top_level_classes()[["insitu"]] %in%
class(value))
private$.insitu <- value
}
#' @field pvds
#' \code{.pvd}s. \code{value} must be list of \code{OGS6_pvd} objects
is_wrapper_list(value, "OGS6_pvd")
private$.pvds <- value
Ruben Heinrich
committed
}
Ruben Heinrich
committed
),
#===== Private parameters =====
Ruben Heinrich
committed
private = list(
Ruben Heinrich
committed
.sim_name = NULL,
.sim_path = NULL,
Ruben Heinrich
committed
.gml = NULL,
.geometry = NULL,
.meshes = list(),
Ruben Heinrich
committed
.search_length_algorithm = NULL,
.time_loop = NULL,
.local_coordinate_system = NULL,
.media = list(),
.parameters = list(),
.curves = list(),
.process_variables = list(),
.nonlinear_solvers = list(),
.linear_solvers = list(),
Ruben Heinrich
committed
)
)
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
#===== ogs6_prj_top_level_classes =====
#' ogs6_prj_top_level_classes
#' @description Returns named character vector of \code{OGS6} top level
#' \code{.prj} tags (names) represented by \code{r2ogs6} classes along with
#' their class names (values).
#' @return character
#' @export
ogs6_prj_top_level_classes <- function(){
xpaths_for_classes <- xpaths_for_classes
flattened_xpaths <- unlist(xpaths_for_classes)
names(flattened_xpaths) <- NULL
prj_components <- character()
seen <- character()
for(i in seq_len(length(flattened_xpaths))){
split_xpath <-
unlist(strsplit(flattened_xpaths[[i]], "/", fixed = TRUE))
if(!split_xpath[[1]] %in% seen){
if(!is.null(get_class_from_xpath(split_xpath[[1]]))){
prj_components <- c(prj_components,
get_class_from_xpath(split_xpath[[1]]))
}else{
xpath <- paste(split_xpath[[1]], split_xpath[[2]], sep = "/")
prj_components <- c(prj_components,
get_class_from_xpath(xpath))
}
names(prj_components)[[length(prj_components)]] <- split_xpath[[1]]
seen <- c(seen, split_xpath[[1]])
}
}
return(prj_components)
}