Merge pull request #152 from CeresBarros/136-need-a-function-to-clear…

…-the-cache

136 need a function to clear the cache

DESCRIPTION

@@ -27,6 +27,7 @@ Imports:
     data.table,
     DBI,
     gh,
+    methods,
     pool,
     RPostgres,
     terra,

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)

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)
+  }
+}

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"))
     }
-
   }
 }
 

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)

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)]

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"
 ))
-
-#

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)
 }
 

man-roxygen/out_spatial.R

@@ -1,2 +1,2 @@
 #' @param out_spatial logical. Should a SpatVector be returned instead of a
-#'   `data.frame`.
+#'   `data.frame`.

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).
+#'   Defaults to no plotting (NULL).