R/Simulation_Project.R

Defines functions move_output_to_dbOutput simulate_SOILWAT2_experiment quickprepare_dbOutput_dbWork update_todos update_actions check_rSFSW2_project_input_data populate_rSFSW2_project_with_data gather_project_inputs init_rSFSW2_project update_project_paths load_project_description is_project_script_file_recent setup_rSFSW2_project_infrastructure

Documented in check_rSFSW2_project_input_data init_rSFSW2_project is_project_script_file_recent load_project_description move_output_to_dbOutput populate_rSFSW2_project_with_data quickprepare_dbOutput_dbWork setup_rSFSW2_project_infrastructure simulate_SOILWAT2_experiment update_actions update_todos

#' Setup infrastructure (skeleton) for a new \pkg{rSFSW2} simulation experiment
#'
#' @param dir_prj A character string. The path to the new simulation project.
#'  Folders are recursively created if not already existing.
#' @param verbose A logical value.
#' @param print.debug A logical value.
#' @return Invisibly \code{dir_prj} on success
#'
#' @section Note: this function uses the \code{definf} object that is stored
#'   in \file{R/sysdata.rda} and which is generated by package developers with
#'   the script \file{data-raw/prepare_default_project_infrastructure.R}.
#' @export
setup_rSFSW2_project_infrastructure <- function(dir_prj, verbose = TRUE,
  print.debug = FALSE) {

  masterinput_pattern <- "_InputMaster_"
  masterinput_pattern_demo <- "_InputMaster_YOURPROJECT_"

  if (verbose || print.debug) {
    t1 <- Sys.time()
    temp_call <- shQuote(match.call()[1])
    print(paste0("rSFSW2's ", temp_call, ": started at ", t1))
    print(paste("A new rSFSW2 project is prepared for:",
      sQuote(basename(dir_prj))))

    on.exit({
      print(paste0("rSFSW2's ", temp_call, ": ended after ",
      round(difftime(Sys.time(), t1, units = "secs"), 2), " s"))
      cat("\n")}, add = TRUE)
  }

  dir_safe_create(dir_prj, showWarnings = print.debug)

  if (exists("definf") && length(definf) == 0)
    stop("No default project infrastructure object located; the installation ",
      "of the package 'rSFSW2' may be faulty.")

  fes <- NULL

  for (di in definf) {
    dtemp <- file.path(dir_prj, di[["path"]])

    if (!dir.exists(dtemp))
       dir_safe_create(dtemp, showWarnings = print.debug)

    ftemp <- file.path(dtemp, di[["fname"]])

    if (file.exists(ftemp)) {
      fes <- c(fes, ftemp)

    } else {
      if (grepl(masterinput_pattern, di[["fname"]])) {
        # Simulation projects usually rename the input master file: check if
        #   present and if any contain sufficient content
        fim <- list.files(dtemp, pattern = masterinput_pattern)
        fim <- grep(masterinput_pattern_demo, fim, value = TRUE, invert = TRUE)
        fim_ok <- FALSE
        for (kfim in fim) {
          fim_fields <- utils::read.csv(file.path(dtemp, kfim), nrows = 1)
          fim_ok <- fim_ok || all(sapply(req_fields_SWRunInformation(),
            function(x) x %in% names(fim_fields)))
        }

        if (fim_ok) {
          if (verbose || print.debug) {
            print(paste("'setup_rSFSW2_project_infrastructure' does not",
              "replace the existing input master file", paste(shQuote(fim),
                collapse = "/"), "with default version of file."))
          }

          next
        }
      }

      writeLines(memDecompress(di[["data"]], type = "gzip", asChar = TRUE),
        con = file.path(dtemp, di[["fname"]]))
    }
  }

  if (!is.null(fes) && (verbose || print.debug)) {
    fes <- gsub(paste0(dir_prj, "/"), "", fes, fixed = TRUE)
    print(paste("File(s)", paste(shQuote(fes), collapse = ", "),
      "already existed in project", shQuote(basename(dir_prj)),
      "; they were not replaced by default files."))
  }

  if (verbose || print.debug) {
    print(paste("The new rSFSW2 project was successfully prepared at:",
      sQuote(dir_prj)))
  }

  # Copy demo scripts
  temp <- system.file("demo", package = "rSFSW2")

  ftemps <- list.files(temp, pattern = ".R", full.names = TRUE)
  if (length(ftemps) == 0)
    stop("No folder 'demo' found in package; the installation of the package ",
      "'rSFSW2' may be faulty.")

  for (f in ftemps)
    file.copy(from = f, to = file.path(dir_prj, basename(f)), overwrite = FALSE)

  invisible(dir_prj)
}


#' Compare elements and 1-st level structure of project script file with
#' installed \pkg{rSFSW2}-package version
#'
#' @param dir_prj A character string. Path the simulation project folder.
#' @param script A character string. Name of the script file to compare.
#' @param ... Passed to \code{\link{load_project_description}} to pre-fill
#'   new environment.
#' @return A logical value.
#'
#' @examples
#' \dontrun{
#' if (exists("SFSW2_prj_meta")) {
#'   is_project_script_file_recent(
#'     dir_prj = SFSW2_prj_meta[["project_paths"]][["dir_prj"]])
#' }}
is_project_script_file_recent <- function(dir_prj,
  script = "SFSW2_project_descriptions.R", ...) {

  is_recent <- TRUE

  # Location of demo scripts of the installed package
  dir_demo <- system.file("demo", package = "rSFSW2")

  # Load from installed package
  installed <- load_project_description(file.path(dir_demo, script), ...)

  # Load from project folder
  has <- load_project_description(file.path(dir_prj, script), ...)

  # Compare elements and 1st-level structure
  installed_names <- names(installed)

  is_recent <- is_recent && all(installed_names %in% names(has))

  for (k in installed_names) {
    xnames <- names(installed[[k]])
    is_recent <- is_recent && all(xnames %in% names(has[[k]]))
  }

  is_recent
}


#' Load a project description script
#' @return An environment containing the named objects generated by the script
load_project_description <- function(fmetar, ...) {
  dots <- list(...)

  # Prepare new environmenet
  meta <- if (length(dots) > 0) {
      list2env(dots, parent = baseenv())
    } else {
      new.env(parent = baseenv())
    }

  # Source file into environment
  sys.source(fmetar, envir = meta, keep.source = FALSE)

  # Delete objects from environemnt which were used to create initial input
  suppressWarnings(rm(list = c("d", "dir_big", "dir_ex", "dir_in", "dir_out",
    "dir_prj", "endyr", "scorp", "startyr", "temp"), envir = meta))

  meta
}

#' @section Note: Currently, this function only updates paths that exist
#'   both in \code{SFSW2_prj_meta} and in the file \file{fmetar} on disk.
#'   This function does not update other elements.
update_project_paths <- function(SFSW2_prj_meta, fmetar) {
  SFSW2_prj_meta2 <- load_project_description(fmetar)

  #--- Update paths of 'project_paths'
  xnames <- names(SFSW2_prj_meta[["project_paths"]])
  names_shared <- intersect(xnames, names(SFSW2_prj_meta2[["project_paths"]]))

  for (k in names_shared) {
    SFSW2_prj_meta[["project_paths"]][[k]] <-
      SFSW2_prj_meta2[["project_paths"]][[k]]
  }

  #--- Update paths of 'fnames_in'
  xnames <- names(SFSW2_prj_meta[["fnames_in"]])
  names_shared <- intersect(xnames, names(SFSW2_prj_meta2[["fnames_in"]]))

  for (k in names_shared) {
    SFSW2_prj_meta[["fnames_in"]][[k]] <- SFSW2_prj_meta2[["fnames_in"]][[k]]
  }

  #--- Update paths of 'fnames_out'
  xnames <- names(SFSW2_prj_meta[["fnames_out"]])
  names_shared <- intersect(xnames, names(SFSW2_prj_meta2[["fnames_out"]]))

  for (k in names_shared) {
    SFSW2_prj_meta[["fnames_out"]][[k]] <- SFSW2_prj_meta2[["fnames_out"]][[k]]
  }


  #--- Update platform
  xnames <- names(SFSW2_prj_meta[["opt_platform"]])
  names_shared <- intersect(xnames, names(SFSW2_prj_meta2[["opt_platform"]]))

  for (k in names_shared) {
    SFSW2_prj_meta[["opt_platform"]][[k]] <-
      SFSW2_prj_meta2[["opt_platform"]][[k]]
  }



  SFSW2_prj_meta
}


