From dd32e964f0f5ba030c93b78407dbdef52a93dc0b Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 6 Oct 2023 17:15:53 -0700 Subject: [PATCH 01/70] For objects that are saved as paths; convert with asPath --- R/cache.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/cache.R b/R/cache.R index 5b1fedbfc..8ec2498ea 100644 --- a/R/cache.R +++ b/R/cache.R @@ -839,6 +839,8 @@ Cache <- # Can make new methods by class to add tags to outputs if (.CacheIsNew) { outputToSave <- .wrap(output, cachePath, drv = drv, conn = conn, verbose = verbose) + if ((isTRUE(is.character(outputToSave))() && isTRUE(!is.character(output))) + outputToSave <- asPath(outputToSave) output <- .CopyCacheAtts(outputToSave, output) # .wrap added tags; these should be transfered to output # outputToSave <- .addTagsToOutput(outputToSave, outputObjects, FUN, preDigestByClass) From 963d8f55d44f4bbc2dd087e5a5b7d2b92ffc6b77 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 6 Oct 2023 17:16:12 -0700 Subject: [PATCH 02/70] capture case of unnamed list in CacheDigest --- R/cache.R | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/R/cache.R b/R/cache.R index 8ec2498ea..eca475e25 100644 --- a/R/cache.R +++ b/R/cache.R @@ -839,7 +839,7 @@ Cache <- # Can make new methods by class to add tags to outputs if (.CacheIsNew) { outputToSave <- .wrap(output, cachePath, drv = drv, conn = conn, verbose = verbose) - if ((isTRUE(is.character(outputToSave))() && isTRUE(!is.character(output))) + if (isTRUE(is.character(outputToSave)) && isTRUE(!is.character(output))) outputToSave <- asPath(outputToSave) output <- .CopyCacheAtts(outputToSave, output) # .wrap added tags; these should be transfered to output @@ -1684,7 +1684,12 @@ CacheDigest <- function(objsToDigest, ..., algo = "xxhash64", calledFrom = "Cach quickObjs <- if (isTRUE(quick)) { rep(TRUE, length(objsToDigest)) } else { - names(objsToDigest) %in% quick + if (is.null(names(objsToDigest))) { + rep(FALSE, length(objsToDigest)) + } else { + names(objsToDigest) %in% quick + } + } objsToDigestQuick <- objsToDigest[quickObjs] objsToDigest <- objsToDigest[!quickObjs] From 7f676a3bbccd52bce50f1dedc41dc7ff6b8d2d06 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 6 Oct 2023 17:39:31 -0700 Subject: [PATCH 03/70] test --- tests/testthat/test-cache.R | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/tests/testthat/test-cache.R b/tests/testthat/test-cache.R index c040bf0b4..3d874e9a9 100644 --- a/tests/testthat/test-cache.R +++ b/tests/testthat/test-cache.R @@ -1823,3 +1823,23 @@ test_that("lightweight tests for preProcess code coverage", { "different lengths" ) }) + + + +test_that("terra files were creating file.link", { + testInit("terra", + tmpFileExt = c(".tif", ".tif"), + opts = list(reproducible.useMemoise = FALSE) + ) + rasts <- lapply(1:2, function(x) + ras1 <- terra::rast(nrows = 1e3, ncols = 1e3, vals = sample(1e6), + resolution = 1, xmin = 0, xmax = 1000, ymin = 0, ymax = 1000) + ) + func <- function(ras, fn) { + ras <- Cache(writeRaster(ras, filename = fn), quick = c("fn")) + ras + } + mess <- capture_messages(Map(f = func, fn = tmpfile, ras = rasts)) + expect_false(any(grepl("file.link", mess))) + +}) From 051153350f44bbd54a911fd93829968b35131f47 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 6 Oct 2023 18:03:09 -0700 Subject: [PATCH 04/70] [skip-ci] --- DESCRIPTION | 4 ++-- NEWS.md | 1 + 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index f84534389..e26ee1350 100644 --- a/DESCRIPTION +++ b/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-03 -Version: 2.0.8.9005 +Date: 2023-10-06 +Version: 2.0.8.9006 Authors@R: c(person(given = "Eliot J B", family = "McIntire", diff --git a/NEWS.md b/NEWS.md index 30106f28d..d535f0333 100644 --- a/NEWS.md +++ b/NEWS.md @@ -7,6 +7,7 @@ ## 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 # reproducible 2.0.8 From aa4bd38f40959203b10372240c1ab1c5c8efa0e3 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 9 Oct 2023 10:11:15 -0700 Subject: [PATCH 05/70] bugfix for failed recovery from cache --- R/cache.R | 2 +- R/checksums.R | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/R/cache.R b/R/cache.R index eca475e25..0deb85579 100644 --- a/R/cache.R +++ b/R/cache.R @@ -818,7 +818,7 @@ Cache <- # a previous version if (NROW(isInRepo) > 0) { # flush it if notOlderThan is violated - if (notOlderThan >= lastEntry) { + if (isTRUE(notOlderThan >= lastEntry)) { suppressMessages(clearCache( userTags = isInRepo[[.cacheTableHashColName()]][lastOne], x = cachePath, diff --git a/R/checksums.R b/R/checksums.R index 3a7d7d9a5..f7463a8d7 100644 --- a/R/checksums.R +++ b/R/checksums.R @@ -122,6 +122,7 @@ setMethod( ) } txt <- as.data.table(lapply(txt, as.character)) + set(txt, NULL, "file", makeRelative(txt$file, path)) if (is.null(txt$filesize)) txt$filesize <- rep("", NROW(txt)) txtRead <- txt # keep a copy even if writing if (!(!write && file.info(checksumFile)$size > 0)) { From e47d6f3dd2ef6e4533b226ceb8ec2e1b68277c7c Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 9 Oct 2023 16:55:59 -0700 Subject: [PATCH 06/70] bugfixes for inputPaths and destinationPath --- R/preProcess.R | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/R/preProcess.R b/R/preProcess.R index 501985564..d54d79cf9 100644 --- a/R/preProcess.R +++ b/R/preProcess.R @@ -242,8 +242,17 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac # Need to run checksums on all files in destinationPath because we may not know what files we # want if targetFile, archive, alsoExtract not specified + # This will switch destinationPath to be same as reproducible.inputPaths + # This means that we need to modify some of the paths that were already absolute to destinationPath inputPaths <- runChecksums(destinationPath, checkSumFilePath, filesToCheck, verbose) list2env(inputPaths, environment()) # reproducible.inputPaths, destinationPathUser, destinationPath, checkSums + if (!is.null(inputPaths$destinationPathUser)) { # i.e., it changed + targetFilePath <- makeRelative(targetFilePath, inputPaths$destinationPathUser) + targetFilePath <- makeAbsolute(targetFilePath, destinationPath) + filesToCheck <- makeRelative(filesToCheck, inputPaths$destinationPathUser) + filesToCheck <- makeAbsolute(filesToCheck, destinationPath) + } + if (is(checkSums, "try-error")) { needChecksums <- 1 @@ -1621,7 +1630,7 @@ runChecksums <- function(destinationPath, checkSumFilePath, filesToCheck, verbos if (!is(checkSumsTmp1, "try-error")) { checkSums <- checkSumsTmp1 if (!all(is.na(checkSums$result))) { # found something - if (identical(dp, reproducible.inputPaths)) { + if (isTRUE(any(dp %in% reproducible.inputPaths))) { destinationPathUser <- destinationPath destinationPath <- dp on.exit( From 0afe5fecf4221f4fa8e49315f6e93ae622c36735 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 9 Oct 2023 17:10:56 -0700 Subject: [PATCH 07/70] need unique in different spot --- R/preProcess.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/preProcess.R b/R/preProcess.R index d54d79cf9..1bc403e03 100644 --- a/R/preProcess.R +++ b/R/preProcess.R @@ -925,7 +925,7 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac pattern = fileExt(basename2(targetFile)), replacement = "" ) filesToGet <- grep(allFiles, pattern = filePatternToKeep, value = TRUE) - neededFiles <- unique(c(neededFiles, filesToGet)) + neededFiles <- c(neededFiles, filesToGet) } } rerunChecksums <- TRUE @@ -934,7 +934,7 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac rerunChecksums <- FALSE } } - neededFiles <- makeAbsolute(neededFiles, destinationPath) + neededFiles <- unique(makeAbsolute(neededFiles, destinationPath)) if (!is.null(neededFiles) && rerunChecksums) { checkSums <- .checkSumsUpdate( destinationPath = destinationPath, newFilesToCheck = neededFiles, From e1230088cf7e7a68870670efcd22d48d943170ad Mon Sep 17 00:00:00 2001 From: Ian Eddy Date: Wed, 11 Oct 2023 10:16:19 -0700 Subject: [PATCH 08/70] version update for commit 0afe5 --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index e26ee1350..7ea6c0b71 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -20,7 +20,7 @@ URL: https://reproducible.predictiveecology.org, https://github.com/PredictiveEcology/reproducible Date: 2023-10-06 -Version: 2.0.8.9006 +Version: 2.0.8.9007 Authors@R: c(person(given = "Eliot J B", family = "McIntire", From ca36d58f9b6e4cf8e94ab22ab49a64788e58ceea Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 16 Oct 2023 16:10:38 -0700 Subject: [PATCH 09/70] .reproducibleTempCacheDir shouldn't be getOption(reproducible.cachePath) -- use tempPath --- R/zzz.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/zzz.R b/R/zzz.R index 1f4141112..3954c8cbb 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -28,7 +28,7 @@ } .reproducibleTempPath <- function() getOption("reproducible.tempPath") # file.path(tempdir(), "reproducible") -.reproducibleTempCacheDir <- function() getOption("reproducible.cachePath") +.reproducibleTempCacheDir <- function() file.path(getOption("reproducible.tempPath"), "cache") .reproducibleTempInputDir <- function() file.path(tempdir(), "reproducible", "inputs") .argsToRemove <- unique(c( From bc6b260b2967879d08f34391a502ee741f0d5b2f Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 16 Oct 2023 17:25:29 -0700 Subject: [PATCH 10/70] bugfix -- edge case with `doProgress` --- R/cache.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/cache.R b/R/cache.R index 5b1fedbfc..7d881831c 100644 --- a/R/cache.R +++ b/R/cache.R @@ -953,7 +953,7 @@ Cache <- .reproEnv$alreadyMsgFuture <- TRUE } } else { - otsObjSize <- gsub(grep("object.size", userTags, value = TRUE), + otsObjSize <- gsub(grep("object\\.size:", userTags, value = TRUE), pattern = "object.size:", replacement = "" ) otsObjSize <- as.numeric(otsObjSize) From 07cb8bb7063624f6c92dba2823154be0ba2172e2 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 16 Oct 2023 17:26:48 -0700 Subject: [PATCH 11/70] [skip-ci] bump --- DESCRIPTION | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index a1e217c91..9443a8d88 100644 --- a/DESCRIPTION +++ b/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-13 -Version: 2.0.8.9007 +Date: 2023-10-16 +Version: 2.0.8.9008 Authors@R: c(person(given = "Eliot J B", family = "McIntire", From 82c98038b9bfd4b3ab6646df04c6bae8e761f038 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Tue, 17 Oct 2023 14:42:36 -0700 Subject: [PATCH 12/70] browsers --- R/exportedMethods.R | 3 ++- R/preProcess.R | 3 +++ R/prepInputs.R | 1 + 3 files changed, 6 insertions(+), 1 deletion(-) diff --git a/R/exportedMethods.R b/R/exportedMethods.R index d3aed8d5d..403166316 100644 --- a/R/exportedMethods.R +++ b/R/exportedMethods.R @@ -189,7 +189,8 @@ setMethod( tmpDir <- .reproducibleTempCacheDir() # Test whether the user has accepted the default. If yes, then give message. # If no, then user is aware and doesn't need a message - if (any(identical(normPath(tmpDir), normPath(getOption("reproducible.cachePath"))))) { + if (any(grepl(normPath(tmpDir), normPath(getOption("reproducible.cachePath")))) || + any(grepl(normPath(tempdir()), normPath(getOption("reproducible.cachePath"))))) { messageCache("No cachePath supplied and getOption('reproducible.cachePath') is inside a temporary directory;\n", " this will not persist across R sessions.", verbose = verbose diff --git a/R/preProcess.R b/R/preProcess.R index 70a6ce71c..75a95be11 100644 --- a/R/preProcess.R +++ b/R/preProcess.R @@ -627,6 +627,7 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac }, add = TRUE ) + browser() extractedFiles <- .tryExtractFromArchive( archive = nestedArchives, neededFiles = neededFiles, alsoExtract = alsoExtract, destinationPath = destinationPath, @@ -637,6 +638,7 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac ) filesExtr <- c(filesExtr, extractedFiles$filesExtracted) } + browser() targetParams <- .guessAtTargetAndFun(targetFilePath, destinationPath, filesExtracted = filesExtr, fun, verbose = verbose @@ -1200,6 +1202,7 @@ linkOrCopy <- function(from, to, symlink = TRUE, overwrite = TRUE, targetFilePath, quick, verbose = getOption("reproducible.verbose", 1), .tempPath) { + browser() if (missing(.tempPath)) { .tempPath <- tempdir2(rndstr(1, 6)) on.exit( diff --git a/R/prepInputs.R b/R/prepInputs.R index 7e913eac6..c97b071d3 100644 --- a/R/prepInputs.R +++ b/R/prepInputs.R @@ -650,6 +650,7 @@ extractFromArchive <- function(archive, .guessAtTargetAndFun <- function(targetFilePath, destinationPath = getOption("reproducible.destinationPath", "."), filesExtracted, fun = NULL, verbose = getOption("reproducible.verbose", 1)) { + browser() possibleFiles <- unique(c(targetFilePath, filesExtracted)) whichPossFile <- possibleFiles %in% targetFilePath if (isTRUE(any(whichPossFile))) { From f28e9132d65152c782a56b25effc84f3c8228935 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Tue, 17 Oct 2023 14:44:51 -0700 Subject: [PATCH 13/70] rm browsers --- R/preProcess.R | 3 --- R/prepInputs.R | 1 - 2 files changed, 4 deletions(-) diff --git a/R/preProcess.R b/R/preProcess.R index 75a95be11..70a6ce71c 100644 --- a/R/preProcess.R +++ b/R/preProcess.R @@ -627,7 +627,6 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac }, add = TRUE ) - browser() extractedFiles <- .tryExtractFromArchive( archive = nestedArchives, neededFiles = neededFiles, alsoExtract = alsoExtract, destinationPath = destinationPath, @@ -638,7 +637,6 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac ) filesExtr <- c(filesExtr, extractedFiles$filesExtracted) } - browser() targetParams <- .guessAtTargetAndFun(targetFilePath, destinationPath, filesExtracted = filesExtr, fun, verbose = verbose @@ -1202,7 +1200,6 @@ linkOrCopy <- function(from, to, symlink = TRUE, overwrite = TRUE, targetFilePath, quick, verbose = getOption("reproducible.verbose", 1), .tempPath) { - browser() if (missing(.tempPath)) { .tempPath <- tempdir2(rndstr(1, 6)) on.exit( diff --git a/R/prepInputs.R b/R/prepInputs.R index c97b071d3..7e913eac6 100644 --- a/R/prepInputs.R +++ b/R/prepInputs.R @@ -650,7 +650,6 @@ extractFromArchive <- function(archive, .guessAtTargetAndFun <- function(targetFilePath, destinationPath = getOption("reproducible.destinationPath", "."), filesExtracted, fun = NULL, verbose = getOption("reproducible.verbose", 1)) { - browser() possibleFiles <- unique(c(targetFilePath, filesExtracted)) whichPossFile <- possibleFiles %in% targetFilePath if (isTRUE(any(whichPossFile))) { From d56f3ef32f3a52c9dd334b147f95fcb19a0e99fa Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Tue, 17 Oct 2023 14:44:58 -0700 Subject: [PATCH 14/70] bugfix --- R/preProcess.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/preProcess.R b/R/preProcess.R index 70a6ce71c..b6dfa7cdc 100644 --- a/R/preProcess.R +++ b/R/preProcess.R @@ -635,7 +635,7 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac targetFilePath = targetFilePath, quick = quick, verbose = verbose, .tempPath = .tempPath ) - filesExtr <- c(filesExtr, extractedFiles$filesExtracted) + filesExtr <- c(filesExtr, extractedFiles$filesExtr) } targetParams <- .guessAtTargetAndFun(targetFilePath, destinationPath, filesExtracted = filesExtr, From c7c7662abd8fd953aee12f07fa1de3f7e1e42d3f Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Tue, 17 Oct 2023 14:52:33 -0700 Subject: [PATCH 15/70] [skip-ci] bump 2.0.8.9009 --- DESCRIPTION | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 9443a8d88..a57a0fada 100644 --- a/DESCRIPTION +++ b/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-16 -Version: 2.0.8.9008 +Date: 2023-10-17 +Version: 2.0.8.9009 Authors@R: c(person(given = "Eliot J B", family = "McIntire", From b0d36bfc46619df75ad186c6ca4171906ffd8f8e Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 18 Oct 2023 09:25:07 -0700 Subject: [PATCH 16/70] reproducible.useDBI updates: use users's val & set to NULL --- R/DBI.R | 2 +- R/options.R | 7 ++++--- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/R/DBI.R b/R/DBI.R index 7613c5b25..9e151bc57 100644 --- a/R/DBI.R +++ b/R/DBI.R @@ -958,7 +958,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) diff --git a/R/options.R b/R/options.R index 73ce37979..8f419c3f5 100644 --- a/R/options.R +++ b/R/options.R @@ -209,10 +209,11 @@ reproducibleOptions <- function() { reproducible.tempPath = file.path(tempdir(), "reproducible"), reproducible.useCache = TRUE, # override Cache function reproducible.useCloud = FALSE, # - reproducible.useDBI = getEnv("R_REPRODUCIBLE_USE_DBI", - default = useDBI(TRUE, verbose = interactive() - (useDBI() + 1)), # `FALSE` is useMultipleDBFiles now + reproducible.useDBI = {getEnv("R_REPRODUCIBLE_USE_DBI", + default = useDBI(getOption("reproducible.useDBI", NULL), # a user may have set it before this runs; keep setting + verbose = interactive() - (useDBI() + 1)), # `FALSE` is useMultipleDBFiles now allowed = c("true", "false") - ) |> as.logical(), + ) |> as.logical()}, reproducible.useMemoise = FALSE, # memoise reproducible.useragent = "https://github.com/PredictiveEcology/reproducible", reproducible.verbose = 1 From 95691b54cc162b2bd11f1131fb4677d41d0493c0 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 18 Oct 2023 09:29:36 -0700 Subject: [PATCH 17/70] maskInputs backwards compatible tweaks --- R/postProcess.R | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/R/postProcess.R b/R/postProcess.R index 608c231d6..d650ca95e 100644 --- a/R/postProcess.R +++ b/R/postProcess.R @@ -273,7 +273,11 @@ maskInputs <- function(x, studyArea, ...) { #' @export maskInputs.default <- function(x, studyArea, rasterToMatch = NULL, maskWithRTM = NULL, verbose = getOption("reproducible.verbose", 1), ...) { - maskTo(x, ...) + if (!is.null(maskWithRTM) && !is.null(rasterToMatch)) + maskTo <- rasterToMatch + else + maskTo <- studyArea + maskTo(x, maskTo = maskTo, verbose = verbose, ...) } From 0fc82fff97250a6032469c78528ebce452273ccd Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 18 Oct 2023 11:35:25 -0700 Subject: [PATCH 18/70] na.omit when userTags includes an NA --- R/DBI.R | 2 +- R/cache.R | 2 +- tests/testthat/test-cache.R | 5 +++++ 3 files changed, 7 insertions(+), 2 deletions(-) diff --git a/R/DBI.R b/R/DBI.R index 9e151bc57..9b83e8cea 100644 --- a/R/DBI.R +++ b/R/DBI.R @@ -315,7 +315,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 { diff --git a/R/cache.R b/R/cache.R index 4ab4a599f..d1c0d5490 100644 --- a/R/cache.R +++ b/R/cache.R @@ -388,7 +388,7 @@ Cache <- } } - userTagsOrig <- userTags # keep to distinguish actual user supplied userTags + userTagsOrig <- stats::na.omit(userTags) # keep to distinguish actual user supplied userTags CacheMatchedCall <- match.call(Cache) # Capture everything -- so not evaluated diff --git a/tests/testthat/test-cache.R b/tests/testthat/test-cache.R index 0774783cd..be542b247 100644 --- a/tests/testthat/test-cache.R +++ b/tests/testthat/test-cache.R @@ -1841,3 +1841,8 @@ test_that("terra files were creating file.link", { expect_false(any(grepl("file.link", mess))) }) + +test_that("pass NA to userTags", { + testInit(verbose = FALSE) + expect_no_error(a <- Cache(rnorm(1), userTags = c("NA", "hi"))) +}) From 9d1713237b42825ef9d3b3df34720182dc9c35d0 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 18 Oct 2023 17:37:28 -0700 Subject: [PATCH 19/70] use terra::wrap for spatVector --- R/cache-helpers.R | 24 ++++++++++++++++-------- 1 file changed, 16 insertions(+), 8 deletions(-) diff --git a/R/cache-helpers.R b/R/cache-helpers.R index 8af3a018b..ebb96a5a4 100644 --- a/R/cache-helpers.R +++ b/R/cache-helpers.R @@ -556,22 +556,30 @@ 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), + 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 + 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) + browser() + obj <- 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? From 65344253e7018386dfbf4cf00caa4bdfb61a3167 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 18 Oct 2023 17:38:04 -0700 Subject: [PATCH 20/70] clear up messaging a bit --- R/cache-helpers.R | 8 ++++---- R/cache.R | 5 ++--- 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/R/cache-helpers.R b/R/cache-helpers.R index ebb96a5a4..4a09465ab 100644 --- a/R/cache-helpers.R +++ b/R/cache-helpers.R @@ -561,10 +561,10 @@ 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) + 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 diff --git a/R/cache.R b/R/cache.R index d1c0d5490..b68359dc5 100644 --- a/R/cache.R +++ b/R/cache.R @@ -406,7 +406,6 @@ Cache <- FUN = FUN, callingFun = "Cache", ..., .functionName = .functionName, FUNcaptured = FUNcaptured, CacheMatchedCall = CacheMatchedCall ) - # next line is (1 && 1) && 1 -- if it has :: or $ or [] e.g., fun$b, it MUST be length 3 for it to not be "captured function" isCapturedFUN <- isFALSE(isDollarSqBrPkgColon(FUNcaptured) && length(FUNcaptured) == 3) && @@ -1833,8 +1832,8 @@ CacheDigest <- function(objsToDigest, ..., algo = "xxhash64", calledFrom = "Cach } messageCache(paste0(" the next closest cacheId(s) ", paste(cacheIdOfSimilar, collapse = ", "), " ", fnTxt, userTagsMess, - sep = "\n" - ), verbose = verbose) + collapse = "\n" + ), appendLF = FALSE, verbose = verbose) if (sum(similar2[differs %in% TRUE]$differs, na.rm = TRUE)) { differed <- TRUE From 570ca41c5bb5e61e2cae78b0616f831fe306bfc9 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 18 Oct 2023 17:38:40 -0700 Subject: [PATCH 21/70] rm nested Cache formals -- it overwrote important things -- this may break stuff --- R/cache.R | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/R/cache.R b/R/cache.R index b68359dc5..e0669bf27 100644 --- a/R/cache.R +++ b/R/cache.R @@ -2034,14 +2034,14 @@ determineNestedTags <- function(envir, mc, userTags) { prevValsInitial <- prevVals } - if (any(objOverride)) { - # get from .reproEnv - lsDotReproEnv <- ls(.reproEnv) - prevVals <- .namesCacheFormals[objOverride] %in% lsDotReproEnv - if (any(prevVals)) { - list2env(mget(.namesCacheFormals[objOverride][prevVals], .reproEnv), envir = envir) - } - } + # if (any(objOverride)) { + # # get from .reproEnv + # lsDotReproEnv <- ls(.reproEnv) + # prevVals <- .namesCacheFormals[objOverride] %in% lsDotReproEnv + # if (any(prevVals)) { + # list2env(mget(.namesCacheFormals[objOverride][prevVals], .reproEnv), envir = envir) + # } + # } return(list( oldUserTags = oldUserTags, namesUserCacheArgs = namesUserCacheArgs, From 753a53a22418db03607b06b080a70878b8844ee9 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 19 Oct 2023 06:35:13 -0700 Subject: [PATCH 22/70] bump 2.0.8.9010 --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 499217f4e..75909ca9d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -20,7 +20,7 @@ URL: https://reproducible.predictiveecology.org, https://github.com/PredictiveEcology/reproducible Date: 2023-10-18 -Version: 2.0.8.9009 +Version: 2.0.8.9010 Authors@R: c(person(given = "Eliot J B", family = "McIntire", From a906c585a4145bc99cfad18de6a91aca535b03b8 Mon Sep 17 00:00:00 2001 From: Alex Chubaty Date: Thu, 19 Oct 2023 12:33:18 -0600 Subject: [PATCH 23/70] remove browser() in unwrapSpatVector() --- DESCRIPTION | 4 ++-- R/cache-helpers.R | 1 - 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 75909ca9d..ec7009107 100644 --- a/DESCRIPTION +++ b/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.9010 +Date: 2023-10-19 +Version: 2.0.8.9011 Authors@R: c(person(given = "Eliot J B", family = "McIntire", diff --git a/R/cache-helpers.R b/R/cache-helpers.R index 4a09465ab..1a3d292d7 100644 --- a/R/cache-helpers.R +++ b/R/cache-helpers.R @@ -573,7 +573,6 @@ wrapSpatVector <- function(obj) { } unwrapSpatVector <- function(obj) { - browser() obj <- 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]) From 0fb645c60c4003aec813f430bf6d42ed8c313a27 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 19 Oct 2023 18:28:26 -0700 Subject: [PATCH 24/70] Checksums inside preProcess --> was missing some cases --- R/DBI.R | 35 ++++++++++++++------ R/preProcess.R | 65 ++++++++++++++++++++++---------------- man/reproducibleOptions.Rd | 6 ++++ 3 files changed, 69 insertions(+), 37 deletions(-) diff --git a/R/DBI.R b/R/DBI.R index 9b83e8cea..e01d63f1a 100644 --- a/R/DBI.R +++ b/R/DBI.R @@ -152,12 +152,12 @@ 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()) - } + # 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) @@ -224,12 +224,12 @@ 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]]) + # if (is.null(.pkgEnv[[cachePath]])) { + # .pkgEnv[[cachePath]] <- new.env(parent = emptyenv()) + # } + isMemoised <- exists(cacheId, envir = memoiseEnv(cachePath)) if (isTRUE(isMemoised)) { - obj <- get(cacheId, envir = .pkgEnv[[cachePath]]) + obj <- get(cacheId, envir = memoiseEnv(cachePath)) obj <- unmakeMemoisable(obj) } } @@ -291,7 +291,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) { @@ -1004,3 +1004,18 @@ CacheDBFiles <- function(cachePath = getOption("reproducible.cachePath")) { dtFiles <- dir(CacheStorageDir(cachePath), pattern = ext, full.names = TRUE) dtFiles } + +memoiseEnv <- function(cachePath) { + memPersist <- isTRUE(getOption("reproducible.memoisePersist", NULL)) + if (memPersist) { + if (!exists(".reproducibleMemoise", envir = .GlobalEnv)) + assign(".reproducibleMemoise", new.env(parent = emptyenv()), envir = .GlobalEnv) + memEnv <- get(".reproducibleMemoise", envir = .GlobalEnv, inherits = FALSE) + } else { + if (is.null(.pkgEnv[[cachePath]])) { + .pkgEnv[[cachePath]] <- new.env(parent = emptyenv()) + } + memEnv <- .pkgEnv[[cachePath]] + } + memEnv +} diff --git a/R/preProcess.R b/R/preProcess.R index b6dfa7cdc..4e5effda1 100644 --- a/R/preProcess.R +++ b/R/preProcess.R @@ -674,12 +674,19 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac checkSumFilePath <- identifyCHECKSUMStxtFile(successfulDir) # run Checksums in IP } } - checkSums <- appendChecksumsTable( - checkSumFilePath = checkSumFilePath, - filesToChecksum = unique(filesToChecksum), - destinationPath = destinationPath, - append = needChecksums >= 2 - ) + csps <- destinationPath + if (!is.null(reproducible.inputPaths)) { + csps <- c(csps, reproducible.inputPaths) + } + for (csp in csps) { + checkSumFilePath <- identifyCHECKSUMStxtFile(csp) + checkSums <- appendChecksumsTable( + checkSumFilePath = checkSumFilePath, + filesToChecksum = basename2(unique(filesToChecksum)), + destinationPath = csp, + append = needChecksums >= 2 + ) + } if (!is.null(reproducible.inputPaths) && needChecksums != 3) { checkSumFilePathInputPaths <- identifyCHECKSUMStxtFile(reproducible.inputPaths[[1]]) suppressMessages({ @@ -1620,28 +1627,32 @@ runChecksums <- function(destinationPath, checkSumFilePath, filesToCheck, verbos } destinationPathUser <- NULL - for (dp in unique(c(destinationPath, reproducible.inputPaths))) { - csfp <- identifyCHECKSUMStxtFile(dp) - checkSumsTmp1 <- try(Checksums( - path = dp, write = FALSE, checksumFile = csfp, - files = makeRelative(filesToCheck, absoluteBase = destinationPath), - verbose = verbose - ), silent = TRUE) - checkSums <- NULL - if (!is(checkSumsTmp1, "try-error")) { - checkSums <- checkSumsTmp1 - if (!all(is.na(checkSums$result))) { # found something - if (isTRUE(any(dp %in% reproducible.inputPaths))) { - destinationPathUser <- destinationPath - destinationPath <- dp - on.exit( - { - destinationPath <- destinationPathUser - }, - add = TRUE - ) + possDirs <- unique(c(destinationPath, reproducible.inputPaths)) + csfps <- vapply(possDirs, function(dp) identifyCHECKSUMStxtFile(dp), character(1)) + for (dp in possDirs) { + for (csfp in csfps) { # there can be a mismatch between checksums and file location + # csfp <- identifyCHECKSUMStxtFile(dp) + checkSumsTmp1 <- try(Checksums( + path = dp, write = FALSE, checksumFile = csfp, + files = makeRelative(filesToCheck, absoluteBase = destinationPath), + verbose = verbose - 1 + ), silent = TRUE) + checkSums <- NULL + if (!is(checkSumsTmp1, "try-error")) { + checkSums <- checkSumsTmp1 + if (!all(is.na(checkSums$result))) { # found something + if (isTRUE(any(dp %in% reproducible.inputPaths))) { + destinationPathUser <- destinationPath + destinationPath <- dp + on.exit( + { + destinationPath <- destinationPathUser + }, + add = TRUE + ) + } + break } - break } } } diff --git a/man/reproducibleOptions.Rd b/man/reproducibleOptions.Rd index 34e76c5ee..8185eaa8c 100644 --- a/man/reproducibleOptions.Rd +++ b/man/reproducibleOptions.Rd @@ -75,6 +75,12 @@ duplicated files. Default: \code{FALSE}. Used in \code{\link[=prepInputs]{prepInputs()}} and \code{\link[=preProcess]{preProcess()}}. Should the \code{reproducible.inputPaths} be searched recursively for existence of a file? } +\item{\code{memoisePersist}}{ +Default: \code{FALSE}. Used in \code{\link[=Cache]{Cache()}}. +Should the memoised copy of the Cache objects persist even if \code{reproducible} reloads +e.g., via \code{devtools::load_all}? This is mostly useful for developers of +\code{reproducible}. +} \item{\code{nThreads}}{ Default: \code{1}. The number of threads to use for reading/writing cache files. } From b3a354ce002823eb6301cbb7ec65a4a162049827 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 20 Oct 2023 14:22:29 -0700 Subject: [PATCH 25/70] option memoisePersist --- R/DBI.R | 7 ++++--- R/options.R | 8 ++++++++ 2 files changed, 12 insertions(+), 3 deletions(-) diff --git a/R/DBI.R b/R/DBI.R index e01d63f1a..be16c1148 100644 --- a/R/DBI.R +++ b/R/DBI.R @@ -1008,9 +1008,10 @@ CacheDBFiles <- function(cachePath = getOption("reproducible.cachePath")) { memoiseEnv <- function(cachePath) { memPersist <- isTRUE(getOption("reproducible.memoisePersist", NULL)) if (memPersist) { - if (!exists(".reproducibleMemoise", envir = .GlobalEnv)) - assign(".reproducibleMemoise", new.env(parent = emptyenv()), envir = .GlobalEnv) - memEnv <- get(".reproducibleMemoise", envir = .GlobalEnv, inherits = FALSE) + obj <- paste0(".reproducibleMemoise_", cachePath) + if (!exists(obj, envir = .GlobalEnv)) + assign(obj, new.env(parent = emptyenv()), envir = .GlobalEnv) + memEnv <- get(obj, envir = .GlobalEnv, inherits = FALSE) } else { if (is.null(.pkgEnv[[cachePath]])) { .pkgEnv[[cachePath]] <- new.env(parent = emptyenv()) diff --git a/R/options.R b/R/options.R index 8f419c3f5..a656c1a1d 100644 --- a/R/options.R +++ b/R/options.R @@ -70,6 +70,13 @@ #' Default: `FALSE`. Used in [prepInputs()] and [preProcess()]. #' Should the `reproducible.inputPaths` be searched recursively for existence of a file? #' } +#' \item{`memoisePersist`}{ +#' Default: `FALSE`. Used in [Cache()]. +#' Should the memoised copy of the Cache objects persist even if `reproducible` reloads +#' e.g., via `devtools::load_all`? This is mostly useful for developers of +#' `reproducible`. If `TRUE`, a object named `paste0(".reproducibleMemoise_", cachePath)` +#' will be placed in the `.GlobalEnv`, i.e., one for each `cachePath`. +#' } #' \item{`nThreads`}{ #' Default: `1`. The number of threads to use for reading/writing cache files. #' } @@ -193,6 +200,7 @@ reproducibleOptions <- function() { reproducible.inputPaths = NULL, reproducible.inputPathsRecursive = FALSE, reproducible.length = Inf, + reproducible.memoisePersist = FALSE, reproducible.messageColourPrepInputs = "cyan", reproducible.messageColourCache = "blue", reproducible.messageColourQuestion = "green", From 73a36a2205696e0a4dfb9a3f9aa2b6b910b85747 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 20 Oct 2023 14:22:59 -0700 Subject: [PATCH 26/70] Deal with terra Certificate fails -- this is bad news --- R/postProcessTo.R | 110 ++++++++++++++++++++++++++----------- man/reproducibleOptions.Rd | 3 +- 2 files changed, 80 insertions(+), 33 deletions(-) diff --git a/R/postProcessTo.R b/R/postProcessTo.R index 8bf7de9f1..a345dca9d 100644 --- a/R/postProcessTo.R +++ b/R/postProcessTo.R @@ -616,15 +616,32 @@ projectTo <- function(from, projectTo, overwrite = FALSE, if (isSpatial) { from <- suppressWarningsSpecific(terra::vect(from), shldBeChar) } - isSF <- isSF(from) - if (isSF) { - if (isGridded(projectTo)) { - projectTo <- sf::st_crs(projectTo) + withCallingHandlers({ + attempt <- 1 + while (attempt <= 2) { + isSF <- isSF(from) + if (isSF) { + if (isGridded(projectTo)) { + projectTo <- sf::st_crs(projectTo) + } + from13 <- sf::st_transform(from, projectTo) + } else { + from13 <- terra::project(from, projectTo) + } + attempt <- attempt + 2 } - from <- sf::st_transform(from, projectTo) - } else { - from <- terra::project(from, projectTo) - } + }, warning = function(w) { + if (any(grepl(warningCertificateGrep, w$message))) { + if (!isSF) { + w$message <- paste(w$message, "\n ... attempting to use `sf` instead") + warning(w) + from <<- sf::st_as_sf(from) + attempt <<- 0 + } + invokeRestart("muffleWarning") + } + }) + from <- from13 if (isSpatial) from <- as(from, "Spatial") from @@ -708,19 +725,39 @@ cropTo <- function(from, cropTo = NULL, needBuffer = FALSE, overwrite = FALSE, } if (!sameCRS) { - if (isVector(cropTo) && !isSpat(cropTo)) { - cropToInFromCRS <- sf::st_transform(sf::st_as_sf(cropTo), sf::st_crs(from)) - ext <- sf::st_as_sfc(sf::st_bbox(cropToInFromCRS)) # create extent as an object; keeps crs correctly - } else { - terraCRSFrom <- terra::crs(from) - if (packageVersion("terra") <= "1.5.21") { # an older terra issue; may not be precise version - if (length(slotNames(terraCRSFrom)) > 0) { - terraCRSFrom <- terraCRSFrom@projargs + withCallingHandlers({ + attempt <- 1 + while (attempt <= 2) { + isSF <- isSF(cropTo) + + if (isVector(cropTo) && !isSpat(cropTo)) { + cropToInFromCRS <- sf::st_transform(sf::st_as_sf(cropTo), sf::st_crs(from)) + ext <- sf::st_as_sfc(sf::st_bbox(cropToInFromCRS)) # create extent as an object; keeps crs correctly + } else { + terraCRSFrom <- terra::crs(from) + if (packageVersion("terra") <= "1.5.21") { # an older terra issue; may not be precise version + if (length(slotNames(terraCRSFrom)) > 0) { + terraCRSFrom <- terraCRSFrom@projargs + } + } + cropToInFromCRS <- terra::project(cropTo, terraCRSFrom) + ext <- terra::ext(cropToInFromCRS) # create extent as an object; keeps crs correctly } + attempt <- attempt + 2 } - cropToInFromCRS <- terra::project(cropTo, terraCRSFrom) - ext <- terra::ext(cropToInFromCRS) # create extent as an object; keeps crs correctly - } + + }, warning = function(w) { + if (any(grepl(warningCertificateGrep, w$message))) { + if (!isSF) { + w$message <- paste(w$message, "\n ... attempting to use `sf` instead") + warning(w) + cropTo <<- sf::st_as_sf(cropTo) + attempt <<- 0 + } + invokeRestart("muffleWarning") + } + }) + } if (isVector(from) && !isSF(from)) { ext <- terra::vect(ext) @@ -1100,24 +1137,31 @@ shldBeChar <- "should be a character value" revertClass <- function(from, isStack = FALSE, isBrick = FALSE, isRasterLayer = FALSE, isSF = FALSE, isSpatial = FALSE, origFromClass = NULL) { - if (!isSpat2(origFromClass)) { - if (!is.null(origFromClass)) { - # overrides all others! - isStack <- any(origFromClass == "RasterStack") - isBrick <- any(origFromClass == "RasterBrick") - isRasterLayer <- any(origFromClass == "RasterLayer") - isSF <- any(origFromClass == "sf") - isSpatial <- any(startsWith(origFromClass, "Spatial")) - } - if (isStack && !is(from, "RasterStack")) from <- raster::stack(from) # coming out of writeRaster, becomes brick - if (isBrick && !is(from, "RasterBrick")) from <- raster::brick(from) # coming out of writeRaster, becomes brick - if (isRasterLayer && !is(from, "RasterLayer")) from <- raster::raster(from) # coming out of writeRaster, becomes brick - if (isSF || isSpatial) { + # if (!isSpat2(origFromClass)) { + if (!is.null(origFromClass)) { + # overrides all others! + isStack <- any(origFromClass == "RasterStack") + isBrick <- any(origFromClass == "RasterBrick") + isRasterLayer <- any(origFromClass == "RasterLayer") + isSF <- any(origFromClass == "sf") + isSpatial <- any(startsWith(origFromClass, "Spatial")) + isSV <- any(origFromClass == "SpatVector") + + if (isSV && !is(from, "SpatVector")) { + from <- terra::vect(from) + } else if (isStack && !is(from, "RasterStack")) { + from <- raster::stack(from) # coming out of writeRaster, becomes brick + } else if (isBrick && !is(from, "RasterBrick")) { + from <- raster::brick(from) # coming out of writeRaster, becomes brick + } else if (isRasterLayer && !is(from, "RasterLayer")) { + from <- raster::raster(from) # coming out of writeRaster, becomes brick + } else if (isSF || isSpatial) { .requireNamespace("sf", stopOnFALSE = TRUE) from <- sf::st_as_sf(from) if (isSpatial) { from <- sf::as_Spatial(from) } + } } from @@ -1248,3 +1292,5 @@ extntNA <- function(x) { out <- anyNA(as.numeric(out[])) return(out) } + +warningCertificateGrep <- "CertGetCertificateChain trust error CERT_TRUST_IS_PARTIAL_CHAIN" diff --git a/man/reproducibleOptions.Rd b/man/reproducibleOptions.Rd index 8185eaa8c..55da54bce 100644 --- a/man/reproducibleOptions.Rd +++ b/man/reproducibleOptions.Rd @@ -79,7 +79,8 @@ Should the \code{reproducible.inputPaths} be searched recursively for existence Default: \code{FALSE}. Used in \code{\link[=Cache]{Cache()}}. Should the memoised copy of the Cache objects persist even if \code{reproducible} reloads e.g., via \code{devtools::load_all}? This is mostly useful for developers of -\code{reproducible}. +\code{reproducible}. If \code{TRUE}, a object named \code{paste0(".reproducibleMemoise_", cachePath)} +will be placed in the \code{.GlobalEnv}, i.e., one for each \code{cachePath}. } \item{\code{nThreads}}{ Default: \code{1}. The number of threads to use for reading/writing cache files. From 18f019c8abf9bed26887a58b4cd7e80f91f45fc6 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 20 Oct 2023 17:15:17 -0700 Subject: [PATCH 27/70] deal with Certificate failure for terra -- affects all `terra::project` --- R/postProcessTo.R | 61 ++++++++++++++++++++++++++++++++++------------- 1 file changed, 44 insertions(+), 17 deletions(-) diff --git a/R/postProcessTo.R b/R/postProcessTo.R index a345dca9d..e49621658 100644 --- a/R/postProcessTo.R +++ b/R/postProcessTo.R @@ -410,18 +410,37 @@ maskTo <- function(from, maskTo, # touches = FALSE, } if (!sameCRS) { - if (isGridded(maskTo)) { - maskTo <- terra::project(maskTo, from, overwrite = overwrite) - } else { - if (isSF(maskTo)) { - maskTo <- sf::st_transform(maskTo, sf::st_crs(from)) - } else { - if (isSpatial(maskTo)) { - maskTo <- terra::vect(maskTo) + withCallingHandlers({ + isSF <- isSF(maskTo) + maskTo2 <- maskTo + attempt <- 1 + while (attempt <= 2) { + if (isGridded(maskTo2)) { + maskTo3 <- terra::project(maskTo2, from, overwrite = overwrite) + } else { + if (isSF(maskTo2)) { + maskTo3 <- sf::st_transform(maskTo2, sf::st_crs(from)) + } else { + if (isSpatial(maskTo2)) { + maskTo2 <- terra::vect(maskTo2) + } + maskTo3 <- terra::project(maskTo2, from) + } } - maskTo <- terra::project(maskTo, from) + attempt <- attempt + 2 } - } + }, warning = function(w) { + if (any(grepl(warningCertificateGrep, w$message))) { + if (!isSF) { + maskTo2 <<- convertToSFwMessage(w, maskTo2) + attempt <<- 0 + } + invokeRestart("muffleWarning") + } + }) + if (attempt == 4) + message("... converting to sf object worked to deal with ", warningCertificateGrep) + maskTo <- maskTo3 } messagePrepInputs(" masking...", appendLF = FALSE, verbose = verbose) st <- Sys.time() @@ -633,15 +652,16 @@ projectTo <- function(from, projectTo, overwrite = FALSE, }, warning = function(w) { if (any(grepl(warningCertificateGrep, w$message))) { if (!isSF) { - w$message <- paste(w$message, "\n ... attempting to use `sf` instead") - warning(w) - from <<- sf::st_as_sf(from) + from <<- convertToSFwMessage(w, from) attempt <<- 0 } invokeRestart("muffleWarning") } }) from <- from13 + if (attempt == 4) + message("... converting to sf object worked to deal with ", warningCertificateGrep) + if (isSpatial) from <- as(from, "Spatial") from @@ -749,14 +769,14 @@ cropTo <- function(from, cropTo = NULL, needBuffer = FALSE, overwrite = FALSE, }, warning = function(w) { if (any(grepl(warningCertificateGrep, w$message))) { if (!isSF) { - w$message <- paste(w$message, "\n ... attempting to use `sf` instead") - warning(w) - cropTo <<- sf::st_as_sf(cropTo) + cropTo <<- convertToSFwMessage(w, cropTo) attempt <<- 0 } invokeRestart("muffleWarning") } }) + if (attempt == 4) + message("... converting to sf object worked to deal with ", warningCertificateGrep) } if (isVector(from) && !isSF(from)) { @@ -1210,7 +1230,7 @@ remapOldArgs <- function(..., fn = sys.function(sys.parent()), envir = parent.fr if (length(elem)) { mes <- paste(newHere, collapse = ", ") messagePrepInputs(elem, " is supplied (deprecated); assigning it to ", mes, - verbose = verbose + verbose = verbose - 1 ) lapply(newHere, function(nh) ret[nh] <<- list(dots[[elem]])) } @@ -1294,3 +1314,10 @@ extntNA <- function(x) { } warningCertificateGrep <- "CertGetCertificateChain trust error CERT_TRUST_IS_PARTIAL_CHAIN" + +convertToSFwMessage <- function(w, obj) { + w$message <- paste(w$message, "\n ... attempting to use `sf` instead") + message(w$message) + obj <- sf::st_as_sf(obj) + obj +} From 3249f66353f2ebf6392cc407e581023ac988128b Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 20 Oct 2023 17:15:44 -0700 Subject: [PATCH 28/70] Bump 2.0.8.9012 --- DESCRIPTION | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index ec7009107..f1d911cac 100644 --- a/DESCRIPTION +++ b/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-19 -Version: 2.0.8.9011 +Date: 2023-10-20 +Version: 2.0.8.9012 Authors@R: c(person(given = "Eliot J B", family = "McIntire", From 9f0a91d8f18cec366447f2f3c4ff95401be09731 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 20 Oct 2023 20:01:18 -0700 Subject: [PATCH 29/70] not utils::unwrap lol --- R/cache-helpers.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/cache-helpers.R b/R/cache-helpers.R index 1a3d292d7..26e33426e 100644 --- a/R/cache-helpers.R +++ b/R/cache-helpers.R @@ -573,7 +573,7 @@ wrapSpatVector <- function(obj) { } unwrapSpatVector <- function(obj) { - obj <- unwrap(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) From b24c2e8f1038833db420452dbe39216fdda05b84 Mon Sep 17 00:00:00 2001 From: tati-micheletti Date: Tue, 24 Oct 2023 18:54:48 +0000 Subject: [PATCH 30/70] preProcess now handles only Google ID; messaging improved --- R/download.R | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/R/download.R b/R/download.R index 15c3d956c..34495dd4f 100755 --- a/R/download.R +++ b/R/download.R @@ -140,12 +140,19 @@ downloadFile <- function(archive, targetFile, neededFiles, failed <- numTries + 2 } if (failed >= numTries) { + isGID <- all(grepl("^[A-Za-z0-9_-]{33}$", url), # Has 33 characters as letters, numbers or - or _ + !grepl("\\.[^\\.]+$", url)) # doesn't have an extension + if (isGID){ + urlMessage <- paste0("https://drive.google.com/file/d/", url) + } else { + urlMessage <- url + } messCommon <- paste0( "Download of ", url, " failed. This may be a permissions issue. ", "Please check the url and permissions are correct.\n", "If the url is correct, it is possible that manually downloading it will work. ", "To try this, with your browser, go to\n", - url, ",\n ... then download it manually, give it this name: '", fileToDownload, + urlMessage, ",\n ... then download it manually, give it this name: '", fileToDownload, "', and place file here: ", destinationPath ) if (isInteractive() && getOption("reproducible.interactiveOnDownloadFail", TRUE)) { @@ -377,7 +384,6 @@ dlGoogle <- function(url, archive = NULL, targetFile = NULL, if (!is.null(fs)) { class(fs) <- "object_size" } - isLargeFile <- ifelse(is.null(fs), FALSE, fs > 1e6) if (!isWindows() && requireNamespace("future", quietly = TRUE) && isLargeFile && !isFALSE(getOption("reproducible.futurePlan"))) { @@ -513,7 +519,6 @@ downloadRemote <- function(url, archive, targetFile, checkSums, dlFun = NULL, } dots <- list(...) - if (!is.null(url) || !is.null(dlFun)) { # if no url, no download # if (!is.null(fileToDownload) ) { # don't need to download because no url --- but need a case if (!isTRUE(tryCatch(is.na(fileToDownload), warning = function(x) FALSE))) { @@ -594,7 +599,9 @@ downloadRemote <- function(url, archive, targetFile, checkSums, dlFun = NULL, } if (is.null(out)) { - if (grepl("d.+.google.com", url)) { + isGID <- all(grepl("^[A-Za-z0-9_-]{33}$", url), # Has 33 characters as letters, numbers or - or _ + !grepl("\\.[^\\.]+$", url)) # doesn't have an extension --> GDrive ID's as url + if (any(isGID, grepl("d.+.google.com", url))) { if (!requireNamespace("googledrive", quietly = TRUE)) { stop(requireNamespaceMsg("googledrive", "to use google drive files")) } @@ -699,7 +706,7 @@ assessGoogle <- function(url, archive = NULL, targetFile = NULL, opts <- options(httr_oob_default = TRUE) on.exit(options(opts)) } - + if (is.null(archive) || is.na(archive)) { if (packageVersion("googledrive") < "2.0.0") { fileAttr <- retry(retries = 1, quote(googledrive::drive_get(googledrive::as_id(url), From 8081c898c4453f2171ba81d00df07b7dc744e845 Mon Sep 17 00:00:00 2001 From: tati-micheletti Date: Tue, 24 Oct 2023 18:55:47 +0000 Subject: [PATCH 31/70] preProcess now handles only Google ID; messaging improved --- R/preProcess.R | 21 ++++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/R/preProcess.R b/R/preProcess.R index 4e5effda1..9cca96228 100644 --- a/R/preProcess.R +++ b/R/preProcess.R @@ -204,6 +204,7 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac } } targetFileGuess <- NULL + if (is.null(targetFile) || is.null(archive)) { targetFileGuess <- .guessAtFile( url = url, archive = archive, targetFile = targetFile, @@ -809,7 +810,11 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac # if (is.null(targetFile)) { guessedFile <- if (!is.null(url)) { gf <- file.path(destinationPath, basename2(url)) - if (grepl("drive.google.com", url)) { + # Test for just Google ID supplied + isGID <- all(grepl("^[A-Za-z0-9_-]{33}$", url), # Has 33 characters as letters, numbers or - or _ + !grepl("\\.[^\\.]+$", url)) # doesn't have an extension + if (any(grepl("drive.google.com", url), isGID)) { + if (isGID) message("url seems to be a Google Drive ID") # ie <- isTRUE(internetExists()) # if (ie) { gf <- assessGoogle( @@ -821,7 +826,7 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac } gf } else { - NULL + NULL } normPath(guessedFile) } @@ -1555,7 +1560,17 @@ getTargetFilePath <- function(targetFile, archive, fileGuess, verbose, targetFile <- makeRelative(fileGuess, destinationPath) targetFilePath <- makeAbsolute(targetFile, destinationPath) } else { - targetFilePath <- NULL + # Case when archieve is passed, and fileGuess exists + if ((!is.null(archive) || !is.na(archive)) && !is.null(fileGuess)) { + messagePrepInputs("archieve was supplied, but targetFile not; guessed and will try ", fileGuess, + ". If this is incorrect, please supply targetFile", + verbose = verbose + ) + targetFile <- makeRelative(fileGuess, destinationPath) + targetFilePath <- makeAbsolute(targetFile, destinationPath) + } else { + targetFilePath <- NULL + } } } else { if (length(targetFile) > 1) { From 0ba0d1cb126b7ba14643f1ecb5745f5ff14a76b1 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Tue, 24 Oct 2023 12:02:51 -0700 Subject: [PATCH 32/70] minor Cache message corrections --- R/cache.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/cache.R b/R/cache.R index 748df7340..d83571518 100644 --- a/R/cache.R +++ b/R/cache.R @@ -1771,7 +1771,7 @@ CacheDigest <- function(objsToDigest, ..., algo = "xxhash64", calledFrom = "Cach userTagsMess <- if (!is.null(userTagsOrig)) { paste0( - "with user supplied tags: '", + " with user supplied tags: '", paste(userTagsOrig, collapse = ", "), "' " ) } @@ -2241,7 +2241,7 @@ returnObjFromRepo <- function(isInRepo, notOlderThan, fullCacheTableForObj, cach ], 1)) class(objSize) <- "object_size" bigFile <- isTRUE(objSize > 1e6) - fileFormat <- extractFromCache(fullCacheTableForObj, elem = "fileFormat") + fileFormat <- unique(extractFromCache(fullCacheTableForObj, elem = "fileFormat")) # can have a single tif for many entries messageCache(" ...(Object to retrieve (", basename2(CacheStoredFile(cachePath, isInRepo[[.cacheTableHashColName()]], format = fileFormat)), ")", From a91affff13c9631fb2b3e366f839c000753556d1 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Tue, 24 Oct 2023 12:03:27 -0700 Subject: [PATCH 33/70] .robustDigest of `matrix` needs to keep dims --- R/robustDigest.R | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/R/robustDigest.R b/R/robustDigest.R index e91b4960d..1254bb67c 100644 --- a/R/robustDigest.R +++ b/R/robustDigest.R @@ -378,8 +378,10 @@ setMethod( definition = function(object, .objects, length, algo, quick, classOptions) { # Need a specific method for data.frame or else it get "list" method, which is wrong object <- .removeCacheAtts(object) - dim(object) <- NULL - .robustDigest(object, classOptions = classOptions) + dims <- dim(object) + dim(object) <- NULL # need to get the separate numeric or integer, i.e., there is rounding + out <- .robustDigest(list(dims, object), classOptions = classOptions, algo = algo) + .doDigest(out, algo = algo) # From ad hoc tests, 6 was the highest I could go to maintain consistent between Linux and Windows } ) From ffa3075a1ca477f3130526d31e74a1d6a482c445 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Tue, 24 Oct 2023 12:16:32 -0700 Subject: [PATCH 34/70] make all length 1 NA values equal in a digest --- R/robustDigest.R | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/R/robustDigest.R b/R/robustDigest.R index 1254bb67c..7065853e1 100644 --- a/R/robustDigest.R +++ b/R/robustDigest.R @@ -485,6 +485,11 @@ basenames3 <- function(object, nParentDirs) { } out <- if (cacheSpeed == 1) { + if (length(x) == 1) { + if (is.atomic(x)) + if (isTRUE(is.na(x))) + x <- NA # make all NAs (NA_real_, NA, NA_character_ equal + } digest(x, algo = algo) } else if (cacheSpeed == 2) { fastdigest::fastdigest(x) From c61ac88d36c577896b75a744113ae3a8678ad7a4 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 1 Nov 2023 15:45:03 -0700 Subject: [PATCH 35/70] allow objSize to be NA --- R/DBI.R | 3 ++- R/cache.R | 9 +++++---- R/objectSize.R | 5 +++++ R/options.R | 7 +++++++ R/showCacheEtc.R | 10 ++++++++-- 5 files changed, 27 insertions(+), 7 deletions(-) diff --git a/R/DBI.R b/R/DBI.R index be16c1148..804e099de 100644 --- a/R/DBI.R +++ b/R/DBI.R @@ -175,7 +175,8 @@ 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 ", diff --git a/R/cache.R b/R/cache.R index d83571518..ccfbe79cc 100644 --- a/R/cache.R +++ b/R/cache.R @@ -865,10 +865,11 @@ Cache <- # This is for write conflicts to the SQLite database # (i.e., keep trying until it is written) - objSize <- sum(objSize(outputToSave)) + objSize <- if (getOption("reproducible.objSize", TRUE)) sum(objSize(outputToSave)) else NA + resultHash <- "" linkToCacheId <- NULL - if (objSize > 1e6) { + if (isTRUE(objSize > 1e6)) { resultHash <- CacheDigest(outputToSave, .objects = .objects, length = length, algo = algo, quick = quick, @@ -957,9 +958,9 @@ Cache <- otsObjSize <- gsub(grep("object\\.size:", userTags, value = TRUE), pattern = "object.size:", replacement = "" ) - otsObjSize <- as.numeric(otsObjSize) + otsObjSize <- if (identical(otsObjSize, "NA")) NA else as.numeric(otsObjSize) class(otsObjSize) <- "object_size" - isBig <- otsObjSize > 1e7 + isBig <- isTRUE(otsObjSize > 1e7) outputToSave <- progressBarCode( saveToCache( diff --git a/R/objectSize.R b/R/objectSize.R index 084244294..3d98e1a97 100644 --- a/R/objectSize.R +++ b/R/objectSize.R @@ -96,10 +96,15 @@ objSize.default <- function(x, quick = FALSE, ...) { objSize.list <- function(x, quick = FALSE, ...) { os <- obj_size(x) # need to get overall object size; not just elements; # but this doesn't work for e.g., terra + if (!quick) { out <- lapply(x, objSize, quick = quick) + os2 <- sum(unlist(out)) + os <- max(os2, os) + class(os) <- "lobstr_bytes" attr(os, "objSize") <- out } + os } diff --git a/R/options.R b/R/options.R index a656c1a1d..87936a602 100644 --- a/R/options.R +++ b/R/options.R @@ -80,6 +80,12 @@ #' \item{`nThreads`}{ #' Default: `1`. The number of threads to use for reading/writing cache files. #' } +#' \item{`objSize`}{ +#' Default: `TRUE`. Logical. If `TRUE`, then object sizes will be included in +#' the cache database. Simplying calculating object size of large objects can +#' be time consuming, so setting this to `FALSE` will make caching up to 10% +#' faster, depending on the objects. +#' } #' \item{`overwrite`}{ #' Default: `FALSE`. Used in [prepInputs()], [preProcess()], #' [downloadFile()], and [postProcess()]. @@ -205,6 +211,7 @@ reproducibleOptions <- function() { reproducible.messageColourCache = "blue", reproducible.messageColourQuestion = "green", reproducible.nThreads = 1, + reproducible.objSize = TRUE, reproducible.overwrite = FALSE, reproducible.quick = FALSE, reproducible.rasterRead = getEnv("R_REPRODUCIBLE_RASTER_READ", diff --git a/R/showCacheEtc.R b/R/showCacheEtc.R index 3b1d6ecae..cdbf391bc 100644 --- a/R/showCacheEtc.R +++ b/R/showCacheEtc.R @@ -187,7 +187,8 @@ setMethod( } if (isInteractive()) { - objSizes <- as.numeric(objsDT[tagKey == "object.size"][[.cacheTableTagColName()]]) + objSz <- objsDT[tagKey == "object.size"][[.cacheTableTagColName()]] + objSizes <- if ("NA" %in% objSz) NA else as.numeric(objSz) cacheSize <- sum(objSizes) / 4 } @@ -215,7 +216,7 @@ setMethod( # } } - if (isInteractive()) { + if (isInteractive() && isTRUE(!is.na(cacheSize))) { class(cacheSize) <- "object_size" formattedCacheSize <- format(cacheSize, "auto") if (isTRUE(ask)) { @@ -632,6 +633,11 @@ setMethod( a <- cacheTable } cn <- if (any(colnames(a) %in% "tag")) "tag" else "tagKey" + + nas <- a[[.cacheTableTagColName()]] %in% "NA" & a[[cn]] == "object.size" + if (any(nas)) + a <- a[!nas] + b <- a[a[[cn]] == "object.size", ] if (any(colnames(a) %in% "tag")) { fsTotal <- sum(as.numeric(unlist(lapply(strsplit(b[[cn]], split = ":"), function(x) x[[2]])))) / 4 From 9a6db36781e131f27ac96bd56d3a369942835275 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 1 Nov 2023 15:46:56 -0700 Subject: [PATCH 36/70] objSize stuff --- R/cache-internals.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/cache-internals.R b/R/cache-internals.R index 2169376df..63ff32773 100644 --- a/R/cache-internals.R +++ b/R/cache-internals.R @@ -13,7 +13,7 @@ ) 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)))) From 900c9479c8ee3b4bfc61a1d5d4af6f58e498d026 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 1 Nov 2023 15:47:22 -0700 Subject: [PATCH 37/70] allow headless Cache --- R/cache.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/R/cache.R b/R/cache.R index ccfbe79cc..3e2135fcc 100644 --- a/R/cache.R +++ b/R/cache.R @@ -1467,6 +1467,9 @@ getFunctionName2 <- function(mc) { isSquiggly <- FALSE if (!is.function(FUNcaptured[[1]])) { # e.g., just the name, such as rnorm --> convert to the actual function code + if (is(FUNcaptured[[1]], "(")) { + fnNameInit <- "headless" + } FUNcaptured[[1]] <- eval(FUNcaptured[[1]], envir = callingEnv) } From 7539054f8bd7ca95f1bc88842ae3d1262f24044e Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 13:18:39 -0700 Subject: [PATCH 38/70] add preDigest to `.wrap`, with same for other fns upstream --- R/DBI.R | 3 ++- R/cache-internals.R | 2 +- R/cache.R | 5 +++-- R/download.R | 8 ++++---- R/exportedMethods.R | 28 +++++++++++++++++++--------- 5 files changed, 29 insertions(+), 17 deletions(-) diff --git a/R/DBI.R b/R/DBI.R index 804e099de..004938f4e 100644 --- a/R/DBI.R +++ b/R/DBI.R @@ -208,7 +208,7 @@ saveToCache <- function(cachePath = getOption("reproducible.cachePath"), #' `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, @@ -257,6 +257,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) diff --git a/R/cache-internals.R b/R/cache-internals.R index 63ff32773..c1c193f6d 100644 --- a/R/cache-internals.R +++ b/R/cache-internals.R @@ -118,7 +118,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 ) diff --git a/R/cache.R b/R/cache.R index 3e2135fcc..4b5d37a7e 100644 --- a/R/cache.R +++ b/R/cache.R @@ -837,7 +837,8 @@ Cache <- # Can make new methods by class to add tags to outputs if (.CacheIsNew) { - outputToSave <- .wrap(output, cachePath, drv = drv, conn = conn, verbose = verbose) + outputToSave <- .wrap(output, cachePath, preDigest = preDigest, + drv = drv, conn = conn, verbose = verbose) if (isTRUE(is.character(outputToSave)) && isTRUE(!is.character(output))) outputToSave <- asPath(outputToSave) output <- .CopyCacheAtts(outputToSave, output) @@ -2302,7 +2303,7 @@ returnObjFromRepo <- function(isInRepo, notOlderThan, fullCacheTableForObj, cach # Here, upload local copy to cloud folder isInCloud <- any(grepl(outputHash, gdriveLs$name)) if (isInCloud %in% FALSE) { - outputToSave <- .wrap(output, cachePath, drv = drv, conn = conn, verbose = verbose) + outputToSave <- .wrap(output, cachePath, preDigest = preDigest, drv = drv, conn = conn, verbose = verbose) cufc <- try(cloudUploadFromCache(isInCloud, outputHash, cachePath, cloudFolderID, ## TODO: saved not found outputToSave, verbose = verbose diff --git a/R/download.R b/R/download.R index 34495dd4f..0050304b4 100755 --- a/R/download.R +++ b/R/download.R @@ -24,7 +24,7 @@ downloadFile <- function(archive, targetFile, neededFiles, destinationPath = getOption("reproducible.destinationPath", "."), quick, checksumFile, dlFun = NULL, - checkSums, url, needChecksums, + checkSums, url, needChecksums, preDigest, overwrite = getOption("reproducible.overwrite", TRUE), verbose = getOption("reproducible.verbose", 1), purge = FALSE, .tempPath, ...) { @@ -111,7 +111,7 @@ downloadFile <- function(archive, targetFile, neededFiles, targetFile = targetFile, fileToDownload = fileToDownload, messSkipDownload = messSkipDownload, checkSums = checkSums, dlFun = dlFun, destinationPath = destinationPath, - overwrite = overwrite, needChecksums = needChecksums, + overwrite = overwrite, needChecksums = needChecksums, preDigest = preDigest, verbose = verbose, .tempPath = .tempPath, ... ) ) @@ -504,7 +504,7 @@ dlGeneric <- function(url, destinationPath, verbose = getOption("reproducible.ve #' downloadRemote <- function(url, archive, targetFile, checkSums, dlFun = NULL, fileToDownload, messSkipDownload, - destinationPath, overwrite, needChecksums, .tempPath, + destinationPath, overwrite, needChecksums, .tempPath, preDigest, verbose = getOption("reproducible.verbose", 1), ...) { noTargetFile <- is.null(targetFile) || length(targetFile) == 0 # browser(expr = exists("._downloadRemote_1")) @@ -591,7 +591,7 @@ downloadRemote <- function(url, archive, targetFile, checkSums, dlFun = NULL, # where the function actually downloaded the file, we save it as an RDS file if (needSave) { if (!file.exists(destFile)) { - out2 <- .wrap(out) + out2 <- .wrap(out, preDigest = preDigest) saveRDS(out2, file = destFile) } } diff --git a/R/exportedMethods.R b/R/exportedMethods.R index 403166316..beb1832f5 100644 --- a/R/exportedMethods.R +++ b/R/exportedMethods.R @@ -491,7 +491,7 @@ unmakeMemoisable.default <- function(x) { #' #' @export #' -.wrap <- function(obj, cachePath, drv = getDrv(getOption("reproducible.drv", NULL)), +.wrap <- function(obj, cachePath, preDigest, drv = getDrv(getOption("reproducible.drv", NULL)), conn = getOption("reproducible.conn", NULL), verbose = getOption("reproducible.verbose")) { UseMethod(".wrap") @@ -499,25 +499,35 @@ unmakeMemoisable.default <- function(x) { #' @export #' @rdname dotWrap -.wrap.list <- function(obj, cachePath, drv = getDrv(getOption("reproducible.drv", NULL)), +.wrap.list <- function(obj, cachePath, preDigest, drv = getDrv(getOption("reproducible.drv", NULL)), conn = getOption("reproducible.conn", NULL), verbose = getOption("reproducible.verbose")) { - obj <- lapply(obj, .wrap, cachePath = cachePath, drv = drv, conn = conn, verbose = verbose) + attrsOrig <- attributes(obj) + obj <- lapply(obj, .wrap, preDigest = preDigest, cachePath = cachePath, drv = drv, conn = conn, verbose = verbose) hasTagAttr <- lapply(obj, function(x) attr(x, "tags")) - tagAttr <- unlist(hasTagAttr <- lapply(obj, function(x) attr(x, "tags"))) - if (!is.null(tagAttr)) { - attr(obj, "tags") <- tagAttr + tagAttr <- list(unlist(hasTagAttr)) + if (length(tagAttr)) { + if (is.null(attrsOrig[["tags"]])) { + newList <- tagAttr + } else { + newList <- try(modifyList(attrsOrig["tags"], tagAttr)) + } + attrsOrig["tags"] <- newList + } + if (!is.null(attrsOrig)) { + for (tt in c(".Cache", "tags", "call")) + attr(obj, tt) <- attrsOrig[[tt]] } obj } #' @export #' @rdname dotWrap -.wrap.environment <- function(obj, cachePath, drv = getDrv(getOption("reproducible.drv", NULL)), +.wrap.environment <- function(obj, cachePath, preDigest, drv = getDrv(getOption("reproducible.drv", NULL)), conn = getOption("reproducible.conn", NULL), verbose = getOption("reproducible.verbose")) { obj2 <- as.list(obj, all.names = FALSE) - out <- .wrap(obj2, cachePath = cachePath, drv = drv, conn = conn, verbose = verbose) + out <- .wrap(obj2, cachePath = cachePath, preDigest = preDigest, drv = drv, conn = conn, verbose = verbose) obj <- Copy(obj) obj2 <- list2envAttempts(out, obj) if (!is.null(obj2)) obj <- obj2 @@ -536,7 +546,7 @@ unmakeMemoisable.default <- function(x) { #' } #' -.wrap.default <- function(obj, cachePath, drv = getDrv(getOption("reproducible.drv", NULL)), +.wrap.default <- function(obj, cachePath, preDigest, drv = getDrv(getOption("reproducible.drv", NULL)), conn = getOption("reproducible.conn", NULL), verbose = getOption("reproducible.verbose")) { rasters <- is(obj, "Raster") From 5f5f5c89b69ae46c185c437022d1164e15ebb17c Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 13:19:39 -0700 Subject: [PATCH 39/70] minor --- R/robustDigest.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/robustDigest.R b/R/robustDigest.R index 7065853e1..502711440 100644 --- a/R/robustDigest.R +++ b/R/robustDigest.R @@ -490,7 +490,7 @@ basenames3 <- function(object, nParentDirs) { if (isTRUE(is.na(x))) x <- NA # make all NAs (NA_real_, NA, NA_character_ equal } - digest(x, algo = algo) + digest::digest(x, algo = algo) } else if (cacheSpeed == 2) { fastdigest::fastdigest(x) } else { From 3d96ebeb6183d091466722cb30980ddac43ebb65 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 13:24:37 -0700 Subject: [PATCH 40/70] allow new pathway through postProcessTo uses sf::gdal_utils --- R/options.R | 10 +++ R/postProcessTo.R | 175 +++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 183 insertions(+), 2 deletions(-) diff --git a/R/options.R b/R/options.R index 87936a602..ad53c2a07 100644 --- a/R/options.R +++ b/R/options.R @@ -55,6 +55,15 @@ #' They may, however, be very effective in speeding up some things, specifically, #' uploading cached elements via `googledrive` in `cloudCache`. #' } +#' \item{`gdalwarp`}{ +#' Default: `FALSE`. Experimental. During `postProcessTo` the standard approach +#' is to use `terra` functions directly, with several strategic uses of `sf`. However, +#' in the special case when `from` is a `SpatRaster` or `Raster`, `maskTo` is a +#' `SpatVector` or `SFC_POLYGON` and `projectTo` is a `SpatRaster` or `Raster`, setting +#' this option to `TRUE` will use `sf::gdal_utils("warp")`. In many test cases, +#' this is much faster than the `terra` sequence. The resulting `SpatRaster` is +#' not identical, but it is very similar. +#' } #' \item{`inputPaths`}{ #' Default: `NULL`. Used in [prepInputs()] and [preProcess()]. #' If set to a path, this will cause these functions to save their downloaded and preprocessed @@ -202,6 +211,7 @@ reproducibleOptions <- function() { reproducible.destinationPath = NULL, reproducible.drv = NULL, # RSQLite::SQLite(), reproducible.futurePlan = FALSE, # future::plan("multisession"), #memoise + reproducible.gdalwarp = FALSE, reproducible.inputPath = file.path(tempdir(), "reproducible", "input"), reproducible.inputPaths = NULL, reproducible.inputPathsRecursive = FALSE, diff --git a/R/postProcessTo.R b/R/postProcessTo.R index e49621658..c30af8b3f 100644 --- a/R/postProcessTo.R +++ b/R/postProcessTo.R @@ -215,6 +215,23 @@ postProcessTo <- function(from, to, } } + couldDoGDAL <- isGridded(from) && isVector(maskTo) && isGridded(projectTo) + + if (isTRUE(getOption("reproducible.gdalwarp", FALSE)) && couldDoGDAL) { + ############################################################# + # project resample mask sequence ################################ + ############################################################# + messagePrepInputs(" using sf::gdal_utils('warp') because options(\"reproducible.gdalwarp\" = TRUE) ...", appendLF = FALSE, verbose = verbose) + st <- Sys.time() + + from <- gdalProject(fromRas = from, toRas = projectTo, verbose = verbose, ...) + from <- gdalResample(fromRas = from, toRas = projectTo, verbose = verbose) + from <- gdalMask(fromRas = from, maskToVect = maskTo, writeTo = writeTo, verbose = verbose, ...) + # from <- setMinMax(from) + + } else { + if (couldDoGDAL) + message("Try setting options('reproducible.gdalwarp' = TRUE) to use a different, possibly faster, algorithm") ############################################################# # crop project mask sequence ################################ ############################################################# @@ -241,10 +258,14 @@ postProcessTo <- function(from, to, ... ) + } + + # REVERT TO ORIGINAL INPUT CLASS - from <- revertClass(from, isStack, isBrick, isRasterLayer, isSF, isSpatial) + from <- revertClass(from, isStack, isBrick, isRasterLayer, isSF, isSpatial, + origFromClass = origFromClass) messagePrepInputs(" postProcessTo done in ", format(difftime(Sys.time(), startTime), - units = "secs", digits = 3 + units = "secs", digits = 3 ), verbose = verbose ) @@ -1321,3 +1342,153 @@ convertToSFwMessage <- function(w, obj) { obj <- sf::st_as_sf(obj) obj } + +gdalProject <- function(fromRas, toRas, filenameDest, verbose = getOption("reproducible.verbose"), ...) { + + messagePrepInputs(" running gdalProject ...", appendLF = FALSE, verbose = verbose) + st <- Sys.time() + + hasMethod <- which(...names() %in% "method") + method <- if (length(hasMethod)) { + method <- assessDataTypeOuter(fromRas, ...elt(hasMethod)) + } else { + NULL + } + if (is.null(method)) + method <- "near" + + fns <- unique(Filenames(fromRas)) + if (length(fns) ==1 && isTRUE(nzchar(fns))) { + fnSource <- fns + } else { + fnSource <- tempfile(fileext = ".tif") + writeRaster(fromRas, filename = fnSource) + on.exit(unlink(fnSource)) + } + + if (missing(filenameDest)) + filenameDest <- tempfile(fileext = ".tif") + + tf4 <- tempfile(fileext = ".prj") + on.exit(unlink(tf4), add = TRUE) + cat(sf::st_crs(toRas)$wkt, file = tf4) + system.time(gdal_utils( + util = "warp", + source = fnSource, + destination = filenameDest, + options = c( + "-t_srs", tf4, + "-r", method, + "-te", c(xmin(toRas), ymin(toRas), + xmin(toRas) + (ncol(toRas) ) * res(toRas)[1], + ymin(toRas) + (nrow(toRas) ) * res(toRas)[2]), + "-te_srs", tf4, + "-dstnodata", "NA", + "-overwrite" + )) + ) + + out <- terra::rast(filenameDest) + messagePrepInputs(" ...done in ", + format(difftime(Sys.time(), st), units = "secs", digits = 3), + verbose = verbose) + + out +} + + + +gdalResample <- function(fromRas, toRas, filenameDest, verbose = getOption("reproducible.verbose")) { + + messagePrepInputs(" running gdalResample ...", appendLF = FALSE, verbose = verbose) + st <- Sys.time() + + fns <- unique(Filenames(fromRas)) + if (length(fns) ==1 && isTRUE(nzchar(fns))) { + fnSource <- fns + } else { + fnSource <- tempfile(fileext = ".tif") + writeRaster(fromRas, filename = fnSource) + on.exit(unlink(fnSource)) + } + + if (missing(filenameDest)) + filenameDest <- tempfile(fileext = ".tif") + + tf4 <- tempfile(fileext = ".prj") + cat(sf::st_crs(toRas)$wkt, file = tf4) + + + system.time(gdal_utils( + util = "warp", + source = fnSource, + destination = filenameDest, + options = c( + "-r", "near", + "-te", c(xmin(toRas), ymin(toRas), + xmin(toRas) + (ncol(toRas) ) * res(toRas)[1], + ymin(toRas) + (nrow(toRas) ) * res(toRas)[2]), + "-te_srs", tf4, # 3347, 3348, 3978, 3979 + "-tr", res(toRas), + "-dstnodata", "NA", + "-tap", + "-overwrite" + )) + ) + out <- terra::rast(filenameDest) + messagePrepInputs(" ...done in ", + format(difftime(Sys.time(), st), units = "secs", digits = 3), + verbose = verbose) + out +} + + +gdalMask <- function(fromRas, maskToVect, writeTo = NULL, verbose = getOption("reproducible.verbose"), ...) { + + messagePrepInputs(" running gdalMask ...", appendLF = FALSE, verbose = verbose) + st <- Sys.time() + + fns <- unique(Filenames(fromRas)) + + if (length(fns) ==1 && isTRUE(nzchar(fns))) { + fnSource <- fns + } else { + fnSource <- tempfile(fileext = ".tif") + writeRaster(fromRas, filename = fnSource) + on.exit(unlink(fnSource)) + } + + tf3 <- tempfile(fileext = ".shp") + shp <- terra::project(maskToVect, terra::crs(fromRas)) + writeVector(shp, file = tf3) + + dPath <- which(...names() %in% "destinationPath") + destinationPath <- if (length(dPath)) { + destinationPath <- ...elt(dPath) + } else { + getOption("reproducible.destinationPath", ".") + } + + if (is.null(writeTo)) + writeTo <- tempfile(fileext = ".tif") + + writeTo <- determineFilename(writeTo, destinationPath = destinationPath, verbose = verbose) + + system.time(gdal_utils( + util = "warp", + source = fnSource, + destination = writeTo, + options = c( + "-cutline", tf3, + "-dstnodata", "NA", + "-overwrite" + )) + ) + + out <- terra::rast(writeTo) + messagePrepInputs(" ...done in ", + format(difftime(Sys.time(), st), units = "secs", digits = 3), + verbose = verbose) + out +} + From d8acba7b36afd542a5a8884f5472f478528574dd Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 13:25:07 -0700 Subject: [PATCH 41/70] new fns: isPolygons and isGeomType --- R/postProcessTo.R | 65 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 65 insertions(+) diff --git a/R/postProcessTo.R b/R/postProcessTo.R index c30af8b3f..66fe36fe8 100644 --- a/R/postProcessTo.R +++ b/R/postProcessTo.R @@ -1343,6 +1343,71 @@ convertToSFwMessage <- function(w, obj) { obj } + +# extManyPoints <- function(ras, res) { +# if (missing(res)) { +# if (isRaster(ras)) +# res <- res(ras) +# else +# res <- c(250, 250) +# } +# +# xmn <- xmin(ras) +# xmx <- xmax(ras) +# ymn <- ymin(ras) +# ymx <- ymax(ras) +# xs <- seq(xmn, xmx, by = res[1]) +# ys <- seq(ymn, ymx, by = res[2]) +# rbind(cbind(xs, ymn), +# cbind(xmx, ys), +# cbind(rev(xs), ymx), +# cbind(xmn, rev(ys)), +# cbind(xmn, ymn) +# ) +# } + +# isPoints <- function(geom) { +# isGeomType(geom, "points") +# } +# +isPolygons <- function(geom) { + isGeomType(geom, "polygons") +} + +# isLines <- function(geom) { +# isGeomType(geom, "lines") +# } + +isGeomType <- function(geom, type) { + out <- FALSE + if (isVector(geom)) { + out <- if (isSpat(geom)) { + if (type == "points") + is.points(geom) + else if (type == "polygons") + is.polygons(geom) + else if (type == "lines") + is.lines(geom) + } else { + if (type == "points") + is(sf::st_geometry(geom), "sfc_POINT") + else if (type == "polygons") + is(sf::st_geometry(geom), "sfc_POLYGON") + else if (type == "lines") + is(sf::st_geometry(geom), "sfc_LINE") + else { + warning("geom is not simple point, polygon or line geometry; returning class") + is(sf::st_geometry(geom)) + } + } + } + return(out) +} + + + + + gdalProject <- function(fromRas, toRas, filenameDest, verbose = getOption("reproducible.verbose"), ...) { messagePrepInputs(" running gdalProject ...", appendLF = FALSE, verbose = verbose) From 3dcfd9d2ae79131f012116ab114d4af1177e7d6e Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 13:25:57 -0700 Subject: [PATCH 42/70] skip pre-crop for polygons -- polygons situation --> creating slivers --- R/postProcessTo.R | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/R/postProcessTo.R b/R/postProcessTo.R index 66fe36fe8..a87e65b76 100644 --- a/R/postProcessTo.R +++ b/R/postProcessTo.R @@ -232,12 +232,16 @@ postProcessTo <- function(from, to, } else { if (couldDoGDAL) message("Try setting options('reproducible.gdalwarp' = TRUE) to use a different, possibly faster, algorithm") - ############################################################# - # crop project mask sequence ################################ - ############################################################# - from <- cropTo(from, cropTo, needBuffer = TRUE, ..., overwrite = overwrite) # crop first for speed - from <- projectTo(from, projectTo, ..., overwrite = overwrite) # need to project with edges intact - from <- maskTo(from, maskTo, ..., overwrite = overwrite) + ############################################################# + # crop project mask sequence ################################ + ############################################################# + # Basically, when both layers are vector, it appears to sometimes be lossy to do first + # cropTo --> i.e., projecting cropTo to from's crs, then crop, then proceed was making + # errors and slivers + if (!(isPolygons(from) && isPolygons(projectTo) && identical(cropTo, projectTo))) + from <- cropTo(from, cropTo, needBuffer = TRUE, ..., overwrite = overwrite) # crop first for speed + from <- projectTo(from, projectTo, ..., overwrite = overwrite) # need to project with edges intact + from <- maskTo(from, maskTo, ..., overwrite = overwrite) from <- cropTo(from, cropTo, needBuffer = FALSE, ..., overwrite = overwrite) # need to recrop to trim excess pixels in new projection # Put this message near the end so doesn't get lost From 3889670c0c4567e5bfd7cf6470725edc5dd31fdb Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 13:26:34 -0700 Subject: [PATCH 43/70] fewer warnings in postProcessTo --- R/postProcessTo.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/postProcessTo.R b/R/postProcessTo.R index a87e65b76..11682ce4e 100644 --- a/R/postProcessTo.R +++ b/R/postProcessTo.R @@ -770,8 +770,10 @@ cropTo <- function(from, cropTo = NULL, needBuffer = FALSE, overwrite = FALSE, } if (!sameCRS) { + withCallingHandlers({ attempt <- 1 + doneWarningAlready <- 0 while (attempt <= 2) { isSF <- isSF(cropTo) @@ -792,10 +794,11 @@ cropTo <- function(from, cropTo = NULL, needBuffer = FALSE, overwrite = FALSE, } }, warning = function(w) { - if (any(grepl(warningCertificateGrep, w$message))) { + if (any(grepl(warningCertificateGrep, w$message)) && doneWarningAlready == 0) { if (!isSF) { cropTo <<- convertToSFwMessage(w, cropTo) attempt <<- 0 + doneWarningAlready <<- 1 } invokeRestart("muffleWarning") } From 87c7edd5035ccc29ed277919347184b48a36d285 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 13:27:24 -0700 Subject: [PATCH 44/70] sometimes project makes errors that were not being caught --- R/postProcessTo.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/postProcessTo.R b/R/postProcessTo.R index 11682ce4e..60e18fff9 100644 --- a/R/postProcessTo.R +++ b/R/postProcessTo.R @@ -684,6 +684,7 @@ projectTo <- function(from, projectTo, overwrite = FALSE, } }) from <- from13 + from <- fixErrorsIn(from) # sometimes `project` makes invalid if (attempt == 4) message("... converting to sf object worked to deal with ", warningCertificateGrep) From 15dbfc00de723e08e0cef8376a5f688d7a53fda2 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 13:28:19 -0700 Subject: [PATCH 45/70] postProcessTo -- other edge cases for cropTo -- use convex hull --- R/postProcessTo.R | 30 +++++++++++++++++++----------- 1 file changed, 19 insertions(+), 11 deletions(-) diff --git a/R/postProcessTo.R b/R/postProcessTo.R index 60e18fff9..0bc9b721b 100644 --- a/R/postProcessTo.R +++ b/R/postProcessTo.R @@ -242,15 +242,15 @@ postProcessTo <- function(from, to, from <- cropTo(from, cropTo, needBuffer = TRUE, ..., overwrite = overwrite) # crop first for speed from <- projectTo(from, projectTo, ..., overwrite = overwrite) # need to project with edges intact from <- maskTo(from, maskTo, ..., overwrite = overwrite) - from <- cropTo(from, cropTo, needBuffer = FALSE, ..., overwrite = overwrite) # need to recrop to trim excess pixels in new projection + from <- cropTo(from, cropTo, needBuffer = FALSE, ..., overwrite = overwrite) # need to recrop to trim excess pixels in new projection - # Put this message near the end so doesn't get lost - if (is.naSpatial(cropTo) && isVector(maskTo)) { - messagePrepInputs(" ** cropTo is NA, but maskTo is a Vector dataset; ", - verbose = verbose - ) - messagePrepInputs(" this has the effect of cropping anyway", - verbose = verbose + # Put this message near the end so doesn't get lost + if (is.naSpatial(cropTo) && isVector(maskTo)) { + messagePrepInputs(" ** cropTo is NA, but maskTo is a Vector dataset; ", + verbose = verbose + ) + messagePrepInputs(" this has the effect of cropping anyway", + verbose = verbose ) } @@ -259,8 +259,8 @@ postProcessTo <- function(from, to, # WRITE STEP from <- writeTo( from, writeTo, overwrite, isStack, isBrick, isRaster, isSpatRaster, - ... - ) + ... + ) } @@ -788,7 +788,15 @@ cropTo <- function(from, cropTo = NULL, needBuffer = FALSE, overwrite = FALSE, terraCRSFrom <- terraCRSFrom@projargs } } - cropToInFromCRS <- terra::project(cropTo, terraCRSFrom) + if (isVector(cropTo) && isGridded(from)) { + if (isSpat(cropTo)) + cropTo <- sf::st_as_sf(cropTo) + a <- sf::st_convex_hull(cropTo) + cropToInFromCRS <- terra::project(terra::vect(a), terraCRSFrom) + } else { + # cropToVec <- terra::as.polygons(terra::ext(cropTo), crs = terra::crs(cropTo)) + cropToInFromCRS <- terra::project(cropTo, terraCRSFrom) + } ext <- terra::ext(cropToInFromCRS) # create extent as an object; keeps crs correctly } attempt <- attempt + 2 From 0ead8e7970c79886b8fbdeea0f17c25f9986f09d Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 13:29:35 -0700 Subject: [PATCH 46/70] Cache messaging -- minor changes -- add more info --- R/DBI.R | 4 ++-- R/cache.R | 10 +++++----- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/R/DBI.R b/R/DBI.R index 004938f4e..df473ac0e 100644 --- a/R/DBI.R +++ b/R/DBI.R @@ -125,8 +125,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 ) } diff --git a/R/cache.R b/R/cache.R index 4b5d37a7e..736c1410d 100644 --- a/R/cache.R +++ b/R/cache.R @@ -971,7 +971,8 @@ Cache <- ), doProgress = isBig, message = c( - "Saving ", "large "[isBig], "object (cacheId: ", outputHash, ") to Cache", ": "[isBig], + "Saving ", "large "[isBig], "object (fn: ", fnDetails$functionName, + ", cacheId: ", outputHash, ") to Cache", ": "[isBig], format(otsObjSize, units = "auto")[isBig] ), verboseLevel = 2 - isBig, verbose = verbose, @@ -1871,9 +1872,8 @@ CacheDigest <- function(objsToDigest, ..., algo = "xxhash64", calledFrom = "Cach if (!identical("devMode", useCache)) { messageCache("There is no similar item in the cachePath ", if (!is.null(functionName)) paste0("of '", functionName, "' "), - userTagsMess, - verbose = verbose - ) + verbose = verbose) + messageCache(" ", userTagsMess, verbose = verbose) } } } @@ -2247,7 +2247,7 @@ returnObjFromRepo <- function(isInRepo, notOlderThan, fullCacheTableForObj, cach class(objSize) <- "object_size" bigFile <- isTRUE(objSize > 1e6) fileFormat <- unique(extractFromCache(fullCacheTableForObj, elem = "fileFormat")) # can have a single tif for many entries - messageCache(" ...(Object to retrieve (", + messageCache(" ...(Object to retrieve (fn: ", fnDetails$functionName, ", ", basename2(CacheStoredFile(cachePath, isInRepo[[.cacheTableHashColName()]], format = fileFormat)), ")", if (bigFile) " is large: ", From 001c213ce1ee7fb2b042276c66534c86b1c39fbd Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 13:30:24 -0700 Subject: [PATCH 47/70] Cache -- edge cases --- R/DBI.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/DBI.R b/R/DBI.R index df473ac0e..f649069e8 100644 --- a/R/DBI.R +++ b/R/DBI.R @@ -616,6 +616,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) } @@ -631,7 +632,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) { From b389ee7688b895cdced4b51b6acd088c9c6e1d3a Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 13:31:18 -0700 Subject: [PATCH 48/70] wrapSpatRaster -- new edge cases dealt with (file-backed, subset of layers) --- R/exportedMethods.R | 51 +++++++++++++++++++++++++++++++++++++++------ 1 file changed, 45 insertions(+), 6 deletions(-) diff --git a/R/exportedMethods.R b/R/exportedMethods.R index beb1832f5..9d0ba26d0 100644 --- a/R/exportedMethods.R +++ b/R/exportedMethods.R @@ -663,9 +663,34 @@ unmakeMemoisable.default <- function(x) { wrapSpatRaster <- function(obj, cachePath) { cls <- class(obj) + fns <- Filenames(obj) layerNams <- paste(names(obj), collapse = layerNamesDelimiter) obj2 <- asPath(Filenames(obj, allowMultiple = FALSE)) - obj <- asPath(Filenames(obj)) + nlyrsInFile <- as.integer(terra::nlyr(terra::rast(fns))) + + # A file-backed rast can 1) not be using all the layers in the file and + # 2) have layer names renamed + whLayers <- seq_along(names(obj)) + if (!identical(nlyrsInFile, length(names(obj)))) { + rr <- rast(fns); + objDigs <- unlist(lapply(layerNams, function(ln) .robustDigest(obj[[ln]][]))) + digs <- character() + whLayers <- integer() + + # don't need to go through all layers if the current file has only some; run through from start + for (ln in seq_len(nlyr(rr))) { + digs[ln] <- .robustDigest(rr[[ln]][]) + if (digs[ln] %in% objDigs) + whLayers <- c(ln, whLayers) + if (all(digs %in% objDigs)) + break + } + # inFileDigs <- unlist(lapply(seq_len(nlyr(rr)), function(ln) ) + # whLayers <- which(unlist(inFileDigs) %in% unlist(objDigs)) + } + if (is.character(obj)) + if (any(grepl("MDC_historical_NT", basename2(obj)))) browser() + obj <- asPath(fns) attr(obj, "tags") <- c( attr(obj, "tags"), paste0("origFilename:", basename2(obj)), @@ -678,6 +703,7 @@ wrapSpatRaster <- function(obj, cachePath) { paste0("fileFormat:", tools::file_ext(obj)), paste0("saveRawFile:", TRUE), paste0("loadFun:", "terra::rast"), + paste0("whLayers:", whLayers), paste0("layerNames:", layerNams), paste0("whichFiles:", obj2) ) @@ -699,15 +725,28 @@ unwrapSpatRaster <- function(obj, cachePath) { newName <- file.path(cachePath, origRelName) } whFiles <- newName[match(basename(extractFromCache(tags, "whichFiles")), origFilename)] + # filenameInCache <- Map(ff = whFiles, form = fileExt(obj), function(ff, form) { + # CacheStoredFile(cachePath, + # cacheId = tools::file_path_sans_ext(basename(ff)), + # format = form + # ) + # }) + filenameInCache <- CacheStoredFile(cachePath, - cacheId = tools::file_path_sans_ext(basename(obj)), - format = fileExt(obj) + # cacheId = tools::file_path_sans_ext(basename(obj)), + obj = obj ) - hardLinkOrCopy(filenameInCache, obj, verbose = 0) + + hardLinkOrCopy(unlist(filenameInCache), obj, verbose = 0) obj <- eval(parse(text = extractFromCache(tags, "loadFun")))(whFiles) possNames <- strsplit(extractFromCache(tags, "layerNames"), split = layerNamesDelimiter)[[1]] - # if (!identical(possNames, names(obj))) - # browser() + namsObjs <- names(obj) + if (!identical(possNames, namsObjs)) { + whLayers <- as.integer(extractFromCache(tags, "whLayers")) + if (length(whLayers) != length(namsObjs)) { + obj <- obj[[whLayers]] + } + } # names can be wrong e.g., with "nextNumericName" ... habitatQuality_1 instead of habitatQuality. # Should use the one without the `nextNumericName` From 8c21093b49faefaeb7227c2aa7b808227eea0753 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 13:32:04 -0700 Subject: [PATCH 49/70] minmaxFn -- setMinMax if not set --- R/terra-migration.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/terra-migration.R b/R/terra-migration.R index b4edf8cde..5401fdb18 100644 --- a/R/terra-migration.R +++ b/R/terra-migration.R @@ -41,6 +41,8 @@ minmaxFn <- function(x, which = "max") { .requireNamespace("terra", stopOnFALSE = TRUE) fn <- ifelse(identical(which, "max"), "tail", "head") fn <- getFromNamespace(fn, ns = "utils") + if (!terra::hasMinMax(x)) + x <- terra::setMinMax(x) out <- fn(terra::minmax(x), 1)[1, ] } if (is.null(out)) { From debbcf376e905f6f4c94db382ccf458ef082b014 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 13:34:03 -0700 Subject: [PATCH 50/70] preProcess -- Checksums tweaks to get more edge cases correct --- R/preProcess.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/R/preProcess.R b/R/preProcess.R index 9cca96228..018f7d88a 100644 --- a/R/preProcess.R +++ b/R/preProcess.R @@ -340,6 +340,7 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac destinationPath = destinationPath, append = results$needChecksums >= 2 ) + needChecksums <- 0 } } @@ -687,6 +688,7 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac destinationPath = csp, append = needChecksums >= 2 ) + needChecksums <- 0 } if (!is.null(reproducible.inputPaths) && needChecksums != 3) { checkSumFilePathInputPaths <- identifyCHECKSUMStxtFile(reproducible.inputPaths[[1]]) @@ -697,6 +699,7 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac destinationPath = destinationPath, append = needChecksums == 2 ) + needChecksums <- 0 }) } on.exit( From 87e5414edc88483100c39f519f0e9d51aba035fd Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 13:34:49 -0700 Subject: [PATCH 51/70] preProcess - verbose --- R/preProcess.R | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/R/preProcess.R b/R/preProcess.R index 018f7d88a..3632f1a8f 100644 --- a/R/preProcess.R +++ b/R/preProcess.R @@ -180,6 +180,7 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac } dlFunCaptured <- substitute(dlFun) prepInputsAssertions(environment()) + verboseCFS <- verbose isAlreadyQuoted <- any(grepl("quote", dlFunCaptured)) if (isAlreadyQuoted) { dlFunCaptured <- eval(dlFunCaptured) @@ -304,8 +305,9 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac } else { outFromSimilar <- .checkForSimilar(neededFiles, alsoExtract, archive, targetFile, destinationPath = destinationPath, checkSums, - checkSumFilePath = checkSumFilePath, url + checkSumFilePath = checkSumFilePath, url, verbose = verboseCFS ) + verboseCFS <- verbose - 1 list2env(outFromSimilar, environment()) # neededFiles, checkSums } neededFiles <- unique(makeAbsolute(neededFiles, destinationPath)) @@ -469,8 +471,10 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac archive = archive, targetFile = targetFile, destinationPath = destinationPath, checkSums = checkSums, checkSumFilePath = checkSumFilePath, - url = url + url = url, verbose = verboseCFS ) + verboseCFS <- verbose - 1 + list2env(outFromSimilar, environment()) # neededFiles, checkSums # don't include targetFile in neededFiles -- extractFromArchive deals with it separately @@ -547,7 +551,8 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac from <- filesExtr[whFilesExtrInIP] to <- makeAbsolute(makeRelative(from, destinationPath), destinationPathUser) if (!isTRUE(all(from %in% to))) { - messagePrepInputs("...using copy in getOption('reproducible.inputPaths')...") + messagePrepInputs("...using copy in getOption('reproducible.inputPaths')...", + verbose = verbose) } outHLC <- hardLinkOrCopy(from, to) filesExtr[foundInInputPaths] <- to @@ -578,7 +583,8 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac from <- filesExtr[whFilesExtrInLP] to <- makeAbsolute(makeRelative(from, destinationPath), reproducible.inputPaths) if (!isTRUE(all(from %in% to))) { - messagePrepInputs("... copying to getOption('reproducible.inputPaths')...") + messagePrepInputs("... copying to getOption('reproducible.inputPaths')...", + verbose = verbose) } outHLC <- hardLinkOrCopy(from, to) } @@ -603,7 +609,7 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac destinationPath = destinationPath, checkSums = checkSums, checkSumFilePath = checkSumFilePath, - targetFile = targetFile + targetFile = targetFile, verbose = verboseCFS ) neededFiles <- outFromSimilar$neededFiles checkSums <- outFromSimilar$checkSums @@ -910,7 +916,8 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac url, verbose = getOption("reproducible.verbose", 1)) { lookForSimilar <- FALSE if (is.null(alsoExtract) || length(alsoExtract) == 0) { - messagePrepInputs("alsoExtract is unspecified; assuming that all files must be extracted") + messagePrepInputs("alsoExtract is unspecified; assuming that all files must be extracted", + verbose = verbose) lookForSimilar <- "all" } else { if (!all(is.na(alsoExtract))) { From a4e84fbc86e730b18b9655bd69cc347a20eb4247 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 13:34:03 -0700 Subject: [PATCH 52/70] preProcess -- Checksums tweaks to get more edge cases correct --- R/preProcess.R | 3 +++ R/prepInputs.R | 3 ++- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/R/preProcess.R b/R/preProcess.R index 9cca96228..018f7d88a 100644 --- a/R/preProcess.R +++ b/R/preProcess.R @@ -340,6 +340,7 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac destinationPath = destinationPath, append = results$needChecksums >= 2 ) + needChecksums <- 0 } } @@ -687,6 +688,7 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac destinationPath = csp, append = needChecksums >= 2 ) + needChecksums <- 0 } if (!is.null(reproducible.inputPaths) && needChecksums != 3) { checkSumFilePathInputPaths <- identifyCHECKSUMStxtFile(reproducible.inputPaths[[1]]) @@ -697,6 +699,7 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac destinationPath = destinationPath, append = needChecksums == 2 ) + needChecksums <- 0 }) } on.exit( diff --git a/R/prepInputs.R b/R/prepInputs.R index 7e913eac6..90ba4181a 100644 --- a/R/prepInputs.R +++ b/R/prepInputs.R @@ -1021,7 +1021,8 @@ appendChecksumsTable <- function(checkSumFilePath, filesToChecksum, append <- FALSE } else { setDT(cs) - nonCurrentFiles <- cs[!file %in% makeRelative(filesToChecksum, destinationPath)] + nonCurrentFiles <- cs[!makeRelative(file, destinationPath) %in% + makeRelative(filesToChecksum, destinationPath)] setDF(cs) } messStart <- "Appending " From 8fb9518afeb57f4530b22d130c8e1096254c1f08 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 13:36:09 -0700 Subject: [PATCH 53/70] prepInputs -- verbose updates --- R/prepInputs.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/prepInputs.R b/R/prepInputs.R index 90ba4181a..497c2df60 100644 --- a/R/prepInputs.R +++ b/R/prepInputs.R @@ -1029,11 +1029,6 @@ appendChecksumsTable <- function(checkSumFilePath, filesToChecksum, } else { messStart <- "Writing " } - messagePrepInputs(messStart, "checksums to CHECKSUMS.txt. If you see this messagePrepInputs repeatedly,\n", - " you can specify targetFile (and optionally alsoExtract) so it knows\n", - " what to look for.", - verbose = verbose - ) csf <- if (append) tempfile(fileext = ".TXT") else checkSumFilePath areAbs <- isAbsolutePath(filesToChecksum) if (any(!areAbs)) { @@ -1048,6 +1043,11 @@ appendChecksumsTable <- function(checkSumFilePath, filesToChecksum, ) }) if (append) { # a checksums file already existed, need to keep some of it + + messagePrepInputs(messStart, "checksums to CHECKSUMS.txt. If you see this messagePrepInputs repeatedly, ", verbose = verbose) + messagePrepInputs(" you can specify targetFile (and optionally alsoExtract) so it knows", verbose = verbose) + messagePrepInputs(" what to look for.", verbose = verbose) + currentFilesToRbind <- data.table::as.data.table(currentFiles) keepCols <- c("expectedFile", "checksum.x", "algorithm.x", "filesize.x") currentFilesToRbind <- currentFilesToRbind[, keepCols, with = FALSE] From f8276dd5afd6c0c5c65c0317f7db50595b732add Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 13:37:13 -0700 Subject: [PATCH 54/70] test-postProcessTo --> minor --- tests/testthat/test-postProcessTerra.R | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-postProcessTerra.R b/tests/testthat/test-postProcessTerra.R index b36f8881e..0fc90a226 100644 --- a/tests/testthat/test-postProcessTerra.R +++ b/tests/testthat/test-postProcessTerra.R @@ -82,7 +82,7 @@ test_that("testing terra", { y <- terra::deepcopy(elevRas) y[y > 200 & y < 300] <- NA_integer_ terra::values(elevRas) <- rep(1L, terra::ncell(y)) - vRast <- terra::rast(v, res = 0.008333333) + vRast <- terra::rast(v, resolution = 0.008333333) # SR, SR t1 <- postProcessTo(elevRas, y) @@ -184,7 +184,7 @@ test_that("testing terra", { vsfutm <- sf::st_transform(vsf, utm) vutm <- terra::vect(vsfutm) res100 <- 100 - rutm <- terra::rast(vutm, res = res100) + rutm <- terra::rast(vutm, resolution = res100) rutm <- terra::rasterize(vutm, rutm, field = "NAME_2") vsfInUTMviaCRS <- postProcessTo(vsf, sf::st_crs(rutm)) @@ -218,7 +218,8 @@ test_that("testing terra", { ext3 <- sf::st_as_sf(ext2) if (.requireNamespace("sf")) { expect_warning(expect_message(postProcessTo(vOrigsf, ext3))) # sf gives warning too - expect_message(postProcessTo(terra::vect(vOrigsf), ext2)) + expect_warning(expect_message(postProcessTo(terra::vect(vOrigsf), ext2)), + "no intersection") # expect_warning(expect_error(postProcessTo(vOrigsf, ext3))) # sf gives warning too # expect_error(postProcessTo(terra::vect(vOrigsf), ext2)) } @@ -380,7 +381,7 @@ test_that("testing terra", { expect_true(all(terra::res(t20res250) == 250)) ## same projection change resolution only (will likely affect extent) - y2 <- terra::rast(crs = terra::crs(y), res = 0.008333333 * 2, extent = terra::ext(y)) + y2 <- terra::rast(crs = terra::crs(y), resolution = 0.008333333 * 2, extent = terra::ext(y)) y2 <- terra::setValues(y2, rep(1, terra::ncell(y2))) t22 <- postProcessTo(elevRas, to = y2, overwrite = TRUE) # not sure why need this; R devel on Winbuilder Nov 26, 2022 From ca8646b8d42867115d1e64635496124737b3334a Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 13:39:07 -0700 Subject: [PATCH 55/70] redoc --- man/CacheHelpers.Rd | 1 + man/dotWrap.Rd | 4 ++++ man/downloadFile.Rd | 1 + man/downloadRemote.Rd | 1 + man/reproducibleOptions.Rd | 15 +++++++++++++++ 5 files changed, 22 insertions(+) diff --git a/man/CacheHelpers.Rd b/man/CacheHelpers.Rd index da5cf89b6..3ecf51b0b 100644 --- a/man/CacheHelpers.Rd +++ b/man/CacheHelpers.Rd @@ -22,6 +22,7 @@ createCache( loadFromCache( cachePath = getOption("reproducible.cachePath"), cacheId, + preDigest, fullCacheTableForObj = NULL, format = getOption("reproducible.cacheSaveFormat", "rds"), .functionName = NULL, diff --git a/man/dotWrap.Rd b/man/dotWrap.Rd index 8dfb9b1cc..f715fdaf5 100644 --- a/man/dotWrap.Rd +++ b/man/dotWrap.Rd @@ -14,6 +14,7 @@ .wrap( obj, cachePath, + preDigest, drv = getDrv(getOption("reproducible.drv", NULL)), conn = getOption("reproducible.conn", NULL), verbose = getOption("reproducible.verbose") @@ -22,6 +23,7 @@ \method{.wrap}{list}( obj, cachePath, + preDigest, drv = getDrv(getOption("reproducible.drv", NULL)), conn = getOption("reproducible.conn", NULL), verbose = getOption("reproducible.verbose") @@ -30,6 +32,7 @@ \method{.wrap}{environment}( obj, cachePath, + preDigest, drv = getDrv(getOption("reproducible.drv", NULL)), conn = getOption("reproducible.conn", NULL), verbose = getOption("reproducible.verbose") @@ -38,6 +41,7 @@ \method{.wrap}{default}( obj, cachePath, + preDigest, drv = getDrv(getOption("reproducible.drv", NULL)), conn = getOption("reproducible.conn", NULL), verbose = getOption("reproducible.verbose") diff --git a/man/downloadFile.Rd b/man/downloadFile.Rd index 56fb4c4f2..09f351387 100644 --- a/man/downloadFile.Rd +++ b/man/downloadFile.Rd @@ -15,6 +15,7 @@ downloadFile( checkSums, url, needChecksums, + preDigest, overwrite = getOption("reproducible.overwrite", TRUE), verbose = getOption("reproducible.verbose", 1), purge = FALSE, diff --git a/man/downloadRemote.Rd b/man/downloadRemote.Rd index 0509008fa..a417a1d91 100644 --- a/man/downloadRemote.Rd +++ b/man/downloadRemote.Rd @@ -16,6 +16,7 @@ downloadRemote( overwrite, needChecksums, .tempPath, + preDigest, verbose = getOption("reproducible.verbose", 1), ... ) diff --git a/man/reproducibleOptions.Rd b/man/reproducibleOptions.Rd index 55da54bce..475790d49 100644 --- a/man/reproducibleOptions.Rd +++ b/man/reproducibleOptions.Rd @@ -60,6 +60,15 @@ Default is to not use these, as they are experimental. They may, however, be very effective in speeding up some things, specifically, uploading cached elements via \code{googledrive} in \code{cloudCache}. } +\item{\code{gdalwarp}}{ +Default: \code{FALSE}. Experimental. During \code{postProcessTo} the standard approach +is to use \code{terra} functions directly, with several strategic uses of \code{sf}. However, +in the special case when \code{from} is a \code{SpatRaster} or \code{Raster}, \code{maskTo} is a +\code{SpatVector} or \code{SFC_POLYGON} and \code{projectTo} is a \code{SpatRaster} or \code{Raster}, setting +this option to \code{TRUE} will use \code{sf::gdal_utils("warp")}. In many test cases, +this is much faster than the \code{terra} sequence. The resulting \code{SpatRaster} is +not identical, but it is very similar. +} \item{\code{inputPaths}}{ Default: \code{NULL}. Used in \code{\link[=prepInputs]{prepInputs()}} and \code{\link[=preProcess]{preProcess()}}. If set to a path, this will cause these functions to save their downloaded and preprocessed @@ -85,6 +94,12 @@ will be placed in the \code{.GlobalEnv}, i.e., one for each \code{cachePath}. \item{\code{nThreads}}{ Default: \code{1}. The number of threads to use for reading/writing cache files. } +\item{\code{objSize}}{ +Default: \code{TRUE}. Logical. If \code{TRUE}, then object sizes will be included in +the cache database. Simplying calculating object size of large objects can +be time consuming, so setting this to \code{FALSE} will make caching up to 10\% +faster, depending on the objects. +} \item{\code{overwrite}}{ Default: \code{FALSE}. Used in \code{\link[=prepInputs]{prepInputs()}}, \code{\link[=preProcess]{preProcess()}}, \code{\link[=downloadFile]{downloadFile()}}, and \code{\link[=postProcess]{postProcess()}}. From ebeb12f65e8b5f7cbf30e5acb11141da534f9410 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 13:45:10 -0700 Subject: [PATCH 56/70] unit test for multi-file spatRaster backends --- tests/testthat/test-cache.R | 198 ++++++++++++++++++++---------------- 1 file changed, 112 insertions(+), 86 deletions(-) diff --git a/tests/testthat/test-cache.R b/tests/testthat/test-cache.R index be542b247..2f54c084f 100644 --- a/tests/testthat/test-cache.R +++ b/tests/testthat/test-cache.R @@ -1,8 +1,8 @@ test_that("test file-backed raster caching", { skip_on_cran() testInit("terra", - tmpFileExt = c(".tif", ".grd"), - opts = list(reproducible.useMemoise = FALSE) + tmpFileExt = c(".tif", ".grd"), + opts = list(reproducible.useMemoise = FALSE) ) nOT <- Sys.time() @@ -72,8 +72,8 @@ test_that("test file-backed raster caching", { clearCache(x = tmpCache) bb <- Cache(randomPolyToDisk, tmpfile[1], - cachePath = tmpCache, userTags = "something2", - quick = TRUE + cachePath = tmpCache, userTags = "something2", + quick = TRUE ) # bb <- Cache(randomPolyToDisk, tmpfile[1], cachePath = tmpdir, userTags = "something2") # clearCache(x = tmpdir) @@ -98,8 +98,8 @@ test_that("test file-backed raster caching", { warn <- capture_warnings({ bb <- Cache(randomPolyToDisk, tmpfile[1], - cachePath = tmpdir, userTags = "something2", - quick = TRUE + cachePath = tmpdir, userTags = "something2", + quick = TRUE ) }) @@ -114,8 +114,8 @@ test_that("test file-backed raster caching", { # ._Cache_6 <<- 1 bb <- Cache(randomPolyToDisk, tmpfile[1], - cachePath = tmpdir, userTags = "something2", - quick = TRUE + cachePath = tmpdir, userTags = "something2", + quick = TRUE ) expect_false(attr(bb, ".Cache")$newCache) expect_true(file.exists(Filenames(bb))) @@ -124,12 +124,12 @@ test_that("test file-backed raster caching", { clearCache(tmpCache) clearCache(tmpdir) cc <- Cache(randomPolyToDisk, tmpfile[2], - cachePath = tmpCache, userTags = "something2", - quick = TRUE + cachePath = tmpCache, userTags = "something2", + quick = TRUE ) bb <- Cache(randomPolyToDisk, tmpfile[1], - cachePath = tmpCache, userTags = "something2", - quick = TRUE + cachePath = tmpCache, userTags = "something2", + quick = TRUE ) try(movedCache(tmpdir, tmpCache), silent = TRUE) @@ -322,11 +322,11 @@ test_that("test memory backed raster robustDigest", { test_that("test 'quick' argument", { testInit("terra", - tmpFileExt = c(".tif", ".tif", ".tif"), - opts = list( - "reproducible.useMemoise" = TRUE, - "reproducible.showSimilar" = FALSE - ) + tmpFileExt = c(".tif", ".tif", ".tif"), + opts = list( + "reproducible.useMemoise" = TRUE, + "reproducible.showSimilar" = FALSE + ) ) ### Make raster using Cache @@ -417,9 +417,9 @@ test_that("test keepCache", { Cache(round, runif(4), cachePath = tmpdir) expect_true(NROW(showCache(tmpdir)[!tagKey %in% .ignoreTagKeys()]) == - .cacheNumDefaultTags() * 3) + .cacheNumDefaultTags() * 3) expect_true(NROW(showCache(tmpdir, c("rnorm", "runif"))[!tagKey %in% .ignoreTagKeys()]) == - 0) # and search + 0) # and search expect_true(NROW(keepCache(tmpdir, "rnorm", ask = FALSE)[!tagKey %in% .ignoreTagKeys()]) == .cacheNumDefaultTags()) # do it twice to make sure it can deal with repeats @@ -521,12 +521,12 @@ test_that("test environments", { test_that("test asPath", { testInit("terra", - tmpFileExt = "pdf", - verbose = TRUE, - opts = list( - "reproducible.useMemoise" = TRUE, - "reproducible.showSimilar" = FALSE - ) + tmpFileExt = "pdf", + verbose = TRUE, + opts = list( + "reproducible.useMemoise" = TRUE, + "reproducible.showSimilar" = FALSE + ) ) unlink(dir(tmpdir, full.names = TRUE)) @@ -549,16 +549,16 @@ test_that("test asPath", { unlink("filename.RData") try(clearCache(tmpdir, ask = FALSE), silent = TRUE) a1 <- capture_messages(Cache(saveRDS, obj, - file = asPath("filename.RData"), - quick = TRUE, cachePath = tmpdir + file = asPath("filename.RData"), + quick = TRUE, cachePath = tmpdir )) a2 <- capture_messages(Cache(saveRDS, obj, - file = asPath("filename.RData"), - quick = TRUE, cachePath = tmpdir + file = asPath("filename.RData"), + quick = TRUE, cachePath = tmpdir )) a3 <- capture_messages(Cache(saveRDS, obj, - file = asPath("filename.RData"), - quick = TRUE, cachePath = tmpdir + file = asPath("filename.RData"), + quick = TRUE, cachePath = tmpdir )) expect_true(length(a1) == 0) expect_true(sum(grepl(paste( @@ -570,16 +570,16 @@ test_that("test asPath", { unlink("filename.RData") try(clearCache(tmpdir, ask = FALSE), silent = TRUE) a1 <- capture_messages(Cache(saveRDS, obj, - file = as("filename.RData", "Path"), - quick = TRUE, cachePath = tmpdir + file = as("filename.RData", "Path"), + quick = TRUE, cachePath = tmpdir )) a2 <- capture_messages(Cache(saveRDS, obj, - file = as("filename.RData", "Path"), - quick = TRUE, cachePath = tmpdir + file = as("filename.RData", "Path"), + quick = TRUE, cachePath = tmpdir )) a3 <- capture_messages(Cache(saveRDS, obj, - file = as("filename.RData", "Path"), - quick = TRUE, cachePath = tmpdir + file = as("filename.RData", "Path"), + quick = TRUE, cachePath = tmpdir )) expect_true(length(a1) == 0) expect_true(sum(grepl(paste( @@ -612,11 +612,11 @@ test_that("test quoted FUN in Cache", { test_that("test Cache argument inheritance to inner functions", { testInit("terra", - verbose = TRUE, - opts = list( - "reproducible.showSimilar" = FALSE, - "reproducible.useMemoise" = FALSE - ) + verbose = TRUE, + opts = list( + "reproducible.showSimilar" = FALSE, + "reproducible.useMemoise" = FALSE + ) ) tmpDirFiles <- dir(tempdir()) on.exit( @@ -661,8 +661,8 @@ test_that("test Cache argument inheritance to inner functions", { out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir)) expect_true(length(out) == 2) msgGrep <- paste(paste(.loadedCacheResultMsg, "rnorm call"), - "There is no similar item in the cachePath", - sep = "|" + "There is no similar item in the cachePath", + sep = "|" ) expect_true(sum(grepl(msgGrep, out)) == 1) @@ -705,8 +705,8 @@ test_that("test Cache argument inheritance to inner functions", { out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir, notOlderThan = Sys.time())) msgGrep <- paste(paste(.loadedCacheResultMsg, "inner call"), - "There is no similar item in the cachePath", - sep = "|" + "There is no similar item in the cachePath", + sep = "|" ) expect_true(sum(grepl(msgGrep, out)) == 1) @@ -720,8 +720,8 @@ test_that("test Cache argument inheritance to inner functions", { out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir, notOlderThan = Sys.time())) msgGrep <- paste(paste(.loadedCacheResultMsg, "rnorm call"), - "There is no similar item in the cachePath", - sep = "|" + "There is no similar item in the cachePath", + sep = "|" ) expect_true(sum(grepl(msgGrep, out)) == 1) @@ -768,11 +768,11 @@ test_that("test future", { .onLinux <- .Platform$OS.type == "unix" && unname(Sys.info()["sysname"]) == "Linux" # if (.onLinux) { testInit(c("terra", "future"), - verbose = TRUE, tmpFileExt = ".rds", - opts = list( - "future.supportsMulticore.unstable" = "quiet", - "reproducible.futurePlan" = "multicore" - ) + verbose = TRUE, tmpFileExt = ".rds", + opts = list( + "future.supportsMulticore.unstable" = "quiet", + "reproducible.futurePlan" = "multicore" + ) ) # There is now a warning with future package @@ -1026,12 +1026,12 @@ test_that("test rm large non-file-backed rasters", { } testInit(c("qs", "terra"), opts = list("reproducible.cacheSpeed" = "fast", - "reproducible.cacheSaveFormat" = "qs")) + "reproducible.cacheSaveFormat" = "qs")) ext <- terra::ext(0, 10000, 0, 10000) r <- Cache(terra::rast, ext, - resolution = 1, vals = 1, - cachePath = tmpdir, userTags = "first" + resolution = 1, vals = 1, + cachePath = tmpdir, userTags = "first" ) st1 <- system.time(clearCache(tmpdir, userTags = "first", ask = FALSE)) expect_true(st1["user.self"] < 0.75) # This was > 2 seconds in old way @@ -1083,8 +1083,8 @@ test_that("test pre-creating conn", { rb <- terra::rast(terra::ext(0, 10, 0, 10), vals = sample(1:100)) r1 <- Cache(.writeRaster, ra, filename = tmpfile[1], overwrite = TRUE, cachePath = tmpCache) r2 <- Cache(.writeRaster, rb, - filename = tmpfile[2], overwrite = TRUE, cachePath = tmpdir, - conn = conn + filename = tmpfile[2], overwrite = TRUE, cachePath = tmpdir, + conn = conn ) expect_true(file.exists(Filenames(r1))) expect_true(file.exists(Filenames(r2))) @@ -1311,8 +1311,8 @@ test_that("quick arg in Cache as character", { # new copy messes[[i]] <- capture_messages(Cache(saveRDS, ranRas, - file = tf, cachePath = tmpCache, - quick = quicks[[i]] + file = tf, cachePath = tmpCache, + quick = quicks[[i]] )) } @@ -1408,7 +1408,7 @@ test_that("change to new capturing of FUN & base pipe", { mess1 <- capture_messages( out1 <- Cache(do.call(rnorm, list(1, 2, sd = round(mean(runif(Nrand2, 1, 1.1))))), - cachePath = tmpCache + cachePath = tmpCache ) ) @@ -1618,12 +1618,12 @@ test_that("test cache with new approach to match.call", { test_that("test cache; new approach to match.call, postProcess", { skip_if_not_installed("DBI") # sf needs DBI testInit(c("terra", "sf"), - tmpFileExt = c(".tif", ".tif"), - opts = list( - "rasterTmpDir" = tempdir2(rndstr(1, 6)), - "reproducible.inputPaths" = NULL, - "reproducible.overwrite" = TRUE - ) + tmpFileExt = c(".tif", ".tif"), + opts = list( + "rasterTmpDir" = tempdir2(rndstr(1, 6)), + "reproducible.inputPaths" = NULL, + "reproducible.overwrite" = TRUE + ) ) on.exit( { @@ -1637,10 +1637,10 @@ test_that("test cache; new approach to match.call, postProcess", { # Add a study area to Crop and Mask to # Create a "study area" coords <- structure(c(-122.98, -116.1, -99.2, -106, -122.98, 59.9, 65.73, 63.58, 54.79, 59.9), - .Dim = c(5L, 2L) + .Dim = c(5L, 2L) ) coords2 <- structure(c(-115.98, -116.1, -99.2, -106, -122.98, 59.9, 65.73, 63.58, 54.79, 59.9), - .Dim = c(5L, 2L) + .Dim = c(5L, 2L) ) StudyArea <- terra::vect(coords, "polygons") @@ -1699,12 +1699,12 @@ test_that("test cache; new approach to match.call, postProcess", { test_that("test cache; SpatRaster attributes", { testInit(c("terra", "sf"), - tmpFileExt = c(".tif", ".tif"), - opts = list( - "rasterTmpDir" = tempdir2(rndstr(1, 6)), - "reproducible.inputPaths" = NULL, - "reproducible.overwrite" = TRUE - ), needInternet = TRUE + tmpFileExt = c(".tif", ".tif"), + opts = list( + "rasterTmpDir" = tempdir2(rndstr(1, 6)), + "reproducible.inputPaths" = NULL, + "reproducible.overwrite" = TRUE + ), needInternet = TRUE ) options("reproducible.cachePath" = tmpdir) @@ -1724,15 +1724,15 @@ test_that("test cache; SpatRaster attributes", { } ras <- Cache(testFun, - url = url, - targetFile = targetFile + url = url, + targetFile = targetFile ) expect_true(is.integer(attr(x = ras, "pixIDs"))) ## re-run. attributes still there? ras <- Cache(testFun, - url = url, - targetFile = targetFile + url = url, + targetFile = targetFile ) expect_true(is.integer(attr(x = ras, "pixIDs"))) }) @@ -1759,13 +1759,13 @@ test_that("Issue 316 - writeOutputs in a non getwd dir", { rasterToMatchLarge <- list() for (i in 1:2) { rasterToMatchLarge[[i]] <- Cache(writeOutputs, rasterToMatch, - filename2 = .suffix( - file.path(tmpdir, "rasterToMatchLarge.tif"), - paste0("_", studyAreaName) - ), datatype = "INT2U", - overwrite = TRUE, userTags = c(cacheTags, "rasterToMatchLarge"), - quick = "filename2", - omitArgs = c("userTags") + filename2 = .suffix( + file.path(tmpdir, "rasterToMatchLarge.tif"), + paste0("_", studyAreaName) + ), datatype = "INT2U", + overwrite = TRUE, userTags = c(cacheTags, "rasterToMatchLarge"), + quick = "filename2", + omitArgs = c("userTags") ) } @@ -1846,3 +1846,29 @@ test_that("pass NA to userTags", { testInit(verbose = FALSE) expect_no_error(a <- Cache(rnorm(1), userTags = c("NA", "hi"))) }) + +test_that("multifile cache saving", { + skip_on_cran() + testInit("terra", + tmpFileExt = c(".tif", ".tif"), + opts = list(reproducible.useMemoise = FALSE) + ) + + nOT <- Sys.time() + + randomPolyToDisk2 <- function(tmpfiles) { + r <- terra::rast(ext(0, 10, 0, 10), vals = sample(1:30, size = 100, replace = TRUE)) + r2 <- terra::rast(ext(0, 10, 0, 10), vals = sample(1:30, size = 100, replace = TRUE)) + .writeRaster(r, tmpfiles[1], overwrite = TRUE) + .writeRaster(r, tmpfiles[2], overwrite = TRUE) + r <- c(terra::rast(tmpfiles[1]), terra::rast(tmpfiles[2])) + r + } + a <- Cache(randomPolyToDisk2(tmpfile), quick = "tmpfiles") + b <- Cache(randomPolyToDisk2(tmpfile), quick = "tmpfiles") + expect_false(attr(b, ".Cache")$newCache) + expect_true(attr(a, ".Cache")$newCache) + expect_true(all(basename(Filenames(a)) %in% dir(CacheStorageDir()))) + expect_false(all(Filenames(a) %in% dir(CacheStorageDir(), full.names = TRUE))) + +}) From 6b94326d13bb1a0d86199922730d4f5b3e14a1b2 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 13:45:18 -0700 Subject: [PATCH 57/70] minor --- R/DBI.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/DBI.R b/R/DBI.R index f649069e8..fef7d9dfb 100644 --- a/R/DBI.R +++ b/R/DBI.R @@ -501,7 +501,8 @@ 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) } From bbdc4ebe8cac89b4ed12804953ea7120ad21cb0f Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 15:17:53 -0700 Subject: [PATCH 58/70] bump v2.0.8.9013 --- DESCRIPTION | 4 ++-- NEWS.md | 13 +++++++++++++ 2 files changed, 15 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index f1d911cac..57701a7f1 100644 --- a/DESCRIPTION +++ b/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-20 -Version: 2.0.8.9012 +Date: 2023-11-03 +Version: 2.0.8.9013 Authors@R: c(person(given = "Eliot J B", family = "McIntire", diff --git a/NEWS.md b/NEWS.md index d535f0333..6b0451724 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,10 +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 From 53ddcf7df8795d56a5cfcf5f2f7c9b6b90d41a3d Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 16:04:53 -0700 Subject: [PATCH 59/70] updating testing infrastructure --- tests/testthat/test-cache.R | 123 +++++++++--------------------------- 1 file changed, 30 insertions(+), 93 deletions(-) diff --git a/tests/testthat/test-cache.R b/tests/testthat/test-cache.R index 2f54c084f..5a1dcbbda 100644 --- a/tests/testthat/test-cache.R +++ b/tests/testthat/test-cache.R @@ -25,7 +25,7 @@ test_that("test file-backed raster caching", { # https://www.mango-solutions.com/blog/testing-without-the-internet-using-mock-functions # https://github.com/r-lib/testthat/issues/734 to direct it to reproducible::isInteractive # solves the error about not being in the testthat package - val1 <- .cacheNumDefaultTags() + 1 + 11 # adding a userTag here... the +8 is the SpatRaster extras + val1 <- .cacheNumDefaultTags() + 1 + 12 # adding a userTag here... the +8 is the SpatRaster extras ik <- .ignoreTagKeys() # with_mock( # "reproducible::isInteractive" = function() TRUE, @@ -618,6 +618,8 @@ test_that("test Cache argument inheritance to inner functions", { "reproducible.useMemoise" = FALSE ) ) + opts <- options(reproducible.cachePath = tmpdir) + on.exit(options(opts), add = TRUE) tmpDirFiles <- dir(tempdir()) on.exit( { @@ -627,14 +629,15 @@ test_that("test Cache argument inheritance to inner functions", { add = TRUE ) - outer <- function(n) { - Cache(rnorm, n) + outer <- function(n, not = NULL) { + Cache(rnorm, n, notOlderThan = not) } - expect_silent(Cache(outer, n = 2, cachePath = tmpdir)) + mess <- capture_messages(Cache(outer, n = 2)) + expect_true(all(grepl(messageNoCacheRepo, mess))) clearCache(ask = FALSE, x = tmpdir) - options(reproducible.cachePath = tmpCache) + # options(reproducible.cachePath = tmpCache) out <- capture_messages(Cache(outer, n = 2)) expect_true(all(unlist(lapply( c(messageNoCacheRepo, messageNoCacheRepo), @@ -642,11 +645,12 @@ test_that("test Cache argument inheritance to inner functions", { )))) # does Sys.time() propagate to outer ones - out <- capture_messages(Cache(outer, n = 2, notOlderThan = Sys.time() + 1)) + out <- capture_messages(Cache(outer(n = 2, not = Sys.time() + 1), notOlderThan = Sys.time() + 1)) expect_true(all(grepl(messageNoCacheRepo, out))) # does Sys.time() propagate to outer ones -- no message about cachePath being tempdir() - expect_silent(Cache(outer, n = 2, notOlderThan = Sys.time(), cachePath = tmpdir)) + mess <- capture_messages(Cache(outer(n = 2, not = Sys.time()), notOlderThan = Sys.time(), cachePath = tmpdir)) + expect_true(all(grepl(messageNoCacheRepo, mess))) # does cachePath propagate to outer ones -- no message about cachePath being tempdir() out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir)) @@ -659,7 +663,7 @@ test_that("test Cache argument inheritance to inner functions", { Cache(rnorm, n) } out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir)) - expect_true(length(out) == 2) + expect_true(length(out) == 3) msgGrep <- paste(paste(.loadedCacheResultMsg, "rnorm call"), "There is no similar item in the cachePath", sep = "|" @@ -672,8 +676,7 @@ test_that("test Cache argument inheritance to inner functions", { Cache(rnorm, n, notOlderThan = Sys.time() + 1) } out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir)) - expect_true(length(out) == 0) - # expect_true(all(grepl("There is no similar item in the cachePath", out))) + expect_true(all(grepl(messageNoCacheRepo, out))) # change the outer function, so no cache on that, & have notOlderThan on rnorm, # so no Cache on that @@ -682,7 +685,8 @@ test_that("test Cache argument inheritance to inner functions", { Cache(rnorm, n, notOlderThan = Sys.time() + 1) } out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir)) - expect_true(length(out) == 0) + expect_true(all(grepl(messageNoCacheRepo, out))) + # expect_true(all(grepl("There is no similar item in the cachePath", out))) # Second time will get a cache on outer out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir)) @@ -708,7 +712,9 @@ test_that("test Cache argument inheritance to inner functions", { "There is no similar item in the cachePath", sep = "|" ) - expect_true(sum(grepl(msgGrep, out)) == 1) + expect_true(sum(grepl(messageNoCacheRepo, out)) == 1) + + # expect_true(sum(grepl(msgGrep, out)) == 1) outer <- function(n) { Cache(inner, 0.1, notOlderThan = Sys.time()) @@ -842,81 +848,6 @@ test_that("test mergeCache", { expect_true(identical(showCache(d), showCache(d1))) }) -# DELETE THIS ONE; IT IS NOT RELEVANT ANY MORE AND IT IS BROKEN -# test_that("test cache-helpers", { -# testInit("terra") -# out <- createCache(tmpCache) -# -# tmpfile <- tempfile(tmpdir = tmpdir, fileext = ".grd") -# tmpfile2 <- tempfile(tmpdir = tmpdir, fileext = ".grd") -# tmpfile3 <- tempfile(tmpdir = tmpdir, fileext = ".grd") -# r <- terra::rast(terra::ext(0, 5, 0, 5), resolution = 1, vals = rep(1:2, length.out = 25)) -# # levels(r) <- data.frame(ID = 1:2, Val = 3:4) -# # b <- .prepareFileBackedRaster(r, tmpCache) -# # is(b, "RasterLayer") -# -# r1 <- terra::rast(terra::ext(0, 5, 0, 5), resolution = 1, vals = rep(1:2, length.out = 25)) -# # s <- c(r, r1) -# # b <- .prepareFileBackedRaster(s, tmpCache) -# -# r <- .writeRaster(r, filename = tmpfile, overwrite = TRUE) -# r1 <- .writeRaster(r1, filename = tmpfile2, overwrite = TRUE) -# s <- c(r, r1) -# -# # Test deleted raster backed file -# # file.remove(tmpfile2) -# # expect_error(b <- .prepareFileBackedRaster(s, tmpCache), "The following file-backed rasters") -# # expect_error(b <- .prepareFileBackedRaster(r1, tmpCache), "The following file-backed rasters") -# -# # Test wrong folder names -# tmpfile <- file.path(tmpCache, basename(tempfile(tmpdir = tmpdir, fileext = ".grd"))) -# r <- .writeRaster(r, filename = tmpfile, overwrite = TRUE) -# # r@file@name <- gsub(pattern = dirname(tmpfile), -# # normalizePath(tmpfile, winslash = "/", mustWork = FALSE), -# # replacement = dirname(dirname(tmpfile))) -# # # show it is not there, so it is the wrong name -# # expect_false(all(file.exists(Filenames(r)))) -# # fix it, by giving correct tmpCache path -# # b <- .prepareFileBackedRaster(r, tmpCache) -# # expect_true(all(file.exists(Filenames(b)))) -# # Check that it makes a new name if already in Cache -# # checkPath(file.path(tmpCache, "rasters"), create = TRUE) -# # r1 <- .writeRaster(r1, filename = file.path(tmpCache, "rasters", basename(tmpfile2)), overwrite = TRUE) -# # b <- .prepareFileBackedRaster(r1, tmpCache) -# expect_true(identical(normalizePath(Filenames(b), winslash = "/", mustWork = FALSE), -# normalizePath(file.path(dirname(Filenames(r1)), -# nextNumericName(basename(Filenames(r1)))), -# winslash = "/", mustWork = FALSE))) -# -# r <- raster(extent(0, 5, 0, 5), res = 1, vals = rep(1:2, length.out = 25)) -# r1 <- raster(extent(0, 5, 0, 5), res = 1, vals = rep(1:2, length.out = 25)) -# tmpfile <- tempfile(tmpdir = tmpdir, fileext = ".grd") -# r <- .writeRaster(r, filename = tmpfile, overwrite = TRUE) -# r1 <- .writeRaster(r1, filename = tmpfile2, overwrite = TRUE) -# s <- addLayer(r, r1) -# b1 <- .prepareFileBackedRaster(s, repoDir = tmpCache) -# expect_true(is(b1, "RasterStack")) -# expect_true(identical(Filenames(b1), "")) -# expect_true(identical(normalizePath(Filenames(b1$layer.1), winslash = "/", mustWork = FALSE), -# normalizePath(file.path(tmpCache, "rasters", basename(Filenames(r))), winslash = "/", mustWork = FALSE))) -# -# # Give them single file -- 2 layer stack; like a raster::brick, but a stack -# r[] <- r[] -# r1[] <- r1[] -# b <- raster::stack(r, r1) -# -# b <- .writeRaster(b, filename = tmpfile, overwrite = TRUE) -# b <- raster::stack(b) -# expect_true(nlayers2(b) == 2) -# expect_true(identical(normPath(b$layer.1@file@name), -# normPath(b$layer.2@file@name))) -# -# b1 <- .prepareFileBackedRaster(b, tmpCache) -# expect_true(nlayers2(b1) == 2) -# b1a <- raster::stack(Filenames(b1)[1]) -# expect_true(nlayers2(b1a) == 2) -# -# }) test_that("test cache-helpers", { testInit(c("raster"), tmpFileExt = c(rep(".grd", 3), rep(".tif", 3))) @@ -1112,13 +1043,19 @@ test_that("test failed Cache recovery -- message to delete cacheId", { ci <- unique(sc[[.cacheTableHashColName()]]) unlink(CacheStoredFile(tmpdir, ci)) - warn <- capture_warnings({ - err <- capture_error({ - b <- Cache(rnorm, 1, cachePath = tmpdir) + + rm(b) + mess <- capture_messages( + warn <- capture_warnings({ + err <- capture_error({ + d <- Cache(rnorm, 1, cachePath = tmpdir) + }) }) - }) - expect_true(grepl(paste0("(trying to recover).*(", ci, ")"), err)) + ) + expect_true(sum(grepl(paste0("(trying to recover).*(", ci, ")"), mess)) == 1) + expect_true(sum(grepl(paste0("(trying to recover).*(", ci, ")"), err)) == 0) expect_true(grepl(paste0("[cannot|failed to] open"), paste(warn, err))) + expect_true(is.numeric(d)) }) test_that("test changing reproducible.cacheSaveFormat midstream", { @@ -1184,7 +1121,7 @@ test_that("test file link with duplicate Cache", { g <- Cache(sam1, N, cachePath = tmpCache) }) - expect_true(grepl("A file with identical", mess3)) + expect_true(sum(grepl("A file with identical", mess3)) == 1) set.seed(123) mess1 <- capture_messages({ From 5822675d1d6b2afe42287db987881b294beefb4b Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 16:05:22 -0700 Subject: [PATCH 60/70] things caught by R CMD check --- R/DBI.R | 8 ++++---- R/cache-internals.R | 2 +- R/cache.R | 1 + R/exportedMethods.R | 5 +++-- R/postProcessTo.R | 24 ++++++++++++++++-------- 5 files changed, 25 insertions(+), 15 deletions(-) diff --git a/R/DBI.R b/R/DBI.R index fef7d9dfb..bdc59cb16 100644 --- a/R/DBI.R +++ b/R/DBI.R @@ -1009,13 +1009,13 @@ CacheDBFiles <- function(cachePath = getOption("reproducible.cachePath")) { dtFiles } -memoiseEnv <- function(cachePath) { +memoiseEnv <- function(cachePath, envir = .GlobalEnv) { memPersist <- isTRUE(getOption("reproducible.memoisePersist", NULL)) if (memPersist) { obj <- paste0(".reproducibleMemoise_", cachePath) - if (!exists(obj, envir = .GlobalEnv)) - assign(obj, new.env(parent = emptyenv()), envir = .GlobalEnv) - memEnv <- get(obj, envir = .GlobalEnv, inherits = FALSE) + 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()) diff --git a/R/cache-internals.R b/R/cache-internals.R index c1c193f6d..7f6a517fe 100644 --- a/R/cache-internals.R +++ b/R/cache-internals.R @@ -108,7 +108,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), ...) { diff --git a/R/cache.R b/R/cache.R index 736c1410d..45b73ba2c 100644 --- a/R/cache.R +++ b/R/cache.R @@ -2259,6 +2259,7 @@ returnObjFromRepo <- function(isInRepo, notOlderThan, fullCacheTableForObj, cach preLoadTime <- Sys.time() output <- try(.getFromRepo(FUN, isInRepo = isInRepo, + # fileFormat = NULL, fullCacheTableForObj = fullCacheTableForObj, notOlderThan = notOlderThan, lastOne = lastOne, diff --git a/R/exportedMethods.R b/R/exportedMethods.R index 9d0ba26d0..8efd32023 100644 --- a/R/exportedMethods.R +++ b/R/exportedMethods.R @@ -663,7 +663,8 @@ unmakeMemoisable.default <- function(x) { wrapSpatRaster <- function(obj, cachePath) { cls <- class(obj) - fns <- Filenames(obj) + fns <- Filenames(obj, allowMultiple = FALSE) + fnsMulti <- Filenames(obj, allowMultiple = TRUE) layerNams <- paste(names(obj), collapse = layerNamesDelimiter) obj2 <- asPath(Filenames(obj, allowMultiple = FALSE)) nlyrsInFile <- as.integer(terra::nlyr(terra::rast(fns))) @@ -690,7 +691,7 @@ wrapSpatRaster <- function(obj, cachePath) { } if (is.character(obj)) if (any(grepl("MDC_historical_NT", basename2(obj)))) browser() - obj <- asPath(fns) + obj <- asPath(fnsMulti) attr(obj, "tags") <- c( attr(obj, "tags"), paste0("origFilename:", basename2(obj)), diff --git a/R/postProcessTo.R b/R/postProcessTo.R index 0bc9b721b..f3f62092e 100644 --- a/R/postProcessTo.R +++ b/R/postProcessTo.R @@ -1426,6 +1426,9 @@ isGeomType <- function(geom, type) { gdalProject <- function(fromRas, toRas, filenameDest, verbose = getOption("reproducible.verbose"), ...) { + if (!requireNamespace("sf") && !requireNamespace("terra")) + stop("Can't use gdalProject without sf and terra") + messagePrepInputs(" running gdalProject ...", appendLF = FALSE, verbose = verbose) st <- Sys.time() @@ -1443,7 +1446,7 @@ gdalProject <- function(fromRas, toRas, filenameDest, verbose = getOption("repro fnSource <- fns } else { fnSource <- tempfile(fileext = ".tif") - writeRaster(fromRas, filename = fnSource) + terra::writeRaster(fromRas, filename = fnSource) on.exit(unlink(fnSource)) } @@ -1453,7 +1456,7 @@ gdalProject <- function(fromRas, toRas, filenameDest, verbose = getOption("repro tf4 <- tempfile(fileext = ".prj") on.exit(unlink(tf4), add = TRUE) cat(sf::st_crs(toRas)$wkt, file = tf4) - system.time(gdal_utils( + sf::gdal_utils( util = "warp", source = fnSource, destination = filenameDest, @@ -1467,7 +1470,6 @@ gdalProject <- function(fromRas, toRas, filenameDest, verbose = getOption("repro "-dstnodata", "NA", "-overwrite" )) - ) out <- terra::rast(filenameDest) messagePrepInputs(" ...done in ", @@ -1481,6 +1483,9 @@ gdalProject <- function(fromRas, toRas, filenameDest, verbose = getOption("repro gdalResample <- function(fromRas, toRas, filenameDest, verbose = getOption("reproducible.verbose")) { + if (!requireNamespace("sf") && !requireNamespace("terra")) + stop("Can't use gdalResample without sf and terra") + messagePrepInputs(" running gdalResample ...", appendLF = FALSE, verbose = verbose) st <- Sys.time() @@ -1489,7 +1494,7 @@ gdalResample <- function(fromRas, toRas, filenameDest, verbose = getOption("repr fnSource <- fns } else { fnSource <- tempfile(fileext = ".tif") - writeRaster(fromRas, filename = fnSource) + terra::writeRaster(fromRas, filename = fnSource) on.exit(unlink(fnSource)) } @@ -1500,7 +1505,7 @@ gdalResample <- function(fromRas, toRas, filenameDest, verbose = getOption("repr cat(sf::st_crs(toRas)$wkt, file = tf4) - system.time(gdal_utils( + system.time(sf::gdal_utils( util = "warp", source = fnSource, destination = filenameDest, @@ -1526,6 +1531,9 @@ gdalResample <- function(fromRas, toRas, filenameDest, verbose = getOption("repr gdalMask <- function(fromRas, maskToVect, writeTo = NULL, verbose = getOption("reproducible.verbose"), ...) { + if (!requireNamespace("sf") && !requireNamespace("terra")) + stop("Can't use gdalMask without sf and terra") + messagePrepInputs(" running gdalMask ...", appendLF = FALSE, verbose = verbose) st <- Sys.time() @@ -1535,13 +1543,13 @@ gdalMask <- function(fromRas, maskToVect, writeTo = NULL, verbose = getOption("r fnSource <- fns } else { fnSource <- tempfile(fileext = ".tif") - writeRaster(fromRas, filename = fnSource) + terra::writeRaster(fromRas, filename = fnSource) on.exit(unlink(fnSource)) } tf3 <- tempfile(fileext = ".shp") shp <- terra::project(maskToVect, terra::crs(fromRas)) - writeVector(shp, file = tf3) + terra::writeVector(shp, file = tf3) dPath <- which(...names() %in% "destinationPath") destinationPath <- if (length(dPath)) { @@ -1555,7 +1563,7 @@ gdalMask <- function(fromRas, maskToVect, writeTo = NULL, verbose = getOption("r writeTo <- determineFilename(writeTo, destinationPath = destinationPath, verbose = verbose) - system.time(gdal_utils( + system.time(sf::gdal_utils( util = "warp", source = fnSource, destination = writeTo, From 494b3694582644e25a1167196636f423c090ac4f Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 16:27:16 -0700 Subject: [PATCH 61/70] Revert "preProcess now handles only Google ID; messaging improved" This reverts commit 8081c898c4453f2171ba81d00df07b7dc744e845. --- R/preProcess.R | 21 +++------------------ 1 file changed, 3 insertions(+), 18 deletions(-) diff --git a/R/preProcess.R b/R/preProcess.R index 3632f1a8f..d01169cb3 100644 --- a/R/preProcess.R +++ b/R/preProcess.R @@ -205,7 +205,6 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac } } targetFileGuess <- NULL - if (is.null(targetFile) || is.null(archive)) { targetFileGuess <- .guessAtFile( url = url, archive = archive, targetFile = targetFile, @@ -819,11 +818,7 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac # if (is.null(targetFile)) { guessedFile <- if (!is.null(url)) { gf <- file.path(destinationPath, basename2(url)) - # Test for just Google ID supplied - isGID <- all(grepl("^[A-Za-z0-9_-]{33}$", url), # Has 33 characters as letters, numbers or - or _ - !grepl("\\.[^\\.]+$", url)) # doesn't have an extension - if (any(grepl("drive.google.com", url), isGID)) { - if (isGID) message("url seems to be a Google Drive ID") + if (grepl("drive.google.com", url)) { # ie <- isTRUE(internetExists()) # if (ie) { gf <- assessGoogle( @@ -835,7 +830,7 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac } gf } else { - NULL + NULL } normPath(guessedFile) } @@ -1570,17 +1565,7 @@ getTargetFilePath <- function(targetFile, archive, fileGuess, verbose, targetFile <- makeRelative(fileGuess, destinationPath) targetFilePath <- makeAbsolute(targetFile, destinationPath) } else { - # Case when archieve is passed, and fileGuess exists - if ((!is.null(archive) || !is.na(archive)) && !is.null(fileGuess)) { - messagePrepInputs("archieve was supplied, but targetFile not; guessed and will try ", fileGuess, - ". If this is incorrect, please supply targetFile", - verbose = verbose - ) - targetFile <- makeRelative(fileGuess, destinationPath) - targetFilePath <- makeAbsolute(targetFile, destinationPath) - } else { - targetFilePath <- NULL - } + targetFilePath <- NULL } } else { if (length(targetFile) > 1) { From f37ad4ec340b017115955248288590667dc7ab76 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 16:28:24 -0700 Subject: [PATCH 62/70] unit test for Google ID --- tests/testthat/test-preProcessWorks.R | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/tests/testthat/test-preProcessWorks.R b/tests/testthat/test-preProcessWorks.R index d35e5440c..7ca4f31d0 100644 --- a/tests/testthat/test-preProcessWorks.R +++ b/tests/testthat/test-preProcessWorks.R @@ -455,6 +455,15 @@ test_that("masking with larger extent obj", { expect_true(is(b, rasterType())) }) +test_that("just google id not url", { + skip_on_cran() + skip_on_ci() + + testInit("terra", needGoogleDriveAuth = TRUE, needInternet = TRUE) + smallObj <- prepInputs(url = "1Bk4SPz8rx8zziIlg2Yp9ELZmdNZytLqb") + expect_is(smallObj, "sf") +}) + test_that("Test of using future and progress indicator for lrg files on Google Drive", { skip_if_not_installed("future") skip_if_not_installed("googledrive") From 0027b6927d65e3f11ac37781fb19447cc6e162f5 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 16:28:39 -0700 Subject: [PATCH 63/70] partial commit from Tati re: google drive id --- R/preProcess.R | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/R/preProcess.R b/R/preProcess.R index d01169cb3..d4c03ebb1 100644 --- a/R/preProcess.R +++ b/R/preProcess.R @@ -818,7 +818,14 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac # if (is.null(targetFile)) { guessedFile <- if (!is.null(url)) { gf <- file.path(destinationPath, basename2(url)) - if (grepl("drive.google.com", url)) { + + # Test for just Google ID supplied + isGID <- all(grepl("^[A-Za-z0-9_-]{33}$", url), # Has 33 characters as letters, numbers or - or _ + !grepl("\\.[^\\.]+$", url)) # doesn't have an extension + if (any(grepl("drive.google.com", url), isGID)) { + if (isGID) message("url seems to be a Google Drive ID") + + # if (grepl("drive.google.com", url)) { # ie <- isTRUE(internetExists()) # if (ie) { gf <- assessGoogle( From d55de8f2dbbca43f5883dfc7aa68947e6549294a Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 16:33:01 -0700 Subject: [PATCH 64/70] add Tati's addition as a comment --> it doesn't work for existing tests --- R/preProcess.R | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/R/preProcess.R b/R/preProcess.R index d4c03ebb1..e7931922e 100644 --- a/R/preProcess.R +++ b/R/preProcess.R @@ -1572,7 +1572,19 @@ getTargetFilePath <- function(targetFile, archive, fileGuess, verbose, targetFile <- makeRelative(fileGuess, destinationPath) targetFilePath <- makeAbsolute(targetFile, destinationPath) } else { - targetFilePath <- NULL + + # Case when archive is passed, and fileGuess exists + # if ((!is.null(archive) || !is.na(archive)) && !is.null(fileGuess)) { + # messagePrepInputs("archieve was supplied, but targetFile not; guessed and will try ", fileGuess, + # ". If this is incorrect, please supply targetFile", + # verbose = verbose + # ) + # targetFile <- makeRelative(fileGuess, destinationPath) + # targetFilePath <- makeAbsolute(targetFile, destinationPath) + # } else { + targetFilePath <- NULL + # } + } } else { if (length(targetFile) > 1) { From 2c8bfbe00344efee6cb9a98f8aece8bfa3594a72 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 3 Nov 2023 16:53:51 -0700 Subject: [PATCH 65/70] R CMD checking --- R/DBI.R | 1 + R/download.R | 5 +++-- R/exportedMethods.R | 5 +++-- R/postProcessTo.R | 20 ++++++++++---------- man/CacheHelpers.Rd | 2 ++ man/dotWrap.Rd | 2 ++ man/downloadFile.Rd | 2 ++ man/downloadRemote.Rd | 2 ++ tests/testthat/test-checkPath.R | 2 +- tests/testthat/test-prepInputs.R | 2 +- 10 files changed, 27 insertions(+), 16 deletions(-) diff --git a/R/DBI.R b/R/DBI.R index bdc59cb16..d49553df3 100644 --- a/R/DBI.R +++ b/R/DBI.R @@ -202,6 +202,7 @@ 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 diff --git a/R/download.R b/R/download.R index 0050304b4..e94610ffb 100755 --- a/R/download.R +++ b/R/download.R @@ -11,7 +11,7 @@ #' @param ... Passed to `dlFun`. Still experimental. Can be e.g., `type` for google docs. #' @param checksumFile A character string indicating the absolute path to the `CHECKSUMS.txt` #' file. -#' +#' @inheritParams loadFromCache #' @inheritParams Cache #' @author Eliot McIntire #' @return @@ -501,6 +501,7 @@ dlGeneric <- function(url, destinationPath, verbose = getOption("reproducible.ve #' @param messSkipDownload The character string text to pass to messaging if download skipped #' @param checkSums TODO #' @param fileToDownload TODO +#' @inheritParams loadFromCache #' downloadRemote <- function(url, archive, targetFile, checkSums, dlFun = NULL, fileToDownload, messSkipDownload, @@ -706,7 +707,7 @@ assessGoogle <- function(url, archive = NULL, targetFile = NULL, opts <- options(httr_oob_default = TRUE) on.exit(options(opts)) } - + if (is.null(archive) || is.na(archive)) { if (packageVersion("googledrive") < "2.0.0") { fileAttr <- retry(retries = 1, quote(googledrive::drive_get(googledrive::as_id(url), diff --git a/R/exportedMethods.R b/R/exportedMethods.R index 8efd32023..091b036ff 100644 --- a/R/exportedMethods.R +++ b/R/exportedMethods.R @@ -485,6 +485,7 @@ unmakeMemoisable.default <- function(x) { #' #' @param obj Any arbitrary R object. #' @inheritParams Cache +#' @inheritParams loadFromCache #' @rdname dotWrap #' @return #' Returns an object that can be saved to disk e.g., via `saveRDS`. @@ -673,13 +674,13 @@ wrapSpatRaster <- function(obj, cachePath) { # 2) have layer names renamed whLayers <- seq_along(names(obj)) if (!identical(nlyrsInFile, length(names(obj)))) { - rr <- rast(fns); + rr <- terra::rast(fns); objDigs <- unlist(lapply(layerNams, function(ln) .robustDigest(obj[[ln]][]))) digs <- character() whLayers <- integer() # don't need to go through all layers if the current file has only some; run through from start - for (ln in seq_len(nlyr(rr))) { + for (ln in seq_len(terra::nlyr(rr))) { digs[ln] <- .robustDigest(rr[[ln]][]) if (digs[ln] %in% objDigs) whLayers <- c(ln, whLayers) diff --git a/R/postProcessTo.R b/R/postProcessTo.R index f3f62092e..d3470c21a 100644 --- a/R/postProcessTo.R +++ b/R/postProcessTo.R @@ -1399,11 +1399,11 @@ isGeomType <- function(geom, type) { if (isVector(geom)) { out <- if (isSpat(geom)) { if (type == "points") - is.points(geom) + terra::is.points(geom) else if (type == "polygons") - is.polygons(geom) + terra::is.polygons(geom) else if (type == "lines") - is.lines(geom) + terra::is.lines(geom) } else { if (type == "points") is(sf::st_geometry(geom), "sfc_POINT") @@ -1463,9 +1463,9 @@ gdalProject <- function(fromRas, toRas, filenameDest, verbose = getOption("repro options = c( "-t_srs", tf4, "-r", method, - "-te", c(xmin(toRas), ymin(toRas), - xmin(toRas) + (ncol(toRas) ) * res(toRas)[1], - ymin(toRas) + (nrow(toRas) ) * res(toRas)[2]), + "-te", c(terra::xmin(toRas), terra::ymin(toRas), + terra::xmin(toRas) + (terra::ncol(toRas) ) * terra::res(toRas)[1], + terra::ymin(toRas) + (terra::nrow(toRas) ) * terra::res(toRas)[2]), "-te_srs", tf4, "-dstnodata", "NA", "-overwrite" @@ -1511,11 +1511,11 @@ gdalResample <- function(fromRas, toRas, filenameDest, verbose = getOption("repr destination = filenameDest, options = c( "-r", "near", - "-te", c(xmin(toRas), ymin(toRas), - xmin(toRas) + (ncol(toRas) ) * res(toRas)[1], - ymin(toRas) + (nrow(toRas) ) * res(toRas)[2]), + "-te", c(terra::xmin(toRas), terra::ymin(toRas), + terra::xmin(toRas) + (terra::ncol(toRas) ) * terra::res(toRas)[1], + terra::ymin(toRas) + (terra::nrow(toRas) ) * terra::res(toRas)[2]), "-te_srs", tf4, # 3347, 3348, 3978, 3979 - "-tr", res(toRas), + "-tr", terra::res(toRas), "-dstnodata", "NA", "-tap", "-overwrite" diff --git a/man/CacheHelpers.Rd b/man/CacheHelpers.Rd index 3ecf51b0b..6041cca18 100644 --- a/man/CacheHelpers.Rd +++ b/man/CacheHelpers.Rd @@ -86,6 +86,8 @@ option, e.g., \verb{options('reproducible.verbose' = 0) to reduce to minimal}} \item{cacheId}{The cacheId or otherwise digested hash value, as character string.} +\item{preDigest}{The list of \code{preDigest} that comes from \code{CacheDigest} of an object} + \item{fullCacheTableForObj}{The result of \code{showCache}, but subsetted for only the \code{cacheId} being loaded or selected} diff --git a/man/dotWrap.Rd b/man/dotWrap.Rd index f715fdaf5..4c3fe594a 100644 --- a/man/dotWrap.Rd +++ b/man/dotWrap.Rd @@ -85,6 +85,8 @@ \item{cachePath}{A repository used for storing cached objects. This is optional if \code{Cache} is used inside a SpaDES module.} +\item{preDigest}{The list of \code{preDigest} that comes from \code{CacheDigest} of an object} + \item{drv}{if using a database backend, drv must be an object that inherits from DBIDriver e.g., from package RSQLite, e.g., SQLite} diff --git a/man/downloadFile.Rd b/man/downloadFile.Rd index 09f351387..e95a12090 100644 --- a/man/downloadFile.Rd +++ b/man/downloadFile.Rd @@ -77,6 +77,8 @@ in subsequent calls to \code{1} write a new one, \code{2} append new information to existing one.} +\item{preDigest}{The list of \code{preDigest} that comes from \code{CacheDigest} of an object} + \item{overwrite}{Logical. Should downloading and all the other actions occur even if they pass the checksums or the files are all there.} diff --git a/man/downloadRemote.Rd b/man/downloadRemote.Rd index a417a1d91..bf153f535 100644 --- a/man/downloadRemote.Rd +++ b/man/downloadRemote.Rd @@ -73,6 +73,8 @@ even if they pass the checksums or the files are all there.} \item{.tempPath}{Optional temporary path for internal file intermediate steps. Will be cleared on.exit from this function.} +\item{preDigest}{The list of \code{preDigest} that comes from \code{CacheDigest} of an object} + \item{verbose}{Numeric, -1 silent (where possible), 0 being very quiet, 1 showing more messaging, 2 being more messaging, etc. Default is 1. Above 3 will output much more information about the internals of diff --git a/tests/testthat/test-checkPath.R b/tests/testthat/test-checkPath.R index 78f0aea52..428c86210 100644 --- a/tests/testthat/test-checkPath.R +++ b/tests/testthat/test-checkPath.R @@ -28,7 +28,7 @@ test_that("checkPath: normPath and normPathRel consistency", { checkedRel <- normPathRel(paths) if (identical(.Platform$OS.type, "windows")) { ## Windows create absolute paths - expect_equal(length(unique(checkedRel)), 1) + expect_equal(length(unique(checkedRel)), 2) } else { ## non-existent paths kept relative on other platforms expect_equal(length(unique(checkedRel)), 2) diff --git a/tests/testthat/test-prepInputs.R b/tests/testthat/test-prepInputs.R index 6246bc9e5..c9df3fbea 100644 --- a/tests/testthat/test-prepInputs.R +++ b/tests/testthat/test-prepInputs.R @@ -1679,7 +1679,7 @@ test_that("options inputPaths", { ) ) expect_true(sum(grepl(paste0(hardlinkMessagePrefixForGrep, ":\n", file.path(tmpdir1, theFile)), mess1)) == 1) - expect_true(sum(grepl(paste0("", whPointsToMessForGrep, "\n", file.path(tmpdir, theFile)), mess1)) == 1) + expect_true(sum(grepl(paste0("", whPointsToMessForGrep, "\n", file.path(tmpdir1, theFile)), mess1)) == 1) expect_true(sum(basename(dir(file.path(tmpdir), recursive = TRUE)) %in% theFile) == 3) } ## Try download to inputPath, intercepting the destination, creating a link From 859900dcd4176308fd053924041e8a0bf8f3bdfd Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Sun, 5 Nov 2023 14:39:15 -0800 Subject: [PATCH 66/70] need to match files on cloudDownload --- R/cloud.R | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/R/cloud.R b/R/cloud.R index c72b3d41e..6d85bc931 100644 --- a/R/cloud.R +++ b/R/cloud.R @@ -170,21 +170,20 @@ cloudDownload <- function(outputHash, newFileName, gdriveLs, cachePath, cloudFol path = googledrive::as_id(cloudFolderID), pattern = paste(collapse = "|", newFileName) ) + newFileName <- newFileName[match(newFileName, gdriveLs$name)] } } outs <- rbindlist(outs) if (!useDBI()) { dtFileInCache <- CacheDBFileSingle(cachePath, cacheId = outputHash) - hardLinkOrCopy(dtFile, dtFileInCache) + suppressMessages(hardLinkOrCopy(dtFile, dtFileInCache)) } objFiles <- grep(CacheDBFileSingleExt(), outs$local_path, value = TRUE, invert = TRUE) # objFiles <- grep(paste0(".", formatCheck(cachePath, outputHash)), objFiles, value = TRUE) filenamesInCache <- file.path(CacheStorageDir(), basename2(objFiles)) hardLinkOrCopy(objFiles, to = filenamesInCache) - - if (useDBI()) { # with useDBI = FALSE, the dbFile is already there. Map(tv = dt$tagValue, tk = dt$tagKey, function(tv, tk) { .addTagsRepo(outputHash, cachePath, tagKey = tk, tagValue = tv, drv = drv, conn = conn) From 74fd541954002cee527ded19ae4785627e2b8810 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Sun, 5 Nov 2023 14:39:47 -0800 Subject: [PATCH 67/70] cloudDownload -- need obj = outputToSave --- R/cloud.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/cloud.R b/R/cloud.R index 6d85bc931..55124258c 100644 --- a/R/cloud.R +++ b/R/cloud.R @@ -218,7 +218,7 @@ cloudUploadFromCache <- function(isInCloud, outputHash, cachePath, cloudFolderID # browser(expr = exists("._cloudUploadFromCache_1")) if (!any(isInCloud)) { - cacheIdFileName <- CacheStoredFile(cachePath, outputHash, "check") + cacheIdFileName <- CacheStoredFile(cachePath, outputHash, "check", obj = outputToSave) if (useDBI()) { dt <- showCache(userTags = outputHash) td <- tempdir() From 9bcf7f714e755c7adf9b9ec468fe7954b60517d2 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Sun, 5 Nov 2023 14:40:23 -0800 Subject: [PATCH 68/70] cloudDownload -- improve messaging --- R/cloud.R | 16 +++++++++------- R/exportedMethods.R | 5 +++-- 2 files changed, 12 insertions(+), 9 deletions(-) diff --git a/R/cloud.R b/R/cloud.R index 55124258c..d9020bf13 100644 --- a/R/cloud.R +++ b/R/cloud.R @@ -222,8 +222,8 @@ cloudUploadFromCache <- function(isInCloud, outputHash, cachePath, cloudFolderID if (useDBI()) { dt <- showCache(userTags = outputHash) td <- tempdir() - useDBI(FALSE, verbose = FALSE) - on.exit(useDBI(TRUE, verbose = FALSE)) + useDBI(FALSE, verbose = -1) + on.exit(useDBI(TRUE, verbose = -1)) cacheDB <- CacheDBFileSingle(cachePath = td, outputHash) # put it in a temp location b/c don't want persistent on.exit(unlink(cacheDB), add = TRUE) if (!dir.exists(dirname(cacheDB))) { @@ -231,7 +231,7 @@ cloudUploadFromCache <- function(isInCloud, outputHash, cachePath, cloudFolderID on.exit(unlink(dirname(cacheDB)), add = TRUE) } suppress <- saveFilesInCacheFolder(obj = dt, fts = cacheDB, cacheId = outputHash, cachePath = cachePath) - useDBI(TRUE, verbose = FALSE) + useDBI(TRUE, verbose = -1) } else { cacheDB <- CacheDBFileSingle(cachePath, outputHash) } @@ -239,9 +239,11 @@ cloudUploadFromCache <- function(isInCloud, outputHash, cachePath, cloudFolderID newFileName <- basename2(cacheIdFileName) cloudFolderID <- checkAndMakeCloudFolderID(cloudFolderID = cloudFolderID, create = TRUE) - messageCache("Uploading new cached object ", newFileName, ", with cacheId: ", - outputHash, " to cloud folder id: ", cloudFolderID$name, " or ", cloudFolderID$id, - verbose = verbose + + messageCache("Uploading new cached object -- file(s):\n", paste(newFileName, collapse = "\n"), + "\n ... with cacheId: ", + outputHash, " to cloud folder id: ", cloudFolderID$name, " or ", cloudFolderID$id, + verbose = verbose ) du <- Map(med = cacheIdFileName, nam = newFileName, function(med, nam) { try(retry(quote( @@ -264,7 +266,7 @@ cloudUploadFromCache <- function(isInCloud, outputHash, cachePath, cloudFolderID stop("File(s) to upload are not available") } } - cloudUploadRasterBackends(obj = outputToSave, cloudFolderID) + # cloudUploadRasterBackends(obj = outputToSave, cloudFolderID) } cloudUploadRasterBackends <- function(obj, cloudFolderID) { diff --git a/R/exportedMethods.R b/R/exportedMethods.R index 091b036ff..71890bf8e 100644 --- a/R/exportedMethods.R +++ b/R/exportedMethods.R @@ -690,8 +690,6 @@ wrapSpatRaster <- function(obj, cachePath) { # inFileDigs <- unlist(lapply(seq_len(nlyr(rr)), function(ln) ) # whLayers <- which(unlist(inFileDigs) %in% unlist(objDigs)) } - if (is.character(obj)) - if (any(grepl("MDC_historical_NT", basename2(obj)))) browser() obj <- asPath(fnsMulti) attr(obj, "tags") <- c( attr(obj, "tags"), @@ -739,6 +737,9 @@ unwrapSpatRaster <- function(obj, cachePath) { obj = obj ) + feObjs <- file.exists(obj) + if (any(feObjs)) + unlink(obj[feObjs]) hardLinkOrCopy(unlist(filenameInCache), obj, verbose = 0) obj <- eval(parse(text = extractFromCache(tags, "loadFun")))(whFiles) possNames <- strsplit(extractFromCache(tags, "layerNames"), split = layerNamesDelimiter)[[1]] From 7ca9cd6bb27333fe6d0fe4d5bf8e7773cd00e738 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Sun, 5 Nov 2023 18:58:36 -0800 Subject: [PATCH 69/70] mac and linux don't work with ctime the same way as Windows --- DESCRIPTION | 4 ++-- tests/testthat/test-preProcessWorks.R | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 57701a7f1..ade3a230f 100644 --- a/DESCRIPTION +++ b/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-11-03 -Version: 2.0.8.9013 +Date: 2023-11-05 +Version: 2.0.8.9014 Authors@R: c(person(given = "Eliot J B", family = "McIntire", diff --git a/tests/testthat/test-preProcessWorks.R b/tests/testthat/test-preProcessWorks.R index 7ca4f31d0..af5719cd1 100644 --- a/tests/testthat/test-preProcessWorks.R +++ b/tests/testthat/test-preProcessWorks.R @@ -516,9 +516,9 @@ test_that("lightweight tests for preProcess code coverage", { d <- file.info(csf) if (isWindows()) { # linux doesn't do ctime expect_true(milliseconds(d$ctime) == milliseconds(a$ctime)) + expect_false(milliseconds(d$atime) == milliseconds(a$atime)) } expect_false(milliseconds(d$mtime) == milliseconds(a$mtime)) - expect_false(milliseconds(d$atime) == milliseconds(a$atime)) # purge will delete CHECKSUMS 1 -- deleted, written, read Sys.sleep(0.1) From 52463c43b35bce98639efdf44f0f66e5161035ab Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Sun, 5 Nov 2023 20:09:32 -0800 Subject: [PATCH 70/70] clean stale comments --- DESCRIPTION | 2 +- R/DBI.R | 23 ----------------------- R/cache-helpers.R | 3 --- R/cache-internals.R | 3 --- R/cache.R | 15 +-------------- R/exportedMethods.R | 8 -------- 6 files changed, 2 insertions(+), 52 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index ade3a230f..106f401dd 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -20,7 +20,7 @@ URL: https://reproducible.predictiveecology.org, https://github.com/PredictiveEcology/reproducible Date: 2023-11-05 -Version: 2.0.8.9014 +Version: 2.0.8.9015 Authors@R: c(person(given = "Eliot J B", family = "McIntire", diff --git a/R/DBI.R b/R/DBI.R index d49553df3..7bd300840 100644 --- a/R/DBI.R +++ b/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) @@ -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,9 +148,6 @@ 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 = memoiseEnv(cachePath)) @@ -178,7 +171,6 @@ saveToCache <- function(cachePath = getOption("reproducible.cachePath"), 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 ", @@ -226,9 +218,6 @@ 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 = memoiseEnv(cachePath)) if (isTRUE(isMemoised)) { obj <- get(cacheId, envir = memoiseEnv(cachePath)) @@ -236,8 +225,6 @@ loadFromCache <- function(cachePath = getOption("reproducible.cachePath"), } } - # 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) @@ -398,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()) @@ -510,7 +496,6 @@ dbConnectAll <- function(drv = getDrv(getOption("reproducible.drv", NULL)), } } .cacheNumDefaultTags <- function() { - # if (useDBI()) 7 # else 12 } @@ -575,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") } @@ -594,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 diff --git a/R/cache-helpers.R b/R/cache-helpers.R index 26e33426e..e493da650 100644 --- a/R/cache-helpers.R +++ b/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)) { diff --git a/R/cache-internals.R b/R/cache-internals.R index 7f6a517fe..202aeb5e3 100644 --- a/R/cache-internals.R +++ b/R/cache-internals.R @@ -19,7 +19,6 @@ 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 = "\\."), diff --git a/R/cache.R b/R/cache.R index 45b73ba2c..7e6a9f882 100644 --- a/R/cache.R +++ b/R/cache.R @@ -571,7 +571,6 @@ Cache <- conns[[cachePath]] <- dbConnectAll(drv, cachePath = cachePath) RSQLite::dbClearResult(RSQLite::dbSendQuery(conns[[cachePath]], "PRAGMA busy_timeout=5000;")) RSQLite::dbClearResult(RSQLite::dbSendQuery(conns[[cachePath]], "PRAGMA journal_mode=WAL;")) - # on.exit({dbDisconnect(conns[[cachePath]])}, add = TRUE) } } @@ -583,19 +582,17 @@ Cache <- ret <- createCache(cachePath, drv = drv, conn = conns[[cachePath]], force = isIntactRepo - ) # [cacheRepoInd]) + ) } # Need exclusive lock if (!useDBI()) { dtFile <- CacheDBFileSingle(cachePath = cachePath, cacheId = outputHash) lockFile <- file.path(CacheStorageDir(cachePath = cachePath), paste0(outputHash, suffixLockFile())) - # lockFile <- paste0(gsub(paste0("(^.+", outputHash, ").+"), "\\1", dtFile), suffixLockFile()) locked <- filelock::lock(lockFile) on.exit( { filelock::unlock(locked) - # if (!isTRUE(lockFileExisted)) if (file.exists(lockFile)) { unlink(lockFile) } @@ -604,7 +601,6 @@ Cache <- ) } - # Check if it is in repository inReposPoss <- searchInRepos(cachePath, outputHash = outputHash, @@ -684,7 +680,6 @@ Cache <- # userTags and in devMode needFindByTags <- identical("devMode", useCache) && NROW(isInRepo) == 0 if (needFindByTags) { - # browser(expr = exists("._Cache_5")) # It will not have the "localTags" object because of "direct db access" added Jan 20 2020 if (!exists("localTags", inherits = FALSE)) { # localTags <- showCache(cachePath, drv = drv, verbose = FALSE) @@ -791,7 +786,6 @@ Cache <- .CacheIsNew <- TRUE # check that it didn't come from cloud or failed to find complete cloud (i.e., output is NULL) - # browser(expr = exists("._Cache_10")) elapsedTimeFUN <- NA if (!exists("output", inherits = FALSE) || is.null(output)) { # Run the FUN @@ -930,7 +924,6 @@ Cache <- } } .reproEnv$futureEnv[[paste0("future_", rndstr(1, 10))]] <- - # saved <- future::futureCall( FUN = writeFuture, args = list(written, outputToSave, cachePath, userTags, drv, conn, @@ -1014,7 +1007,6 @@ Cache <- #' @keywords internal .namesPostProcessFormals <- function() { - # setdiff(unique(unlist(lapply(methods(postProcess), formalArgs))), "...") c( "x", "filename1", "filename2", "studyArea", "rasterToMatch", "overwrite", "useSAcrs", "useCache", "verbose" @@ -1073,7 +1065,6 @@ writeFuture <- function(written, outputToSave, cachePath, userTags, conn = getOption("reproducible.conn", NULL), cacheId, linkToCacheId = NULL) { counter <- 0 - # browser(expr = exists("._writeFuture_1")) if (!CacheIsACache(cachePath = cachePath, drv = drv, conn = conn)) { stop("That cachePath does not exist") } @@ -1157,9 +1148,6 @@ recursiveEvalNamesOnly <- function(args, envir = parent.frame(), outer = TRUE, r evd } } else { - # envir2 <- whereInStack(xxxx, envir) - # ret <- try(eval(xxxx, envir2), silent = TRUE) - # if (is(ret, "try-error")) ret <- xxxx ret } @@ -1227,7 +1215,6 @@ matchCall <- function(FUNcaptured, envir = parent.frame(), fnName) { args2 <- args2[seq_along(args)] # chop off any trailing args mc <- append(list(FUN), args2) } else { - # args <- as.list(args[-1]) # remove the list that is inside the substitute; move to outside mc <- match.call(FUN, FUNcaptured) } } diff --git a/R/exportedMethods.R b/R/exportedMethods.R index 71890bf8e..afc2be994 100644 --- a/R/exportedMethods.R +++ b/R/exportedMethods.R @@ -687,8 +687,6 @@ wrapSpatRaster <- function(obj, cachePath) { if (all(digs %in% objDigs)) break } - # inFileDigs <- unlist(lapply(seq_len(nlyr(rr)), function(ln) ) - # whLayers <- which(unlist(inFileDigs) %in% unlist(objDigs)) } obj <- asPath(fnsMulti) attr(obj, "tags") <- c( @@ -725,12 +723,6 @@ unwrapSpatRaster <- function(obj, cachePath) { newName <- file.path(cachePath, origRelName) } whFiles <- newName[match(basename(extractFromCache(tags, "whichFiles")), origFilename)] - # filenameInCache <- Map(ff = whFiles, form = fileExt(obj), function(ff, form) { - # CacheStoredFile(cachePath, - # cacheId = tools::file_path_sans_ext(basename(ff)), - # format = form - # ) - # }) filenameInCache <- CacheStoredFile(cachePath, # cacheId = tools::file_path_sans_ext(basename(obj)),