diff --git a/DESCRIPTION b/DESCRIPTION index d2d65c79c..106f401dd 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.9008 +Date: 2023-11-05 +Version: 2.0.8.9015 Authors@R: c(person(given = "Eliot J B", family = "McIntire", diff --git a/NEWS.md b/NEWS.md index 30106f28d..6b0451724 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,9 +4,23 @@ * new function `isUpdated()` to determine whether a cached object has been updated; * `makeRelative()` is now exported for use downstream (e.g., `SpaDES.core`); * new functions `getRelative()` and `normPathRel()` for improved symlink handling (#362); +* messaging is improved for `Cache` with the function named instead of just `cacheId` +* messaging for `prepInputs`: minor changes +* more edge cases for `Checksums` dealt with, so fewer unneeded downloads +* `wrapSpatRaster` (`wrap` for file-backed `spatRaster` objects) fixes for more edge cases +* `postProcessTo` can now use `sf::gdal_utils` for the case of `from` is a gridded object and `to` is a polygon vector. This appears to be between 2x and 10x faster in tests. +* `postProcessTo` does a pre-crop (with buffer) to make the `projectTo` faster. When both `from` and `to` are vector objects, this pre-crop appears to create slivers in some cases. This step is now skipped for these cases. +* `Cache` can now deal with unnamed functions, e.g., `Cache((function(x) x)())` +* `terra` would fail if internet was unavailable, even when internet is not necessary, due to needing to retrieve projection information. Many cases where this happens will now divert to use `sf`. +* `Cache` can now skip calculating `objSize`, which can take a non-trivial amount of time for large, complicated objects; see `reproducibleOptions()` ## Bug fixes * Filenames for some classes returned ""; now returns NULL so character vectors are only pointers to files +* Cache on a terra object that writes file to disk, when `quick` argument is specified was failing, always creating the same object; fixed with #PR368 +* `useDBI` was incorrectly used if a user had set the option prior to package loading. Now works as expected. +* several other minor +* `preProcess` deals better with more cases of nested paths in archives. +* more edge cases corrected for `inputPaths` # reproducible 2.0.8 diff --git a/R/DBI.R b/R/DBI.R index 7613c5b25..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) @@ -125,8 +123,8 @@ saveToCache <- function(cachePath = getOption("reproducible.cachePath"), if (is(out, "try-error") || !all((out %in% TRUE))) { linkToCacheId <- NULL } else { - messageCache(" (A file with identical properties already exists in the Cache: ", basename(ftL), "; ", - "The newly added (", basename(fts), ") is a file.link to that file)", + messageCache(" (A file with identical properties already exists in the Cache: ", basename(ftL), "; ") + messageCache(" The newly added (", basename(fts), ") is a file.link to that file)", verbose = verbose ) } @@ -140,8 +138,6 @@ saveToCache <- function(cachePath = getOption("reproducible.cachePath"), ) if (!useDBI()) { dtFile <- saveDBFileSingle(dt = dt, cachePath, cacheId) - # dtFile <- CacheDBFileSingle(cachePath = cachePath, cacheId = cacheId) - # saveFilesInCacheFolder(dt, dtFile, cachePath = cachePath, cacheId = cacheId) } else { a <- retry(retries = 250, exponentialDecayBase = 1.01, quote( DBI::dbAppendTable(conn, CacheDBTableName(cachePath, drv), dt) @@ -152,12 +148,9 @@ saveToCache <- function(cachePath = getOption("reproducible.cachePath"), fs <- saveFilesInCacheFolder(cachePath = cachePath, obj, fts, cacheId = cacheId) } if (isTRUE(getOption("reproducible.useMemoise"))) { - if (is.null(.pkgEnv[[cachePath]])) { - .pkgEnv[[cachePath]] <- new.env(parent = emptyenv()) - } obj <- .unwrap(obj, cachePath, cacheId, drv, conn) # This takes time, but whether it happens now or later, same obj2 <- makeMemoisable(obj) - assign(cacheId, obj2, envir = .pkgEnv[[cachePath]]) + assign(cacheId, obj2, envir = memoiseEnv(cachePath)) } fsChar <- as.character(fs) @@ -175,9 +168,9 @@ saveToCache <- function(cachePath = getOption("reproducible.cachePath"), # So effectively, it is like 6x buffer to try to avoid false positives. whichOS <- which(tagKey == "object.size") if (length(whichOS)) { - fsBig <- (as.numeric(tagValue[whichOS]) * 4) < fs + objSize <- if (identical(tagValue[whichOS], "NA")) NA else as.numeric(tagValue[whichOS]) + fsBig <- (objSize * 4) < fs if (isTRUE(fsBig)) { - # browser(expr = exists("._saveToCache_3")) messageCache("Object with cacheId ", cacheId, " appears to have a much larger size ", "on disk than in memory. ", "This usually means that the object has captured an environment with ", @@ -201,13 +194,14 @@ saveToCache <- function(cachePath = getOption("reproducible.cachePath"), #' the `cacheId` being loaded or selected #' @param .dotsFromCache Optional. Used internally. #' @param .functionName Optional. Used for messaging when this function is called from `Cache` +#' @param preDigest The list of `preDigest` that comes from `CacheDigest` of an object #' @details #' `loadFromCache` is a function to get a single object from the cache, given its `cacheId`. #' @return #' `loadFromCache` returns the object from the cache that has the particular `cacheId`. #' loadFromCache <- function(cachePath = getOption("reproducible.cachePath"), - cacheId, + cacheId, preDigest, fullCacheTableForObj = NULL, format = getOption("reproducible.cacheSaveFormat", "rds"), .functionName = NULL, .dotsFromCache = NULL, @@ -224,18 +218,13 @@ loadFromCache <- function(cachePath = getOption("reproducible.cachePath"), isMemoised <- NA if (isTRUE(getOption("reproducible.useMemoise"))) { - if (is.null(.pkgEnv[[cachePath]])) { - .pkgEnv[[cachePath]] <- new.env(parent = emptyenv()) - } - isMemoised <- exists(cacheId, envir = .pkgEnv[[cachePath]]) + isMemoised <- exists(cacheId, envir = memoiseEnv(cachePath)) if (isTRUE(isMemoised)) { - obj <- get(cacheId, envir = .pkgEnv[[cachePath]]) + obj <- get(cacheId, envir = memoiseEnv(cachePath)) obj <- unmakeMemoisable(obj) } } - # fileFormat <- extractFromCache(fullCacheTableForObj, "fileFormat", ifNot = format) - if (!isTRUE(isMemoised)) { f <- CacheStoredFile(cachePath, cacheId, format) f <- unique(f) # It is OK if there is a vector of unique cacheIds e.g., loadFromCache(showCache(userTags = "hi")$cacheId) @@ -256,6 +245,7 @@ loadFromCache <- function(cachePath = getOption("reproducible.cachePath"), cachePath = cachePath, fullCacheTableForObj = fullCacheTableForObj, cacheId = cacheId, format = fileExt(sameCacheID), + preDigest = preDigest, verbose = verbose ) obj <- .wrap(obj, cachePath = cachePath, drv = drv, conn = conn) @@ -291,7 +281,7 @@ loadFromCache <- function(cachePath = getOption("reproducible.cachePath"), if (isTRUE(getOption("reproducible.useMemoise")) && !isTRUE(isMemoised)) { obj2 <- makeMemoisable(obj) - assign(cacheId, obj2, envir = .pkgEnv[[cachePath]]) + assign(cacheId, obj2, envir = memoiseEnv(cachePath)) } if (verbose > 3) { @@ -315,7 +305,7 @@ loadFromCache <- function(cachePath = getOption("reproducible.cachePath"), extractFromCache <- function(sc, elem, ifNot = NULL) { - rowNum <- sc[["tagKey"]] == elem + rowNum <- sc[["tagKey"]] %in% elem elemExtracted <- if (any(rowNum)) { sc[["tagValue"]][rowNum] } else { @@ -395,7 +385,6 @@ dbConnectAll <- function(drv = getDrv(getOption("reproducible.drv", NULL)), tagKey = character(), tagValue = character(), drv = getDrv(getOption("reproducible.drv", NULL)), conn = getOption("reproducible.conn", NULL)) { - # browser(expr = exists("._addTagsRepo_1")) if (length(cacheId) > 0) { if (length(cacheId) > 1) stop(".addTagsRepo can only handle appending 1 tag at a time") curTime <- as.character(Sys.time()) @@ -499,14 +488,14 @@ dbConnectAll <- function(drv = getDrv(getOption("reproducible.drv", NULL)), if (add && alreadyThere == 0) { dt2 <- rbindlist(list(dt2, dt)) } else { - dt2[tagKey == tk & cacheId == cacheId, tagValue := dt$tagValue] + set(dt2, which(dt2$tagKey == tk & dt2$cacheId == cacheId), "tagValue", dt$tagValue) + # dt2[tagKey == tk & cacheId == cacheId, tagValue := dt$tagValue] } saveFilesInCacheFolder(dt2, dtFile, cachePath = cachePath, cacheId = cacheId) } } } .cacheNumDefaultTags <- function() { - # if (useDBI()) 7 # else 12 } @@ -571,11 +560,7 @@ CacheDBFile <- function(cachePath = getOption("reproducible.cachePath"), # } if (grepl(type, "SQLite")) { - # if (useDBI()) { file.path(cachePath, "cache.db") - # } else { - # file.path(cachePath, "backpack.db") - # } } else { file.path(cachePath, "cache.txt") } @@ -590,11 +575,7 @@ CacheDBFile <- function(cachePath = getOption("reproducible.cachePath"), #' `CacheStorageDir` returns the name of the directory where cached objects are #' stored. CacheStorageDir <- function(cachePath = getOption("reproducible.cachePath")) { - # if (useDBI()) { file.path(cachePath, "cacheOutputs") - # } # else { - # file.path(cachePath, "gallery") - # } } #' @details @@ -614,6 +595,7 @@ CacheStorageDir <- function(cachePath = getOption("reproducible.cachePath")) { CacheStoredFile <- function(cachePath = getOption("reproducible.cachePath"), cacheId, format = NULL, obj = NULL) { if (is.null(format)) format <- getOption("reproducible.cacheSaveFormat", "rds") + if (missing(cacheId)) cacheId <- NULL if (any(format %in% "check")) { format <- formatCheck(cachePath, cacheId, format) } @@ -629,7 +611,7 @@ CacheStoredFile <- function(cachePath = getOption("reproducible.cachePath"), cac "rda" } } - filename <- paste(cacheId, csExtension, sep = ".") + filename <- if (is.null(cacheId)) NULL else paste(cacheId, csExtension, sep = ".") if (length(cacheId) > 1) { filename <- vapply(filename, nextNumericName, FUN.VALUE = character(1)) for (i in seq(filename[-1]) + 1) { @@ -958,7 +940,7 @@ convertDBbackendIfIncorrect <- function(cachePath, drv, conn, newDBI <- suppressMessages(useDBI(!origDBI)) # switch to the other if (!identical(newDBI, origDBI)) { # if they are same, then DBI is not installed; not point proceeding on.exit(suppressMessages(useDBI(origDBI))) - drv <- getDrv(drv) + drv <- getDrv(drv) # This will return the DBI driver, if it is installed, regardless of drv DBFileWrong <- CacheDBFile(cachePath, drv, conn) if (file.exists(DBFileWrong)) { sc <- showCache(cachePath, drv = drv, conn = conn, verbose = -2) @@ -1004,3 +986,19 @@ CacheDBFiles <- function(cachePath = getOption("reproducible.cachePath")) { dtFiles <- dir(CacheStorageDir(cachePath), pattern = ext, full.names = TRUE) dtFiles } + +memoiseEnv <- function(cachePath, envir = .GlobalEnv) { + memPersist <- isTRUE(getOption("reproducible.memoisePersist", NULL)) + if (memPersist) { + obj <- paste0(".reproducibleMemoise_", cachePath) + if (!exists(obj, envir = envir)) + assign(obj, new.env(parent = emptyenv()), envir = envir) + memEnv <- get(obj, envir = envir, inherits = FALSE) + } else { + if (is.null(.pkgEnv[[cachePath]])) { + .pkgEnv[[cachePath]] <- new.env(parent = emptyenv()) + } + memEnv <- .pkgEnv[[cachePath]] + } + memEnv +} diff --git a/R/cache-helpers.R b/R/cache-helpers.R index 8af3a018b..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)) { @@ -556,22 +553,29 @@ withoutFinalNumeric <- function(string) { setClass("PackedSpatExtent") wrapSpatVector <- function(obj) { - geom1 <- terra::geom(obj) - geom1 <- list( - cols125 = matrix(as.integer(geom1[, c(1, 2, 5)]), ncol = 3), - cols34 = matrix(as.integer(geom1[, c(3, 4)]), ncol = 2) - ) - geomtype1 <- terra::geomtype(obj) - dat1 <- terra::values(obj) - crs1 <- terra::crs(obj) - obj <- list(geom1, geomtype1, dat1, crs1) - names(obj) <- spatVectorNamesForCache + obj <- terra::wrap(obj) + if (FALSE) { + geom1 <- terra::geom(obj) + geom1 <- list( + cols125 = matrix(as.integer(geom1[, c(1, 2, 5)]), ncol = 3), + cols34 = matrix(as.integer(geom1[, c(3, 4)]), ncol = 2) + ) + geomtype1 <- terra::geomtype(obj) + dat1 <- terra::values(obj) + crs1 <- terra::crs(obj) + obj <- list(geom1, geomtype1, dat1, crs1) + names(obj) <- spatVectorNamesForCache + } obj } unwrapSpatVector <- function(obj) { - obj$x <- cbind(obj$x$cols125[, 1:2, drop = FALSE], obj$x$cols34[, 1:2, drop = FALSE], obj$x$cols125[, 3, drop = FALSE]) - do.call(terra::vect, obj) + obj <- terra::unwrap(obj) + if (FALSE) { + obj$x <- cbind(obj$x$cols125[, 1:2, drop = FALSE], obj$x$cols34[, 1:2, drop = FALSE], obj$x$cols125[, 3, drop = FALSE]) + do.call(terra::vect, obj) + } + obj } #' Has a cached object has been updated? diff --git a/R/cache-internals.R b/R/cache-internals.R index 2169376df..202aeb5e3 100644 --- a/R/cache-internals.R +++ b/R/cache-internals.R @@ -13,13 +13,12 @@ ) hashObjectSize <- unlist(lapply(modifiedDots, function(x) { - objSize <- unname(attr(objSize(x), "objSize")) + if (getOption("reproducible.objSize", TRUE)) unname(attr(objSize(x), "objSize")) else NA })) lengths <- unlist(lapply(preDigestUnlist, function(x) length(unlist(x)))) hashDetails <- data.frame( objectNames = rep(names(preDigestUnlist), lengths), - # objSize = rep(hashObjectSize, lengths), hashElements = names(unlist(preDigestUnlist)), hash = unname(unlist(preDigestUnlist)), stringsAsFactors = FALSE @@ -32,8 +31,6 @@ strsplit(names(hashObjectSize), split = "\\$"), function(x) paste0(tail(x, 2), collapse = ".") )) - # hashObjectSizeNames <- unlist(lapply(strsplit(hashObjectSizeNames, split = "\\.y"), - # function(x) paste0(tail(x, 2), collapse = "."))) hashObjectSizeNames <- gsub("\\.y", replacement = "", hashObjectSizeNames) hashObjectSizeNames <- unlist(lapply( strsplit(hashObjectSizeNames, split = "\\."), @@ -108,7 +105,7 @@ .getFromRepo <- function(FUN, isInRepo, fullCacheTableForObj, notOlderThan, lastOne, cachePath, fnDetails, modifiedDots, debugCache, verbose, # sideEffect, - quick, fileFormat = NULL, + quick, # fileFormat = NULL, algo, preDigest, startCacheTime, drv = getDrv(getOption("reproducible.drv", NULL)), conn = getOption("reproducible.conn", NULL), ...) { @@ -118,7 +115,7 @@ output <- loadFromCache(cachePath, isInRepo[[.cacheTableHashColName()[lastOne]]], fullCacheTableForObj = fullCacheTableForObj, # format = fileFormat, loadFun = loadFun, - .functionName = fnDetails$functionName, .dotsFromCache = modifiedDots, + .functionName = fnDetails$functionName, preDigest = preDigest, .dotsFromCache = modifiedDots, drv = drv, conn = conn, verbose = verbose ) diff --git a/R/cache.R b/R/cache.R index daa20acad..7e6a9f882 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 @@ -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) && @@ -572,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) } } @@ -584,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) } @@ -605,7 +601,6 @@ Cache <- ) } - # Check if it is in repository inReposPoss <- searchInRepos(cachePath, outputHash = outputHash, @@ -685,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) @@ -792,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 @@ -818,7 +811,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, @@ -838,7 +831,10 @@ 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) # .wrap added tags; these should be transfered to output # outputToSave <- .addTagsToOutput(outputToSave, outputObjects, FUN, preDigestByClass) @@ -864,10 +860,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, @@ -927,7 +924,6 @@ Cache <- } } .reproEnv$futureEnv[[paste0("future_", rndstr(1, 10))]] <- - # saved <- future::futureCall( FUN = writeFuture, args = list(written, outputToSave, cachePath, userTags, drv, conn, @@ -953,12 +949,12 @@ 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) + otsObjSize <- if (identical(otsObjSize, "NA")) NA else as.numeric(otsObjSize) class(otsObjSize) <- "object_size" - isBig <- otsObjSize > 1e7 + isBig <- isTRUE(otsObjSize > 1e7) outputToSave <- progressBarCode( saveToCache( @@ -968,7 +964,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, @@ -1010,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" @@ -1069,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") } @@ -1153,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 } @@ -1223,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) } } @@ -1465,6 +1456,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) } @@ -1682,7 +1676,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] @@ -1765,7 +1764,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 = ", "), "' " ) } @@ -1826,8 +1825,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 @@ -1860,9 +1859,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) } } } @@ -2028,14 +2026,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, @@ -2235,8 +2233,8 @@ returnObjFromRepo <- function(isInRepo, notOlderThan, fullCacheTableForObj, cach ], 1)) class(objSize) <- "object_size" bigFile <- isTRUE(objSize > 1e6) - fileFormat <- extractFromCache(fullCacheTableForObj, elem = "fileFormat") - messageCache(" ...(Object to retrieve (", + fileFormat <- unique(extractFromCache(fullCacheTableForObj, elem = "fileFormat")) # can have a single tif for many entries + messageCache(" ...(Object to retrieve (fn: ", fnDetails$functionName, ", ", basename2(CacheStoredFile(cachePath, isInRepo[[.cacheTableHashColName()]], format = fileFormat)), ")", if (bigFile) " is large: ", @@ -2248,6 +2246,7 @@ returnObjFromRepo <- function(isInRepo, notOlderThan, fullCacheTableForObj, cach preLoadTime <- Sys.time() output <- try(.getFromRepo(FUN, isInRepo = isInRepo, + # fileFormat = NULL, fullCacheTableForObj = fullCacheTableForObj, notOlderThan = notOlderThan, lastOne = lastOne, @@ -2292,7 +2291,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/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)) { diff --git a/R/cloud.R b/R/cloud.R index c72b3d41e..d9020bf13 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) @@ -219,12 +218,12 @@ 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() - 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))) { @@ -232,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) } @@ -240,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( @@ -265,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/download.R b/R/download.R index 15c3d956c..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 @@ -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, ... ) ) @@ -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"))) { @@ -495,10 +501,11 @@ 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, - 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")) @@ -513,7 +520,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))) { @@ -586,7 +592,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) } } @@ -594,7 +600,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")) } diff --git a/R/exportedMethods.R b/R/exportedMethods.R index d3aed8d5d..afc2be994 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 @@ -484,13 +485,14 @@ 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`. #' #' @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") @@ -498,25 +500,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 @@ -535,7 +547,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") @@ -652,9 +664,31 @@ unmakeMemoisable.default <- function(x) { wrapSpatRaster <- function(obj, cachePath) { cls <- class(obj) + fns <- Filenames(obj, allowMultiple = FALSE) + fnsMulti <- Filenames(obj, allowMultiple = TRUE) 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 <- 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(terra::nlyr(rr))) { + digs[ln] <- .robustDigest(rr[[ln]][]) + if (digs[ln] %in% objDigs) + whLayers <- c(ln, whLayers) + if (all(digs %in% objDigs)) + break + } + } + obj <- asPath(fnsMulti) attr(obj, "tags") <- c( attr(obj, "tags"), paste0("origFilename:", basename2(obj)), @@ -667,6 +701,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) ) @@ -688,15 +723,25 @@ unwrapSpatRaster <- function(obj, cachePath) { newName <- file.path(cachePath, origRelName) } whFiles <- newName[match(basename(extractFromCache(tags, "whichFiles")), origFilename)] + 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) + + 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]] - # 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` 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 73ce37979..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 @@ -70,9 +79,22 @@ #' 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. #' } +#' \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()]. @@ -189,14 +211,17 @@ 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, reproducible.length = Inf, + reproducible.memoisePersist = FALSE, reproducible.messageColourPrepInputs = "cyan", 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", @@ -209,10 +234,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 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, ...) } diff --git a/R/postProcessTo.R b/R/postProcessTo.R index 8bf7de9f1..d3470c21a 100644 --- a/R/postProcessTo.R +++ b/R/postProcessTo.R @@ -215,21 +215,42 @@ postProcessTo <- function(from, to, } } - ############################################################# - # 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) - 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 + 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 ################################ + ############################################################# + # 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 + 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 ) } @@ -238,13 +259,17 @@ postProcessTo <- function(from, to, # WRITE STEP from <- writeTo( from, writeTo, overwrite, isStack, isBrick, isRaster, isSpatRaster, - ... - ) + ... + ) + + } + # 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 ) @@ -410,18 +435,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() @@ -616,15 +660,34 @@ 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) { + from <<- convertToSFwMessage(w, from) + attempt <<- 0 + } + invokeRestart("muffleWarning") + } + }) + from <- from13 + from <- fixErrorsIn(from) # sometimes `project` makes invalid + if (attempt == 4) + message("... converting to sf object worked to deal with ", warningCertificateGrep) + if (isSpatial) from <- as(from, "Spatial") from @@ -708,19 +771,50 @@ 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 + doneWarningAlready <- 0 + 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 + } + } + 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 } - 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)) && doneWarningAlready == 0) { + if (!isSF) { + cropTo <<- convertToSFwMessage(w, cropTo) + attempt <<- 0 + doneWarningAlready <<- 1 + } + invokeRestart("muffleWarning") + } + }) + if (attempt == 4) + message("... converting to sf object worked to deal with ", warningCertificateGrep) + } if (isVector(from) && !isSF(from)) { ext <- terra::vect(ext) @@ -1100,24 +1194,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 @@ -1166,7 +1267,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]])) } @@ -1248,3 +1349,235 @@ extntNA <- function(x) { out <- anyNA(as.numeric(out[])) return(out) } + +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 +} + + +# 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") + terra::is.points(geom) + else if (type == "polygons") + terra::is.polygons(geom) + else if (type == "lines") + terra::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"), ...) { + + if (!requireNamespace("sf") && !requireNamespace("terra")) + stop("Can't use gdalProject without sf and terra") + + 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") + terra::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) + sf::gdal_utils( + util = "warp", + source = fnSource, + destination = filenameDest, + options = c( + "-t_srs", tf4, + "-r", method, + "-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" + )) + + 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")) { + + if (!requireNamespace("sf") && !requireNamespace("terra")) + stop("Can't use gdalResample without sf and terra") + + 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") + terra::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(sf::gdal_utils( + util = "warp", + source = fnSource, + destination = filenameDest, + options = c( + "-r", "near", + "-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", terra::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"), ...) { + + if (!requireNamespace("sf") && !requireNamespace("terra")) + stop("Can't use gdalMask without sf and terra") + + 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") + terra::writeRaster(fromRas, filename = fnSource) + on.exit(unlink(fnSource)) + } + + tf3 <- tempfile(fileext = ".shp") + shp <- terra::project(maskToVect, terra::crs(fromRas)) + terra::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(sf::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 +} + diff --git a/R/preProcess.R b/R/preProcess.R index 299a05d4f..e7931922e 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) @@ -242,8 +243,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 @@ -294,8 +304,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)) @@ -330,6 +341,7 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac destinationPath = destinationPath, append = results$needChecksums >= 2 ) + needChecksums <- 0 } } @@ -458,8 +470,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 @@ -536,7 +550,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 @@ -567,7 +582,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) } @@ -592,7 +608,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 @@ -626,7 +642,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, @@ -665,12 +681,20 @@ 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 + ) + needChecksums <- 0 + } if (!is.null(reproducible.inputPaths) && needChecksums != 3) { checkSumFilePathInputPaths <- identifyCHECKSUMStxtFile(reproducible.inputPaths[[1]]) suppressMessages({ @@ -680,6 +704,7 @@ preProcess <- function(targetFile = NULL, url = NULL, archive = NULL, alsoExtrac destinationPath = destinationPath, append = needChecksums == 2 ) + needChecksums <- 0 }) } on.exit( @@ -793,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( @@ -886,7 +918,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))) { @@ -915,7 +948,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 @@ -924,7 +957,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, @@ -1539,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) { @@ -1611,28 +1656,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 (identical(dp, 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/R/prepInputs.R b/R/prepInputs.R index 7e913eac6..497c2df60 100644 --- a/R/prepInputs.R +++ b/R/prepInputs.R @@ -1021,18 +1021,14 @@ 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 " } 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)) { @@ -1047,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] diff --git a/R/robustDigest.R b/R/robustDigest.R index e91b4960d..502711440 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 } ) @@ -483,7 +485,12 @@ basenames3 <- function(object, nParentDirs) { } out <- if (cacheSpeed == 1) { - digest(x, algo = algo) + 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::digest(x, algo = algo) } else if (cacheSpeed == 2) { fastdigest::fastdigest(x) } else { 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 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)) { 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( diff --git a/man/CacheHelpers.Rd b/man/CacheHelpers.Rd index da5cf89b6..6041cca18 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, @@ -85,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 8dfb9b1cc..4c3fe594a 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") @@ -81,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 56fb4c4f2..e95a12090 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, @@ -76,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 0509008fa..bf153f535 100644 --- a/man/downloadRemote.Rd +++ b/man/downloadRemote.Rd @@ -16,6 +16,7 @@ downloadRemote( overwrite, needChecksums, .tempPath, + preDigest, verbose = getOption("reproducible.verbose", 1), ... ) @@ -72,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/man/reproducibleOptions.Rd b/man/reproducibleOptions.Rd index 34e76c5ee..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 @@ -75,9 +84,22 @@ 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}. 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. } +\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()}}. diff --git a/tests/testthat/test-cache.R b/tests/testthat/test-cache.R index 9d1856d88..5a1dcbbda 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() @@ -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, @@ -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,12 +612,14 @@ 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 + ) ) + 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,10 +663,10 @@ 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 = "|" + "There is no similar item in the cachePath", + sep = "|" ) expect_true(sum(grepl(msgGrep, out)) == 1) @@ -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)) @@ -705,10 +709,12 @@ 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) + expect_true(sum(grepl(messageNoCacheRepo, out)) == 1) + + # expect_true(sum(grepl(msgGrep, out)) == 1) outer <- function(n) { Cache(inner, 0.1, notOlderThan = Sys.time()) @@ -720,8 +726,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 +774,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 @@ -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))) @@ -1026,12 +957,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 +1014,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))) @@ -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({ @@ -1311,8 +1248,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 +1345,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 +1555,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 +1574,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 +1636,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 +1661,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 +1696,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") ) } @@ -1821,3 +1758,54 @@ 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))) + +}) + +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))) + +}) 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-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 diff --git a/tests/testthat/test-preProcessWorks.R b/tests/testthat/test-preProcessWorks.R index d35e5440c..af5719cd1 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") @@ -507,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) 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