#' Initialize a \pkg{rSFSW2} project (setup description file)
#'
#' This function creates/loads an object \code{SFSW2_prj_meta} based on the file
#' \code{fmetar} containing the descriptions/metadata for this simulation
#' project. The file should be comparable to \code{file.path(system.file("demo",
#' package = "rSFSW2"), "SFSW2_project_descriptions.R")}
#'
#' @param fmetar A character string. The path name to the project description
#'   file.
#' @param update A logical value. If \code{TRUE}, the path names are re-scanned
#'   from \code{fmetar} and updated values are stored in \code{SFSW2_prj_meta}.
#' @param verbose A logical value.
#' @param print.debug A logical value.
#'
#' @return The object \code{SFSW2_prj_meta} of type environment.
#'
#' @export
init_rSFSW2_project <- function(fmetar, update = FALSE, verbose = TRUE,
  print.debug = FALSE) {

  if (verbose) {
    t1 <- Sys.time()
    temp_call <- shQuote(match.call()[1])
    print(paste0("rSFSW2's ", temp_call, ": started at ", t1))

    on.exit({
      print(paste0("rSFSW2's ", temp_call, ": ended after ",
      round(difftime(Sys.time(), t1, units = "secs"), 2), " s"))
      cat("\n")}, add = TRUE)
  }

  if (is.character(fmetar) && endsWith(toupper(fmetar), ".R")) {
    fmeta <- paste0(substr(fmetar, 1, nchar(fmetar) - 1), "rds")

  } else {
    stop("Argument 'fmetar' must represent the path to a file of ",
      "type/extension 'R'")
  }

  if (file.exists(fmeta)) {
    #--- Load (and possible update) existing 'SFSW2_prj_meta'

    # Load pre-prepared project description if it was setup previously
    SFSW2_prj_meta <- readRDS(fmeta)

    # Update
    if (update) {
      SFSW2_prj_meta <- update_project_paths(SFSW2_prj_meta, fmetar)
      SFSW2_prj_meta[["fnames_in"]][["fmeta"]] <- fmeta
      SFSW2_prj_meta[["fnames_in"]] <- complete_with_defaultpaths(
        SFSW2_prj_meta[["project_paths"]], SFSW2_prj_meta[["fnames_in"]])
    }

    # Ensure that all necessary paths do exists
    dir_safe_create(SFSW2_prj_meta[["project_paths"]],
      showWarnings = print.debug)


  } else {
    #--- Create 'SFSW2_prj_meta'

    # 1a) Setup default project infrastructure
    setup_rSFSW2_project_infrastructure(dirname(fmetar), verbose = verbose,
      print.debug = print.debug)

    # 1b) In text editor: specify project description/metadata
    #  ("SFSW2_project_description.R")
    if (verbose || print.debug) {
      warning("Check/adjust project description/metadata in file ",
        shQuote(basename(fmetar)), " before further steps are executed.",
        call. = FALSE, immediate. = TRUE)
    }

    # 1c) Load and prepare project description
    SFSW2_prj_meta <- load_project_description(fmetar)

    #--- Update project paths and file names
    dir_safe_create(SFSW2_prj_meta[["project_paths"]],
      showWarnings = print.debug)

    SFSW2_prj_meta[["fnames_in"]][["fmeta"]] <- fmeta
    SFSW2_prj_meta[["fnames_in"]] <- complete_with_defaultpaths(
      SFSW2_prj_meta[["project_paths"]], SFSW2_prj_meta[["fnames_in"]])

    init_timer(SFSW2_prj_meta[["fnames_out"]][["timerfile"]])

    #--- Update simulation time
    is_idem <- isTRUE(SFSW2_prj_meta[["req_scens"]][["method_DS"]] == "idem")

    SFSW2_prj_meta[["sim_time"]] <- setup_time_simulation_project(
      sim_time = SFSW2_prj_meta[["sim_time"]],
      is_idem = is_idem,
      add_st2 = TRUE,
      adjust_NS = SFSW2_prj_meta[["opt_agg"]][["adjust_NorthSouth"]],
      use_doy_range = SFSW2_prj_meta[["opt_agg"]][["use_doy_range"]],
      doy_ranges = SFSW2_prj_meta[["opt_agg"]][["doy_ranges"]]
    )

    #--- Determine scenario names
    SFSW2_prj_meta[["sim_scens"]] <- setup_scenarios(
      sim_scens = SFSW2_prj_meta[["req_scens"]],
      is_idem = is_idem,
      sim_time = SFSW2_prj_meta[["sim_time"]]
    )

    #--- Determine requested ensembles across climate scenarios
    SFSW2_prj_meta <- update_scenarios_with_ensembles(SFSW2_prj_meta)

    #--- Prior calculations
    SFSW2_prj_meta[["pcalcs"]] <- convert_to_todo_list(
      SFSW2_prj_meta[["opt_input"]][["prior_calculations"]])

    #--- External data extraction
    SFSW2_prj_meta[["exinfo"]] <- convert_to_todo_list(
      SFSW2_prj_meta[["opt_input"]][["req_data"]])

    #--- Matrix to track progress with input preparations
    SFSW2_prj_meta[["input_status"]] <- init_intracker()
  }

  save_to_rds_with_backup(SFSW2_prj_meta,
    file = SFSW2_prj_meta[["fnames_in"]][["fmeta"]])

  SFSW2_prj_meta
}




