#' 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)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.