.reproducibleTempCacheDir shouldn't be getOption(reproducible.cachePath) -- use tempPath

DESCRIPTION

@@ -19,8 +19,8 @@ SystemRequirements: 'unrar' (Linux/macOS) or '7-Zip' (Windows) to work with '.ra
 URL: 
     https://reproducible.predictiveecology.org,
     https://github.com/PredictiveEcology/reproducible
-Date: 2023-10-18
-Version: 2.0.8.9008
+Date: 2023-11-05
+Version: 2.0.8.9015
 Authors@R: 
     c(person(given = "Eliot J B",
              family = "McIntire",

NEWS.md

@@ -4,9 +4,23 @@
 * new function `isUpdated()` to determine whether a cached object has been updated;
 * `makeRelative()` is now exported for use downstream (e.g., `SpaDES.core`);
 * new functions `getRelative()` and `normPathRel()` for improved symlink handling (#362);
+* messaging is improved for `Cache` with the function named instead of just `cacheId`
+* messaging for `prepInputs`: minor changes
+* more edge cases for `Checksums` dealt with, so fewer unneeded downloads
+* `wrapSpatRaster` (`wrap` for file-backed `spatRaster` objects) fixes for more edge cases
+* `postProcessTo` can now use `sf::gdal_utils` for the case of `from` is a gridded object and `to` is a polygon vector. This appears to be between 2x and 10x faster in tests.
+* `postProcessTo` does a pre-crop (with buffer) to make the `projectTo` faster. When both `from` and `to` are vector objects, this pre-crop appears to create slivers in some cases. This step is now skipped for these cases.
+* `Cache` can now deal with unnamed functions, e.g., `Cache((function(x) x)())`
+* `terra` would fail if internet was unavailable, even when internet is not necessary, due to needing to retrieve projection information. Many cases where this happens will now divert to use `sf`.
+* `Cache` can now skip calculating `objSize`, which can take a non-trivial amount of time for large, complicated objects; see `reproducibleOptions()`
 
 ## Bug fixes
 * Filenames for some classes returned ""; now returns NULL so character vectors are only pointers to files
+* Cache on a terra object that writes file to disk, when `quick` argument is specified was failing, always creating the same object; fixed with #PR368
+* `useDBI` was incorrectly used if a user had set the option prior to package loading. Now works as expected.
+* several other minor
+* `preProcess` deals better with more cases of nested paths in archives.
+* more edge cases corrected for `inputPaths`
 
 # reproducible 2.0.8
 

R/DBI.R

@@ -114,8 +114,6 @@ saveToCache <- function(cachePath = getOption("reproducible.cachePath"),
 
   fts <- CacheStoredFile(cachePath, cacheId, obj = obj)
 
-  # browser(expr = exists("._saveToCache_2"))
-
   # TRY link first, if there is a linkToCacheId, but some cases will fail; not sure what these cases are
   if (!is.null(linkToCacheId)) {
     ftL <- CacheStoredFile(cachePath, linkToCacheId)
@@ -125,8 +123,8 @@ saveToCache <- function(cachePath = getOption("reproducible.cachePath"),
     if (is(out, "try-error") || !all((out %in% TRUE))) {
       linkToCacheId <- NULL
     } else {
-      messageCache("  (A file with identical properties already exists in the Cache: ", basename(ftL), "; ",
-        "The newly added (", basename(fts), ") is a file.link to that file)",
+      messageCache("  (A file with identical properties already exists in the Cache: ", basename(ftL), "; ")
+      messageCache("    The newly added (", basename(fts), ") is a file.link to that file)",
         verbose = verbose
       )
     }
@@ -140,8 +138,6 @@ saveToCache <- function(cachePath = getOption("reproducible.cachePath"),
   )
   if (!useDBI()) {
     dtFile <- saveDBFileSingle(dt = dt, cachePath, cacheId)
-    # dtFile <- CacheDBFileSingle(cachePath = cachePath, cacheId = cacheId)
-    # saveFilesInCacheFolder(dt, dtFile, cachePath = cachePath, cacheId = cacheId)
   } else {
     a <- retry(retries = 250, exponentialDecayBase = 1.01, quote(
       DBI::dbAppendTable(conn, CacheDBTableName(cachePath, drv), dt)
@@ -152,12 +148,9 @@ saveToCache <- function(cachePath = getOption("reproducible.cachePath"),
     fs <- saveFilesInCacheFolder(cachePath = cachePath, obj, fts, cacheId = cacheId)
   }
   if (isTRUE(getOption("reproducible.useMemoise"))) {
-    if (is.null(.pkgEnv[[cachePath]])) {
-      .pkgEnv[[cachePath]] <- new.env(parent = emptyenv())
-    }
     obj <- .unwrap(obj, cachePath, cacheId, drv, conn) # This takes time, but whether it happens now or later, same
     obj2 <- makeMemoisable(obj)
-    assign(cacheId, obj2, envir = .pkgEnv[[cachePath]])
+    assign(cacheId, obj2, envir = memoiseEnv(cachePath))
   }
 
   fsChar <- as.character(fs)
@@ -175,9 +168,9 @@ saveToCache <- function(cachePath = getOption("reproducible.cachePath"),
   #  So effectively, it is like 6x buffer to try to avoid false positives.
   whichOS <- which(tagKey == "object.size")
   if (length(whichOS)) {
-    fsBig <- (as.numeric(tagValue[whichOS]) * 4) < fs
+    objSize <- if (identical(tagValue[whichOS], "NA")) NA else as.numeric(tagValue[whichOS])
+    fsBig <- (objSize * 4) < fs
     if (isTRUE(fsBig)) {
-      # browser(expr = exists("._saveToCache_3"))
       messageCache("Object with cacheId ", cacheId, " appears to have a much larger size ",
         "on disk than in memory. ",
         "This usually means that the object has captured an environment with ",
@@ -201,13 +194,14 @@ saveToCache <- function(cachePath = getOption("reproducible.cachePath"),
 #'   the `cacheId` being loaded or selected
 #' @param .dotsFromCache Optional. Used internally.
 #' @param .functionName Optional. Used for messaging when this function is called from `Cache`
+#' @param preDigest The list of `preDigest` that comes from `CacheDigest` of an object
 #' @details
 #' `loadFromCache` is a function to get a single object from the cache, given its `cacheId`.
 #' @return
 #' `loadFromCache` returns the object from the cache that has the particular `cacheId`.
 #'
 loadFromCache <- function(cachePath = getOption("reproducible.cachePath"),
-                          cacheId,
+                          cacheId, preDigest,
                           fullCacheTableForObj = NULL,
                           format = getOption("reproducible.cacheSaveFormat", "rds"),
                           .functionName = NULL, .dotsFromCache = NULL,
@@ -224,18 +218,13 @@ loadFromCache <- function(cachePath = getOption("reproducible.cachePath"),
 
   isMemoised <- NA
   if (isTRUE(getOption("reproducible.useMemoise"))) {
-    if (is.null(.pkgEnv[[cachePath]])) {
-      .pkgEnv[[cachePath]] <- new.env(parent = emptyenv())
-    }
-    isMemoised <- exists(cacheId, envir = .pkgEnv[[cachePath]])
+    isMemoised <- exists(cacheId, envir = memoiseEnv(cachePath))
     if (isTRUE(isMemoised)) {
-      obj <- get(cacheId, envir = .pkgEnv[[cachePath]])
+      obj <- get(cacheId, envir = memoiseEnv(cachePath))
       obj <- unmakeMemoisable(obj)
     }
   }
 
-  # fileFormat <- extractFromCache(fullCacheTableForObj, "fileFormat", ifNot = format)
-
   if (!isTRUE(isMemoised)) {
     f <- CacheStoredFile(cachePath, cacheId, format)
     f <- unique(f) # It is OK if there is a vector of unique cacheIds e.g., loadFromCache(showCache(userTags = "hi")$cacheId)
@@ -256,6 +245,7 @@ loadFromCache <- function(cachePath = getOption("reproducible.cachePath"),
           cachePath = cachePath, fullCacheTableForObj = fullCacheTableForObj,
           cacheId = cacheId,
           format = fileExt(sameCacheID),
+          preDigest = preDigest,
           verbose = verbose
         )
         obj <- .wrap(obj, cachePath = cachePath, drv = drv, conn = conn)
@@ -291,7 +281,7 @@ loadFromCache <- function(cachePath = getOption("reproducible.cachePath"),
 
   if (isTRUE(getOption("reproducible.useMemoise")) && !isTRUE(isMemoised)) {
     obj2 <- makeMemoisable(obj)
-    assign(cacheId, obj2, envir = .pkgEnv[[cachePath]])
+    assign(cacheId, obj2, envir = memoiseEnv(cachePath))
   }
 
   if (verbose > 3) {
@@ -315,7 +305,7 @@ loadFromCache <- function(cachePath = getOption("reproducible.cachePath"),
 
 
 extractFromCache <- function(sc, elem, ifNot = NULL) {
-  rowNum <- sc[["tagKey"]] == elem
+  rowNum <- sc[["tagKey"]] %in% elem
   elemExtracted <- if (any(rowNum)) {
     sc[["tagValue"]][rowNum]
   } else {
@@ -395,7 +385,6 @@ dbConnectAll <- function(drv = getDrv(getOption("reproducible.drv", NULL)),
                          tagKey = character(), tagValue = character(),
                          drv = getDrv(getOption("reproducible.drv", NULL)),
                          conn = getOption("reproducible.conn", NULL)) {
-  # browser(expr = exists("._addTagsRepo_1"))
   if (length(cacheId) > 0) {
     if (length(cacheId) > 1) stop(".addTagsRepo can only handle appending 1 tag at a time")
     curTime <- as.character(Sys.time())
@@ -499,14 +488,14 @@ dbConnectAll <- function(drv = getDrv(getOption("reproducible.drv", NULL)),
       if (add && alreadyThere == 0) {
         dt2 <- rbindlist(list(dt2, dt))
       } else {
-        dt2[tagKey == tk & cacheId == cacheId, tagValue := dt$tagValue]
+        set(dt2, which(dt2$tagKey == tk & dt2$cacheId == cacheId), "tagValue", dt$tagValue)
+        # dt2[tagKey == tk & cacheId == cacheId, tagValue := dt$tagValue]
       }
       saveFilesInCacheFolder(dt2, dtFile, cachePath = cachePath, cacheId = cacheId)
     }
   }
 }
 .cacheNumDefaultTags <- function() {
-  # if (useDBI())
   7 # else 12
 }
 
@@ -571,11 +560,7 @@ CacheDBFile <- function(cachePath = getOption("reproducible.cachePath"),
     #   }
 
     if (grepl(type, "SQLite")) {
-      # if (useDBI()) {
       file.path(cachePath, "cache.db")
-      # } else {
-      #  file.path(cachePath, "backpack.db")
-      # }
     } else {
       file.path(cachePath, "cache.txt")
     }
@@ -590,11 +575,7 @@ CacheDBFile <- function(cachePath = getOption("reproducible.cachePath"),
 #' `CacheStorageDir` returns the name of the directory where cached objects are
 #' stored.
 CacheStorageDir <- function(cachePath = getOption("reproducible.cachePath")) {
-  # if (useDBI()) {
   file.path(cachePath, "cacheOutputs")
-  # } # else {
-  # file.path(cachePath, "gallery")
-  # }
 }
 
 #' @details
@@ -614,6 +595,7 @@ CacheStorageDir <- function(cachePath = getOption("reproducible.cachePath")) {
 CacheStoredFile <- function(cachePath = getOption("reproducible.cachePath"), cacheId,
                             format = NULL, obj = NULL) {
   if (is.null(format)) format <- getOption("reproducible.cacheSaveFormat", "rds")
+  if (missing(cacheId)) cacheId <- NULL
   if (any(format %in% "check")) {
     format <- formatCheck(cachePath, cacheId, format)
   }
@@ -629,7 +611,7 @@ CacheStoredFile <- function(cachePath = getOption("reproducible.cachePath"), cac
       "rda"
     }
   }
-  filename <- paste(cacheId, csExtension, sep = ".")
+  filename <- if (is.null(cacheId)) NULL else paste(cacheId, csExtension, sep = ".")
   if (length(cacheId) > 1) {
     filename <- vapply(filename, nextNumericName, FUN.VALUE = character(1))
     for (i in seq(filename[-1]) + 1) {
@@ -958,7 +940,7 @@ convertDBbackendIfIncorrect <- function(cachePath, drv, conn,
   newDBI <- suppressMessages(useDBI(!origDBI)) # switch to the other
   if (!identical(newDBI, origDBI)) { # if they are same, then DBI is not installed; not point proceeding
     on.exit(suppressMessages(useDBI(origDBI)))
-    drv <- getDrv(drv)
+    drv <- getDrv(drv) # This will return the DBI driver, if it is installed, regardless of drv
     DBFileWrong <- CacheDBFile(cachePath, drv, conn)
     if (file.exists(DBFileWrong)) {
       sc <- showCache(cachePath, drv = drv, conn = conn, verbose = -2)
@@ -1004,3 +986,19 @@ CacheDBFiles <- function(cachePath = getOption("reproducible.cachePath")) {
   dtFiles <- dir(CacheStorageDir(cachePath), pattern = ext, full.names = TRUE)
   dtFiles
 }
+
+memoiseEnv <- function(cachePath, envir = .GlobalEnv) {
+  memPersist <- isTRUE(getOption("reproducible.memoisePersist", NULL))
+  if (memPersist) {
+    obj <- paste0(".reproducibleMemoise_", cachePath)
+    if (!exists(obj, envir = envir))
+      assign(obj, new.env(parent = emptyenv()), envir = envir)
+    memEnv <- get(obj, envir = envir, inherits = FALSE)
+  } else {
+    if (is.null(.pkgEnv[[cachePath]])) {
+      .pkgEnv[[cachePath]] <- new.env(parent = emptyenv())
+    }
+    memEnv <- .pkgEnv[[cachePath]]
+  }
+  memEnv
+}

R/cache-helpers.R

@@ -132,7 +132,6 @@ setAs(from = "character", to = "Path", function(from) {
 #'
 copySingleFile <- function(from = NULL, to = NULL, useRobocopy = TRUE,
                            overwrite = TRUE, delDestination = FALSE,
-                           # copyRasterFile = TRUE, clearRepo = TRUE,
                            create = TRUE, silent = FALSE) {
   if (any(length(from) != 1, length(to) != 1)) stop("from and to must each be length 1")
   useFileCopy <- identical(dirname(from), dirname(to))
@@ -355,8 +354,6 @@ copyFile <- Vectorize(copySingleFile, vectorize.args = c("from", "to"))
   obj
 }
 
-# loadFromLocalRepoMem <- memoise::memoise(loadFromLocalRepo)
-
 #' @keywords internal
 .getOtherFnNamesAndTags <- function(scalls) {
   if (is.null(scalls)) {
@@ -556,22 +553,29 @@ withoutFinalNumeric <- function(string) {
 setClass("PackedSpatExtent")
 
 wrapSpatVector <- function(obj) {
-  geom1 <- terra::geom(obj)
-  geom1 <- list(
-    cols125 = matrix(as.integer(geom1[, c(1, 2, 5)]), ncol = 3),
-    cols34 = matrix(as.integer(geom1[, c(3, 4)]), ncol = 2)
-  )
-  geomtype1 <- terra::geomtype(obj)
-  dat1 <- terra::values(obj)
-  crs1 <- terra::crs(obj)
-  obj <- list(geom1, geomtype1, dat1, crs1)
-  names(obj) <- spatVectorNamesForCache
+  obj <- terra::wrap(obj)
+  if (FALSE) {
+    geom1 <- terra::geom(obj)
+    geom1 <- list(
+      cols125 = matrix(as.integer(geom1[, c(1, 2, 5)]), ncol = 3),
+      cols34 = matrix(as.integer(geom1[, c(3, 4)]), ncol = 2)
+    )
+    geomtype1 <- terra::geomtype(obj)
+    dat1 <- terra::values(obj)
+    crs1 <- terra::crs(obj)
+    obj <- list(geom1, geomtype1, dat1, crs1)
+    names(obj) <- spatVectorNamesForCache
+  }
   obj
 }
 
 unwrapSpatVector <- function(obj) {
-  obj$x <- cbind(obj$x$cols125[, 1:2, drop = FALSE], obj$x$cols34[, 1:2, drop = FALSE], obj$x$cols125[, 3, drop = FALSE])
-  do.call(terra::vect, obj)
+  obj <- terra::unwrap(obj)
+  if (FALSE) {
+    obj$x <- cbind(obj$x$cols125[, 1:2, drop = FALSE], obj$x$cols34[, 1:2, drop = FALSE], obj$x$cols125[, 3, drop = FALSE])
+    do.call(terra::vect, obj)
+  }
+  obj
 }
 
 #' Has a cached object has been updated?

R/cache-internals.R

@@ -13,13 +13,12 @@
   )
 
   hashObjectSize <- unlist(lapply(modifiedDots, function(x) {
-    objSize <- unname(attr(objSize(x), "objSize"))
+    if (getOption("reproducible.objSize", TRUE)) unname(attr(objSize(x), "objSize")) else NA
   }))
 
   lengths <- unlist(lapply(preDigestUnlist, function(x) length(unlist(x))))
   hashDetails <- data.frame(
     objectNames = rep(names(preDigestUnlist), lengths),
-    # objSize = rep(hashObjectSize, lengths),
     hashElements = names(unlist(preDigestUnlist)),
     hash = unname(unlist(preDigestUnlist)),
     stringsAsFactors = FALSE
@@ -32,8 +31,6 @@
     strsplit(names(hashObjectSize), split = "\\$"),
     function(x) paste0(tail(x, 2), collapse = ".")
   ))
-  # hashObjectSizeNames <- unlist(lapply(strsplit(hashObjectSizeNames, split = "\\.y"),
-  #                                      function(x) paste0(tail(x, 2), collapse = ".")))
   hashObjectSizeNames <- gsub("\\.y", replacement = "", hashObjectSizeNames)
   hashObjectSizeNames <- unlist(lapply(
     strsplit(hashObjectSizeNames, split = "\\."),
@@ -108,7 +105,7 @@
 .getFromRepo <- function(FUN, isInRepo, fullCacheTableForObj,
                          notOlderThan, lastOne, cachePath, fnDetails,
                          modifiedDots, debugCache, verbose, # sideEffect,
-                         quick, fileFormat = NULL,
+                         quick, # fileFormat = NULL,
                          algo, preDigest, startCacheTime,
                          drv = getDrv(getOption("reproducible.drv", NULL)),
                          conn = getOption("reproducible.conn", NULL), ...) {
@@ -118,7 +115,7 @@
   output <- loadFromCache(cachePath, isInRepo[[.cacheTableHashColName()[lastOne]]],
     fullCacheTableForObj = fullCacheTableForObj,
     # format = fileFormat, loadFun = loadFun,
-    .functionName = fnDetails$functionName, .dotsFromCache = modifiedDots,
+    .functionName = fnDetails$functionName, preDigest = preDigest, .dotsFromCache = modifiedDots,
     drv = drv, conn = conn,
     verbose = verbose
   )