gather_project_inputs <- function(SFSW2_prj_meta, use_preprocin = TRUE,
  verbose = FALSE) {

  #--- Import data
  if (!exists("SFSW2_prj_inputs") || is.null(SFSW2_prj_inputs) ||
    todo_intracker(SFSW2_prj_meta, "load_inputs", "prepared")) {

    SFSW2_prj_inputs <- process_inputs(
      project_paths = SFSW2_prj_meta[["project_paths"]],
      fnames_in = SFSW2_prj_meta[["fnames_in"]],
      use_preprocin,
      verbose
    )

    #--- Update output aggregation options
    SFSW2_prj_meta[["opt_agg"]] <- setup_aggregation_options(
      SFSW2_prj_meta[["opt_agg"]],
      GISSM_species_No = SFSW2_prj_inputs[["GISSM_species_No"]],
      GISSM_params = SFSW2_prj_inputs[["GISSM_params"]])

    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]], tracker = "load_inputs",
      prepared = TRUE, checked = !SFSW2_prj_inputs[["do_check_include"]])

    save_to_rds_with_backup(SFSW2_prj_meta,
      file = SFSW2_prj_meta[["fnames_in"]][["fmeta"]])
  }

  # Make sure that input-tracker is updated correctly if inputs were
  # re-processed
  if (!todo_intracker(SFSW2_prj_meta, "table_lookup", "prepared") &&
    is.null(SFSW2_prj_inputs[["done_prior"]])) {

    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]], tracker = "table_lookup",
      prepared = FALSE)
  }


  if (all(stats::na.exclude(SFSW2_prj_meta[["input_status"]][, "prepared"])) &&
    exists("SFSW2_prj_inputs")) {
    # Return if all is prepared (from a previous run) and input object exists
    # and haven'tbeen changed since last time ('do_check_include' is FALSE)

    return(list(SFSW2_prj_meta = SFSW2_prj_meta,
      SFSW2_prj_inputs = SFSW2_prj_inputs))
  }


  #--- Determine size of simulation runs
  if (todo_intracker(SFSW2_prj_meta, "calc_size", "prepared")) {
    SFSW2_prj_meta[["sim_size"]] <- determine_simulation_size(
      SFSW2_prj_inputs[["SWRunInformation"]], SFSW2_prj_inputs[["include_YN"]],
      SFSW2_prj_inputs[["sw_input_experimentals"]],
      SFSW2_prj_meta[["sim_scens"]])

    SFSW2_prj_meta[["sim_time"]] <- get_simulation_time(
      st = SFSW2_prj_meta[["sim_time"]], SFSW2_prj_inputs)

    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]], tracker = "calc_size", prepared = TRUE,
      clean_subsequent = TRUE)
  }


  #--- Spatial setup of simulations
  if (todo_intracker(SFSW2_prj_meta, "spatial_setup", "prepared")) {
    # nolint start
    SFSW2_prj_meta[["use_sim_spatial"]] <-
      (todo_intracker(SFSW2_prj_meta, "soil_data", "prepared") &&
        (SFSW2_prj_meta[["exinfo"]][["ExtractSoilDataFromCONUSSOILFromSTATSGO_USA"]] ||
        SFSW2_prj_meta[["exinfo"]][["ExtractSoilDataFromISRICWISEv12_Global"]] ||
        SFSW2_prj_meta[["exinfo"]][["ExtractSoilDataFromISRICWISE30secV1a_Global"]])) ||
      (todo_intracker(SFSW2_prj_meta, "elev_data", "prepared") &&
        (SFSW2_prj_meta[["exinfo"]][["ExtractElevation_NED_USA"]] ||
        SFSW2_prj_meta[["exinfo"]][["ExtractElevation_HWSD_Global"]])) ||
      (todo_intracker(SFSW2_prj_meta, "climnorm_data", "prepared") &&
        (SFSW2_prj_meta[["exinfo"]][["ExtractSkyDataFromNOAAClimateAtlas_USA"]] ||
        SFSW2_prj_meta[["exinfo"]][["ExtractSkyDataFromNCEPCFSR_Global"]]))
    # nolint end

    SFSW2_prj_meta <- setup_spatial_simulation(SFSW2_prj_meta, SFSW2_prj_inputs,
      use_sim_spatial = SFSW2_prj_meta[["use_sim_spatial"]], verbose = verbose)

    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]], tracker = "spatial_setup",
      prepared = TRUE, clean_subsequent = TRUE)
  }


  #--- Determine todos for simulation project
  if (todo_intracker(SFSW2_prj_meta, "prj_todos", "prepared")) {
    if (is.null(SFSW2_prj_meta[["prj_todos"]])) {
      SFSW2_prj_meta[["prj_todos"]] <- list()
    }

    # nolint start
    SFSW2_prj_meta[["prj_todos"]][["EstimateConstantSoilTemperatureAtUpperAndLowerBoundaryAsMeanAnnualAirTemperature"]] <-
      SFSW2_prj_meta[["pcalcs"]][["EstimateConstantSoilTemperatureAtUpperAndLowerBoundaryAsMeanAnnualAirTemperature"]]
    SFSW2_prj_meta[["prj_todos"]][["EstimateInitialSoilTemperatureForEachSoilLayer"]] <-
      SFSW2_prj_meta[["pcalcs"]][["EstimateInitialSoilTemperatureForEachSoilLayer"]]
    # nolint end

    # output aggregate overall
    SFSW2_prj_meta[["prj_todos"]][["aon"]] <- convert_to_todo_list(
      SFSW2_prj_meta[["req_out"]][["overall_out"]])
    # output aggregate daily
    SFSW2_prj_meta[["prj_todos"]][["adaily"]] <- setup_meandaily_output(
      SFSW2_prj_meta[["req_out"]][["mean_daily"]], SFSW2_prj_meta[["opt_agg"]])
    # output daily traces
    SFSW2_prj_meta[["prj_todos"]][["otrace"]] <-
      SFSW2_prj_meta[["req_out"]][["traces"]]

    #--- Update todo list
    # nolint start
    SFSW2_prj_meta[["prj_todos"]][["need_cli_means"]] <-
      any(SFSW2_prj_inputs[["sw_input_climscen_values_use"]]) ||
      SFSW2_prj_meta[["prj_todos"]][["EstimateConstantSoilTemperatureAtUpperAndLowerBoundaryAsMeanAnnualAirTemperature"]] ||
      SFSW2_prj_inputs[["sw_input_site_use"]]["SoilTempC_atLowerBoundary"] ||
      SFSW2_prj_inputs[["sw_input_site_use"]]["SoilTempC_atUpperBoundary"] ||
      SFSW2_prj_meta[["prj_todos"]][["EstimateInitialSoilTemperatureForEachSoilLayer"]] ||
      any(SFSW2_prj_inputs[["create_treatments"]] == "PotentialNaturalVegetation_CompositionShrubsC3C4_Paruelo1996") ||
      any(SFSW2_prj_inputs[["create_treatments"]] == "AdjMonthlyBioMass_Temperature") ||
      any(SFSW2_prj_inputs[["create_treatments"]] == "AdjMonthlyBioMass_Precipitation") ||
      any(SFSW2_prj_inputs[["create_treatments"]] == "Vegetation_Biomass_ScalingSeason_AllGrowingORNongrowing")
    # nolint end

    # Update todos for simulation project
    SFSW2_prj_meta <- update_todos(SFSW2_prj_meta)

    # Check that all 'prj_todos' are TRUE or FALSE except exceptions 'adaily'
    # and 'otrace'
    itemp <- names(SFSW2_prj_meta[["prj_todos"]])
    itemp <- itemp[!(itemp %in% c("adaily", "otrace"))]
    temp <- unlist(SFSW2_prj_meta[["prj_todos"]][itemp])
    ibad <- sapply(temp, function(x)
      !identical(x, TRUE) && !identical(x, FALSE))
    if (any(ibad)) {
      stop("elements of 'prj_todos' should not be 'NULL': ",
      paste(shQuote(names(temp)[ibad]), collapse = ", "))
    }

    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]], tracker = "prj_todos", prepared = TRUE)
  }

  list(SFSW2_prj_meta = SFSW2_prj_meta, SFSW2_prj_inputs = SFSW2_prj_inputs)
}


