recommitting kiri's changes for run_nm

bcgov · Aug 19, 2024 · ac7bbb2 · ac7bbb2
1 parent da479b2
commit ac7bbb2
Show file tree

Hide file tree

Showing 10 changed files with 112 additions and 36 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -20,7 +20,8 @@ export(list_gcms)
 export(list_obs_periods)
 export(list_obs_years)
 export(list_refmaps)
-export(list_run)
+export(list_runs_historic)
+export(list_runs_ssp)
 export(list_ssps)
 export(list_vars)
 export(pgGetTerra)

diff --git a/R/climr-package.R b/R/climr-package.R
@@ -30,8 +30,8 @@ NULL
     gcm_ts_runs <- dbGetQuery(dbCon, "select distinct mod, scenario, run from esm_layers_ts order by mod, scenario, run;")
     gcm_hist_runs <- dbGetQuery(dbCon, "select distinct mod, run from esm_layers_hist order by mod, run;")
     fwrite(gcm_period_runs, file.path(rInfoPath, "gcm_periods.csv"))
-    fwrite(gcm_period_runs, file.path(rInfoPath, "gcm_ts.csv"))
-    fwrite(gcm_period_runs, file.path(rInfoPath, "gcm_hist.csv"))
+    fwrite(gcm_ts_runs, file.path(rInfoPath, "gcm_ts.csv"))
+    fwrite(gcm_hist_runs, file.path(rInfoPath, "gcm_hist.csv"))
   }
 }
 

diff --git a/R/data-lists.R b/R/data-lists.R
@@ -36,17 +36,34 @@ list_gcm_periods <- function() {
   c("2001_2020", "2021_2040", "2041_2060", "2061_2080", "2081_2100")
 }
 
+
 #' @description
-#' `list_run` lists available runs for a given GCM.
-#'
-#' @template dbCon
-#' @param gcms Character vector to specify requested GCMs
-#' @importFrom RPostgres dbGetQuery
-#'
+#' lists available runs for a given GCM/ssp.
+#' @param gcm Name of GCM
+#' @param ssp Name of scenario
+#' @importFrom data.table fread
+#' @importFrom tools R_user_dir
+#' 
+#' @rdname data-option-lists
+#' @export
+list_runs_ssp <- function(gcm, ssp){
+  rInfoPath <- file.path(R_user_dir("climr", "data"), "run_info")
+  runs <- fread(file.path(rInfoPath, "gcm_periods.csv"))
+  runs[mod == gcm & scenario == ssp, run]
+}
+
+#' @description
+#' lists available runs for a given historic GCM.
+#' @param gcm Name of GCM
+#' @importFrom data.table fread
+#' @importFrom tools R_user_dir
+#' 
 #' @rdname data-option-lists
 #' @export
