R/define.R

Defines functions modify_table variety_params layer_params layer_init_params tree_init_params root_init_params check_type check_range check_accepted check_input_values define_hisafe_file define_hisafe

Documented in check_accepted check_input_values check_range check_type define_hisafe define_hisafe_file layer_init_params layer_params modify_table root_init_params tree_init_params variety_params

#' Define a Hi-sAFe experiment
#' @description Defines a Hi-sAFe experiment - the input parameters to one or more Hi-sAFe simulations.
#' @details It is strongly recommended to name each simulation in your experiment. This can be done via the \code{SimulationName} parameter.
#' If no names are provided, then generic names of "Sim_1", "Sim_2", etc. will be generated.
#' The only additional input parameter that is available but not part of the input files is **weatherFile**, which specifies a path to a .WTH file to use.
#' @return An object of class "hip". This is a list of 5 elements:
#' \itemize{
#'  \item{"exp.plan"}{ - A data frame (tibble) of manipulated Hi-sAFe input parameters, with each row a Hi-sAFe simulation and each column a Hi-sAFe input parameter.}
#'  \item{"template"}{ - A character string of the path to the directory containing the template set of Hi-sAFe simulation folders/files used.}
#'  \item{"profiles"}{ - A character vector of the names of the Hi-sAFe export profiles that will be exported by Hi-sAFe.}
#'  \item{"freqs"}{ - A numeric vector of the exportFrequencies at which the Hi-sAFe export profiles will be exported by Hi-sAFe.}
#'  \item{"path"}{ - A character string of the absolute path to the directory where the simulation/experiment is to be built.
#' }
#' If a relative path is via \code{path}, it is converted to an absolute path to maximize "hip" object versaitility.}
#' @param path A character string of the path (relative or absolute) to the directory where the simulation/experiment is to be built.
#' @param exp.name A character string of the name of the experiment folder. Only used if defining more than one simulation.
#' @param profiles A character vector of Hi-sAFe export profiles to be exported by Hi-sAFe.
#' If "all" (the default), then the basic set of profiles for all data levels will be exported.
#' @param freqs A numeric vector of export frequencies (days) for the export profiles specified in \code{profiles}.
#' if \code{NULL} (the default), then the default export frequences (daily, monthly, annual) are applied to respective profiles.
#' Export frequencies can be any positive integer. Special values include 30, which triggers export on the first day of each month,
#' and 365, which triggers export on the first day of each January.
#' @param template A character string of the path to the directory containing the template set of Hi-sAFe simulation folders/files to use.
#' hisafer comes with a variety of "default" templates than can be used by specificying specific character strings:
#' \itemize{
#'  \item{"agroforestry"}{ - a simple alley cropping template, with trees spaced at 9m x 13m and a durum wheat alley crop}
#'  \item{"forestry"}{ - a simple forestry template, with trees spaced at 5m x 7m and an understory of bare soil}
#'  \item{"monocrop"}{ - a simple, single-celled monocrop template with durum-wheat}
#'  \item{"restinclieres_agroforestry_A2"}{ - a template based on the agroforestry calibration simulation of Hi-sAFe in Plot A2 at Restinclieres in Southern France}
#'  \item{"restinclieres_agroforestry_A3"}{ - a template based on the agroforestry calibration simulation of Hi-sAFe in Plot A3 at Restinclieres in Southern France}
#'  \item{"restinclieres_forestry_A4"}{ - a template based on the forestry calibration simulation of Hi-sAFe in Plot A4 at Restinclieres in Southern France}
#'  \item{"restinclieres_monocrop_A2"}{ - a template basd on the monocrop calibration simulation of Hi-sAFe in Plot A2 at Restinclieres in Southern France}
#'  \item{"restinclieres_monocrop_A3"}{ - a template basd on the monocrop calibration simulation of Hi-sAFe in Plot A3 at Restinclieres in Southern France}
#'  \item{"castries_agroforestry"}{ - a template basd on the agroforestry validation simulation of Hi-sAFe at Castries in Southern France}
#' }
#' @param factorial If \code{FALSE}, the default, then supplied input values are recycled (i.e. such as for default behavior of \code{\link{data.frame}}).
#' If \code{TRUE}, then a factorial experiment is created, in which an experiment is defined for each possible combination of supplied values.
#' @param force Logical indicating wether the supplied values should be forced past the constraint checks. Use \code{TRUE} for development only.
#' @param bulk.pass Any Hi-sAFe input parameter in the .SIM, .PLD, .TREE, and .PAR files can be passed here grouped as a list,
#' just as can be passed to \code{...}. This facilitates sending the same list of arguments to multiple calls of \code{define_hisafe}.
#' @param ... Any Hi-sAFe input parameter in the .SIM, .PLD, .TREE, .PLT, .TEC, and .PAR files can be passed.
#' Parameters in .TREE, .PLT, and .TEC files will be applied to **all** .TREE, .PLT, and .TEC files in each simulation.
#' To display supported parameters, use \code{\link{hip_params}}. See below for further details.
#' There are three methods for passing parameters to \code{define_hisafe}, one for each of the three types of parameters within the parameter files:
#' \itemize{
#'  \item{individual numeric or character values}{ - For parameters that require a single value (most parameters),
#'  a simulation can be defined via \code{parameterName = value}. To define an experiment, use \code{parameterName = c(value1, value2)}}
#'  \item{multiple numeric values}{ - For parameters that require multiple numeric values
#'  (e.g. tree planting, tree pruning, tree thinning, and root pruning parameters),
#'  a simulation can be defined by wrapping one or more numeric vectors within a list.
#'  For a single simulation, use \code{parameterName = list(c(value1, value2, ...))}.
#'  For an experiment, use \code{parameterName = list(c(value1, value2, ...), c(value3, value4, ...))}.}
#'  \item{"tables"}{ - There are four parameter tables within the .pld file (layers, layer.initialization, tree.initialization, root.initialization)
#'  and one parameter table with the .plt file (varieties) that are supported.
#'  To define prameters within these tables, use the helper functions
#'  \code{\link{layer_params}}, \code{\link{layer_init_params}}, \code{\link{tree_init_params}}, \code{\link{root_init_params}}, and \code{\link{variety_params}}.
#'  These functions create a list of data frames (tibbles).}
#' }
#' Passing \code{NA} to any parameter will "deactivate" the parameter by commenting it out in the resulting Hi-sAFe parameter file. This can be useful to deactivate
#' processes such as tree root pruning or branch pruning, but care must be taken to only deactivate parameters that are not mandatory!
#' @export
#' @importFrom dplyr %>%
#' @family hisafe definition functions
#' @examples
#' \dontrun{
#' # To define a Hi-sAFe simulation using all default parameter values:
#' default.exp <- define_hisafe(path = "./")
#'
#' # To define a Hi-sAFe experiment analyzing only variation in latitude:
#' latitude.exp <- define_hisafe(path = "./", SimulationName = c("Lat15", "Lat30", "Lat45", "Lat60"),
#'                                latitude = seq(15, 60, 15))
#'
#' # To define a factorial Hi-sAFe experiment analyzing
#' # simultaneous variation in latitude and tree line orientation:
#' lat.orient.exp <- define_hisafe(path = "./",
#'                                  latitude = seq(15, 60, 15),
#'                                  treeLineOrientation = c(0,90))
#' }
define_hisafe <- function(path,
                          exp.name  = "experiment",
                          profiles  = "all",
                          freqs     = NULL,
                          template  = "agroforestry",
                          factorial = FALSE,
                          force     = FALSE,
                          bulk.pass = NULL, ...) {

  if(!(is.character(exp.name) & length(exp.name) == 1))
    stop("exp.name argument must be a character vector of length 1", call. = FALSE)
  if(!(all(is.character(profiles)) | profiles[1] == "all"))
    stop("profiles argument must be 'all' or a character vector",    call. = FALSE)
  if(!(all(is.numeric(freqs)) | is.null(freqs)))
    stop("freqs argument must be NULL or a numeric vector",          call. = FALSE)
  if(!(is.character(template) & length(template) == 1))
    stop("template argument must be a character vector of length 1", call. = FALSE)
  if(!(is.null(bulk.pass) | is.list(bulk.pass)))
    stop("bulk.pass argument must be a list",                        call. = FALSE)

  is_TF(factorial)
  is_TF(force)

  path          <- get_absolute_path(path)
  if(!file.exists(path)) stop("supplied path does not exist", call. = FALSE)

  param.list    <- list(...)
  if(!is.null(bulk.pass)) param.list <- c(param.list, bulk.pass)

  ## Get profile names and check that they are present in template directory
  available.profiles <- get_available_profiles(template)
  if(profiles[1] == "all") {
    profiles <- available.profiles[available.profiles %in% CORE.PROFILES]
  } else if(profiles[1] == "all-private"){
    profiles <- available.profiles
  } else if(!all(profiles %in% available.profiles)) {
    missing.profiles <- profiles[!(profiles %in% available.profiles)]
    stop(paste(c("The following profiles are not available:", missing.profiles), collapse = "\n"), call. = FALSE)
  }

  ## Apply export frequencies from user or internal defaults
  default.freqs <- SUPPORTED.PROFILES$freqs[match(profiles, SUPPORTED.PROFILES$profiles)]
  if(is.null(freqs)) {
    freqs <- default.freqs
  } else if(length(profiles) != length(freqs)) {
    stop("profiles and freqs must have the same length", call. = FALSE)
  } else if(!all((freqs %% 1) == 0 & freqs > 0)) {
    stop("freqs must positive integers", call. = FALSE)
  }

  if(factorial) {
    exp.plan <- dplyr::as_tibble(expand.grid(param.list, stringsAsFactors = FALSE))
  } else if(length(param.list) > 0){
    reps.to.make <- param.list %>%
      purrr::map(length) %>%
      unlist() %>%
      (function(x) max(x) / x)

    if(any(reps.to.make %% 1 != 0))
      stop("If factorial = FALSE, lengths of supplied input parameters must be multiples of each other", call. = FALSE)

    exp.plan <- param.list %>%
      purrr::map2(reps.to.make, rep.int) %>%
      dplyr::as_tibble()
  } else {
    exp.plan <- dplyr::tibble(SimulationName = "Sim_1")
  }

  if(!("SimulationName" %in% names(exp.plan))) exp.plan$SimulationName <- paste0("Sim_", 1:nrow(exp.plan))
  exp.plan <- dplyr::select(exp.plan, SimulationName, dplyr::everything())

  if("weatherFile" %in% names(exp.plan)) exp.plan$weatherFile <- as.character(get_absolute_path(exp.plan$weatherFile))

  if(nrow(exp.plan) > 1) path <- clean_path(paste0(path, "/", exp.name))
  hip <- list(exp.plan = exp.plan,
              template = template,
              profiles = profiles,
              freqs    = freqs,
              path     = path)

  check_input_values(hip = hip, force = force)

  class(hip) <- c("hip", class(hip))
  return(hip)
}