#' Populate \pkg{rSFSW2} project with input data
#' @export
populate_rSFSW2_project_with_data <- function(SFSW2_prj_meta, opt_behave,
  opt_parallel, opt_chunks, opt_out_run, opt_verbosity) {

  if (opt_verbosity[["verbose"]]) {
    t1 <- Sys.time()
    temp_call <- shQuote(match.call()[1])
    print(paste0("rSFSW2's ", temp_call, ": started at ", t1))

    on.exit(
      {
        print(paste0(
          "rSFSW2's ", temp_call, ": ended after ",
          round(difftime(Sys.time(), t1, units = "secs"), 2), " s with ",
          "input tracker status:"
        ))
        print(SFSW2_prj_meta[["input_status"]])
      },
      add = TRUE
    )
  }


  #------ PROJECT INPUTS
  temp <- gather_project_inputs(
    SFSW2_prj_meta,
    use_preprocin = opt_behave[["use_preprocin"]],
    verbose = opt_verbosity[["verbose"]]
  )
  SFSW2_prj_meta <- temp[["SFSW2_prj_meta"]]
  SFSW2_prj_inputs <- temp[["SFSW2_prj_inputs"]]

  # Check that dbWork is available and has up-to-date structure of tables/fields
  SFSW2_prj_meta[["input_status"]] <- update_intracker(
    SFSW2_prj_meta[["input_status"]],
    tracker = "dbWork",
    prepared =
      dbWork_check_design(SFSW2_prj_meta[["project_paths"]][["dir_out"]])
  )

  # Check that dbOut is available
  SFSW2_prj_meta[["input_status"]] <- update_intracker(
    SFSW2_prj_meta[["input_status"]],
    tracker = "dbOut",
    prepared = file.exists(SFSW2_prj_meta[["fnames_out"]][["dbOutput"]])
  )


  #------ Return if all is prepared (from a previous run), input tracker design
  # is up-to-date, and input object exists and haven't been changed since last
  # time
  if (
    all(stats::na.exclude(SFSW2_prj_meta[["input_status"]][, "prepared"])) &&
    check_intracker_design(SFSW2_prj_meta[["input_status"]]) &&
    exists("SFSW2_prj_inputs")
  ) {

    return(list(
      SFSW2_prj_meta = SFSW2_prj_meta,
      SFSW2_prj_inputs = SFSW2_prj_inputs
    ))
  }


  #------ Data preparation steps required
  # From here on: objects 'SFSW2_prj_meta' and 'SFSW2_prj_inputs' will be
  # manipulated, i.e., save them to disk upon exiting function (by error to
  # save intermediate state) or by final 'return'
  on.exit(
    save_to_rds_with_backup(
      SFSW2_prj_meta,
      file = SFSW2_prj_meta[["fnames_in"]][["fmeta"]]
    ),
    add = TRUE
  )
  on.exit(
    save_to_rds_with_backup(
      SFSW2_prj_inputs,
      file = SFSW2_prj_meta[["fnames_in"]][["fpreprocin"]]
    ),
    add = TRUE
  )


  #--- Setup random number generator streams for each runsN_master
  # Note: runsN_master: each site = row of master and not for runsN_total
  # because same site but under different experimental treatments should have
  # same random numbers

  if (todo_intracker(SFSW2_prj_meta, "rng_setup", "prepared")) {

    SFSW2_prj_meta[["rng_specs"]] <- setup_RNG(
      streams_N = SFSW2_prj_meta[["sim_size"]][["runsN_master"]],
      global_seed = SFSW2_prj_meta[["opt_sim"]][["global_seed"]],
      reproducible = SFSW2_prj_meta[["opt_sim"]][["reproducible"]]
    )

    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]],
      tracker = "rng_setup",
      prepared = TRUE
    )

    save_to_rds_with_backup(
      SFSW2_prj_meta,
      SFSW2_prj_meta[["fnames_in"]][["fmeta"]]
    )
  }



  #------ EXTERNAL INPUTS
  #------ DAILY WEATHER
  if (todo_intracker(SFSW2_prj_meta, "dbW_paths", "prepared")) {
    SFSW2_prj_meta <- set_paths_to_dailyweather_datasources(SFSW2_prj_meta)

    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]],
      tracker = "dbW_paths",
      prepared = TRUE
    )
  }


  #--- Determine sources of daily weather
  if (todo_intracker(SFSW2_prj_meta, "dbW_sources", "prepared")) {

    temp1 <-
      SFSW2_prj_meta[["opt_input"]][["how_determine_sources"]] ==
      "SWRunInformation"
    temp2 <-
      "dailyweather_source" %in%
      colnames(SFSW2_prj_inputs[["SWRunInformation"]])

    if (temp1 && temp2) {
      dw_source <- factor(
        SFSW2_prj_inputs[["SWRunInformation"]][
        SFSW2_prj_meta[["sim_size"]][["runIDs_sites"]], "dailyweather_source"],
        levels = SFSW2_prj_meta[["opt_input"]][["dw_source_priority"]]
      )
      do_weather_source <- anyNA(dw_source)

    } else {
      dw_source <- factor(
        rep(NA, SFSW2_prj_meta[["sim_size"]][["runsN_sites"]]),
        levels = SFSW2_prj_meta[["opt_input"]][["dw_source_priority"]]
      )
      do_weather_source <- TRUE
    }

    if (do_weather_source) {
      SFSW2_prj_inputs[["SWRunInformation"]] <- dw_determine_sources(
        dw_source = dw_source,
        exinfo = SFSW2_prj_meta[["exinfo"]],
        dw_avail_sources =
          SFSW2_prj_meta[["opt_input"]][["dw_source_priority"]],
        SFSW2_prj_inputs = SFSW2_prj_inputs,
        SWRunInformation = SFSW2_prj_inputs[["SWRunInformation"]],
        sim_size = SFSW2_prj_meta[["sim_size"]],
        sim_time = SFSW2_prj_meta[["sim_time"]],
        fnames_in = SFSW2_prj_meta[["fnames_in"]],
        project_paths = SFSW2_prj_meta[["project_paths"]],
        verbose = opt_verbosity[["verbose"]]
      )

      SFSW2_prj_meta[["input_status"]] <- update_intracker(
        SFSW2_prj_meta[["input_status"]],
        tracker = "load_inputs",
        prepared = TRUE,
        checked = FALSE
      )
    }

    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]],
      tracker = "dbW_sources",
      prepared = TRUE,
      clean_subsequent = TRUE
    )

    save_to_rds_with_backup(
      SFSW2_prj_meta,
      SFSW2_prj_meta[["fnames_in"]][["fmeta"]]
    )
  }


  #--- Create weather database and populate with weather for current conditions
  if (todo_intracker(SFSW2_prj_meta, "dbW_current", "prepared")) {

    if (SFSW2_prj_meta[["exinfo"]][["ExtractClimateChangeScenarios"]]) {
      SFSW2_prj_meta[["opt_sim"]][["use_dbW_future"]] <- TRUE
      SFSW2_prj_meta[["opt_sim"]][["use_dbW_current"]] <- TRUE
    }

    if (SFSW2_prj_meta[["opt_sim"]][["use_dbW_future"]]) {
      SFSW2_prj_meta[["opt_sim"]][["use_dbW_current"]] <- TRUE
    }

    if (SFSW2_prj_meta[["opt_sim"]][["use_dbW_current"]]) {
      # Call to `update_runIDs_sites_by_dbW` does nothing if `dbWeather` does
      # not exist (first run) and updates information if called repeatedly
      SFSW2_prj_meta[["sim_size"]] <- update_runIDs_sites_by_dbW(
        sim_size = SFSW2_prj_meta[["sim_size"]],
        label_WeatherData =
          SFSW2_prj_inputs[["SWRunInformation"]][, "WeatherFolder"],
        fdbWeather = SFSW2_prj_meta[["fnames_in"]][["fdbWeather"]],
        verbose = opt_verbosity[["verbose"]]
      )

      make_dbW(
        SFSW2_prj_meta,
        SWRunInformation = SFSW2_prj_inputs[["SWRunInformation"]],
        opt_parallel, opt_chunks, opt_behave,
        deleteTmpSQLFiles = opt_out_run[["deleteTmpSQLFiles"]],
        verbose = opt_verbosity[["verbose"]],
        print.debug = opt_verbosity[["print.debug"]]
      )

      SFSW2_prj_meta[["input_status"]] <- update_intracker(
        SFSW2_prj_meta[["input_status"]],
        tracker = "dbW_current",
        prepared = TRUE,
        clean_subsequent = TRUE
      )

      save_to_rds_with_backup(
        SFSW2_prj_meta,
        SFSW2_prj_meta[["fnames_in"]][["fmeta"]]
      )

    } else {
      SFSW2_prj_meta[["input_status"]] <- update_intracker(
        SFSW2_prj_meta[["input_status"]],
        tracker = "dbW_current",
        prepared = NA,
        checked = NA
      )
    }
  }


  #------ DATA EXTRACTIONS
  #--- Soil data
  # nolint start
  if (
    SFSW2_prj_meta[["exinfo"]][["ExtractSoilDataFromCONUSSOILFromSTATSGO_USA"]] ||
    SFSW2_prj_meta[["exinfo"]][["ExtractSoilDataFromISRICWISEv12_Global"]] ||
    SFSW2_prj_meta[["exinfo"]][["ExtractSoilDataFromISRICWISE30secV1a_Global"]]
  ) {
  # nolint end

    if (todo_intracker(SFSW2_prj_meta, "soil_data", "prepared")) {

      SFSW2_prj_inputs <- ExtractData_Soils(
        SFSW2_prj_meta[["exinfo"]],
        SFSW2_prj_meta, SFSW2_prj_inputs, opt_parallel,
        resume = opt_behave[["resume"]],
        verbose = opt_verbosity[["verbose"]]
      )

      SFSW2_prj_meta[["input_status"]] <- update_intracker(
        SFSW2_prj_meta[["input_status"]],
        tracker = "soil_data",
        prepared = TRUE
      )

      save_to_rds_with_backup(
        SFSW2_prj_meta,
        SFSW2_prj_meta[["fnames_in"]][["fmeta"]]
      )
    }

  } else {
    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]],
      tracker = "soil_data",
      prepared = NA,
      checked = NA
    )
  }


  #--- Mean monthly climate data
  if (
    SFSW2_prj_meta[["exinfo"]][["ExtractSkyDataFromNOAAClimateAtlas_USA"]] ||
    SFSW2_prj_meta[["exinfo"]][["ExtractSkyDataFromNCEPCFSR_Global"]]
  ) {

    if (todo_intracker(SFSW2_prj_meta, "climnorm_data", "prepared")) {

      SFSW2_prj_inputs <- ExtractData_MeanMonthlyClimate(
        SFSW2_prj_meta[["exinfo"]],
        SFSW2_prj_meta, SFSW2_prj_inputs,
        opt_parallel, opt_chunks,
        resume = opt_behave[["resume"]],
        verbose = opt_verbosity[["verbose"]]
      )

      SFSW2_prj_meta[["input_status"]] <- update_intracker(
        SFSW2_prj_meta[["input_status"]],
        tracker = "climnorm_data",
        prepared = TRUE
      )

      save_to_rds_with_backup(
        SFSW2_prj_meta,
        SFSW2_prj_meta[["fnames_in"]][["fmeta"]]
      )
    }

  } else {
    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]],
      tracker = "climnorm_data",
      prepared = NA,
      checked = NA
    )
  }


  #--- Topographic data
  if (
    SFSW2_prj_meta[["exinfo"]][["ExtractElevation_NED_USA"]] ||
    SFSW2_prj_meta[["exinfo"]][["ExtractElevation_HWSD_Global"]]
  ) {

    if (todo_intracker(SFSW2_prj_meta, "elev_data", "prepared")) {

      SFSW2_prj_inputs <- ExtractData_Elevation(
        exinfo = SFSW2_prj_meta[["exinfo"]],
        SFSW2_prj_meta,
        SFSW2_prj_inputs,
        resume = opt_behave[["resume"]],
        verbose = opt_verbosity[["verbose"]]
      )

      SFSW2_prj_meta[["input_status"]] <- update_intracker(
        SFSW2_prj_meta[["input_status"]],
        tracker = "elev_data",
        prepared = TRUE
      )

      save_to_rds_with_backup(
        SFSW2_prj_meta,
        SFSW2_prj_meta[["fnames_in"]][["fmeta"]]
      )
    }

  } else {
    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]],
      tracker = "elev_data",
      prepared = NA,
      checked = NA
    )
  }


  #--- Climate scenarios and downscaling
  if (SFSW2_prj_meta[["exinfo"]][["ExtractClimateChangeScenarios"]]) {

    if (todo_intracker(SFSW2_prj_meta, "dbW_scenarios", "prepared")) {
      SFSW2_prj_meta[["sim_size"]] <- update_runIDs_sites_by_dbW(
        sim_size = SFSW2_prj_meta[["sim_size"]],
        label_WeatherData =
          SFSW2_prj_inputs[["SWRunInformation"]][, "WeatherFolder"],
        fdbWeather = SFSW2_prj_meta[["fnames_in"]][["fdbWeather"]],
        verbose = opt_verbosity[["verbose"]]
      )

      temp <- PrepareClimateScenarios(
        SFSW2_prj_meta,
        SFSW2_prj_inputs,
        opt_parallel,
        resume = opt_behave[["resume"]],
        opt_verbosity,
        opt_chunks
      )

      SFSW2_prj_inputs <- temp[["SFSW2_prj_inputs"]]

      # SFSW2_prj_meta is updated with random streams for downscaling
      SFSW2_prj_meta <- temp[["SFSW2_prj_meta"]]

      SFSW2_prj_meta[["input_status"]] <- update_intracker(
        SFSW2_prj_meta[["input_status"]], tracker = "dbW_scenarios",
        prepared = TRUE)

      save_to_rds_with_backup(
        SFSW2_prj_meta,
        SFSW2_prj_meta[["fnames_in"]][["fmeta"]]
      )
    }

  } else {
    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]],
      tracker = "dbW_scenarios",
      prepared = NA,
      checked = NA
    )
  }



  #------ CALCULATIONS PRIOR TO SIMULATION RUNS

  if (any(unlist(SFSW2_prj_meta[["pcalcs"]])))
    # if not all, then runIDs_sites
    runIDs_adjust <- seq_len(SFSW2_prj_meta[["sim_size"]][["runsN_master"]])

  if (SFSW2_prj_meta[["pcalcs"]][["AddRequestedSoilLayers"]]) {
    if (todo_intracker(SFSW2_prj_meta, "req_soillayers", "prepared")) {

      temp <- calc_RequestedSoilLayers(
        SFSW2_prj_meta,
        SFSW2_prj_inputs,
        runIDs_adjust,
        keep_old_depth = SFSW2_prj_meta[["opt_input"]][["keep_old_depth"]],
        verbose = opt_verbosity[["verbose"]]
      )

      SFSW2_prj_meta <- temp[["SFSW2_prj_meta"]]
      SFSW2_prj_inputs <- temp[["SFSW2_prj_inputs"]]

      SFSW2_prj_meta[["input_status"]] <- update_intracker(
        SFSW2_prj_meta[["input_status"]],
        tracker = "req_soillayers",
        prepared = TRUE
      )

      save_to_rds_with_backup(
        SFSW2_prj_meta,
        SFSW2_prj_meta[["fnames_in"]][["fmeta"]]
      )
    }

  } else {
    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]],
      tracker = "req_soillayers",
      prepared = NA,
      checked = NA
    )
  }


  if (SFSW2_prj_meta[["pcalcs"]][["CalculateBareSoilEvaporationCoefficientsFromSoilTexture"]]) { # nolint
    if (todo_intracker(SFSW2_prj_meta, "calc_bsevap", "prepared")) {

      SFSW2_prj_inputs <- get_BareSoilEvapCoefs(
        SFSW2_prj_meta,
        SFSW2_prj_inputs,
        runIDs_adjust,
        resume = opt_behave[["resume"]],
        verbose = opt_verbosity[["verbose"]]
      )

      SFSW2_prj_meta[["input_status"]] <- update_intracker(
        SFSW2_prj_meta[["input_status"]],
        tracker = "calc_bsevap",
        prepared = TRUE
      )

      save_to_rds_with_backup(
        SFSW2_prj_meta,
        SFSW2_prj_meta[["fnames_in"]][["fmeta"]]
      )
    }

  } else {
    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]],
      tracker = "calc_bsevap",
      prepared = NA,
      checked = NA
    )
  }


  #--- The following will be calculated by each simulation run: set flags here
  # TODO(drs): they require knowledge of site climate which is not available
  #   at this point by the code; such calculations can be carried out here
  #   once dbW summarizes/contains climate variables and SFSW2_prj_inputs can
  #   store inputs for each run (instead of sites and experimentalDesign
  #   separately)
  if (SFSW2_prj_meta[["pcalcs"]][["EstimateConstantSoilTemperatureAtUpperAndLowerBoundaryAsMeanAnnualAirTemperature"]]) { # nolint

    # Set use-flags so that function 'SiteClimate' is called by
    #   each SOILWAT2-run
    SFSW2_prj_inputs[["sw_input_site_use"]]["SoilTempC_atLowerBoundary"] <- TRUE
    SFSW2_prj_inputs[["sw_input_site_use"]]["SoilTempC_atUpperBoundary"] <- TRUE
  }

  if (SFSW2_prj_meta[["pcalcs"]][["EstimateInitialSoilTemperatureForEachSoilLayer"]]) { # nolint

    use.layers <- which(
      SFSW2_prj_inputs[["sw_input_soils_use"]][
      paste0("Sand_L", SFSW2_glovars[["slyrs_ids"]])]
    )
    index.soilTemp <- paste0(
      "SoilTemp_L",
      SFSW2_glovars[["slyrs_ids"]]
    )[use.layers]

    SFSW2_prj_inputs[["sw_input_soils_use"]][index.soilTemp] <- TRUE
  }


  #------ OBTAIN INFORMATION FROM TABLES PRIOR TO SIMULATION RUNS
  # As specified by sw_input_treatments and sw_input_experimentals

  if (todo_intracker(SFSW2_prj_meta, "table_lookup", "prepared")) {

    SFSW2_prj_inputs <- do_prior_TableLookups(
      SFSW2_prj_meta,
      SFSW2_prj_inputs,
      resume = opt_behave[["resume"]],
      verbose = opt_verbosity[["verbose"]]
    )

    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]],
      tracker = "table_lookup",
      prepared = TRUE
    )

    save_to_rds_with_backup(
      SFSW2_prj_meta,
      SFSW2_prj_meta[["fnames_in"]][["fmeta"]]
    )
  }


  #------ CREATE OUTPUT DATABASE (IF NOT ALREADY EXISTING)
  if (todo_intracker(SFSW2_prj_meta, "dbOut", "prepared")) {

    temp <- try(
      make_dbOutput(
        SFSW2_prj_meta,
        SFSW2_prj_inputs,
        verbose = opt_verbosity[["verbose"]]
      ),
      silent = !opt_verbosity[["print.debug"]]
    )

    if (inherits(temp, "try-error")) {
      stop("Output database failed to setup")
    }

    SFSW2_prj_meta[["sim_size"]][["ncol_dbOut_overall"]] <-
      temp[["ncol_dbOut_overall"]]
    SFSW2_prj_meta[["prj_todos"]][["aon_fields"]] <- temp[["fields"]]

    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]],
      tracker = "dbOut",
      prepared = TRUE
    )
  }


  #------ CREATE WORK DATABASE (IF NOT ALREADY EXISTING)
  if (todo_intracker(SFSW2_prj_meta, "dbWork", "prepared")) {

    # This requires the presence of dbOutput
    temp <- recreate_dbWork(
      SFSW2_prj_meta = SFSW2_prj_meta,
      verbose = opt_verbosity[["print.debug"]]
    )

    if (!temp) {
      stop("Work database failed to setup")
    }

    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]],
      tracker = "dbWork",
      prepared = TRUE
    )
  }



  list(SFSW2_prj_meta = SFSW2_prj_meta, SFSW2_prj_inputs = SFSW2_prj_inputs)
}



