ogs6.R

#===== OGS6 =====


#'OGS6
#'@description Constructor for the OGS6 base class
#'@export
OGS6 <- R6::R6Class("OGS6",
  public = list(

    #'@description
    #'Creates new OGS6 object
    #'@param sim_name string: Simulation name
    #'@param sim_id double: Simulation ID
    #'@param sim_path string: Path where all files for the simulation will be
    #' saved
    initialize = function(sim_name,
                          sim_id,
                          sim_path) {

      # Basic validation
      self$sim_name <- sim_name

      assertthat::assert_that(assertthat::is.number(sim_id))
      private$.sim_id <- sim_id

      if(missing(sim_path)){
        sim_path <- unlist(options("r2ogs6.default_sim_path"))
      }
      self$sim_path <- sim_path

    },


    #===== Adding components =====


    #'@description
    #'Adds a .prj simulation component
    #'@param x An object of any .prj `r2ogs6` class
    add = function(x){

      # Assert that class name is in implemented .prj classes for OGS6
      ogs6_prj_classes <- 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, ")")))

      active_field_call <-
        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 .gml file and optionally, a OGS6_gml object
    #'@param gml string | r2ogs6_gml: Either a path to a file with extension
    #' .gml or a r2ogs6_gml object.
    #@examples
    add_gml = function(gml){

      if(assertthat::is.string(gml)){
        assertthat::assert_that(grepl("\\.gml$", gml))
        private$.geometry <- gml
      }else{
        assertthat::assert_that(inherits(gml, "OGS6_gml"))
        private$.gml <- gml

        if(!is.null(private$.geometry)){
          warning(paste("OGS6 parameter 'geometry' now refers",
                        "to a different .gml object"), call. = FALSE)
        }
        private$.geometry <- paste0(self$sim_name, ".gml")
      }
    },

    #'@description
    #'Adds a reference to a .vtu file and optionally, a OGS6_vtu object
    #'@param path string:
    #'@param read_in_vtu flag: Optional: Should .vtu file just be copied or
    #' read in too?
    add_vtu = function(path,
                       read_in_vtu = FALSE){
      assertthat::assert_that(assertthat::is.string(path))
      assertthat::assert_that(grepl("\\.vtu$", path))
      assertthat::assert_that(assertthat::is.flag(read_in_vtu))

      self$meshes <- c(self$meshes, mesh = path)

      if(read_in_vtu){
        private$.vtus <- c(private$.vtus, list(OGS6_vtu$new(path)))
      }
    },


    #===== Utility =====


    #'@description
    #'Checks if the OGS6 object has all necessary parameters for
    #' starting a simulation
    #'@param print_status flag: Should the status be printed to the console?
    get_status = function(print_status = TRUE){

      assertthat::assert_that(assertthat::is.flag(print_status))
      flag <- TRUE

      status_strs <- character()
      tag_names <- lapply(prj_top_level_tags(), `[[`, 1)
      required <- lapply(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)
      }

      status <- paste(status_strs, collapse = "\n")

      if(print_status){
        cat(status)

        if(flag){
          cat(paste0("Your OGS6 object has all necessary components.\n",
                     "You can try calling run_simulation().",
                     "Note that this calls more validation functions, ",
                     "so you may not be done just yet.\n"))
        }
      }

      return(invisible(flag))
    },

    #'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 OGS6 object
    #'@param which character: The names of the components (all by default).
    #' If you want to delete only some components, run
    #' names(prj_top_level_classes()) for the available options.
    clear = function(which){

      if(missing(which)){
        which <- names(prj_top_level_classes())
      }

      valid_input = names(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))
        }
      }
    }

  ),


  #===== Active fields =====


  active = list(

      #'@field sim_name
      #'Simulation name. `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
        }
      },

      #'@field sim_id
      #'Simulation ID. read-only
      sim_id = function() {
        private$.sim_id
      },

      #'@field sim_path
      #'Simulation path. `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. `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
      #'.gml. read-only
      gml = function() {
        private$.gml
      },

      #'@field geometry
      #'.prj `geometry` tag. `value` must be string
      geometry = function(value) {
        if(missing(value)) {
          private$.geometry
        }else{
          assertthat::assert_that(is.string(value))
          private$.geometry <- value
        }
      },

      #'@field meshes
      #'.prj `meshes` tag. `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(assertthat::is.string(x))
          })
          private$.meshes <- value
        }
      },

      #'@field vtus
      #'.vtus. `value` must be list of `OGS_vtu` objects
      vtus = function(value) {
        if(missing(value)) {
          private$.vtus
        }else{
          is_wrapper_list(value,
                          prj_top_level_classes()[["vtus"]])
          private$.vtus <- value
        }
      },

      #'@field python_script
      #'.prj `python_script` tag. `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
      #'.prj `search_length_algorithm` tag. `value` must be
      #' `r2ogs6_search_length_algorithm` object
      search_length_algorithm = function(value) {
        if(missing(value)) {
          private$.search_length_algorithm
        }else{
          assertthat::assert_that(
            prj_top_level_classes()[["search_length_algorithm"]] %in%
              class(value))
          private$.search_length_algorithm <- value
        }
      },

      #'@field processes
      #'.prj `processes` tag. `value` must be list of `r2ogs6_process` objects
      processes = function(value) {
        if(missing(value)) {
          private$.processes
        }else{
          # If there already is a process element
          if(length(private$.processes) > 0){
            if(prj_top_level_classes()[["processes"]] %in%
               class(private$.processes[[1]])){
                 is_wrapper_list(value,
                                       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{
              is_wrapper_list(value,
                                    prj_top_level_classes()[["processes"]])
            }
          }

          private$.processes <- value
        }
      },

      #'@field time_loop
      #'.prj `time_loop` tag. `value` must be `r2ogs6_time_loop` object
      time_loop = function(value) {
        if(missing(value)) {
          private$.time_loop
        }else{
          assertthat::assert_that(
            prj_top_level_classes()[["time_loop"]] %in%
              class(value))
          private$.time_loop <- value
        }
      },

      #'@field local_coordinate_system
      #'.prj `local_coordinate_system` tag. `value` must be
      #' `r2ogs6_local_coordinate_system` object
      local_coordinate_system = function(value) {
        if(missing(value)) {
          private$.local_coordinate_system
        }else{
          assertthat::assert_that(
            prj_top_level_classes()[["local_coordinate_system"]] %in%
              class(value))
          private$.local_coordinate_system <- value
        }
      },

      #'@field media
      #'.prj `media` tag. `value` must be list of `r2ogs6_medium` objects
      media = function(value) {
        if(missing(value)) {
          private$.media
        }else{
          is_wrapper_list(value,
                          prj_top_level_classes()[["media"]])
          private$.media <- value
        }
      },

      #'@field parameters
      #'.prj `parameters` tag. `value` must be list of `r2ogs6_parameter`
      #' objects
      parameters = function(value) {
        if(missing(value)) {
          private$.parameters
        }else{
          is_wrapper_list(value,
                                prj_top_level_classes()[["parameters"]])
          private$.parameters <- value
        }
      },

      #'@field chemical_system
      #'.prj `chemical_system` tag. `value` must be `r2ogs6_chemical_system`
      #' object
      chemical_system = function(value) {
        if(missing(value)) {
          private$.chemical_system
        }else{
          assertthat::assert_that(
            prj_top_level_classes()[["chemical_system"]] %in%
              class(value))
          private$.chemical_system <- value
        }
      },

      #'@field curves
      #'.prj `curves` tag. `value` must be list of `r2ogs6_curve` objects
      curves = function(value) {
        if(missing(value)) {
          private$.curves
        }else{
          is_wrapper_list(value,
                                prj_top_level_classes()[["curves"]])
          private$.curves <- value
        }
      },

      #'@field process_variables
      #'.prj `process_variables` tag. `value` must be list of
      #' `r2ogs6_process_variable` objects
      process_variables = function(value) {
        if(missing(value)) {
          private$.process_variables
        }else{
          is_wrapper_list(
            value,
            prj_top_level_classes()[["process_variables"]])
          private$.process_variables <- value
        }
      },

      #'@field nonlinear_solvers
      #'.prj `nonlinear_solvers` tag. `value` must be list of
      #' `r2ogs6_nonlinear_solver` objects
      nonlinear_solvers = function(value) {
        if(missing(value)) {
          private$.nonlinear_solvers
        }else{
          is_wrapper_list(
            value,
            prj_top_level_classes()[["nonlinear_solvers"]])
          private$.nonlinear_solvers <- value
        }
      },

      #'@field linear_solvers
      #'.prj `linear_solvers` tag. `value` must be list of
      #' `r2ogs6_linear_solver` objects
      linear_solvers = function(value) {
        if(missing(value)) {
          private$.linear_solvers
        }else{
          is_wrapper_list(value,
                          prj_top_level_classes()[["linear_solvers"]])
          private$.linear_solvers <- value
        }
      },

      #'@field test_definition
      #'.prj `test_definition` tag. `value` must be list of `r2ogs6_vtkdiff`
      #' objects
      test_definition = function(value) {
        if(missing(value)) {
          private$.test_definition
        }else{
          is_wrapper_list(value,
                          prj_top_level_classes()[["test_definition"]])
          private$.test_definition <- value
        }
      },

      #'@field insitu
      #'.prj `insitu` tag. `value` must be `r2ogs6_insitu` object
      insitu = function(value) {
        if(missing(value)) {
          private$.insitu
        }else{
          assertthat::assert_that(
            prj_top_level_classes()[["insitu"]] %in%
              class(value))
          private$.insitu <- value
        }
      },

      #'@field pvd
      #'.pvd. `value` must be `OGS6_pvd` object
      pvd = function(value) {
        if(missing(value)) {
          private$.pvd
        }else{
          assertthat::assert_that(inherits(value, "OGS6_pvd"))
          private$.pvd <- value
        }
      }
  ),

  #===== Private parameters =====

  private = list(
    # general parameters
      .sim_name = NULL,
      .sim_id = NULL,
      .sim_path = NULL,

      .logfile = NULL,

      # .gml object
      .gml = NULL,

      # .vtu objects
      .vtus = NULL,

      # .prj parameters

      # .gml reference
      .geometry = NULL,

      # .vtu reference(s)
      .meshes = list(),

      .python_script = NULL,
      .search_length_algorithm = NULL,
      .processes = list(),
      .time_loop = NULL,
      .local_coordinate_system = NULL,
      .media = list(),
      .parameters = list(),
      .chemical_system = NULL,
      .curves = list(),
      .process_variables = list(),
      .nonlinear_solvers = list(),
      .linear_solvers = list(),
      .test_definition = list(),
      .insitu = NULL,

      # .pvd object (output)
      .pvd = NULL
  )
)