#' Define a Hi-sAFe experiment from a file
#' @description Defines a Hi-sAFe experiment - the input parameters to one or more Hi-sAFe simulations.
#' \code{define_hisafe_file} cannot handle parameters that require numeric vectors or are within parameters tables. Use \code{\link{define_hisafe}} instead.
#' @details It is strongly recommended to name each simulation in your experiment. This can be done via the \code{SimulationName} parameter.
#' If no names are provided, then generic names of "Sim_1", "Sim_2", etc. will be generated.
#' @return An object of class "hip". See \code{\link{define_hisafe}} for more details.
#' @param file A character string of the path to a csv file.
#' Each row in the file should represent a Hi-sAFe simulation and each column a Hi-sAFe input parameter.
#' For more information on supported parameters, use \code{\link{hip_params}}.
#' @param path A character string of the path (relative or absolute) to the directory where the simulation/experiment is to be built.
#' @param exp.name A character string of the name of the experiment folder. Only used if defining more than one simulation.
#' @param profiles A character vector of Hi-sAFe export profiles to be exported by Hi-sAFe. If "all" (the default), then all supported profiles will be exported.
#' @param template A character string of the path to the directory containing the template set of Hi-sAFe simulation folders/files to use.
#' See \code{\link{define_hisafe}} for more details.
#' @param force Logical indicating wether the supplied values should be forced past the constraint checks. Use \code{TRUE} for development only.
#' See \code{\link{define_hisafe}} for more details.
#' @export
#' @importFrom dplyr %>%
#' @family hisafe definition functions
#' @examples
#' \dontrun{
#' # To define a Hi-sAFe experiment from a file:
#' myexp <- define_hisafe_file("./example_exp.csv")
#' }
define_hisafe_file <- function(file,
                               path,
                               exp.name = "experiment",
                               profiles = "all",
                               template = "agroforestry",
                               force    = FALSE) {

  path          <- get_absolute_path(path)
  template.path <- get_template_path(template)

  if(!(is.character(file) & length(file) == 1))             stop("file argument must be a character vector of length 1",     call. = FALSE)
  if(!dir.exists(path))                                     stop("directory specified by path does not exist",               call. = FALSE)
  if(!(is.character(exp.name) & length(exp.name) == 1))     stop("exp.name argument must be a character vector of length 1", call. = FALSE)
  if(!(all(is.character(profiles)) | profiles[1] == "all")) stop("profiles argument must be 'all' or a character vector",    call. = FALSE)
  if(!(is.character(template) & length(template) == 1))     stop("template argument must be a character vector of length 1", call. = FALSE)
  if(!dir.exists(template.path))                            stop("template directory does not exist",                        call. = FALSE)
  is_TF(force)

  exp.plan <- dplyr::as_tibble(read.csv(file, header = TRUE, stringsAsFactors = FALSE))

  ## Get profile names and check that they are present in template directory
  available.profiles <- get_available_profiles(template)
  if(profiles[1] == "all") {
    profiles <- available.profiles
  } else if(!all(profiles %in% available.profiles)) {
    missing.profiles      <- profiles[!(profiles %in% available.profiles)]
    stop(paste(c("The following profiles are not available:", missing.profiles), collapse = "\n"), call. = FALSE)
  }

  if(!("SimulationName" %in% names(exp.plan))) exp.plan$SimulationName <- paste0("Sim_", 1:nrow(exp.plan))
  exp.plan <- dplyr::select(exp.plan, SimulationName, dplyr::everything())

  hip <- list(exp.plan = exp.plan,
              template = template,
              profiles = profiles,
              path     = clean_path(paste0(path, "/", exp.name)))

  check_input_values(hip = hip, force = force)

  class(hip) <- c("hip", class(hip))
  return(hip)
}