#' Attempt to check input data of a \pkg{rSFSW2} project for consistency
#' @export
check_rSFSW2_project_input_data <- function(SFSW2_prj_meta, SFSW2_prj_inputs,
  opt_chunks, opt_verbosity) {

  if (opt_verbosity[["verbose"]]) {
    t1 <- Sys.time()
    temp_call <- shQuote(match.call()[1])
    print(paste0("rSFSW2's ", temp_call, ": started at ", t1))

    on.exit({
        print(paste0("rSFSW2's ", temp_call, ": ended after ",
          round(difftime(Sys.time(), t1, units = "secs"), 2), " s with ",
          "input tracker  status:"))
        print(SFSW2_prj_meta[["input_status"]])
      }, add = TRUE)
  }

  if (all(stats::na.exclude(SFSW2_prj_meta[["input_status"]][, "checked"]))) {
    # Return if all is checked (from a previous run)

    return(list(SFSW2_prj_meta = SFSW2_prj_meta,
      SFSW2_prj_inputs = SFSW2_prj_inputs))
  }

  on.exit(save_to_rds_with_backup(SFSW2_prj_meta,
    file = SFSW2_prj_meta[["fnames_in"]][["fmeta"]]), add = TRUE)
  on.exit(save_to_rds_with_backup(SFSW2_prj_inputs,
    file = SFSW2_prj_meta[["fnames_in"]][["fpreprocin"]]), add = TRUE)


  #--- Checking input 'SWRunInformation'
  if (todo_intracker(SFSW2_prj_meta, "load_inputs", "checked")) {
    # Check that 'dailyweather_source' are specified
    itemp <- SFSW2_prj_inputs[["SWRunInformation"]][
      SFSW2_prj_meta[["sim_size"]][["runIDs_sites"]], ]
    icheck1 <- !anyNA(itemp[, "dailyweather_source"])
    if (!icheck1) {
      stop("There are sites without a specified daily weather data source. ",
        "Provide data for every requested run.")
    }
  }


  #--- Check daily weather
  if (todo_intracker(SFSW2_prj_meta, "dbW_current", "checked")) {

    if (SFSW2_prj_meta[["opt_sim"]][["use_dbW_current"]] ||
      SFSW2_prj_meta[["opt_sim"]][["use_dbW_future"]]) {

      icheck1 <- file.exists(SFSW2_prj_meta[["fnames_in"]][["fdbWeather"]])
      icheck2 <- check_dbWeather_version(
        SFSW2_prj_meta[["fnames_in"]][["fdbWeather"]])
      icheck <- icheck1 && icheck2

    } else {
      # nolint start
      icheck <- any(all(SFSW2_prj_inputs[["create_treatments"]] == "LookupWeatherFolder"),
      SFSW2_prj_meta[["exinfo"]][["GriddedDailyWeatherFromMaurer2002_NorthAmerica"]],
      SFSW2_prj_meta[["exinfo"]][["GriddedDailyWeatherFromDayMet_NorthAmerica"]])
      # nolint end

      if (!icheck) {
        stop("Daily weather data must be provided through ",
          "'LookupWeatherFolder', 'Maurer2002_NorthAmerica', or ",
          "'DayMet_NorthAmerica' since no weather database is used")
      }
    }

    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]], tracker = "dbW_current",
      checked = icheck)
  }


  #--- Check scenario weather
  if (todo_intracker(SFSW2_prj_meta, "dbW_scenarios", "checked")) {

    icheck <- find_sites_with_bad_weather(
      fdbWeather = SFSW2_prj_meta[["fnames_in"]][["fdbWeather"]],
      site_labels = SFSW2_prj_inputs[["SWRunInformation"]][
        SFSW2_prj_meta[["sim_size"]][["runIDs_sites"]], "WeatherFolder"],
      scen_labels = SFSW2_prj_meta[["sim_scens"]][["id"]],
      chunk_size = opt_chunks[["ensembleCollectSize"]],
      verbose = opt_verbosity[["verbose"]])

    if (any(icheck)) {
      stop("Daily scenario weather data are not available for n = ",
        sum(icheck), " sites.")
    }

    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]], tracker = "dbW_scenarios",
      checked = all(!icheck))
  }


  #---- Map input variables (for quality control)
  map_soils <- !isdone_intracker(SFSW2_prj_meta, "soil_data", "checked")
  map_elevs <- !isdone_intracker(SFSW2_prj_meta, "elev_data", "checked")
  map_climnorms <- !isdone_intracker(SFSW2_prj_meta, "climnorm_data", "checked")

  if (any(map_soils, map_elevs, map_climnorms) &&
      !SFSW2_prj_meta[["use_sim_spatial"]]) {

    SFSW2_prj_meta[["use_sim_spatial"]] <- TRUE
    SFSW2_prj_meta <- setup_spatial_simulation(SFSW2_prj_meta, SFSW2_prj_inputs,
      use_sim_spatial = SFSW2_prj_meta[["use_sim_spatial"]],
      verbose = opt_verbosity[["verbose"]])

    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]], tracker = "spatial_setup",
      prepared = TRUE)
  }

  if (map_soils) {
    map_vars <- c("SoilDepth", "Matricd", "GravelContent", "Sand", "Clay",
      "TOC_GperKG", "EvapCoeff")
    icheck <- map_input_variables(map_vars = map_vars, SFSW2_prj_meta,
      SFSW2_prj_inputs, verbose = opt_verbosity[["verbose"]])

    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]], tracker = "soil_data", checked = icheck)
  }

  if (map_elevs) {
    icheck <- map_input_variables(map_vars = "ELEV_m", SFSW2_prj_meta,
      SFSW2_prj_inputs, verbose = opt_verbosity[["verbose"]])

    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]], tracker = "elev_data", checked = icheck)
  }

  if (map_climnorms) {
    icheck <- map_input_variables(map_vars = c("RH", "SkyC", "Wind", "snowd"),
      SFSW2_prj_meta, SFSW2_prj_inputs, verbose = opt_verbosity[["verbose"]])

    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]], tracker = "climnorm_data",
      checked = icheck)
  }


  #--- Check that INCLUDE_YN* are inclusive
  if (todo_intracker(SFSW2_prj_meta, "load_inputs", "checked")) {
    icheck <- check_requested_sites(
      SFSW2_prj_inputs[["include_YN"]], SFSW2_prj_inputs[["SWRunInformation"]],
      SFSW2_prj_meta[["fnames_in"]], verbose = opt_verbosity[["verbose"]])

    SFSW2_prj_inputs[["SWRunInformation"]] <- icheck[["SWRunInformation"]]

    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]], tracker = "load_inputs",
      checked = icheck[["check"]])
  }


  #--- Check that todos/treatments are coherent
  if (todo_intracker(SFSW2_prj_meta, "prj_todos", "checked")) {
    # Check that overall 'pnv0_temp' is turned on if any of the specific
    # ones 'pnv_temp' are active or alternatively that none of the
    # `PotentialNaturalVegetation_*` columns are turned on
    pnv0_temp <- "PotentialNaturalVegetation_CompositionShrubsC3C4_Paruelo1996"

    pnv_temp <- c(
      "PotentialNaturalVegetation_CompositionShrubs_Fraction",
      "PotentialNaturalVegetation_CompositionTotalGrasses_Fraction",
      "PotentialNaturalVegetation_CompositionC3_Fraction",
      "PotentialNaturalVegetation_CompositionC4_Fraction",
      "PotentialNaturalVegetation_CompositionAnnuals_Fraction",
      "PotentialNaturalVegetation_CompositionForb_Fraction",
      "PotentialNaturalVegetation_CompositionBareGround_Fraction",
      "PotentialNaturalVegetation_Composition_basedOnReferenceOrScenarioClimate", # nolint
      "AdjMonthlyBioMass_Precipitation",
      "AdjMonthlyBioMass_Temperature",
      "AdjRootProfile",
      "RootProfile_C3",
      "RootProfile_C4",
      "RootProfile_Annuals",
      "RootProfile_Shrubs",
      "RootProfile_Forb"
    )

    temp1 <- pnv0_temp %in% SFSW2_prj_inputs[["create_treatments"]]
    temp2 <- pnv_temp %in% SFSW2_prj_inputs[["create_treatments"]]
    icheck <- (!temp1 && all(!temp2)) || (temp1 && any(temp2))

    if (any(!icheck)) {
      stop(
        "Calculation and/or adjustement of 'potential natural vegetation' ",
        "is requested for some composition/biomass/root components: the ",
        "column ",
        "'PotentialNaturalVegetation_CompositionShrubsC3C4_Paruelo1996' ",
        "is the overall gate-keeper for this suit of functionality and must ",
        "thus be turned on as well but is currently not."
      )
    }

    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]], tracker = "prj_todos", checked = icheck)
  }

  #--- Check table lookups prior to simulation runs
  if (todo_intracker(SFSW2_prj_meta, "table_lookup", "checked")) {

    icheck <- length(SFSW2_prj_inputs[["done_prior"]]) == 0

    if (any(icheck)) {
      stop("Table lookups prior to simulation runs was not carried out: reset ",
        "tracker with:\n\t",
        "`SFSW2_prj_meta[['input_status']] <- update_intracker(",
          "SFSW2_prj_meta[['input_status']], tracker = 'table_lookup', ",
          "prepared = FALSE, checked = FALSE)`\n",
        "and repeat call to function `populate_rSFSW2_project_with_data`")
    }

    SFSW2_prj_meta[["input_status"]] <- update_intracker(
      SFSW2_prj_meta[["input_status"]], tracker = "table_lookup",
      checked = all(!icheck))
  }


  list(SFSW2_prj_meta = SFSW2_prj_meta, SFSW2_prj_inputs = SFSW2_prj_inputs)
}



