Devl

.Rbuildignore

@@ -1,6 +1,7 @@
 ^.*\.Rproj$
 ^\.Rproj\.user$
-^inputs$
+^inputs_raw$
+^inputs_pkg$
 ^scripts$
 ^\.git
 ^\.github$

DESCRIPTION

@@ -26,8 +26,7 @@ Imports:
     parallel,
     data.table,
     gh,
-    methods,
-    memoise
+    methods
 Depends: 
     R (>= 4.0)
 Suggests: 

NAMESPACE

@@ -1,11 +1,10 @@
 # Generated by roxygen2: do not edit by hand
 
-export(baseline)
 export(data_delete)
 export(data_path)
 export(data_update)
 export(downscale)
-export(future)
+export(gcm_input)
 export(lapse_rate)
 export(list_data)
 export(list_dem)
@@ -14,9 +13,9 @@ export(list_normal)
 export(list_period)
 export(list_ssp)
 export(list_variables)
+export(normal_input)
 import(data.table)
 importFrom(gh,gh)
-importFrom(memoise,memoise)
 importFrom(parallel,detectCores)
 importFrom(parallel,mclapply)
 importFrom(raster,brick)

R/data.R

@@ -1,19 +1,18 @@
 #' Update external package data
 #' @param dem A character. Relative path from the source root to digital elevation model files folder.
-#' Default to option value "climRpnw.dem.path" if set, or "inputs/digitalElevationModel".
+#' Default to option value "climRpnw.dem.path" if set, or "inputs_pkg/digitalElevationModel".
 #' @param gcm A character. Relative path from the source root to global circulation models files folder.
-#' Default to option value "climRpnw.gcm.path" if set, or "inputs/gcmData".
+#' Default to option value "climRpnw.gcm.path" if set, or "inputs_pkg/gcmData".
 #' @param normal A character. Relative path from the source root to base normal files folder.