-list_run <- function(dbCon, gcms) {
-  sort(dbGetQuery(dbCon, paste0("SELECT DISTINCT run FROM esm_layers_period WHERE mod IN ('", paste(gcms, collapse = "','", "')")))[, 1])
+list_runs_historic <- function(gcm){
+  rInfoPath <- file.path(R_user_dir("climr", "data"), "run_info")
+  runs <- fread(file.path(rInfoPath, "gcm_hist.csv"))
+  runs[mod == gcm, run]
 }
 
 #' @description

diff --git a/R/downscale.R b/R/downscale.R
@@ -52,6 +52,7 @@
 #'   historical scenario. See [`list_gcm_hist_years()`] for available years.
 #'   Defaults to `NULL`.
 #' @template max_run
+#' @template run_nm
 #' @param cache logical. Cache data locally? Default `TRUE`
 #' @param ... other arguments passed to [`downscale_core()`]. Namely: `return_refperiod`,
 #'   `vars`, `out_spatial` and `plot`
@@ -112,14 +113,15 @@ downscale <- function(xyz, which_refmap = "auto",
                       gcms = NULL, ssps = NULL,
                       gcm_periods = NULL, gcm_ssp_years = NULL,
                       gcm_hist_years = NULL, max_run = 0L,
+                      run_nm = NULL,
                       cache = TRUE, ...) {
   message("Welcome to climr!")
 
   ## checks
   .checkDwnsclArgs(
     xyz, which_refmap, obs_periods, obs_years, obs_ts_dataset,
     gcms, ssps, gcm_periods, gcm_ssp_years,
-    gcm_hist_years, max_run
+    gcm_hist_years, max_run, run_nm
   )
 
   expectedCols <- c("lon", "lat", "elev", "id")
@@ -197,6 +199,7 @@ downscale <- function(xyz, which_refmap = "auto",
         ssps = ssps,
         period = gcm_periods,
         max_run = max_run,
+        run_nm = run_nm,
         cache = cache
       )
     } else {
@@ -209,6 +212,7 @@ downscale <- function(xyz, which_refmap = "auto",
         years = gcm_ssp_years,
         max_run = max_run,
         cache = cache,
+        run_nm = run_nm,
         fast = TRUE
       )
     } else {
@@ -219,6 +223,7 @@ downscale <- function(xyz, which_refmap = "auto",
         bbox = thebb, gcms = gcms,
         years = gcm_hist_years,
         max_run = max_run,
+        run_nm = run_nm,
         cache = cache
       )
     } else {
@@ -228,7 +233,7 @@ downscale <- function(xyz, which_refmap = "auto",
     gcm_ssp_periods <- gcm_ssp_ts <- gcm_hist_ts <- NULL
   }
 
-  message("Downscaling!!")
+  message("Downscaling...")
   results <- downscale_core(
     xyz = xyz,
     refmap = reference,
@@ -283,10 +288,14 @@ downscale <- function(xyz, which_refmap = "auto",
 #' @noRd
 .checkDwnsclArgs <- function(xyz, which_refmap = NULL, obs_periods = NULL, obs_years = NULL,
                              obs_ts_dataset = NULL, gcms = NULL, ssps = list_ssps(), gcm_periods = NULL, gcm_ssp_years = NULL,
-                             gcm_hist_years = NULL, max_run = 0L) {
+                             gcm_hist_years = NULL, max_run = 0L, run_nm = NULL) {
   if (is.null(ssps) & (!is.null(gcm_periods) | !is.null(gcm_ssp_years))) {
     stop("ssps must be specified")
   }
+
+  if(!is.null(run_nm) & max_run > 1){
+    warning("max_run is > 0, but run_nm is specified. Only named runs will be returned.")
+  }
 
   if (!is.null(ssps)) {
     notSupportedSsps <- setdiff(ssps, list_ssps())

diff --git a/R/gcm.R b/R/gcm.R
@@ -14,6 +14,7 @@
 #' @template period
 #' @template max_run
 #' @template cache
+#' @template run_nm
 #'
 #' @details
 #' This function returns a list with one slot for each requested GCM. Rasters inside the list contain anomalies for all requested SSPs, runs, and periods.
@@ -69,7 +70,8 @@ input_gcms <- function(dbCon, bbox = NULL, gcms = list_gcms(), ssps = list_ssps(
   res <- sapply(gcms, process_one_gcm2,
     ssps = ssps, period = period,
     bbox = bbox, dbnames = dbnames, dbCon = dbCon,
-    max_run = max_run, cache = cache, USE.NAMES = TRUE, simplify = FALSE
+    max_run = max_run, cache = cache, run_nm = run_nm, 
+    USE.NAMES = TRUE, simplify = FALSE
   )
   attr(res, "builder") <- "climr"
 
@@ -89,6 +91,7 @@ input_gcms <- function(dbCon, bbox = NULL, gcms = list_gcms(), ssps = list_ssps(
 #'   See [`list_gcm_hist_years()`] for available years.
 #' @template max_run
 #' @template cache
+#' @template run_nm
 #'
 #' @seealso [list_gcm_periods()], [`list_gcm_periods()`]
 #'
@@ -107,7 +110,7 @@ input_gcms <- function(dbCon, bbox = NULL, gcms = list_gcms(), ssps = list_ssps(
 #' @rdname gcms-input-data
 #' @export
 input_gcm_hist <- function(dbCon, bbox = NULL, gcms = list_gcms(),
-                           years = 1901:2014, max_run = 0L, cache = TRUE) {
+                           years = 1901:2014, max_run = 0L, cache = TRUE, run_nm = NULL) {
   ## checks
   if (!is.null(bbox)) {
     .check_bb(bbox)
@@ -117,7 +120,7 @@ input_gcm_hist <- function(dbCon, bbox = NULL, gcms = list_gcms(),
   res <- sapply(gcms, process_one_gcm3,
     years = years,
     dbCon = dbCon, bbox = bbox, dbnames = dbnames_hist,
-    max_run = max_run, cache = cache, USE.NAMES = TRUE, simplify = FALSE
+    max_run = max_run, cache = cache, run_nm = run_nm, USE.NAMES = TRUE, simplify = FALSE
   )
   res <- res[!sapply(res, is.null)] ## remove NULL
   attr(res, "builder") <- "climr"
@@ -144,6 +147,7 @@ input_gcm_hist <- function(dbCon, bbox = NULL, gcms = list_gcms(),
 #'   See [`list_gcm_ssp_years()`] for available years.
 #' @template max_run
 #' @template cache
+#' @template run_nm
 #' @param fast Logical. Should we use the faster method of downloading data from the database using arrays instead of Postgis rasters?
 #'
 #' @return A `list` of `SpatRasters`, each with possibly multiple layers, that can
@@ -164,7 +168,7 @@ input_gcm_hist <- function(dbCon, bbox = NULL, gcms = list_gcms(),
 #' @rdname gcms-input-data
 #' @export
 input_gcm_ssp <- function(dbCon, bbox = NULL, gcms = list_gcms(), ssps = list_ssps(),
-                         years = 2020:2030, max_run = 0L, cache = TRUE, fast = TRUE) {
+                         years = 2020:2030, max_run = 0L, cache = TRUE, run_nm = NULL, fast = TRUE) {
 
   ## checks
   if (!is.null(bbox)) {
@@ -177,13 +181,13 @@ input_gcm_ssp <- function(dbCon, bbox = NULL, gcms = list_gcms(), ssps = list_ss
     res <- sapply(gcms, process_one_gcmts_fast,
                   ssps = ssps, period = years,
                   dbnames = dbnames_ts_fast, bbox = bbox, dbCon = dbCon,
-                  max_run = max_run, cache = cache, USE.NAMES = TRUE, simplify = FALSE
+                  max_run = max_run, cache = cache, run_nm = run_nm, USE.NAMES = TRUE, simplify = FALSE
     )
   }else{
     res <- sapply(gcms, process_one_gcm4,
                   ssps = ssps, period = years,
                   dbnames = dbnames_ts, bbox = bbox, dbCon = dbCon,
-                  max_run = max_run, cache = cache, USE.NAMES = TRUE, simplify = FALSE
+                  max_run = max_run, cache = cache, run_nm = run_nm, USE.NAMES = TRUE, simplify = FALSE
     )
   }
 
@@ -237,23 +241,27 @@ list_unique <- function(files, col_num) {
 #'   corresponding names in the PostGIS data base.  See climr:::dbnames
 #' @template dbCon
 #' @template cache
+#' @template run_nm
 #'
 #' @importFrom tools R_user_dir
 #' @importFrom data.table fread
 #'
 #' @return `SpatRaster`
 #' @noRd
-process_one_gcm2 <- function(gcm_nm, ssps, bbox, period, max_run, dbnames = dbnames, dbCon, cache, run_nm = NULL) { ## need to update to all GCMs
+process_one_gcm2 <- function(gcm_nm, ssps, bbox, period, max_run, dbnames = dbnames, dbCon, cache, run_nm) { ## need to update to all GCMs
   gcmcode <- dbnames$dbname[dbnames$GCM == gcm_nm]
   # gcm_nm <- gsub("-", ".", gcm_nm)
 
   rInfoPath <- file.path(R_user_dir("climr", "data"), "run_info")
 
+  runs <- fread(file.path(rInfoPath, "gcm_periods.csv"))
+  runs <- sort(unique(runs[mod == gcm_nm & scenario %in% ssps, run]))
   if(is.null(run_nm)){
-    runs <- fread(file.path(rInfoPath, "gcm_periods.csv"))
-    runs <- sort(unique(runs[mod == gcm_nm & scenario %in% ssps, run]))
     sel_runs <- runs[1:(max_run + 1L)]
   }else{
+    if(!run_nm %in% runs){
+      stop("Run ", run_nm, "doesn't exist for this GCM.")
+    }
     sel_runs <- run_nm
   }
 
@@ -362,21 +370,30 @@ process_one_gcm2 <- function(gcm_nm, ssps, bbox, period, max_run, dbnames = dbna
 #' @param dbnames `data.frame` with the list of available GCMs (historical projections)
 #'   and their corresponding names in the PostGIS data base. See climr:::dbnames_hist
 #' @template cache
+#' @template run_nm
 #'
 #' @importFrom tools R_user_dir
 #' @importFrom data.table fread
 #'
 #' @return `SpatRaster`
 #' @noRd
-process_one_gcm3 <- function(gcm_nm, years, dbCon, bbox, max_run, dbnames = dbnames_hist, cache) { ## need to update to all GCMs
+process_one_gcm3 <- function(gcm_nm, years, dbCon, bbox, max_run, dbnames = dbnames_hist, cache, run_nm) { ## need to update to all GCMs
   if (gcm_nm %in% dbnames$GCM) {
     gcmcode <- dbnames$dbname[dbnames$GCM == gcm_nm]
 
     rInfoPath <- file.path(R_user_dir("climr", "data"), "run_info")
 
     runs <- fread(file.path(rInfoPath, "gcm_hist.csv"))
     runs <- sort(unique(runs[mod == gcm_nm, run]))
-    sel_runs <- runs[1:(max_run + 1L)]
+    if(is.null(run_nm)){
+      sel_runs <- runs[1:(max_run + 1L)]
+    }else{
+      if(!run_nm %in% runs){
+        stop("Run ", run_nm, "doesn't exist for this GCM.")
+      }
+      sel_runs <- run_nm
+    }
+
 
     ## check cached
     needDownload <- TRUE
@@ -475,13 +492,14 @@ process_one_gcm3 <- function(gcm_nm, years, dbCon, bbox, max_run, dbnames = dbna
 #' @template bbox
 #' @template dbCon
 #' @template cache
+#' @template run_nm
 #'
 #' @importFrom tools R_user_dir
 #' @importFrom data.table fread
 #'
 #' @return a `SpatRaster`
 #' @noRd
-process_one_gcm4 <- function(gcm_nm, ssps, period, max_run, dbnames = dbnames_ts, bbox, dbCon, cache) { ## need to update to all GCMs
+process_one_gcm4 <- function(gcm_nm, ssps, period, max_run, dbnames = dbnames_ts, bbox, dbCon, cache, run_nm) { ## need to update to all GCMs
   if (gcm_nm %in% dbnames$GCM) {
     gcmcode <- dbnames$dbname[dbnames$GCM == gcm_nm]
 
@@ -492,7 +510,14 @@ process_one_gcm4 <- function(gcm_nm, ssps, period, max_run, dbnames = dbnames_ts
     if (length(runs) < 1) {
       warning("That GCM isn't in our database yet.")
     } else {
-      sel_runs <- runs[1:(max_run + 1L)]
+      if(is.null(run_nm)){
+        sel_runs <- runs[1:(max_run + 1L)]
+      }else{
+        if(!run_nm %in% runs){
+          stop("Run ", run_nm, "doesn't exist for this GCM.")
+        }
+        sel_runs <- run_nm
+      }
 
       ## check cached
       needDownload <- TRUE
@@ -616,12 +641,13 @@ process_one_gcm4 <- function(gcm_nm, ssps, period, max_run, dbnames = dbnames_ts
 #' @template bbox
 #' @template dbCon
 #' @template cache
+#' @template run_nm
 #'
 #' @importFrom tools R_user_dir
 #'
 #' @return a `SpatRaster`
 #' @noRd
-process_one_gcmts_fast <- function(gcm_nm, ssps, period, max_run, dbnames = dbnames_ts, bbox, dbCon, cache) { ## need to update to all GCMs
+process_one_gcmts_fast <- function(gcm_nm, ssps, period, max_run, dbnames = dbnames_ts, bbox, dbCon, cache, run_nm) { 
   if(gcm_nm %in% dbnames$GCM){
     gcmcode <- dbnames$dbname[dbnames$GCM == gcm_nm]
     gcmarray <- dbnames$dbarray[dbnames$GCM == gcm_nm]
@@ -632,7 +658,15 @@ process_one_gcmts_fast <- function(gcm_nm, ssps, period, max_run, dbnames = dbna
     if (length(runs) < 1) {
       warning("That GCM isn't in our database yet.")
     }else{
-      sel_runs <- runs[1:(max_run + 1L)]
+      if(is.null(run_nm)){
+        sel_runs <- runs[1:(max_run + 1L)]
+      }else{
+        if(!run_nm %in% runs){
+          stop("Run ", run_nm, "doesn't exist for this GCM.")
+        }
+        sel_runs <- run_nm
+      }
+
 
       ## check cached
       needDownload <- TRUE

diff --git a/data_processing/Test_Script.R b/data_processing/Test_Script.R
@@ -1,4 +1,5 @@
 library(data.table)
+
 library(terra)
 library(climr)
 
@@ -33,7 +34,8 @@ plot(test)
 my_grid <- as.data.frame(dem, cells = TRUE, xy = TRUE)
 colnames(my_grid) <- c("id", "lon", "lat", "elev") # rename column names to what climr expects
 climr <- downscale(
-  xyz = my_grid, which_refmap = "refmap_climatena", vars = "MAT"
+  xyz = my_grid, which_refmap = "refmap_climatena", gcms = list_gcms()[1], ssps = list_ssps()[1:3], 
+  gcm_periods = list_gcm_periods(), run_nm = "r1i1p1f1", vars = "MAT"
 )
 
 X <- rast(dem) 

diff --git a/man-roxygen/run_nm.R b/man-roxygen/run_nm.R
@@ -0,0 +1 @@
+#' @param run_nm character. `NULL` or length >= 1. Name of specified run(s) to return, instead of using `max_run`. Use the `list_runs_*()` functions to list available runs.Defaults to `NULL`.