#' Update actions for simulation project
#'
#' @param SFSW2_prj_meta An environment.
#' @param actions A named list of logical elements. See
#'   \file{SFSW2_project_code.R}.
#' @param wipe_dbOutput A logical value
#' @return A version of \code{SFSW2_prj_meta} with updated values for element
#'   \code{prj_todos}.
#' @export
update_actions <- function(SFSW2_prj_meta, actions = NULL,
  wipe_dbOutput = FALSE) {

  if (is.null(SFSW2_prj_meta[["prj_todos"]])) {
    SFSW2_prj_meta[["prj_todos"]] <- list()
  }

  if (!is.null(actions)) {
    SFSW2_prj_meta[["prj_todos"]][["actions"]] <- actions

    SFSW2_prj_meta[["prj_todos"]][["use_SOILWAT2"]] <- any(unlist(
      actions[c("sim_create", "sim_execute", "sim_aggregate")]))

    SFSW2_prj_meta[["prj_todos"]][["wipe_dbOut"]] <- wipe_dbOutput &&
      !(sum(unlist(actions)) == 1 && actions[["ensemble"]])
  }

  SFSW2_prj_meta
}


#' Update todos for simulation project
#'
#' @param SFSW2_prj_meta An environment.
#' @return A version of \code{SFSW2_prj_meta} with updated values for element
#'   \code{prj_todos}.
update_todos <- function(SFSW2_prj_meta) {
  SFSW2_prj_meta[["prj_todos"]][["need_cli_means"]] <-
    SFSW2_prj_meta[["prj_todos"]][["need_cli_means"]] &&
    SFSW2_prj_meta[["prj_todos"]][["use_SOILWAT2"]]

  SFSW2_prj_meta[["prj_todos"]][["do_ensembles"]] <-
    SFSW2_prj_meta[["sim_scens"]][["has_ensembles"]] &&
    SFSW2_prj_meta[["prj_todos"]][["actions"]][["ensemble"]]

  SFSW2_prj_meta
}