-#' Default to option value "climRpnw.normal.path" if set, or "inputs/Normal_1961_1990MP".
 #' @param quiet A logical. If `TRUE`, suppress status messages (if any), and the progress bar.
 #' @param ... Others parameters such as `source` or `repo` for content getting functions.
 #' @details This package uses data that are too big to be included with sources.
 #' Instead, data is downloaded, optionally cached, when you need to run functions.
 #' @export
 data_update <- function(
-  dem = getOption("climRpnw.dem.path", default = "inputs/dem"),
-  gcm = getOption("climRpnw.gcm.path", default = "inputs/gcm"),
-  normal = getOption("climRpnw.normal.path", default = "inputs/normal"),
+  dem = getOption("climRpnw.dem.path", default = "inputs_pkg/dem"),
+  gcm = getOption("climRpnw.gcm.path", default = "inputs_pkg/gcm"),
+  normal = getOption("climRpnw.normal.path", default = "inputs_pkg/normal"),
   quiet = !interactive(),
   ...) {
 
@@ -125,7 +124,8 @@ data_delete <- function(ask = interactive()) {
     "climRpnw.session.tmp.path" = NULL,
     "climRpnw.dem.path" = NULL,
     "climRpnw.gcm.path" = NULL,
-    "climRpnw.normal.path" = NULL
+    "climRpnw.normal.path" = NULL,
+    "climRpnw.session.cache.ask.response" = NULL
   )
 
   return(invisible(TRUE))

R/downscale.R

@@ -1,114 +1,125 @@
 #' Downscale target rasters to points of interest
 #' @param xyz A 3-column matrix or data.frame (x, y, z) or (lon, lat, elev).
-#' @param normal Reference normal baseline climate variables rasters.
-#' @param gcm Future climate variables rasters, probably from Global Circulation Models. Default to NULL.
-#' @param extra_variables A character vector of extra variables to compute. Supported variables can be obtained
-#' with `list_variables(FALSE)`. Definitions can be found in this package `variables` dataset.
-#' Default to `character()`.
-#' @param grouping A character vector of variables grouping. Can be `m` (monthly), `s` (seasonal) or `a` (annual).
-#' @param use_cache A boolean. For lapse rate calculation, if `TRUE` and available,
-#'  uses cached computation. If `FALSE`, recompute. Default to `TRUE`.
-#' @details Couple first calls should be slower as it will cache the costly lapse rate
-#' computation. After that, it should be as quick as possible.
+#' @param normal Reference normal baseline input from `normal_input`.
+#' @param gcm Global Circulation Models input from `gcm_input`. Default to NULL.
+#' @param extra A character vector of extra variables to compute. Supported variables
+#' can be obtained with `list_variables(FALSE)`. Definitions can be found in this package
+#' `variables` dataset. Default to `character()`.
 #' @import data.table
 #' @importFrom terra extract
 #' @export
 #' @examples
 #' \dontrun{
 #' xyz <- data.frame(lon = runif(10, -140, -106), lat = runif(10, 37, 61), elev = runif(10))
-#' normal <- baseline()
-#' gcm <- future(list_gcm()[3], list_ssp()[1], list_period()[2])
+#' normal <- normal_input()
+#' gcm_input <- gcm_input(list_gcm()[3], list_ssp()[1], list_period()[2])
 #' downscale(xyz, normal, gcm)
 #' }
-downscale <- function(xyz, normal, gcm = NULL, extra_variables = character(), grouping = c("m", "s", "a"), use_cache = TRUE) {
+downscale <- function(xyz, normal, gcm = NULL, extra = character()) {
 
-  # Make sure normal was built using baseline
+  # Make sure normal was built using normal_input
   if (!isTRUE(attr(normal, "builder") == "climRpnw")) {
-    stop("Please use this package `baseline` function to create `normal`. See `?baseline` for details.")
+    stop(
+      "Please use this package `normal_input` function to create `normal`.",
+      " See `?normal_input` for details."
+    )
   }
 
-  # Make sure gcm was built using future
+  # Make sure gcm was built using gcm_input
   if (!is.null(gcm) && !isTRUE(attr(gcm, "builder") == "climRpnw")) {
-    stop("Please use this package `future` function to create `gcm`. See `?future` for details.")
+    stop(
+      "Please use this package `gcm_input` function to create `gcm`.",
+      " See `?gcm_input` for details."
+    )
   }
 
-  # Baseline value extraction
+  # Normal value extraction
   # possible garbage output :
   # Error in (function (x)  : attempt to apply non-function
   # Error in x$.self$finalize() : attempt to apply non-function
-  # Can ignore, trying to suppress messages
+  # Can ignore, trying to suppress messages with `shush`
   # https://github.com/rspatial/terra/issues/287
-  res <- try(
-    {terra::extract(x = normal, y = xyz[,1L:2L], method = "bilinear")},
-    silent = TRUE
-  )
-
-  # Compute lapse rates and cache for same session reprocessing
-  if (isTRUE(use_cache)) {
-    lapse_rates <- lapse_rate_mem(normal)
-  } else {
-    lapse_rates <- lapse_rate(normal)
-  }
+  res <- shush(terra::extract(x = normal, y = xyz[,1L:2L], method = "bilinear"))
 
   # Compute elevation differences between provided points elevation and normal
-  elev_delta <- xyz[,3L] - try(
-    {terra::extract(x = attr(normal, "dem"), y = xyz[,1L:2L], method = "simple")},
-    silent = TRUE
-  )[, -1L] # Remove ID column
+  elev_delta <- xyz[,3L] - shush(
+      terra::extract(x = attr(normal, "dem"), y = xyz[,1L:2L], method = "simple")
+  )[,-1L] # Remove ID column
 
   # Compute individual point lapse rate adjustments
-  lr <- elev_delta * try(
-    {terra::extract(x = lapse_rates, y = xyz[,1L:2L], method = "bilinear")},
-    silent = TRUE
-  )[,-1L]
+  lr <- elev_delta * shush(
+    terra::extract(x = attr(normal, "lapse_rates"), y = xyz[,1L:2L], method = "bilinear")
+  )[,-1L] # Remove ID column
 
-  # Combine results
+  # Combine results (ignoring ID column)
   res[,-1L] <- res[,-1L] + lr
 
-  process_one_fut <- function(fut) {
-    nm <- names(fut)
-    # Extract future / gcm bilinear interpolation
-    fut <- try(
-      {terra::extract(x = fut, y = xyz[,1L:2L], method = "bilinear")},
-      silent = TRUE
+  # Process one GCM stacked layers
+  process_one_gcm <- function(gcm_, res, xyz) {
+    # Store names for later use
+    nm <- names(gcm_)
+    # Extract gcm bilinear interpolations
+    gcm_ <- shush(terra::extract(x = gcm_, y = xyz[,1L:2L], method = "bilinear"))
+    # Create match set to match with res names
+    labels <- vapply(
+      strsplit(nm, "_"),
+      function(x) {paste0(x[2:3], collapse = "")},
+      character(1)
     )
-    # Find matching column in baseline
-    labels <- vapply(strsplit(nm, "_"), function(x) {paste0(x[2:3], collapse = "")}, character(1))
     labels <- gsub("pr", "PPT", labels)
     labels <- gsub("tas", "T", labels)
-    # Add matching column to fut and return
-    fut[,-1L] <- fut[,-1L] + res[,match(labels, names(res))]
+    # Add matching column to gcm_
+    gcm_[,-1L] <- gcm_[,-1L] + res[,match(labels, names(res))]
 
     # Reshape (melt / dcast) to obtain final form
     ref_dt <- data.table::tstrsplit(nm, "_")
-    # Recombine PERIOD
+    # Recombine PERIOD into one field
     ref_dt[[6]] <- paste(ref_dt[[6]], ref_dt[[7]], sep = "_")
     ref_dt[7] <- NULL
-    # Transform labels to data.table for remerging
+    # Transform ref_dt to data.table for remerging
     data.table::setDT(ref_dt)
     data.table::setnames(ref_dt, c("GCM", "VAR", "MONTH", "SSP", "RUN", "PERIOD"))
     data.table::set(ref_dt, j = "variable", value = nm)
-    data.table::set(ref_dt, j = "VAR", value = c("pr" = "PPT", "tasmin" = "Tmin", "tasmax" = "Tmax")[ref_dt[["VAR"]]])
+    data.table::set(
+      ref_dt,
+      j = "VAR",
+      # This is a quick trick to replace multiple elements in a character vector
+      # You can test it with c("a" = 2, "b" = 3)[c("b", "b")]
+      value = c("pr" = "PPT", "tasmin" = "Tmin", "tasmax" = "Tmax")[ref_dt[["VAR"]]]
+    )
     data.table::setkey(ref_dt, "variable")
 
-    # Melt fut and set the same key for merging
-    fut <- data.table::melt(data.table::setDT(fut), id.vars = "ID", variable.factor = FALSE)
-    data.table::setkey(fut, "variable")
+    # Melt gcm_ and set the same key for merging
+    gcm_ <- data.table::melt(
+      data.table::setDT(gcm_),
+      id.vars = "ID",
+      variable.factor = FALSE
+    )
+    data.table::setkey(gcm_, "variable")
 
-    # And dcast back to final form to get original 36 columns
-    fut <- data.table::dcast(fut[ref_dt,], ID + GCM + SSP + RUN + PERIOD ~ VAR + MONTH, value.var = "value", sep = "")
+    # Finally, dcast back to final form to get original 36 columns
+    gcm_ <- data.table::dcast(
+      # The merge with shared keys is as simple as that
+      gcm_[ref_dt,],
+      ID + GCM + SSP + RUN + PERIOD ~ VAR + MONTH,
+      value.var = "value",
+      sep = ""
+    )
 
-    return(fut)
+    return(gcm_)
   }
 
-  # User provided gcm
+  # In case user provided some gcm
   if (!is.null(gcm)) {
-    # Compute future
-    res <- data.table::rbindlist(lapply(gcm, process_one_fut), use.names = TRUE)
+    # Process each gcm and rbind resulting tables
+    res <- data.table::rbindlist(
+      lapply(gcm, process_one_gcm, res = res, xyz = xyz),
+      use.names = TRUE
+    )
   }
 
   # Compute extra climate variables, assign by reference
-  append_calc(res, extra_variables, grouping)
+  append_extra(res, extra)
 
   return(res)
 

R/extra.R

@@ -0,0 +1,33 @@
+#' Add extra climate variables to a data.table
+#' @param dt A data.table with TminXX, TmaxXX, PPTXX for XX in 01 to 12.
+#' @param extra A character vector of extra variables to compute.
+append_extra <- function(dt, extra) {
+
+  # Suffixes
+  s <- c("wt", "sp", "sm", "at")
+  m <- sprintf("%02d", 1:12)
+
+  #Deal with default variables first
+  # if ("s" %in% grouping) {
+  #   set(dt, j = paste0("")
+  # }
+  if ("DD_0" %in% extra) {
+    set(dt, j = paste0("DD_0_",m), value = {
+      lapply(1:12, function(x) {
+        calc_DD_below_0(x, dt[, rowMeans(.SD), .SDcols = sprintf("%s%02d", c("Tmin", "Tmax"), x)])
+      })
+    })
+  }
+}
+
+#' List climate variables
+#' @param only_extra A boolean. Should Tmin, Tmax and PPT be excluded? Default to TRUE.
+#' @export
+list_variables <- function(only_extra = TRUE) {
+  if (FALSE) { variables <- NULL }
+  res <- variables[["Code"]]
+  if (isTRUE(only_extra)) {
+    res <- res[!grepl("(^PPT|^Tmax|^Tmin)", res)]
+  }
+  return(sort(unique(res)))
+}