diff --git a/DESCRIPTION b/DESCRIPTION index a84ab084..14186836 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -27,6 +27,7 @@ Imports: data.table, DBI, gh, + methods, pool, RPostgres, terra, diff --git a/NAMESPACE b/NAMESPACE index cd40b7ee..e2096c16 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,6 @@ # Generated by roxygen2: do not edit by hand +export(cache_clear) export(cache_path) export(climr_downscale) export(data_connect) @@ -41,10 +42,14 @@ importFrom(data.table,setDTthreads) importFrom(data.table,setcolorder) importFrom(data.table,setkey) importFrom(data.table,setorder) +importFrom(grDevices,hcl.colors) +importFrom(grDevices,palette) +importFrom(methods,is) importFrom(pool,dbPool) importFrom(pool,poolClose) importFrom(sf,st_as_sf) importFrom(sf,st_join) +importFrom(stats,complete.cases) importFrom(terra,"crs<-") importFrom(terra,as.list) importFrom(terra,as.matrix) diff --git a/R/cache.R b/R/cache.R index 3be9d89a..fc12a851 100644 --- a/R/cache.R +++ b/R/cache.R @@ -1,4 +1,4 @@ -# Cache utility +# Cache utilities #' Return package local cache path #' @@ -7,8 +7,9 @@ #' #' @return character. The full path of the package local cache. #' -#' @importFrom tools R_user_dir #' @export +#' @rdname Caching +#' @importFrom tools R_user_dir cache_path <- function() { getOption("climr.cache.path", default = R_user_dir("climr", "cache")) } @@ -46,3 +47,41 @@ cache_ask <- function(ask = interactive()) { return(TRUE) } } + + +#' Clear the package's local cache path +#' Attempts to delete all folder/files in `cache_path()`. +#' +#' @param what character. Which data folders should be cleared? +#' Accepts "normal", "gcm" or both. +#' +#' @details +#' It may fail if R has no permission to delete files/folders +#' in the `cache_path()` directory +#' +#' @return TRUE or FALSE depending on whether cache was cleared successfully +#' or not. +#' @rdname Caching +#' @export +cache_clear <- function(what = c("gcm", "normal", "historic")) { + what <- match.arg(what, several.ok = TRUE) + + fileList <- list.files(cache_path()) + fileList <- fileList[fileList %in% what] + fileList <- unlist(sapply(file.path(cache_path(), fileList), FUN = function(p) { + fileList <- list.files(p, recursive = TRUE, full.names = TRUE) + folderList <- list.dirs(p, recursive = TRUE, full.names = TRUE) + c(fileList, folderList) + }, + simplify = FALSE, USE.NAMES = FALSE)) + unlink(fileList, recursive = TRUE, force = TRUE) + + fileList2 <- list.files(cache_path(), recursive = TRUE, full.names = TRUE) + + if (any(fileList %in% fileList2)) { + warning("Unable to fully clear the cache. This may be due to restricted permissions.") + return(FALSE) + } else { + return(TRUE) + } +} diff --git a/R/climr-package.R b/R/climr-package.R index 6ad5d517..cab0c8be 100644 --- a/R/climr-package.R +++ b/R/climr-package.R @@ -3,21 +3,22 @@ #' @importFrom RPostgres dbGetQuery #' @noRd .onLoad <- function(libname, pkgname) { - if(!dir.exists(paste0(cache_path(), "/run_info/"))){ + rInfoPath <- file.path(R_user_dir("climr", "data"), "run_info") + + if (!dir.exists(rInfoPath)){ message("Downloading and Caching ESM run info :)") dbCon <- data_connect() - if(is.null(dbCon)){ + if (is.null(dbCon)){ warning("Could not connect to server. Only cached normal periods will be available.") - }else{ - dir.create(paste0(cache_path(), "/run_info/"), recursive = TRUE) + } else { + dir.create(rInfoPath, recursive = TRUE) gcm_period_runs <- dbGetQuery(dbCon, "select distinct mod, scenario, run from esm_layers order by mod, scenario, run;") 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, paste0(cache_path(), "/run_info/gcm_period.csv")) - fwrite(gcm_ts_runs, paste0(cache_path(), "/run_info/gcm_ts.csv")) - fwrite(gcm_hist_runs, paste0(cache_path(), "/run_info/gcm_hist.csv")) + fwrite(gcm_period_runs, file.path(rInfoPath, "gcm_period.csv")) + fwrite(gcm_period_runs, file.path(rInfoPath, "gcm_ts.csv")) + fwrite(gcm_period_runs, file.path(rInfoPath, "gcm_hist.csv")) } - } } diff --git a/R/downscale.R b/R/downscale.R index a5d4d9de..2f12d019 100644 --- a/R/downscale.R +++ b/R/downscale.R @@ -214,6 +214,8 @@ climr_downscale <- function(xyz, which_normal = c("auto", "BC", "NorAm"), histor #' #' @import data.table #' @importFrom terra extract rast sources ext xres yres crop plot as.polygons +#' @importFrom grDevices hcl.colors palette +#' @importFrom stats complete.cases #' #' @return A `data.table` or SpatVector with downscaled climate variables. If `gcm` is NULL, #' this is just the downscaled `normal` at point locations. If `gcm` is provided, @@ -821,6 +823,7 @@ process_one_historic <- function(historic_, res, xyzID, timeseries) { #' #' @importFrom terra vect crs #' @importFrom data.table as.data.table +#' @importFrom methods is addIDCols <- function(IDCols, results) { if(!is.null(IDCols)){ nm_order <- names(results) diff --git a/R/gcm.R b/R/gcm.R index 837299c3..6460c493 100644 --- a/R/gcm.R +++ b/R/gcm.R @@ -209,7 +209,9 @@ process_one_gcm2 <- function(gcm_nm, ssp, bbox, period, max_run, dbnames = dbnam gcmcode <- dbnames$dbname[dbnames$GCM == gcm_nm] gcm_nm <- gsub("-", ".", gcm_nm) - runs <- fread(paste0(cache_path(), "/run_info/gcm_period.csv")) + rInfoPath <- file.path(R_user_dir("climr", "data"), "run_info") + + runs <- fread(file.path(rInfoPath, "gcm_period.csv")) runs <- sort(unique(runs[mod == gcm_nm & scenario %in% ssp, run])) sel_runs <- runs[1:(max_run + 1L)] @@ -286,7 +288,9 @@ process_one_gcm2 <- function(gcm_nm, ssp, bbox, period, max_run, dbnames = dbnam process_one_gcm3 <- function(gcm_nm, years, dbCon, bbox, max_run, dbnames = dbnames_hist, cache) { ## need to update to all GCMs gcmcode <- dbnames$dbname[dbnames$GCM == gcm_nm] - runs <- fread(paste0(cache_path(), "/run_info/gcm_hist.csv")) + 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)] @@ -355,7 +359,10 @@ process_one_gcm3 <- function(gcm_nm, years, dbCon, bbox, max_run, dbnames = dbna #' @return a SpatRaster process_one_gcm4 <- function(gcm_nm, ssp, period, max_run, dbnames = dbnames_ts, bbox, dbCon, cache) { ## need to update to all GCMs gcmcode <- dbnames$dbname[dbnames$GCM == gcm_nm] - runs <- fread(paste0(cache_path(), "/run_info/gcm_ts.csv")) + + rInfoPath <- file.path(R_user_dir("climr", "data"), "run_info") + + runs <- fread(file.path(rInfoPath, "gcm_ts.csv")) runs <- sort(unique(runs[mod == gcm_nm & scenario %in% ssp, run])) if (length(runs) < 1) stop("That GCM isn't in our database yet.") sel_runs <- runs[1:(max_run + 1L)] diff --git a/R/globalVars.R b/R/globalVars.R index df6e9c67..bdb15abf 100644 --- a/R/globalVars.R +++ b/R/globalVars.R @@ -1,7 +1,5 @@ utils::globalVariables(c( - "Period", "Period1", "Period2", "Run", - "Scenario", "Year", "fullnm", "laynum", - "mod", "numlay", "period", "run", "var" + "..cols", "fullnm", "laynum", "mod", "numlay", "period", + "Period", "Period1", "Period2", "run", "Run", + "scenario", "Scenario", "skip_if_not_installed", "var", "Year" )) - -# diff --git a/R/lapserate.R b/R/lapserate.R index 71de2ff9..4db43f5f 100644 --- a/R/lapserate.R +++ b/R/lapserate.R @@ -13,10 +13,10 @@ recycle_borders <- function(mat, nr, nc) { # Instantiate an extended border representation res <- matrix(nrow = nr + 2L, ncol = nc + 2L) - + # Fill the representation starting with the original data in the center res[2L:(nr + 1L), 2L:(nc + 1L)] <- mat - + # Recycle the borders # North res[1L, 2L:(nc + 1L)] <- mat[1L,] @@ -26,7 +26,7 @@ recycle_borders <- function(mat, nr, nc) { res[2L:(nr + 1L), 1L] <- mat[, 1L] # East res[2L:(nr + 1L), nc + 2L] <- mat[, nc] - + # Recycle the corners # North-West res[1L, 1L] <- mat[1L, 1L] @@ -36,7 +36,7 @@ recycle_borders <- function(mat, nr, nc) { res[(nr + 2L), 1L] <- mat[nr, 1L] # South-East res[(nr + 2L), (nc + 2L)] <- mat[nr, nc] - + return(res) } @@ -141,7 +141,7 @@ fitted <- function(x, beta_coef) { deltas <- function(mat, nr, nc, NA_replace = TRUE) { # Reference values ref <- mat[c(-1L, -(nr + 2L)), c(-1L, -(nc + 2L))] - + # Surrounding values res <- list( northwest = mat[-(nr + 1L):-(nr + 2L), -(nc + 1L):-(nc + 2L)] - ref, @@ -153,12 +153,12 @@ deltas <- function(mat, nr, nc, NA_replace = TRUE) { southwest = mat[-1L:-2L, -(nc + 1L):-(nc + 2L)] - ref, west = mat[c(-1L, -(nr + 2L)), -(nc + 1L):-(nc + 2L)] - ref ) - + # Only the deltas are replaced by 0. if (isTRUE(NA_replace)) { res <- lapply(res, NArep) } - + return(res) } @@ -185,7 +185,7 @@ deltas <- function(mat, nr, nc, NA_replace = TRUE) { lapse_rate <- function(normal, dem, NA_replace = TRUE, nthread = 1L, rasterize = TRUE) { # Transform normal to list, capture names before normal_names <- names(normal) - + # Validation if (nlyr(normal) != 36L || !all(sprintf(c("PPT%02d", "Tmax%02d", "Tmin%02d"), sort(rep(1:12, 3))) %in% names(normal))) { stop( @@ -204,7 +204,7 @@ lapse_rate <- function(normal, dem, NA_replace = TRUE, nthread = 1L, rasterize = warning("Normal and Digital elevation model rasters have different extents. They must be the same. Resampling dem to match.") dem <- resample(dem, normal, method = "bilinear") } - + # Compute everything related to the dem and independant of normal n_r <- nrow(dem) n_c <- ncol(dem) @@ -217,7 +217,7 @@ lapse_rate <- function(normal, dem, NA_replace = TRUE, nthread = 1L, rasterize = n_sc <- length(x_i) # Sums of x squared sum_xx <- sum_matrix(sup(x_i, 2)) - + if (isTRUE(nthread > 1L)) { if (!requireNamespace("parallel")) { message("nthreads is >1, but 'parallel' package is not available.") @@ -236,10 +236,10 @@ lapse_rate <- function(normal, dem, NA_replace = TRUE, nthread = 1L, rasterize = } else { cl <- parallel::makePSOCKcluster(nthread) } - + # destroy cluster on exit on.exit(parallel::stopCluster(cl), add = TRUE) - + res <- parallel::parLapply( cl = cl, X = shush(lapply(as.list(normal), as.matrix, wide = TRUE)), @@ -264,7 +264,7 @@ lapse_rate <- function(normal, dem, NA_replace = TRUE, nthread = 1L, rasterize = NA_replace = NA_replace ) } - + # Transform back into SpatRaster if (isTRUE(rasterize)) { res <- shush( @@ -278,10 +278,10 @@ lapse_rate <- function(normal, dem, NA_replace = TRUE, nthread = 1L, rasterize = ) crs(res) <- crs(normal) } - + # Set names of lapse rates to match normal names(res) <- normal_names - + return(res) } diff --git a/man-roxygen/out_spatial.R b/man-roxygen/out_spatial.R index 3d72afa2..ff386353 100644 --- a/man-roxygen/out_spatial.R +++ b/man-roxygen/out_spatial.R @@ -1,2 +1,2 @@ #' @param out_spatial logical. Should a SpatVector be returned instead of a -#' `data.frame`. \ No newline at end of file +#' `data.frame`. diff --git a/man-roxygen/plot.R b/man-roxygen/plot.R index f35692aa..b79df1bf 100644 --- a/man-roxygen/plot.R +++ b/man-roxygen/plot.R @@ -1,4 +1,4 @@ #' @param plot character. If `out_spatial` is TRUE, the name of a variable to plot. #' If the variable exists in `normal`, then its normal values will also be plotted. #' Otherwise, normal January total precipitation (PPT01) values will be plotted. -#' Defaults to no plotting (NULL). \ No newline at end of file +#' Defaults to no plotting (NULL). diff --git a/man/cache_path.Rd b/man/Caching.Rd similarity index 52% rename from man/cache_path.Rd rename to man/Caching.Rd index 2f151cbd..d5af2f2d 100644 --- a/man/cache_path.Rd +++ b/man/Caching.Rd @@ -2,17 +2,33 @@ % Please edit documentation in R/cache.R \name{cache_path} \alias{cache_path} +\alias{cache_clear} \title{Return package local cache path} \usage{ cache_path() + +cache_clear(what = c("gcm", "normal", "historic")) +} +\arguments{ +\item{what}{character. Which data folders should be cleared? +Accepts "normal", "gcm" or both.} } \value{ character. The full path of the package local cache. + +TRUE or FALSE depending on whether cache was cleared successfully +or not. } \description{ Return package local cache path + +Clear the package's local cache path +Attempts to delete all folder/files in \code{cache_path()}. } \details{ By default, it uses \code{\link[tools:userdir]{tools::R_user_dir()}}. The cache location can be set using the \code{climr.cache.path} option with \code{options("climr.cache.path" = "your_path")}. + +It may fail if R has no permission to delete files/folders +in the \code{cache_path()} directory } diff --git a/tests/testthat/test-cache.R b/tests/testthat/test-cache.R new file mode 100644 index 00000000..67e6beda --- /dev/null +++ b/tests/testthat/test-cache.R @@ -0,0 +1,136 @@ +test_that("test cache in default location", { + dbCon <- data_connect() + on.exit(try(pool::poolClose(dbCon)), add = TRUE) + xyz <- data.frame(Long = c(-127.70521, -127.62279, -127.56235, -127.7162, + -127.18585, -127.1254, -126.94957, -126.95507), + Lat = c(55.3557, 55.38847, 55.28537, 55.25721, 54.88135, 54.65636, 54.6913, 54.61025), + Elev = c(291L, 296L, 626L, 377L, 424L, 591L, 723L, 633L), + ID = LETTERS[1:8], + Zone = c(rep("CWH",3), rep("CDF",5)), + Subzone = c("vm1","vm2","vs1",rep("mm",3),"dk","dc")) + + thebb <- get_bb(xyz) + + expect_identical(cache_path(), R_user_dir("climr", "cache")) + + expecteddirs <- normalizePath(file.path(cache_path(), c("gcm", "normal", "historic")), winslash = "/") + + cache_clear() + normal <- normal_input(dbCon = dbCon, bbox = thebb, cache = FALSE) + cachedirs <- normalizePath(list.dirs(cache_path(), recursive = FALSE), winslash = "/") + expect_false(any(expecteddirs %in% cachedirs)) + + gcm1 <- gcm_input( + dbCon, + thebb, + gcm = "BCC-CSM2-MR", + ssp = c("ssp126"), + period = "2041_2060", + max_run = 1, cache = FALSE + ) + cachedirs <- normalizePath(list.dirs(cache_path(), recursive = FALSE), winslash = "/") + expect_false(any(expecteddirs %in% cachedirs)) + + ds_res <- climr_downscale(xyz, which_normal = "BC", historic_period = "2001_2020", + cache = FALSE) + cachedirs <- normalizePath(list.dirs(cache_path(), recursive = FALSE), winslash = "/") + expect_false(any(expecteddirs %in% cachedirs)) + + normal <- normal_input(dbCon = dbCon, bbox = thebb) + expect_true("normal" %in% list.files(cache_path())) + + gcm1 <- gcm_input( + dbCon, + thebb, + gcm = "BCC-CSM2-MR", + ssp = c("ssp126"), + period = "2041_2060", + max_run = 1 + ) + expect_true("gcm" %in% list.files(cache_path())) + + ds_res <- climr_downscale(xyz, which_normal = "BC", historic_period = "2001_2020") + expect_true("historic" %in% list.files(cache_path())) + + + cache_clear("gcm") + expect_false("gcm" %in% list.files(cache_path())) + expect_true("normal" %in% list.files(cache_path())) + + gcm1 <- gcm_input( + dbCon, + thebb, + gcm = "BCC-CSM2-MR", + ssp = c("ssp126"), + period = "2041_2060", + max_run = 1 + ) + cache_clear("normal") + expect_false("normal" %in% list.files(cache_path())) + expect_true("gcm" %in% list.files(cache_path())) + + cache_clear("historic") + expect_true("gcm" %in% list.files(cache_path())) + expect_false("historic" %in% list.files(cache_path())) + + cache_clear() + ds_res <- climr_downscale(xyz, which_normal = "BC", historic_period = "2001_2020", + gcm_models = list_gcm()[1], gcm_period = "2041_2060") + cachedirs <- normalizePath(list.dirs(cache_path(), recursive = FALSE), winslash = "/") + test <- all(expecteddirs %in% cachedirs) + expect_true(test) + + cache_clear() + cachedirs <- normalizePath(list.dirs(cache_path(), recursive = FALSE), winslash = "/") + test <- all(expecteddirs %in% cachedirs) + expect_false(test) +}) + +test_that("test cache in custom location", { + opts <- options("climr.cache.path" = "~/test_climr") + on.exit(options(opts), add = TRUE) + expect_identical(cache_path(), "~/test_climr") + + expecteddirs <- suppressWarnings(normalizePath(file.path(cache_path(), c("gcm", "normal", "historic")), winslash = "/")) + + xyz <- data.frame(Long = c(-127.70521, -127.62279, -127.56235, -127.7162, + -127.18585, -127.1254, -126.94957, -126.95507), + Lat = c(55.3557, 55.38847, 55.28537, 55.25721, 54.88135, 54.65636, 54.6913, 54.61025), + Elev = c(291L, 296L, 626L, 377L, 424L, 591L, 723L, 633L), + ID = LETTERS[1:8], + Zone = c(rep("CWH",3), rep("CDF",5)), + Subzone = c("vm1","vm2","vs1",rep("mm",3),"dk","dc")) + + cache_clear() + ds_res <- climr_downscale(xyz, which_normal = "auto", historic_period = "2001_2020", + gcm_models = list_gcm()[1], gcm_period = "2041_2060") + + cachedirs <- normalizePath(list.dirs(cache_path(), recursive = FALSE), winslash = "/") + test <- all(expecteddirs %in% cachedirs) + expect_true(test) + + cache_clear() + cachedirs <- normalizePath(list.dirs(cache_path(), recursive = FALSE), winslash = "/") + test <- all(expecteddirs %in% cachedirs) + expect_false(test) +}) + +test_that("test cache works within same bbox", { + dbCon <- data_connect() + on.exit(try(pool::poolClose(dbCon)), add = TRUE) + + xyz <- data.frame(Long = c(-127.70521, -127.62279, -127.56235, -127.7162, + -127.18585, -127.1254, -126.94957, -126.95507), + Lat = c(55.3557, 55.38847, 55.28537, 55.25721, 54.88135, 54.65636, 54.6913, 54.61025), + Elev = c(291L, 296L, 626L, 377L, 424L, 591L, 723L, 633L), + ID = LETTERS[1:8], + Zone = c(rep("CWH",3), rep("CDF",5)), + Subzone = c("vm1","vm2","vs1",rep("mm",3),"dk","dc")) + thebb <- get_bb(xyz) + + cache_clear() + normal <- normal_input(dbCon = dbCon, bbox = thebb) + normal2 <- normal_input(dbCon = NULL, bbox = thebb) + + expect_true(terra::compareGeom(normal, normal2, res = TRUE, lyrs = TRUE, stopOnError = FALSE)) +}) \ No newline at end of file diff --git a/tests/testthat/test-calcfuns.R b/tests/testthat/test-calcfuns.R index b81ce53a..8ccd548d 100644 --- a/tests/testthat/test-calcfuns.R +++ b/tests/testthat/test-calcfuns.R @@ -45,11 +45,10 @@ test_that("calc_* functions work", { test_that("calc_* give sensible outputs", { - library(pool) - library(data.table) - library(terra) + testInit(c("data.table", "terra")) dbCon <- data_connect() + on.exit(try(pool::poolClose(dbCon)), add = TRUE) ## the following includes NAs for the test xyz <- data.frame(lon = c(-128, -125, -128, -125), lat = c(50, 50, 48, 48), elev = runif(4)) diff --git a/tests/testthat/test-climr_downscale.R b/tests/testthat/test-climr_downscale.R index 638fd5c7..b3680c97 100644 --- a/tests/testthat/test-climr_downscale.R +++ b/tests/testthat/test-climr_downscale.R @@ -1,9 +1,8 @@ test_that("test climr_dowscale", { -library(pool) -library(data.table) -library(terra) +testInit("data.table") dbCon <- data_connect() +on.exit(try(pool::poolClose(dbCon)), add = TRUE) ## a small area xyz <- structure(list(Long = c(-127.70521, -127.62279, -127.56235, -127.7162,