#' Check validity of all Hi-sAFe inputs
#' @description Checks the validity of all defined inputs against Hi-sAFe model constraints
#' and constraints found in the template file comments. Errors are generated if issues are found.
#' Used within \code{\link{define_hisafe}} and \code{\link{define_hisafe_file}}.
#' @return Produces errors if issues are found. Otherwise, invisibly returns \code{TRUE}.
#' @param hip An object of class "hip".
#' @param force Logical indicating wether the supplied values should be forced past the constraint checks. Use \code{TRUE} for development only.
#' @keywords internal
check_input_values <- function(hip, force) {

  if(force) {
    warning("Bypassing validation of input parameter definitions can lead to unpredictable functionality of Hi-sAFe.",
            call. = FALSE, immediate. = TRUE)
    return(FALSE)
  }

  USED.PARAMS <- get_used_params(hip)

  get_used       <- function(param) USED.PARAMS[[param]]$value
  get_used_un    <- function(param) unlist(get_used(param))
  is_mod         <- function(param) USED.PARAMS[[param]]$exp.plan
  rm.na          <- function(x) x[!is.na(x)]
  get_length     <- function(param) purrr::map(get_used(param), function(x) if(is.na(x[1])) as.integer(0) else length(x))
  get_init_vals  <- function(tab, param) {
    tab <- get_used(tab)
    out.list <- list()
    for(i in 1:length(tab)) {
      if(all(is.na(tab[[i]]))) {
        out.list <- c(out.list, list(NA))
      } else {
        out.list <- c(out.list, list(tab[[i]][[param]]))
      }
    }
    return(out.list)
  }
  less_than      <- function(x, y) all(is.na(x) | x <= y)
  equal_to       <- function(x, y) all(is.na(x) | x == y)

  ## Get available template file names
  avail.path  <- get_template_subpath(hip$template)
  AVAIL.CROPS <- list.files(clean_path(paste0(avail.path, "/cropSpecies")))
  AVAIL.TECS  <- list.files(clean_path(paste0(avail.path, "/cropInterventions")))
  AVAIL.TREES <- gsub("\\.tree", "", list.files(clean_path(paste0(avail.path, "/treeSpecies"))))

  ## ENSURE INITIALIZATION TABLES ARE FROM CORRECT SOURCES
  comp_table_names <- function(x, check) {
    get_name <- function(x) ifelse(is.na(x), check, unique(x$name))
    all(unlist(purrr::map(x, get_name)) == check)
  }
  tree.table        <- get_used("tree.initialization")
  root.table        <- get_used("root.initialization")
  layers.table      <- get_used("layers")
  layers.init.table <- get_used("layer.initialization")
  if(!comp_table_names(tree.table,        "TreeInit"))  stop("tree.initialization must be specified via tree_init_params()",   call. = FALSE)
  if(!comp_table_names(root.table,        "RootInit"))  stop("root.initialization must be specified via root_init_params()",   call. = FALSE)
  if(!comp_table_names(layers.table,      "Layer"))     stop("layers must be specified via layer_params()",                    call. = FALSE)
  if(!comp_table_names(layers.init.table, "LayerInit")) stop("layer.initialization must be specified via layer_init_params()", call. = FALSE)

  ## Initialize Error Message
  errors <-   "Hi-sAFe definition errors:"

  ## UNSUPPORTED INPUT, BAD CLASS, BAD RANGE ERRORS FIRST
  names.to.check <- names(hip$exp.plan)[!(names(hip$exp.plan) %in% c("SimulationName", "weatherFile"))]
  if(any(!(names.to.check %in% names(USED.PARAMS)))) {
    unsupported.names   <- names.to.check[!(names.to.check %in% names(USED.PARAMS))]
    unsupported.var.error <- c("The following variables are not supported:", paste0(unsupported.names, collapse = ", "))
  } else {
    unsupported.var.error <- ""
  }

  accepted.errors <- purrr::map_chr(names.to.check, check_accepted, exp.plan = hip$exp.plan)
  range.errors    <- purrr::map_chr(names.to.check, check_range,    exp.plan = hip$exp.plan)
  type.errors     <- purrr::map_chr(names.to.check, check_type,     exp.plan = hip$exp.plan)

  prelim.errors <- c(errors, unsupported.var.error, accepted.errors, range.errors, type.errors)
  prelim.errors <- paste0(prelim.errors[!(prelim.errors == "") & !is.na(prelim.errors)], collapse = "\n")
  if(prelim.errors != errors) stop(prelim.errors, call. = FALSE)

  ## SimulationName errors
  paste_together  <- function(x) unlist(purrr::map(x, paste, collapse = ";"))
  orig.exp.plan <- hip$exp.plan %>%
    dplyr::mutate_if(is.list, paste_together)
  test.exp.plan <- orig.exp.plan %>%
    dplyr::distinct()

  unique.sim.error     <- ifelse(nrow(orig.exp.plan) == nrow(test.exp.plan),
                                 "", "-- Each simulaton must be distinct.")
  unique.simname.error <- ifelse(unique(table(unlist(hip$exp.plan$SimulationName))) == 1,
                                 "", "-- SimulationName - each siulation must have a unique name")
  simname.space.error  <- ifelse(!any(grepl(" ", unlist(hip$exp.plan$SimulationName))),
                                 "", "-- SimulationName - names cannot contains spaces")

  ## Tree Errors
  tree.species.used <- unique(unlist(get_init_vals("tree.initialization", "species")))
  if(!is.na(tree.species.used[1]) & any(!(tree.species.used %in% AVAIL.TREES))) {
    tree.species.missing <- tree.species.used[!(tree.species.used %in% AVAIL.TREES)]
    unsupported.trees.error <- paste("--", tree.species.missing, "is not a tree available in the template directory.")
  } else {
    unsupported.trees.error <- ""
  }
  several.trees <- length(tree.species.used) > 1
  tree.params.edited <- any(names(hip$exp.plan) %in% dplyr::filter(INPUT.DEFS, file == "TREE")$name)
  too.many.trees.error <- ifelse(several.trees & tree.params.edited,
                                 "-- Cannot edit tree paramaters when simulations contain more than one tree species.", "")

  ## Crop Errors
  crop.species.used <- unique(c(get_used_un("mainCropSpecies"), get_used_un("interCropSpecies")))
  if(any(!(crop.species.used %in% AVAIL.CROPS))) {
    crop.species.missing <- crop.species.used[!(crop.species.used %in% AVAIL.CROPS)]
    unsupported.crops.error <- paste("-- The following crop .PLT files are not available in the template directory: ", paste(crop.species.missing, collapse = ", "))
  } else {
    unsupported.crops.error <- ""
  }

  ## itk Errors
  crop.itks.used <- unique(c(get_used_un("mainCropItk"), get_used_un("interCropItk")))
  if(any(!(crop.itks.used %in% AVAIL.TECS))) {
    crop.itks.missing <- crop.itks.used[!(crop.itks.used %in% AVAIL.TECS)]
    unsupported.itks.error <- paste("-- The following crop .TEC files are not available in the template directory: ", paste(crop.itks.missing, collapse = ", "))
  } else {
    unsupported.itks.error <- ""
  }

  ## Spacing Errors
  plot.width.error   <- ifelse(!all(((get_used_un("plotWidth") / get_used_un("cellWidth")) %% 1) != 0),
                               "", "-- (plotWidth / cellWidth) should be a whole number")
  plot.height.error <- ifelse(!all(((get_used_un("plotHeight")  / get_used_un("cellWidth")) %% 1) != 0),
                              "", "-- (plotHeight / cellWidth) should be a whole number")

  ## Tree Centered in Cell Error
  on_scene_check <- function(x, edge) is.na(x) | (x <= edge & x >=0)
  bad.trees <- ""
  off.scene.trees <- ""
  coloc.sims <- ""
  for(i in 1:nrow(hip$exp.plan)) {
    X <- get_init_vals("tree.initialization", "treeX")[[i]]
    Y <- get_init_vals("tree.initialization", "treeY")[[i]]
    if(all(is.na(X) & is.na(Y))) next

    okay.loc <- (X == 0 & Y == 0) | (abs(X %% get_used("cellWidth")[[i]] - rep(get_used("cellWidth")[[i]] / 2, length(X))) < 1e-5 &
                                       abs(Y %% get_used("cellWidth")[[i]] - rep(get_used("cellWidth")[[i]] / 2, length(Y))) < 1e-5)

    x.on.scene <- on_scene_check(X, get_used("plotWidth")[[i]])
    y.on.scene <- on_scene_check(Y, get_used("plotHeight")[[i]])
    on.scene <- (x.on.scene & y.on.scene)

    coloc <- any(duplicated(dplyr::tibble(x = X, y = Y)))

    if(any(!okay.loc)) bad.trees       <- c(bad.trees,       paste0(hip$exp.plan$SimulationName[i], "-Tree", c(1:length(X))[!okay.loc]))
    if(any(!on.scene)) off.scene.trees <- c(off.scene.trees, paste0(hip$exp.plan$SimulationName[i], "-Tree", c(1:length(X))[!on.scene]))
    if(any(coloc))     coloc.sims      <- c(coloc.sims,      hip$exp.plan$SimulationName[i])
  }
  bad.trees       <- bad.trees[bad.trees != ""]
  off.scene.trees <- off.scene.trees[off.scene.trees != ""]
  coloc.sims      <- coloc.sims[coloc.sims != ""]

  tree.centered.error <- ifelse(length(bad.trees)       == 0, "", paste("-- The following trees are not centered on a cell:",
                                                                        paste(bad.trees, collapse = ", ")))
  tree.offscene.error <- ifelse(length(off.scene.trees) == 0, "", paste("-- The following trees' coordinates are beyond the scene boundaries:",
                                                                        paste(off.scene.trees, collapse = ", ")))
  tree.coloc.error    <- ifelse(length(coloc.sims)      == 0, "", paste("-- The following simulations have two or more trees located on the same cell:",
                                                                        paste(hip$exp.plan$SimulationName[coloc], collapse = ', ')))

  ## Distance & Time Errors
  less_than_comp <- function(param, ref) {
    ifelse(all(purrr::map2_lgl(get_used(param), get_used(ref), less_than)), "", paste0("-- ", param, " must be less than ", ref))
  }
  treeCropDistance.error        <- less_than_comp("treeCropDistance",        "plotWidth")
  treeRootPruningDistance.error <- less_than_comp("treeRootPruningDistance", "plotWidth")

  ## nrow(tree_init) == nrow(root_init) Error
  tree.init <- get_used("tree.initialization")
  if(all(is.na(tree.init))) {
    tree.rows <- rep(0, length(tree.init))
  } else {
    tree.rows <- purrr::map_dbl(tree.init, nrow)
  }

  root.init <- get_used("root.initialization")
  if(all(is.na(root.init))) {
    root.rows <- 0
  } else {
    root.rows <- purrr::map_dbl(root.init, nrow)
  }

  tree.root.error <- ifelse(all(tree.rows == root.rows),
                            "", "-- The number of rows in the tree initialization and root initialization tables must be equal.")

  ## Don't Edit Export Profile Errors
  EP.error <- ifelse(is_mod("profileNames") | is_mod("exportFrequencies"),
                     "-- profileNames and exportFrequencies must be defined using the 'profiles' and 'freqs'
                     arguments of define_hisafe(), respectively.", "")

  ## STICS parameter dependencies check
  capillary.error <- ifelse((is_mod("capillaryUptake") | is_mod("capillaryUptakeMinWater")) & (all(get_used("capillary") == 0) & all(get_used("macropososity") == 0)),
                            "-- capillaryUptake and capillaryUptakeMinWater are not active parameters when capillary = 0 or macropososity = 0.", "")
  drainage.error <- ifelse((is_mod("drainagePipesSpacing") | is_mod("drainagePipesDepth") | is_mod("waterConductivity") | is_mod("impermeableLayerDepth"))
                           & (all(get_used("artificialDrainage") == 0)& all(get_used("macropososity") == 0)),
                           "-- drainagePipesSpacing, drainagePipesDepth, waterConductivity, and impermeableLayerDepth are not active parameters when artificialDrainage = 0 or macroporosity = 0.",
                           "")
  denitrif.error <- ifelse((is_mod("denitrificationDepth") | is_mod("denitrificationRate")) & all(get_used("denitrification") == 0),
                           "-- denitrificationDepth and denitrificationRate are not active parameters when denitrification = 0.", "")
  watertable.error <- ifelse((is_mod("no3ConcentrationInWaterTable") | is_mod("nh4ConcentrationInWaterTable")) & all(get_used("waterTable") == 0),
                             "-- no3ConcentrationInWaterTable and nh4ConcentrationInWaterTable are not active parameters when waterTable = 0.", "")
  dm.error <- ifelse(any(get_used("artificialDrainage") == 1 & get_used("macroporosity") == 0),
                     "-- macroporosity mucst be activated (set to 1) if artificialDrainage is activated (set to 1).", "")
  cap.error <- ifelse(any(get_used("capillary") == 1 & get_used("macroporosity") == 0),
                      "-- macroporosity mucst be activated (set to 1) if capillary is activated (set to 1).", "")

  ## Timeseries Length Errors
  treePlanting.length.error <- ifelse(all(purrr::map_lgl(list(get_length("treePlantingYears"),
                                                              get_length("treePlantingDays")),
                                                         identical,
                                                         y = as.list(as.integer(tree.rows)))), "",
                                      "-- treePlantingYears and treePlantingDays must have the same length as the number of rows in the tree initialziation table")

  treePruning.length.error <- ifelse(all(purrr::map_lgl(list(get_length("treePruningProp"),
                                                             get_length("treePruningMaxHeight"),
                                                             get_length("treePruningDays")),
                                                        identical,
                                                        y = get_length("treePruningYears"))),
                                     "", "-- treePruningYears, treePruningProp, treePruningMaxHeight, and treePruningDays must have the same length")

  treeThinning.length.error <- ifelse(all(purrr::map_lgl(list(get_length("treeThinningYears"),
                                                              get_length("treeThinningDays")),
                                                         identical,
                                                         y = get_length("treeThinningIds"))),
                                      "", "-- treeThinningIds, treeThinningYears, and treeThinningDays must have the same length")

  rootPruning.length.error <- ifelse(all(purrr::map_lgl(list(get_length("treeRootPruningDays"),
                                                             get_length("treeRootPruningDistance"),
                                                             get_length("treeRootPruningDepth")),
                                                        identical,
                                                        y = get_length("treeRootPruningYears"))), "",
                                     "-- treeRootPruningYears, treeRootPruningDays, treeRootPruningDistance, and treeRootPruningDepth must have the same length")

  ## Root pruning depth less than max soil depth
  rp.depth.check <- purrr::map2_lgl(get_used("treeRootPruningDepth"),
                                    purrr::map(get_init_vals("layers", "thick"), function(x) max(cumsum(x))),
                                    less_than)
  if(!all(rp.depth.check)) warning("-- treeRootPruningDepth is greater than the maximum soil depth", call. = FALSE, immediate. = TRUE)

  ## Tree thinning ids <= number of trees
  tree.thinning.id.check <- purrr::map2_lgl(get_length("treeThinningIds"),
                                            purrr::map(get_init_vals("tree.initialization", "species"), length),
                                            less_than)
  tree.thinning.id.error <- ifelse(!all(rp.depth.check), "-- one or more values of treeThinningIds is greater than the number of simulated trees", "")

  ## Crop Length & Simulation Length Errors
  goes_evenly  <- function(x, y) x > y | y %% x == 0
  if(!all(purrr::map2_lgl(get_length("mainCropSpecies"), get_used("nbSimulations"), goes_evenly))) {
    warning("-- mainCropSpecies length does not go evenly into nbSimulations.", call. = FALSE, immediate. = TRUE)
  }
  if(!all(purrr::map2_lgl(get_length("interCropSpecies"), get_used("nbSimulations"), goes_evenly))) {
    warning("-- interCropSpecies length does not go evenly into nbSimulations.", call. = FALSE, immediate. = TRUE)
  }
  if(!all(purrr::map2_lgl(get_length("mainCropSpecies"), get_used("nbSimulations"), less_than))) {
    warning("-- length of mainCropSpecies is larger than value of nbSimulations", call. = FALSE, immediate. = TRUE)
  }
  if(!all(purrr::map2_lgl(get_length("interCropSpecies"), get_used("nbSimulations"), less_than))) {
    warning("-- length of interCropSpecies is larger than value of nbSimulations", call. = FALSE, immediate. = TRUE)
  }
  if(!all(purrr::map_lgl(get_length("simulationNbrDays"), equal_to, y = 1) | purrr::map2_lgl(get_length("mainCropSpecies"),
                                                                                             get_length("simulationNbrDays"), equal_to))) {
    warning("-- simulationNbrDays and mainCropSpecies should have the same length if simulationNbrDays does not have length 1", call. = FALSE, immediate. = TRUE)
  }

  ## Geometry Errors
  weed.error <- ifelse(any(get_used_un("treeCropDistance") > 0 & get_used_un("treeCropRadius") > 0),
                       "-- treeCropDistance and treeCropRadius can not both be greater than 0", "")

  ## All weatherFile files exist
  if("weatherFile" %in% names(hip$exp.plan)) {
    if(all(file.exists(hip$exp.plan$weatherFile))) {
      wth.error <- ""
    } else {
      missing.wth.files <- hip$exp.plan$weatherFile[!file.exists(hip$exp.plan$weatherFile)]
      wth.error <- paste("-- the following .WTH files do not exist:", paste(missing.wth.files, collapse = ", "))
    }
  } else {
    wth.error <- ""
  }

  all.errors <- c(errors,
                  unique.sim.error, unique.simname.error, simname.space.error,
                  unsupported.trees.error, too.many.trees.error,
                  unsupported.crops.error, unsupported.itks.error,
                  plot.width.error, plot.height.error,
                  treeCropDistance.error, treeRootPruningDistance.error,
                  tree.centered.error, tree.offscene.error, tree.coloc.error,
                  tree.root.error, EP.error,
                  capillary.error, drainage.error, denitrif.error, watertable.error, dm.error, cap.error,
                  treePlanting.length.error, treePruning.length.error, treeThinning.length.error, rootPruning.length.error,
                  tree.thinning.id.error, weed.error, wth.error)
  all.errors <- paste0(all.errors[!(all.errors == "") & !is.na(all.errors)], collapse = "\n")
  if(all.errors != errors) stop(all.errors, call. = FALSE)

  invisible(TRUE)
}

#' Check validity of Hi-sAFe accepted values
#' @description Checks validity of Hi-sAFe inputs accepted values found in the package param_defs.txt file
#' Used within \code{\link{check_input_values}}.
#' @return An error message or empty character stirng.
#' @param variable A character string of the name of the variable to check.
#' @param exp.plan The exp.plan of a "hip" object.
#' @keywords internal
check_accepted <- function(variable, exp.plan) {
  exp.plan <- dplyr::mutate_all(exp.plan, as.list)
  if(variable %in% INPUT.DEFS$name) {
    to.check <- unlist(exp.plan[[variable]])
    to.check <- to.check[!is.na(to.check)]
    if(length(to.check) == 0) return("")
    element.def <- dplyr::filter(INPUT.DEFS, name == variable)
    accepted.vals <- stringr::str_split(element.def$accepted, "; ?|, ?")[[1]]
    accepted.pass <- (all(is.na(accepted.vals)) | all(as.character(to.check) %in% accepted.vals))
    if(accepted.pass) {
      return("")
    } else {
      return(paste0("-- ", variable, " - must be one of: ", paste0(accepted.vals, collapse = ", ")))
    }
  } else {
    return("")
  }
}

#' Check validity of Hi-sAFe input ranges
#' @description Checks validity of Hi-sAFe inputs against accepted ranges found in the package param_defs.txt file
#' Used within \code{\link{check_input_values}}.
#' @return An error message or empty character stirng.
#' @param variable A character string of the name of the variable to check.
#' @param exp.plan The exp.plan of a "hip" object.
#' @keywords internal
check_range <- function(variable, exp.plan) {
  exp.plan <- dplyr::mutate_all(exp.plan, as.list)
  if(variable %in% INPUT.DEFS$name) {
    to.check <- unlist(exp.plan[[variable]])
    to.check <- to.check[!is.na(to.check)]
    if(length(to.check) == 0) return("")
    element.def <- dplyr::filter(INPUT.DEFS, name == variable)
    min.val  <- element.def$min
    max.val  <- element.def$max
    max.pass <- (is.na(max.val) | all(to.check <= max.val))
    min.pass <- (is.na(min.val) | all(to.check >= min.val))
    if(max.pass & min.pass) {
      return("")
    } else if(!is.na(max.val) & !is.na(min.val)) {
      return(paste0("-- ", variable, " - must be betwen ", min.val, " and ", max.val))
    } else if(is.na(max.val) & !is.na(min.val)) {
      return(paste0("-- ", variable, " - must be greater than ", min.val))
    } else if(!is.na(max.val) & is.na(min.val)) {
      return(paste0("-- ", variable, " - must be less than ", max.val))
    }
  } else {
    return("")
  }
}

#' Check validity of Hi-sAFe input numeric types
#' @description Checks validity of Hi-sAFe inputs against accepted numeric types (continuous, integer) found in the package param_defs.txt file
#' Used within \code{\link{check_input_values}}.
#' @return An error message or empty character stirng.
#' @param variable A character string of the name of the variable to check.
#' @param exp.plan The exp.plan of a "hip" object.
#' @keywords internal
check_type <- function(variable, exp.plan) {
  exp.plan <- dplyr::mutate_all(exp.plan, as.list)
  if(variable %in% INPUT.DEFS$name) {
    to.check <- unlist(exp.plan[[variable]])
    to.check <- to.check[!is.na(to.check)]
    if(length(to.check) == 0) return("")
    element.def <- dplyr::filter(INPUT.DEFS, name == variable)
    type  <- element.def$type
    if(is.na(type)) return("")
    if(type == "integer"){
      if(all(is.numeric(to.check))) {
        if(!all(to.check %% 1 == 0)) {
          return(paste0("-- ", variable, " - must be an integer"))
        } else {
          return("")
        }
      } else {
        return(paste0("-- ", variable, " - must be an integer"))
      }
    } else if(type == "real" & !all(is.numeric(to.check))){
      return(paste0("-- ", variable, " - must be numeric"))
    } else if(type == "character" & !all(is.character(to.check))){
      return(paste0("-- ", variable, " - must be a character string/vector"))
    } else {
      return("")
    }
  } else {
    return("")
  }
}

#' Generate root initialization table for define_hisafe
#' @description Generates a root initialization table suitable for passing to \code{\link{define_hisafe}}.
#' The output of this function is always passed to \code{\link{define_hisafe}} via the \code{root.initialization} argument
#' (see example below). Any passed parameters modify the table in the provided template.
#' @return A list containing a Hi-sAFE root initialization table.
#' @param template A character string of the path to the directory containing the template set of Hi-sAFe simulation folders/files to use.
#' See \code{\link{define_hisafe}} for more details.
#' @param rep Number of times to repeats the rows of the defined table.
#' @param ... Any parameters of Hi-sAFe root initialization table:
#'  \itemize{
#'  \item{"shape"}{}
#'  \item{"repartition"}{}
#'  \item{"paramShape1"}{}
#'  \item{"paramShape2"}{}
#'  \item{"paramShape3"}{}
#' }
#' @export
#' @family hisafe definition functions
#' @examples
#' \dontrun{
#' hip <- define_hisafe(path = getwd(), template = "agroforestry",
#'                      root.initialization = root_init_params(template    = "agroforestry",
#'                                                             paramShape1 = 0.5))
#' }
root_init_params <- function(template, reps = 1, ...) {
  supported <- c("shape", "repartition", "paramShape1", "paramShape2", "paramShape3")
  temp <- modify_table(args           = list(...),
                       supported.args = supported,
                       character.args = NULL,
                       numeric.args   = supported,
                       positive.args  = supported,
                       perc.args      = NULL,
                       table.name     = "root.initialization",
                       template       = template)

  out <- list(temp)
  if(reps > 1) {
    for(i in 2:reps) {
      out[[i]] <- temp
      out <- list(purrr::map_df(out, dplyr::bind_rows))
    }
  }
  return(out)
}

#' Generate tree initialization table for define_hisafe
#' @description Generates a tree initialization table suitable for passing to \code{\link{define_hisafe}}.
#' The output of this function is always passed to \code{\link{define_hisafe}} via the \code{tree.initialization} argument
#' (see example below). Any passed parameters modify the table in the provided template.
#' @return A list containing a Hi-sAFE tree initialization table.
#' @param template A character string of the path to the directory containing the template set of Hi-sAFe simulation
#' folders/files to use.
#' See \code{\link{define_hisafe}} for more details.
#' @param ... Any parameters of Hi-sAFe tree initialization table:
#'  \itemize{
#'  \item{"species"}{}
#'  \item{"height"}{}
#'  \item{"crownBaseHeight"}{}
#'  \item{"crownRadius"}{}
#'  \item{"treeX"}{}
#'  \item{"treeY"}{}
#' }
#' @export
#' @family hisafe definition functions
#' @examples
#' \dontrun{
#' hip <- define_hisafe(path = getwd(), template = "agroforestry",
#'                     tree.initialization = tree_init_params(template = "agroforestry",
#'                                                            height   = 2))
#' }
tree_init_params <- function(template, ...) {
  supported <- c("species", "height", "crownBaseHeight", "crownRadius", "treeX", "treeY")
  out <- modify_table(args           = list(...),
                      supported.args = supported,
                      character.args = "species",
                      numeric.args   = supported[supported != "species"],
                      positive.args  = supported[supported != "species"],
                      perc.args      = NULL,
                      table.name     = "tree.initialization",
                      template       = template)
  return(list(out))
}

#' Generate soil layer initialization table for define_hisafe
#' @description Generates a soil layer initialization table suitable for passing to \code{\link{define_hisafe}}.
#' The output of this function is always passed to \code{\link{define_hisafe}} via the \code{layer.initialization} argument
#' (see example below). Any passed parameters modify the table in the provided template.
#' @return A list containing a Hi-sAFE soil layer initialization table.
#' @param template A character string of the path to the directory containing the template set of Hi-sAFe simulation
#' folders/files to use.
#' See \code{\link{define_hisafe}} for more details.
#' @param ... Any parameters of Hi-sAFe soil layer initialization table:
#'  \itemize{
#'  \item{"waterContent"}{}
#'  \item{"no3Concentration"}{}
#'  \item{"nh4concentration"}{}
#' }
#' @export
#' @importFrom dplyr %>%
#' @family hisafe definition functions
#' @examples
#' \dontrun{
#' hip <- define_hisafe(path = getwd(),
#'                      layer.initialization = layer_init_params(template         = "agroforestry",
#'                                                               no3Concentration = c(40, 15, 5, 2, 0)))
#' }
layer_init_params <- function(template, ...) {
  supported <- c("waterContent", "no3Concentration", "nh4concentration")
  out <- modify_table(args           = list(...),
                      supported.args = supported,
                      numeric.args   = supported,
                      character.args = NULL,
                      positive.args  = supported,
                      perc.args      = NULL,
                      table.name     = "layer.initialization",
                      template       = template) %>%
    dplyr::mutate_all(function(x) format(x, nsmall = 1, trim = TRUE))

  if(nrow(out) > 5) stop(paste("Hi-sAFe supports a maximum of 5 soil layers"), call. = FALSE)

  return(list(out))
}

#' Generate soil layer table for define_hisafe
#' @description Generates a soil layer table suitable for passing to \code{\link{define_hisafe}}.
#' The output of this function is always passed to \code{\link{define_hisafe}} via the \code{layers} argument
#' (see example below). Any passed parameters modify the table in the provided template.
#' @return A list containing a Hi-sAFE soil layer table.
#' @param template A character string of the path to the directory containing the template set of Hi-sAFe simulation
#' folders/files to use.
#' See \code{\link{define_hisafe}} for more details.
#' @param ... Any parameters of Hi-sAFe soil layer table:
#'  \itemize{
#'  \item{"thick"}{}
#'  \item{"sand"}{}
#'  \item{"clay"}{}
#'  \item{"limeStone"}{}
#'  \item{"organicMatter"}{}
#'  \item{"partSizeSand"}{}
#'  \item{"stone"}{}
#'  \item{"stoneType"}{}
#'  \item{"infiltrability"}{}
#' }
#' @export
#' @importFrom dplyr %>%
#' @family hisafe definition functions
#' @examples
#' \dontrun{
#' hip <- define_hisafe(path = getwd(),
#'                      layers = layer_params(template     = "agroforestry",
#'                                            partSizeSand = 200))
#' }
layer_params <- function(template, ...) {
  supported <- c("thick", "sand", "clay", "limeStone", "organicMatter",
                 "partSizeSand", "stone", "stoneType", "infiltrability")
  out <- modify_table(args           = list(...),
                      supported.args = supported,
                      numeric.args   = supported,
                      character.args = NULL,
                      positive.args  = c("thick", "partSizeSand", "stoneType", "infiltrability"),
                      perc.args      = c("sand", "clay", "limeStone", "organicMatter", "stone"),
                      table.name     = "layers",
                      template       = template) %>%
    dplyr::mutate_at(.vars = dplyr::vars(-stoneType), .funs = function(x) format(x, nsmall = 1, trim = TRUE)) %>%
    dplyr::mutate(stoneType = format(stoneType, nsmall = 0, trim = TRUE))

  if(nrow(out) > 5) stop(paste("Hi-sAFe supports a maximum of 5 soil layers"), call. = FALSE)

  return(list(out))
}

#' Generate variety table for define_hisafe
#' @description Generates a variety table suitable for passing to \code{\link{define_hisafe}}.
#' The output of this function is always passed to \code{\link{define_hisafe}} via the \code{varieties} argument
#' (see example below). Any passed parameters modify the table in the provided template.
#' @return A list containing a Hi-sAFE variety table.
#' @param template A character string of the path to the directory containing the template set of Hi-sAFe simulation
#' folders/files to use.
#' See \code{\link{define_hisafe}} for more details.
#' @param ... Any parameters of Hi-sAFe variety table:
#'  \itemize{
#'  \item{"ID"}{}
#'  \item{"codevar"}{}
#'  \item{"stlevamf"}{}
#'  \item{"stamflax"}{}
#'  \item{"stlevdrp"}{}
#'  \item{"stflodrp"}{}
#'  \item{"stdrpdes"}{}
#'  \item{"pgrainmaxi"}{}
#'  \item{"adens"}{}
#'  \item{"croirac"}{}
#'  \item{"durvieF"}{}
#'  \item{"jvc"}{}
#'  \item{"sensiphot"}{}
#'  \item{"stlaxsen"}{}
#'  \item{"stsenlan"}{}
#'  \item{"nbgrmax"}{}
#'  \item{"stdrpmat"}{}
#'  \item{"afruitpot"}{}
#'  \item{"dureefruit"}{}
#' }
#' @export
#' @importFrom dplyr %>%
#' @family hisafe definition functions
#' @examples
#' \dontrun{
#' hip <- define_hisafe(path = getwd(),
#'                      varieties = variety_params(template = "monocrop",
#'                                                 croirac  = 0.1))
#' }
variety_params <- function(template, ...) {
  supported <- c("ID", "codevar", "stlevamf", "stamflax", "stlevdrp", "stflodrp", "stdrpdes",
                 "pgrainmaxi", "adens", "croirac", "durvieF", "jvc", "sensiphot", "stlaxsen",
                 "stsenlan", "nbgrmax", "stdrpmat", "afruitpot", "dureefruit")
  out <- modify_table(args           = list(...),
                      supported.args = supported,
                      numeric.args   = supported[supported != "codevar"],
                      character.args = "codevar",
                      positive.args  = supported[!(supported %in% c("codevar", "adens"))],
                      perc.args      = NULL,
                      table.name     = "varieties",
                      template       = template) %>%
    dplyr::mutate_at(.vars = dplyr::vars(ID, stlevamf, stamflax, stlevdrp, stflodrp, stdrpdes,
                                         durvieF, jvc,stlaxsen, stsenlan, nbgrmax, stdrpmat), .funs = function(x) format(x, nsmall = 0, trim = TRUE)) %>%
    dplyr::mutate_at(.vars = dplyr::vars(croirac, sensiphot, afruitpot, dureefruit), .funs = function(x) format(x, nsmall = 2, trim = TRUE)) %>%
    dplyr::mutate_at(.vars = dplyr::vars(pgrainmaxi, adens), .funs = function(x) format(x, nsmall = 5, trim = TRUE))

  return(list(out))
}

#' Build tables for table param functions
#' @description Builds tables for table param functions
#' @return A data.frame (tibble) containing a Hi-sAFE soil layer table.
#' @param args From table param function
#' @param supported.args From table param function
#' @param numeric.args From table param function
#' @param character.args From table param function
#' @param positive.args From table param function
#' @param perc.args From table param function
#' @param table.name From table param function
#' @param template From table param function
#' @keywords internal
modify_table <- function(args, supported.args, numeric.args, character.args, positive.args, perc.args, table.name, template) {
  unsupported.args <- names(args)[!(names(args) %in% supported.args)]
  if(length(unsupported.args) > 0) {
    stop(paste0("The following arguments are not supported: ", paste(unsupported.args, collapse = ", "),
                "\nSupported arguments include: ", paste(supported.args, collapse = ", ")), call. = FALSE)
  }

  errors <- ""
  for(i in numeric.args) {
    if(i %in% names(args)) if(!is.numeric(args[[i]]))               errors <- c(errors, paste("--", i, "must be numeric"))
  }
  for(i in character.args) {
    if(i %in% names(args)) if(!is.character(args[[i]]))             errors <- c(errors, paste("--", i, "must be character"))
  }
  for(i in positive.args) {
    if(i %in% names(args)) if(any(args[[i]] < 0))                   errors <- c(errors, paste("--", i, "must be greater than or equal to 0"))
  }
  for(i in perc.args) {
    if(i %in% names(args)) if(any(args[[i]] < 0 | args[[i]] > 100)) errors <- c(errors, paste("--", i, "must be between 0 and 100"))
  }

  error.starter <- "One or more arguments with incorrect values:"
  errors <- paste(c(error.starter, errors[!(errors == "")]), collapse = "\n")
  if(errors != error.starter) stop(errors, call. = FALSE)

  TEMPLATE_PARAMS <- get_template_params(template)
  PARAM_NAMES     <- get_param_names(TEMPLATE_PARAMS)
  PARAM_DEFAULTS  <- get_param_vals(TEMPLATE_PARAMS, "value")

  out <- PARAM_DEFAULTS[[table.name]][[1]]

  if(length(args) > 0) {
    while(nrow(out) < max(purrr::map_dbl(args, length))) {
      out <- dplyr::bind_rows(out, out[nrow(out),])
    }
  }

  for(arg in names(args)) {
    if(length(out[[arg]]) %% length(args[[arg]]) != 0) stop(paste("Length of provided", arg, "values does not go evenly into template table"), call. = FALSE)
    out[[arg]] <- args[[arg]]
  }

  return(out)
}
kevinwolz/hisafer documentation built on Oct. 19, 2020, 4:43 p.m.