#' Prepare output database without running proper steps of
#' \file{SFSW2_project_code.R}
#'
#' The need may arise if all/some of input data of your simulation project is
#' located on a remote server and you want to create the output database and
#' work database locally. This function can be called before executing step 3
#' (\code{populate_rSFSW2_project_with_data}) in the demo code
#' \file{SFSW2_project_code.R}.
#'
#' @param path A character string. The path at which the databases will be
#'   created -- ignoring the path information from \code{SFSW2_prj_meta} used
#'   otherwise.
#'
#' @return Invisibly the number of output fields in the overall aggregation
#'   table. Side effect: creation of \code{dbOutput} and \code{dbWork}.
#' @export
quickprepare_dbOutput_dbWork <- function(actions, path, SFSW2_prj_meta,
  verbose = FALSE) {

  # Prepare arguments
  temp <- gather_project_inputs(SFSW2_prj_meta, use_preprocin = TRUE,
    verbose = verbose)
  SFSW2_prj_meta <- temp[["SFSW2_prj_meta"]]
  SFSW2_prj_inputs <- temp[["SFSW2_prj_inputs"]]

  SFSW2_prj_meta <- update_actions(SFSW2_prj_meta, actions,
    wipe_dbOutput = FALSE)
  SFSW2_prj_meta <- update_todos(SFSW2_prj_meta)

  # Create dbOutput
  SFSW2_prj_meta[["fnames_out"]][["dbOutput"]] <- file.path(path,
    "dbOutput.sqlite3")
  temp <- make_dbOutput(SFSW2_prj_meta, SFSW2_prj_inputs,
    verbose = verbose)

  # Create/connect dbWork
  stopifnot(setup_dbWork(path = path,
    include_YN = SFSW2_prj_inputs[["include_YN"]],
    SFSW2_prj_meta = SFSW2_prj_meta, resume = FALSE))

  invisible(temp[["ncol_dbOut_overall"]])
}



#' Carry out a \pkg{rSFSW2} simulation experiment
#' @export
simulate_SOILWAT2_experiment <- function(SFSW2_prj_meta, SFSW2_prj_inputs,
  opt_behave, opt_parallel, opt_chunks, opt_out_run, opt_verbosity) {

  t1 <- Sys.time()
  si <- utils::sessionInfo()

  if (opt_verbosity[["verbose"]]) {
    temp_call <- shQuote(match.call()[1])
    print(paste0("rSFSW2's ", temp_call, ": started at ", t1,
      " for project ",
      sQuote(basename(SFSW2_prj_meta[["project_paths"]][["dir_prj"]]))))

    print(si) # print system information

    on.exit({
      print(paste0("rSFSW2's ", temp_call, ": ended after ",
      round(difftime(Sys.time(), t1, units = "secs"), 2), " s"))
      cat("\n")}, add = TRUE)
  }

  if (opt_behave[["check_blas"]]) {
    benchmark_BLAS(si$platform)
  }

  rm(si)


  #---------------------------------------------------------------------------#
  #----------------CHECK ON DATABASES FOR SIMULATION OUTPUT (FROM PREVIOUS RUN)

  #--- Check whether dbWork is up-to-date:
  # recreate if
  # (i) it is not being kept updated and
  temp1 <- !opt_behave[["keep_dbWork_updated"]]
  # (ii) status suggest being out of sync, or
  temp2 <- dbWork_check_status(SFSW2_prj_meta[["project_paths"]][["dir_out"]],
    SFSW2_prj_meta)
  # (iii) design structure is bad, or
  temp3 <- !dbWork_check_design(SFSW2_prj_meta[["project_paths"]][["dir_out"]])
  # (iv) move_dbTempOut_to_dbOut() is called and processed at least one
  # dbTempOut
  do_dbWork <- (temp1 && temp2) || temp3

  #--- Consolidate (partial) output data
  if (!opt_out_run[["wipe_dbOutput"]]) {
    dir_out_temp <- SFSW2_prj_meta[["project_paths"]][["dir_out_temp"]]

    if (length(get_fnames_dbTempOut(dir_out_temp)) > 0L) {
      temp <- move_dbTempOut_to_dbOut(SFSW2_prj_meta,
        t_job_start = t1, opt_parallel, opt_behave, opt_out_run, opt_verbosity,
        chunk_size = -1L, dir_out_temp = dir_out_temp,
        check_if_Pid_present = FALSE)

      do_dbWork <- do_dbWork || temp > 0
    }
  }

  #--- Make sure that dbWork is up-to-date
  stopifnot(dbWork_clean(SFSW2_prj_meta[["project_paths"]][["dir_out"]]))

  if (do_dbWork) {
    recreate_dbWork(SFSW2_prj_meta = SFSW2_prj_meta,
      verbose = opt_verbosity[["verbose"]])
  }


  #--- Determine which runs (still) need to be done for this round
  SFSW2_prj_meta[["sim_size"]][["runIDs_todo"]] <-
    dbWork_todos(SFSW2_prj_meta[["project_paths"]][["dir_out"]])
  SFSW2_prj_meta[["sim_size"]][["runsN_todo"]] <-
    length(SFSW2_prj_meta[["sim_size"]][["runIDs_todo"]])


  #----------------------------------------------------------------------------#
  #------------------------PREPARE SOILWAT2 SIMULATIONS

  #--- Set up parallelization
  # used in:
  #   - loop calling do_OneSite
  #   - ensembles
  setup_SFSW2_cluster(opt_parallel,
    dir_out = SFSW2_prj_meta[["project_paths"]][["dir_prj"]],
    verbose = opt_verbosity[["verbose"]],
    print.debug = opt_verbosity[["print.debug"]])
  on.exit(exit_SFSW2_cluster(verbose = opt_verbosity[["verbose"]]),
    add = TRUE)
  on.exit(set_full_RNG(SFSW2_prj_meta[["rng_specs"]][["seed_prev"]],
    kind = SFSW2_prj_meta[["rng_specs"]][["RNGkind_prev"]][1],
    normal.kind = SFSW2_prj_meta[["rng_specs"]][["RNGkind_prev"]][2]),
    add = TRUE)

  ow_prev <- set_options_warn_error(opt_verbosity[["debug.warn.level"]],
    opt_verbosity[["debug.dump.objects"]], project_paths[["dir_prj"]],
    verbose = opt_verbosity[["verbose"]])
  on.exit(options(ow_prev), add = TRUE)


  #----------------------------------------------------------------------------#
  #------------------------RUN RSOILWAT
  if (SFSW2_prj_meta[["prj_todos"]][["use_SOILWAT2"]] &&
    SFSW2_prj_meta[["sim_size"]][["runsN_todo"]] > 0) {

    on.exit(dbWork_clean(SFSW2_prj_meta[["project_paths"]][["dir_out"]]),
      add = TRUE)

    swof <- rSOILWAT2::sw_out_flags()
    swDefaultInputs <- read_SOILWAT2_DefaultInputs()
    args_do_OneSite <- gather_args_do_OneSite(SFSW2_prj_meta, SFSW2_prj_inputs)

    runs.completed <- run_simulation_experiment(
      sim_size = SFSW2_prj_meta[["sim_size"]],
      SFSW2_prj_inputs = SFSW2_prj_inputs,
      MoreArgs = args_do_OneSite
    )

  } else {
    runs.completed <- 0
  }


  oe <- sys.on.exit()
  oe <- remove_from_onexit_expression(oe, "exit_SFSW2_cluster")
  on.exit(eval(oe), add = FALSE)


  #----------------------------------------------------------------------------#
  #------------------------OVERALL TIMING
  delta.overall <- difftime(Sys.time(), t1, units = "secs")

  compile_overall_timer(SFSW2_prj_meta[["fnames_out"]][["timerfile"]],
    SFSW2_prj_meta[["project_paths"]][["dir_out"]],
    SFSW2_glovars[["p_workersN"]], runs.completed,
    SFSW2_prj_meta[["sim_scens"]][["N"]], 0, delta.overall, NA, 0, 0)

  if (opt_verbosity[["verbose"]]) {
    print(utils::sessionInfo())
  }

  SFSW2_prj_meta
}


