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
    #'@param ogs_bin_path string: Path to OpenGeoSys6 /bin directory
    #'@param test_mode In test mode, ogs_bin_path will not be
    #' validated. Unless you're a dev, please don't touch.
    initialize = function(sim_name,
                          sim_id,
                          sim_path,
                          ogs_bin_path,
                          test_mode = FALSE) {

      # Basic validation
      assertthat::assert_that(assertthat::is.number(sim_id))

      self$sim_name <- sim_name
      self$sim_path <- sim_path

      if(!test_mode){
        if(!file.exists(paste0(ogs_bin_path, "generateStructuredMesh.exe"))) {
          stop(paste("Could not find executable file",
                     "generateStructuredMesh.exe at location",
                     ogs_bin_path), call. = FALSE)
        }
      }

        private$.sim_name <- sim_name
        private$.sim_id <- sim_id
        private$.ogs_bin_path <- validate_is_dir_path(ogs_bin_path)
    },


    #===== ADDING COMPONENTS =====


    #'@description
    #'Adds a simulation component (WIP)
    #'@param x OGS6_*: An object of a class listed in get_implemented_classes()
    add_component = function(x){

      class_prefix <- "r2ogs6_"

      # Assert that x is OGS6 class object
      assertthat::assert_that(any(grepl(class_prefix, class(x), fixed = TRUE)))

      # Get exact class name of x
      x_class_name <- grep(class_prefix, class(x), fixed = TRUE, value = TRUE)

      assertthat::assert_that(length(x_class_name) == 1)

      # Assert that class name is in implemented classes for OGS6
      impl_classes <- get_implemented_classes()

      assertthat::assert_that(x_class_name %in% impl_classes)

      # Get name of corresponding OGS6 parameter
      variable_name <- ""

      for(i in seq_len(length(impl_classes))){
        if(impl_classes[[i]] == x_class_name){
          variable_name <- names(impl_classes)[[i]]
          break
        }
      }

      af_call <- ""

      if (is_wrapper(variable_name)) {
        af_call <- paste0("self$", variable_name,
                          " <- c(self$", variable_name, ", list(x))")
      } else{
        af_call <- paste0("self$", variable_name, " <- x")
      }

      eval(parse(text = af_call))

      # If class has `name` variable, make it accessable by name
      if("name" %in% names(as.list(formals(x_class_name)))){

        name_call <- paste0("names(self$", variable_name, ")[[length(self$",
                            variable_name, ")]] <- x$name")

        eval(parse(text = name_call))
      }
    },


    #'@description
    #'Adds a reference to a .vtu file
    #'@param mesh string: .vtu path
    add_mesh = function(mesh){
      assertthat::assert_that(assertthat::is.string(mesh))
      self$meshes <- c(self$meshes, mesh = mesh)
    },

    #'@description
    #'Adds a r2ogs6_gml object
    #'@param gml r2ogs6_gml
    add_gml = function(gml){
      assertthat::assert_that(class(gml) == "r2ogs6_gml")

      private$.gml <- gml
      private$.geometry <- paste0(gml$name, ".gml")
    },

    #'@description
    #'Adds a r2ogs6_gml object
    #'@param vtu r2ogs6_vtu
    #'@param filename string:
    add_vtu = function(vtu, filename){
      assertthat::assert_that(class(vtu) == "r2ogs6_vtu")

      private$.vtus <- c(private$.vtus, list(vtu))
      self$meshes <- c(self$meshes, mesh = filename)
    },

    #'@description
    #'Adds a python script
    #'@param python_script string: File name of python script
    add_python_script = function(python_script){
      self$python_script <- python_script
    },

    #'@description
    #'Adds a r2ogs6_search_length_algorithm object
    #'@param search_length_algorithm r2ogs6_search_length_algorithm
    add_search_length_algorithm = function(search_length_algorithm){
      self$search_length_algorithm <- search_length_algorithm
    },

    #'@description
    #'Adds a r2ogs6_process object
    #'@param process r2ogs6_process
    add_process = function(process){
      self$processes <- c(self$processes,
                          list(process))

      names(self$processes)[[length(self$processes)]] <- process$name
    },

    #'@description
    #'Adds a r2ogs6_time_loop object
    #'@param time_loop r2ogs6_time_loop
    add_time_loop = function(time_loop){
      self$time_loop <- time_loop
    },

    #'@description
    #'Adds a r2ogs6_local_coordinate_system object
    #'@param local_coordinate_system r2ogs6_local_coordinate_system
    add_local_coordinate_system = function(local_coordinate_system){
      self$local_coordinate_system <- local_coordinate_system
    },

    #'@description
    #'Adds a r2ogs6_medium object
    #'@param medium r2ogs6_medium
    add_medium = function(medium){
      self$media <- c(self$media,
                      list(medium))
    },

    #'@description
    #'Adds a r2ogs6_parameter object
    #'@param parameter r2ogs6_parameter
    add_parameter = function(parameter){
      self$parameters <- c(self$parameters,
                       list(parameter))

      names(self$parameters)[[length(self$parameters)]] <- parameter$name
    },

    #'@description
    #'Adds a r2ogs6_curve object
    #'@param curve r2ogs6_curve
    add_curve = function(curve){
      self$curves <- c(self$curves,
                       list(curve))
    },

    #'@description
    #'Adds a r2ogs6_process_variable object
    #'@param process_variable r2ogs6_process_variable
    add_process_variable = function(process_variable){
      self$process_variables <- c(self$process_variables,
                                  list(process_variable))

      names(self$process_variables)[[length(self$process_variables)]] <-
        process_variable$name
    },

    #'@description
    #'Adds a r2ogs6_nonlinear_solver object
    #'@param nonlinear_solver r2ogs6_nonlinear_solver
    add_nonlinear_solver = function(nonlinear_solver){
      self$nonlinear_solvers <- c(self$nonlinear_solvers,
                                  list(nonlinear_solver))

      names(self$nonlinear_solvers)[[length(self$nonlinear_solvers)]] <-
        nonlinear_solver$name
    },

    #'@description
    #'Adds a r2ogs6_linear_solver object
    #'@param linear_solver r2ogs6_linear_solver
    add_linear_solver = function(linear_solver){
      self$linear_solvers <- c(self$linear_solvers,
                               list(linear_solver))

      names(self$linear_solvers)[[length(self$linear_solvers)]] <-
        linear_solver$name
    },

    #'@description
    #'Adds a r2ogs6_vtkdiff object
    #'@param vtkdiff r2ogs6_vtkdiff
    add_vtkdiff = function(vtkdiff){
      self$test_definition <- c(self$test_definition, list(vtkdiff))
    },

    #'@description
    #'Adds a r2ogs6_insitu object
    #'@param insitu r2ogs6_insitu
    add_insitu = function(insitu){
      self$insitu <- insitu
    },


    #===== UTILITY FUNCTIONS =====


    #'@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
      impl_classes <- get_implemented_classes()

      status_strs <- character()

      for(i in seq_len(length(impl_classes))){
        status_call <- paste0("get_obj_status(flag, private$.",
                              names(impl_classes)[[i]], ")")

        status <- eval(parse(text = status_call))
        flag <- status[[1]]
        status_strs <- c(status_strs, status[[2]])
      }

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

      if(print_status){

        cat(status_str)

        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(get_implemented_classes()) for the available options.
    clear = function(which = names(get_implemented_classes())){

      assertthat::assert_that(is.character(which))

      valid_input = names(get_implemented_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
      #'Access to private parameter '.sim_name'
      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
      #'Getter for OGS6 private parameter '.sim_id'
      sim_id = function() {
        private$.sim_id
      },

      #'@field sim_path
      #'Access to private parameter '.sim_path'
      sim_path = function(value) {
        if(missing(value)) {
          private$.sim_path
        }else{
          private$.sim_path <- validate_is_dir_path(value)
        }
      },

      #'@field logfile
      #'Access to private parameter '.logfile'
      logfile = function(value) {
        if(missing(value)) {
          private$.logfile
        }else{
          assertthat::assert_that(assertthat::is.string(value))
          private$.logfile <- value
        }
      },

      #'@field ogs_bin_path
      #'Getter for OGS6 private parameter '.ogs_bin_path'
      ogs_bin_path = function() {
        private$.ogs_bin_path
      },

      #'@field gml
      #'Getter for OGS6 private parameter '.gml'
      gml = function() {
        private$.gml
      },

      #'@field geometry
      #'Access to private parameter '.geometry'
      geometry = function(value) {
        if(missing(value)) {
          private$.geometry
        }else{
          assertthat::assert_that(is.string(value))
          private$.geometry <- value
        }
      },

      #'@field meshes
      #'Access to private parameter '.meshes'
      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
      #'Access to private parameter '.vtus'
      vtus = function(value) {
        if(missing(value)) {
          private$.vtus
        }else{
          validate_wrapper_list(value,
                                get_implemented_classes()[["vtus"]])
          private$.vtus <- value
        }
      },

      #'@field python_script
      #'Access to private parameter '.python_script'
      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
      #'Access to private parameter '.search_length_algorithm'
      search_length_algorithm = function(value) {
        if(missing(value)) {
          private$.search_length_algorithm
        }else{
          assertthat::assert_that(
            get_implemented_classes()[["search_length_algorithm"]] %in%
              class(value))
          private$.search_length_algorithm <- value
        }
      },

      #'@field processes
      #'Access to private parameter '.processes'
      processes = function(value) {
        if(missing(value)) {
          private$.processes
        }else{
          validate_wrapper_list(value,
                                get_implemented_classes()[["processes"]])
          private$.processes <- value
        }
      },

      #'@field time_loop
      #'Access to private parameter '.time_loop'
      time_loop = function(value) {
        if(missing(value)) {
          private$.time_loop
        }else{
          assertthat::assert_that(
            get_implemented_classes()[["time_loop"]] %in%
              class(value))
          private$.time_loop <- value
        }
      },

      #'@field local_coordinate_system
      #'Access to private parameter '.local_coordinate_system'
      local_coordinate_system = function(value) {
        if(missing(value)) {
          private$.local_coordinate_system
        }else{
          assertthat::assert_that(
            get_implemented_classes()[["local_coordinate_system"]] %in%
              class(value))
          private$.local_coordinate_system <- value
        }
      },

      #'@field media
      #'Access to private parameter '.media'
      media = function(value) {
        if(missing(value)) {
          private$.media
        }else{
          validate_wrapper_list(value,
                                get_implemented_classes()[["media"]])
          private$.media <- value
        }
      },

      #'@field parameters
      #'Access to private parameter '.parameters'
      parameters = function(value) {
        if(missing(value)) {
          private$.parameters
        }else{
          validate_wrapper_list(value,
                                get_implemented_classes()[["parameters"]])
          private$.parameters <- value
        }
      },

      #'@field curves
      #'Access to private parameter '.curves'
      curves = function(value) {
        if(missing(value)) {
          private$.curves
        }else{
          validate_wrapper_list(value,
                                get_implemented_classes()[["curves"]])
          private$.curves <- value
        }
      },

      #'@field process_variables
      #'Access to private parameter '.process_variables'
      process_variables = function(value) {
        if(missing(value)) {
          private$.process_variables
        }else{
          validate_wrapper_list(
            value,
            get_implemented_classes()[["process_variables"]])
          private$.process_variables <- value
        }
      },

      #'@field nonlinear_solvers
      #'Access to private parameter '.nonlinear_solvers'
      nonlinear_solvers = function(value) {
        if(missing(value)) {
          private$.nonlinear_solvers
        }else{
          validate_wrapper_list(
            value,
            get_implemented_classes()[["nonlinear_solvers"]])
          private$.nonlinear_solvers <- value
        }
      },

      #'@field linear_solvers
      #'Access to private parameter '.linear_solvers'
      linear_solvers = function(value) {
        if(missing(value)) {
          private$.linear_solvers
        }else{
          validate_wrapper_list(value,
                                get_implemented_classes()[["linear_solvers"]])
          private$.linear_solvers <- value
        }
      },

      #'@field test_definition
      #'Access to private parameter '.test_definition'
      test_definition = function(value) {
        if(missing(value)) {
          private$.test_definition
        }else{
          validate_wrapper_list(value,
                                get_implemented_classes()[["test_definition"]])
          private$.test_definition <- value
        }
      },

      #'@field insitu
      #'Access to private parameter '.insitu'
      insitu = function(value) {
        if(missing(value)) {
          private$.insitu
        }else{
          assertthat::assert_that(
            get_implemented_classes()[["insitu"]] %in%
              class(value))
          private$.insitu <- value
        }
      }
  ),

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

      .logfile = NULL,

      #.gml parameters
      .gml = NULL,

      #.vtu parameters
      .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(),
      .curves = list(),
      .process_variables = list(),
      .nonlinear_solvers = list(),
      .linear_solvers = list(),
      .test_definition = list(),
      .insitu = NULL
  )
)