#------------------------------------------------------------------------------#

#' Move temporary output data to output databases
#'
#' @param dir_out_temp A character string. The path to temporary output files.
#'   If \code{NULL}, then temporary output files are assumed to be located at
#'   \code{SFSW2_prj_meta[["project_paths"]][["dir_out_temp"]]}. This cannot be
#'   \code{NULL} unless all simulation runs have finished (to prevent
#'   overwriting of temporary output files of a potential concurrent run). This
#'   can however only be checked if \code{opt_behave[["keep_dbWork_updated"]]}.
#'
#' @section Details: Expectations on how the function locates files on disk:
#'   \itemize{
#'   \item \code{SFSW2_prj_meta[["project_paths"]][["dir_out"]]} is
#'     the path to \code{dbWork}
#'   \item \code{SFSW2_prj_meta[["project_paths"]][["dir_out_temp"]]}
#'     is the path to \code{concatFile} and \file{SQL_tmptxt_failed.txt}
#'   \item \code{dir_out_temp} is the path to temporary output files
#'   \item \code{SFSW2_prj_meta[["fnames_out"]][["dbOutput"]]} is the full
#'     file name of \code{dbOutput}
#'   \item \code{SFSW2_prj_meta[["fnames_out"]][["dbOutput_current"]]} is the
#'     full file name of \code{dbOutput_current} }
#'
#' @section Details: The code executes \code{opt_out} option
#'   \code{dbOutCurrent_from_dbOut} only, once all simulation runs are
#'   completed.
#'
#' @export
move_output_to_dbOutput <- function(SFSW2_prj_meta, t_job_start, opt_parallel,
  opt_behave, opt_out_run, opt_verbosity, check_if_Pid_present = FALSE,
  dir_out_temp = NULL) {

  t.outputDB <- Sys.time()

  if (opt_behave[["keep_dbWork_updated"]]) {
    runsN_todo <- dbWork_Ntodo(SFSW2_prj_meta[["project_paths"]][["dir_out"]])

    if (runsN_todo > 0 && is.null(dir_out_temp)) {
      stop("'move_output_to_dbOutput': if 'dir_out_temp' is NULL, then all ",
        "runs must have completed; but runsN_todo = ", runsN_todo)
    }
  }

  has_time_to_concat <- (difftime(t.outputDB, t_job_start, units = "secs") +
    opt_parallel[["opt_job_time"]][["one_concat_s"]]) <
    opt_parallel[["opt_job_time"]][["wall_time_s"]]

  if (has_time_to_concat) {
    if (is.null(dir_out_temp)) {
      # Use default project location for temporary text files
      dir_out_temp <- SFSW2_prj_meta[["project_paths"]][["dir_out_temp"]]
    }

    # check: old behavior used temporary text files; new code uses temporary
    # database files
    has_tempTXT <- length(get_fnames_temporaryOutput(dir_out_temp)) > 0L
    has_tempDB <- length(get_fnames_dbTempOut(dir_out_temp)) > 0L

    if (has_tempTXT) {
      # old behavior used temporary text files; maintain calls as long as
      # functions are deprecated and not yet defunct
      if (check_if_Pid_present) {
        move_temporary_to_outputDB_withChecks(SFSW2_prj_meta, t_job_start,
          opt_parallel, opt_behave, opt_out_run, opt_verbosity,
          chunk_size = 1000L, check_if_Pid_present = TRUE,
          dir_out_temp = dir_out_temp)

      } else {
        move_temporary_to_outputDB(SFSW2_prj_meta, t_job_start, opt_parallel,
          opt_behave, opt_out_run, opt_verbosity, chunk_size = 1000L,
          dir_out_temp = dir_out_temp)
      }
    }

    if (has_tempDB) {
      # new behavior
      if (!SFSW2_prj_meta[["opt_out_fix"]][["dbOutCurrent_from_dbOut"]] &&
        SFSW2_prj_meta[["opt_out_fix"]][["dbOutCurrent_from_tempTXT"]]) {
         warning("move_output_to_dbOutput: option 'dbOutCurrent_from_tempTXT' ",
           "iscurrently not supported")
      }

      move_dbTempOut_to_dbOut(SFSW2_prj_meta, t_job_start, opt_parallel,
        opt_behave, opt_out_run, opt_verbosity, chunk_size = -1L,
        dir_out_temp = dir_out_temp,
        check_if_Pid_present = check_if_Pid_present)
    }

  } else {
    print(paste("Need at least",
      opt_parallel[["opt_job_time"]][["one_concat_s"]], "seconds to put SQL",
      "in output DB."))
  }


  if (SFSW2_prj_meta[["opt_out_fix"]][["dbOutCurrent_from_dbOut"]] &&
    !SFSW2_prj_meta[["opt_out_fix"]][["dbOutCurrent_from_tempTXT"]] &&
    runsN_todo == 0) {

    has_time_to_concat <- (difftime(Sys.time(), t_job_start, units = "secs") +
      opt_parallel[["opt_job_time"]][["one_concat_s"]]) <
      opt_parallel[["opt_job_time"]][["wall_time_s"]]

    if (has_time_to_concat) {
      do_copyCurrentConditionsFromDatabase(
        SFSW2_prj_meta[["fnames_out"]][["dbOutput"]],
        SFSW2_prj_meta[["fnames_out"]][["dbOutput_current"]],
        verbose = opt_verbosity[["verbose"]])

    } else {
      print(paste("Need at least",
        opt_parallel[["opt_job_time"]][["one_concat_s"]],
        "seconds to put SQL in output DB."))
    }
  }

  #timing of outputDB
  delta.outputDB <- as.double(difftime(Sys.time(), t.outputDB, units = "secs"))

  write_timer(SFSW2_prj_meta[["fnames_out"]][["timerfile"]], "Time_OutputDB",
    time_sec = delta.outputDB)

  invisible(TRUE)
}
Burke-Lauenroth-Lab/rSFSW2 documentation built on Aug. 14, 2020, 5:20 p.m.