From 66ceddb4c0385df8fac094e696e68372323651c9 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Tue, 3 Dec 2024 17:14:28 -0800 Subject: [PATCH 01/11] messageColoured use cli --- R/messages.R | 161 ++++++++++++++++++++++++++++++--------------------- 1 file changed, 94 insertions(+), 67 deletions(-) diff --git a/R/messages.R b/R/messages.R index 9d8495109..133210cc0 100644 --- a/R/messages.R +++ b/R/messages.R @@ -176,7 +176,7 @@ messageQuestion <- function(..., verboseLevel = 0, appendLF = TRUE) { #' @rdname messageColoured .messageFunctionFn <- function(..., appendLF = TRUE, verbose = getOption("reproducible.verbose"), - verboseLevel = 1) { + verboseLevel = 1) { fn <- getFromNamespace(getOption("reproducible.messageColourFunction"), asNamespace("crayon")) fn(...) } @@ -192,79 +192,106 @@ messageQuestion <- function(..., verboseLevel = 0, appendLF = TRUE) { messageColoured <- function(..., colour = NULL, indent = NULL, hangingIndent = TRUE, verbose = getOption("reproducible.verbose", 1), verboseLevel = 1, appendLF = TRUE) { + if (isTRUE(verboseLevel <= verbose)) { - needCrayon <- FALSE - if (!is.null(colour)) { - if (is.character(colour)) { - needCrayon <- TRUE + + if (TRUE) { + mess <- paste(..., collapse = " ") + if (!is.null(colour)) { + fn <- get(paste0("col_", colour), envir = asNamespace('cli')) + mess <- fn(mess) } - } - mess <- paste0(..., collapse = "") - if (!is.null(indent)) { - mess <- paste0(indent, mess) - } + indentNum <- indent + if (!is.null(indent)) + if (is.character(indent)) + indentNum <- ansi_nchar(indent) + if (is.null(indent)) indentNum <- 0 + + mess <- ansi_trimws(mess, which = c("both")) + mess <- cli::ansi_strwrap(x = mess, + indent = indentNum, + exdent = indentNum + hangingIndent * 2, + simplify = TRUE) + mess <- .addSlashNToAllButFinalElement(mess) - # do line wrap with hanging indent - maxLineLngth <- getOption("width") - 10 # 10 is a "buffer" for Rstudio miscalculations - chars <- nchar(mess) - if (chars > maxLineLngth) { - splitOnSlashN <- strsplit(mess, "\n") - newMess <- lapply(splitOnSlashN, function(m) { - anyOneLine <- any(nchar(m) > maxLineLngth) - if (anyOneLine) { - messSplit <- strsplit(mess, split = " ") - remainingChars <- chars - messBuild <- character() - while (remainingChars > maxLineLngth) { - whNewLine <- which(cumsum(nchar(messSplit[[1]]) + 1) >= maxLineLngth)[1] - 1 - # if (isTRUE(any(grepl("...because of", mess)))) browser() - if (anyNA(whNewLine)) browser() - - keepInd <- 1:whNewLine - newMess <- paste(messSplit[[1]][keepInd], collapse = " ") - messBuild <- c(messBuild, newMess) - if (is.null(indent)) { - # if it starts with a space -- that is the indent that is needed - if (startsWith(newMess, " ")) { - indent <<- sub("^( +).+", "\\1", newMess) - if (grepl("^ +\\.\\.\\.", newMess)) { - indent <<- paste0(indent, " ") - } - } else { - indent <<- "" - } - - } - messSplit[[1]] <- messSplit[[1]][-keepInd] - remainingChars <- remainingChars - nchar(newMess) - 1 - hangingIndent <<- TRUE - } - newMess <- paste(messSplit[[1]], collapse = " ") - m <- c(messBuild, newMess) - } - m - }) - mess <- unlist(newMess) - mess <- paste0(.addSlashNToAllButFinalElement(mess), collapse = "") - } - hi <- if (isTRUE(hangingIndent)) paste0(indent, .message$BecauseOfA) else indent - if (any(grepl("\n", mess))) { - mess <- gsub("\n *", paste0("\n", hi), mess) - } + message(mess) - if (needCrayon && requireNamespace("crayon", quietly = TRUE)) { - mess <- lapply(strsplit(mess, "\n"), function(m) paste0(getFromNamespace(colour, "crayon")(m)))[[1]] - mess <- .addSlashNToAllButFinalElement(mess) - message(mess, appendLF = appendLF) - # message(getFromNamespace(colour, "crayon")(mess), appendLF = appendLF) } else { - if (needCrayon && !isTRUE(.pkgEnv$.checkedCrayon) && !.requireNamespace("crayon")) { - message("To add colours to messages, install.packages('crayon')", appendLF = appendLF) - .pkgEnv$.checkedCrayon <- TRUE - } - message(mess, appendLF = appendLF) +# +# +# needCrayon <- FALSE +# if (!is.null(colour)) { +# if (is.character(colour)) { +# needCrayon <- TRUE +# } +# } +# mess <- paste0(..., collapse = "") +# if (!is.null(indent)) { +# mess <- paste0(indent, mess) +# } +# +# # do line wrap with hanging indent +# maxLineLngth <- getOption("width") - 10 # 10 is a "buffer" for Rstudio miscalculations +# chars <- nchar(mess) +# if (chars > maxLineLngth) { +# splitOnSlashN <- strsplit(mess, "\n") +# newMess <- lapply(splitOnSlashN, function(m) { +# anyOneLine <- any(nchar(m) > maxLineLngth) +# if (anyOneLine) { +# messSplit <- strsplit(mess, split = " ") +# remainingChars <- chars +# messBuild <- character() +# while (remainingChars > maxLineLngth) { +# whNewLine <- which(cumsum(nchar(messSplit[[1]]) + 1) >= maxLineLngth)[1] - 1 +# # if (isTRUE(any(grepl("...because of", mess)))) browser() +# if (anyNA(whNewLine)) browser() +# +# keepInd <- 1:whNewLine +# newMess <- paste(messSplit[[1]][keepInd], collapse = " ") +# messBuild <- c(messBuild, newMess) +# if (is.null(indent)) { +# # if it starts with a space -- that is the indent that is needed +# if (startsWith(newMess, " ")) { +# indent <<- sub("^( +).+", "\\1", newMess) +# if (grepl("^ +\\.\\.\\.", newMess)) { +# indent <<- paste0(indent, " ") +# } +# } else { +# indent <<- "" +# } +# +# } +# messSplit[[1]] <- messSplit[[1]][-keepInd] +# remainingChars <- remainingChars - nchar(newMess) - 1 +# hangingIndent <<- TRUE +# } +# newMess <- paste(messSplit[[1]], collapse = " ") +# m <- c(messBuild, newMess) +# } +# m +# }) +# mess <- unlist(newMess) +# mess <- paste0(.addSlashNToAllButFinalElement(mess), collapse = "") +# } +# hi <- if (isTRUE(hangingIndent)) paste0(indent, .message$BecauseOfA) else indent +# if (any(grepl("\n", mess))) { +# mess <- gsub("\n *", paste0("\n", hi), mess) +# } +# if (needCrayon && requireNamespace("crayon", quietly = TRUE)) { +# mess <- lapply(strsplit(mess, "\n"), function(m) paste0(getFromNamespace(colour, "crayon")(m)))[[1]] +# mess <- .addSlashNToAllButFinalElement(mess) +# message(mess, appendLF = appendLF) +# # message(getFromNamespace(colour, "crayon")(mess), appendLF = appendLF) +# } else { +# if (needCrayon && !isTRUE(.pkgEnv$.checkedCrayon) && !.requireNamespace("crayon")) { +# message("To add colours to messages, install.packages('crayon')", appendLF = appendLF) +# .pkgEnv$.checkedCrayon <- TRUE +# } +# message(mess, appendLF = appendLF) +# } } } + } #' @keywords internal From 507acd311b37b899a08eaa68c925800ca683dec6 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Tue, 3 Dec 2024 22:10:07 -0800 Subject: [PATCH 02/11] add cli and use --- DESCRIPTION | 1 + R/messages.R | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index ee9f7299d..da181c6c9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -52,6 +52,7 @@ Authors@R: Depends: R (>= 4.1) Imports: + cli, data.table (>= 1.10.4), digest, filelock, diff --git a/R/messages.R b/R/messages.R index 133210cc0..45384d6d5 100644 --- a/R/messages.R +++ b/R/messages.R @@ -204,7 +204,7 @@ messageColoured <- function(..., colour = NULL, indent = NULL, hangingIndent = T indentNum <- indent if (!is.null(indent)) if (is.character(indent)) - indentNum <- ansi_nchar(indent) + indentNum <- cli::ansi_nchar(indent) if (is.null(indent)) indentNum <- 0 mess <- ansi_trimws(mess, which = c("both")) From 617ae7164d7775682fa62b17a70d71d21e17b382 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 4 Dec 2024 13:38:07 -0800 Subject: [PATCH 03/11] cli fix --- R/download.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/download.R b/R/download.R index 2940f3525..8b54763c0 100755 --- a/R/download.R +++ b/R/download.R @@ -871,7 +871,7 @@ dlErrorHandling <- function(failed, downloadResults, warns, messOrig, numTries, messHere <- cli::ansi_strwrap(simplify = TRUE, paste0("Temporarily setting Sys.setenv(R_LIBCURL_SSL_REVOKE_BEST_EFFORT = TRUE) because ", "it looks like there may be an SSL certificate problem")) - message(paste0(messHere, "\n")) + message(gsub("\n$", "", paste(paste0(messHere, "\n"), collapse = " "))) # https://stackoverflow.com/a/76684292/3890027 prevCurlVal <- Sys.getenv("R_LIBCURL_SSL_REVOKE_BEST_EFFORT") From 84dd85332e239669ea46ad3e7f837e9b91c4013f Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 4 Dec 2024 17:35:28 -0800 Subject: [PATCH 04/11] protect httr2::req_progress that doesn't exist in R 4.1.3 binary httr2 --- R/download.R | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/R/download.R b/R/download.R index c35d53094..73448b6aa 100755 --- a/R/download.R +++ b/R/download.R @@ -575,15 +575,16 @@ dlGeneric <- function(url, destinationPath, verbose = getOption("reproducible.ve httr::stop_for_status(request) needDwnFl <- FALSE } else { - - if (.requireNamespace("httr2") && .requireNamespace("curl") && getRversion() >= "4.2") { for (i in 1:2) { req <- httr2::request(url) - if (i == 1) + if (i == 1) # only try on first run through, in case this is the cause of failure; which it is on some sites req <- req |> httr2::req_user_agent(getOption("reproducible.useragent")) - if (verbose > 0) - req <- req |> httr2::req_progress() + if (verbose > 0) { + # req_progress is not in the binary httr2 available for R version 4.1.3; fails on CRAN checks + reqProgress <- get("req_progress", envir = asNamespace("httr2")) + req <- req |> reqProgress + } resp <- req |> httr2::req_url_query() |> httr2::req_perform(path = destFile) From da59ff8e7a4ea21ad7b1bcd9d2de59f1183a6259 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 5 Dec 2024 10:02:39 -0800 Subject: [PATCH 05/11] keep httr version for old R alive --- R/download.R | 29 ++++++++++++++++++++--------- 1 file changed, 20 insertions(+), 9 deletions(-) diff --git a/R/download.R b/R/download.R index 7066230f1..ec8f075dc 100755 --- a/R/download.R +++ b/R/download.R @@ -565,15 +565,26 @@ dlGeneric <- function(url, destinationPath, verbose = getOption("reproducible.ve if (.requireNamespace("httr") && .requireNamespace("curl") && getRversion() < "4.2") { ua <- httr::user_agent(getOption("reproducible.useragent")) - request <- suppressWarnings( - ## TODO: GET is throwing warnings - httr::GET( - url, ua, httr::progress(), - httr::write_disk(destFile, overwrite = TRUE) - ) ## TODO: overwrite? - ) - httr::stop_for_status(request) - needDwnFl <- FALSE + filesize <- as.numeric(httr::HEAD(url)$headers$`content-length`) + for (i in 1:2) { + request <- suppressWarnings( + ## TODO: GET is throwing warnings + httr::GET( + url, ua, httr::progress(), + httr::write_disk(destFile, overwrite = TRUE) + ) ## TODO: overwrite? + ) + filesizeDownloaded <- file.size(destFile) + if ( (abs(filesize - filesizeDownloaded))/filesize > 0.2) { # if it is 20% the size; consider it a fail + # There is only one example where this fails -- the presence of user_agent is the cause + # prepInputs(url = "http://sis.agr.gc.ca/cansis/nsdb/ecostrat/zone/ecozone_shp.zip") + ua <- NULL + } else { + httr::stop_for_status(request) + needDwnFl <- FALSE + break + } + } } else { if (.requireNamespace("httr2") && .requireNamespace("curl") && getRversion() >= "4.2") { for (i in 1:2) { From 53692efeb2189a4940d33455cdb9750a75cb0529 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 5 Dec 2024 10:04:47 -0800 Subject: [PATCH 06/11] minor merge --- R/download.R | 2 +- R/messages.R | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/download.R b/R/download.R index e1ea9ebbd..951c21c75 100755 --- a/R/download.R +++ b/R/download.R @@ -575,7 +575,7 @@ dlGeneric <- function(url, destinationPath, verbose = getOption("reproducible.ve ) ## TODO: overwrite? ) filesizeDownloaded <- file.size(destFile) - if ( (abs(filesize - filesizeDownloaded))/filesize > 0.2) { # if it is 20% the size; consider it a fail + if ( (abs(filesize - filesizeDownloaded))/filesize > 0.2) { # if it is <20% the size; consider it a fail # There is only one example where this fails -- the presence of user_agent is the cause # prepInputs(url = "http://sis.agr.gc.ca/cansis/nsdb/ecostrat/zone/ecozone_shp.zip") ua <- NULL diff --git a/R/messages.R b/R/messages.R index 9100b7254..033eeda33 100644 --- a/R/messages.R +++ b/R/messages.R @@ -207,7 +207,7 @@ messageColoured <- function(..., colour = NULL, indent = NULL, hangingIndent = T indentNum <- cli::ansi_nchar(indent) if (is.null(indent)) indentNum <- 0 - mess <- ansi_trimws(mess, which = c("both")) + mess <- cli::ansi_trimws(mess, which = c("both")) mess <- cli::ansi_strwrap(x = mess, indent = indentNum, exdent = indentNum + hangingIndent * 2, From b623fc682cf132811445a598baf80d3bb6a1d4a0 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 5 Dec 2024 10:38:32 -0800 Subject: [PATCH 07/11] reproducible.useCli --- R/messages.R | 159 +++++++++++++++++++----------------- tests/testthat/test-cache.R | 1 + 2 files changed, 83 insertions(+), 77 deletions(-) diff --git a/R/messages.R b/R/messages.R index 033eeda33..c3e091225 100644 --- a/R/messages.R +++ b/R/messages.R @@ -195,7 +195,7 @@ messageColoured <- function(..., colour = NULL, indent = NULL, hangingIndent = T if (isTRUE(verboseLevel <= verbose)) { - if (TRUE) { + if (getOption("reproducible.useCli", FALSE)) { mess <- paste(..., collapse = " ") if (!is.null(colour)) { fn <- get(paste0("col_", colour), envir = asNamespace('cli')) @@ -208,87 +208,92 @@ messageColoured <- function(..., colour = NULL, indent = NULL, hangingIndent = T if (is.null(indent)) indentNum <- 0 mess <- cli::ansi_trimws(mess, which = c("both")) - mess <- cli::ansi_strwrap(x = mess, - indent = indentNum, - exdent = indentNum + hangingIndent * 2, - simplify = TRUE) + hasSlashN <- any(grepl("\n", mess)) + if (!hasSlashN && cli::ansi_nchar(mess) > cli::console_width()) + mess <- cli::ansi_strwrap(x = mess, + indent = indentNum, + exdent = indentNum + hangingIndent * 2, + simplify = TRUE) mess <- .addSlashNToAllButFinalElement(mess) + if (any(grepl(.spaceTmpChar, mess))) + mess <- gsub(.spaceTmpChar, " ", mess) message(mess) } else { -# -# -# needCrayon <- FALSE -# if (!is.null(colour)) { -# if (is.character(colour)) { -# needCrayon <- TRUE -# } -# } -# mess <- paste0(..., collapse = "") -# if (!is.null(indent)) { -# mess <- paste0(indent, mess) -# } -# -# # do line wrap with hanging indent -# maxLineLngth <- getOption("width") - 10 # 10 is a "buffer" for Rstudio miscalculations -# chars <- nchar(mess) -# if (chars > maxLineLngth) { -# splitOnSlashN <- strsplit(mess, "\n") -# newMess <- lapply(splitOnSlashN, function(m) { -# anyOneLine <- any(nchar(m) > maxLineLngth) -# if (anyOneLine) { -# messSplit <- strsplit(mess, split = " ") -# remainingChars <- chars -# messBuild <- character() -# while (remainingChars > maxLineLngth) { -# whNewLine <- which(cumsum(nchar(messSplit[[1]]) + 1) >= maxLineLngth)[1] - 1 -# # if (isTRUE(any(grepl("...because of", mess)))) browser() -# if (anyNA(whNewLine)) browser() -# -# keepInd <- 1:whNewLine -# newMess <- paste(messSplit[[1]][keepInd], collapse = " ") -# messBuild <- c(messBuild, newMess) -# if (is.null(indent)) { -# # if it starts with a space -- that is the indent that is needed -# if (startsWith(newMess, " ")) { -# indent <<- sub("^( +).+", "\\1", newMess) -# if (grepl("^ +\\.\\.\\.", newMess)) { -# indent <<- paste0(indent, " ") -# } -# } else { -# indent <<- "" -# } -# -# } -# messSplit[[1]] <- messSplit[[1]][-keepInd] -# remainingChars <- remainingChars - nchar(newMess) - 1 -# hangingIndent <<- TRUE -# } -# newMess <- paste(messSplit[[1]], collapse = " ") -# m <- c(messBuild, newMess) -# } -# m -# }) -# mess <- unlist(newMess) -# mess <- paste0(.addSlashNToAllButFinalElement(mess), collapse = "") -# } -# hi <- if (isTRUE(hangingIndent)) paste0(indent, .message$BecauseOfA) else indent -# if (any(grepl("\n", mess))) { -# mess <- gsub("\n *", paste0("\n", hi), mess) -# } -# if (needCrayon && requireNamespace("crayon", quietly = TRUE)) { -# mess <- lapply(strsplit(mess, "\n"), function(m) paste0(getFromNamespace(colour, "crayon")(m)))[[1]] -# mess <- .addSlashNToAllButFinalElement(mess) -# message(mess, appendLF = appendLF) -# # message(getFromNamespace(colour, "crayon")(mess), appendLF = appendLF) -# } else { -# if (needCrayon && !isTRUE(.pkgEnv$.checkedCrayon) && !.requireNamespace("crayon")) { -# message("To add colours to messages, install.packages('crayon')", appendLF = appendLF) -# .pkgEnv$.checkedCrayon <- TRUE -# } -# message(mess, appendLF = appendLF) -# } + + needCrayon <- FALSE + if (!is.null(colour)) { + if (is.character(colour)) { + needCrayon <- TRUE + } + } + mess <- paste0(..., collapse = "") + if (!is.null(indent)) { + mess <- paste0(indent, mess) + } + + # do line wrap with hanging indent + maxLineLngth <- getOption("width") - 10 # 10 is a "buffer" for Rstudio miscalculations + chars <- nchar(mess) + if (chars > maxLineLngth) { + splitOnSlashN <- strsplit(mess, "\n") + newMess <- lapply(splitOnSlashN, function(m) { + anyOneLine <- any(nchar(m) > maxLineLngth) + if (anyOneLine) { + messSplit <- strsplit(mess, split = " ") + remainingChars <- chars + messBuild <- character() + while (remainingChars > maxLineLngth) { + whNewLine <- which(cumsum(nchar(messSplit[[1]]) + 1) >= maxLineLngth)[1] - 1 + # if (isTRUE(any(grepl("...because of", mess)))) browser() + if (anyNA(whNewLine)) browser() + + keepInd <- 1:whNewLine + newMess <- paste(messSplit[[1]][keepInd], collapse = " ") + messBuild <- c(messBuild, newMess) + if (is.null(indent)) { + # if it starts with a space -- that is the indent that is needed + if (startsWith(newMess, " ")) { + indent <<- sub("^( +).+", "\\1", newMess) + if (grepl("^ +\\.\\.\\.", newMess)) { + indent <<- paste0(indent, " ") + } + } else { + indent <<- "" + } + + } + messSplit[[1]] <- messSplit[[1]][-keepInd] + remainingChars <- remainingChars - nchar(newMess) - 1 + hangingIndent <<- TRUE + } + newMess <- paste(messSplit[[1]], collapse = " ") + m <- c(messBuild, newMess) + } + m + }) + mess <- unlist(newMess) + mess <- paste0(.addSlashNToAllButFinalElement(mess), collapse = "") + } + hi <- if (isTRUE(hangingIndent)) paste0(indent, .message$BecauseOfA) else indent + if (any(grepl("\n", mess))) { + mess <- gsub("\n *", paste0("\n", hi), mess) + } + if (any(grepl(.spaceTmpChar, mess))) + mess <- gsub(.spaceTmpChar, " ", mess) + if (needCrayon && requireNamespace("crayon", quietly = TRUE)) { + mess <- lapply(strsplit(mess, "\n"), function(m) paste0(getFromNamespace(colour, "crayon")(m)))[[1]] + mess <- .addSlashNToAllButFinalElement(mess) + message(mess, appendLF = appendLF) + # message(getFromNamespace(colour, "crayon")(mess), appendLF = appendLF) + } else { + if (needCrayon && !isTRUE(.pkgEnv$.checkedCrayon) && !.requireNamespace("crayon")) { + message("To add colours to messages, install.packages('crayon')", appendLF = appendLF) + .pkgEnv$.checkedCrayon <- TRUE + } + message(mess, appendLF = appendLF) + } } } diff --git a/tests/testthat/test-cache.R b/tests/testthat/test-cache.R index 88aa7705a..f9c9b154d 100644 --- a/tests/testthat/test-cache.R +++ b/tests/testthat/test-cache.R @@ -1361,6 +1361,7 @@ test_that("change to new capturing of FUN & base pipe", { # (function(xx) rnorm(1, 2, sd = xx))() |> Cache(cachePath = tmpCache) ") + browser() mess3 <- capture_messages( eval(parse(text = f2)) ) From fea036dc1756b3ae39882f924ded36757f5ee092 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 5 Dec 2024 10:39:36 -0800 Subject: [PATCH 08/11] useCli = TRUE --- R/exportedMethods.R | 2 +- R/messages.R | 33 +++++++++++++++++++++------------ 2 files changed, 22 insertions(+), 13 deletions(-) diff --git a/R/exportedMethods.R b/R/exportedMethods.R index 5342ab170..47af87a19 100644 --- a/R/exportedMethods.R +++ b/R/exportedMethods.R @@ -391,7 +391,7 @@ setMethod( } else if (fromMemoise %in% FALSE) { postMess <- paste0(" ", .message$AddingToMemoised) } - baseMess <- .message$LoadedCache(whMessage, functionName) + baseMess <- .message$LoadedCache(whMessage, .messageFunctionFn(functionName)) # ELIOT HERE if (!is.null(postMess)) baseMess <- paste0(baseMess, postMess) messageCache(baseMess, verbose = verbose) diff --git a/R/messages.R b/R/messages.R index c3e091225..4a3d713e3 100644 --- a/R/messages.R +++ b/R/messages.R @@ -71,8 +71,8 @@ #' #' @param df A data.frame, data.table, matrix #' @param round An optional numeric to pass to `round` -#' @param colour Passed to `getFromNamespace(colour, ns = "crayon")`, -#' so any colour that `crayon` can use +#' @param colour Passed to `getFromNamespace(colour, ns = "cli")`, +#' so any colour that `cli` can use #' @param colnames Logical or `NULL`. If `TRUE`, then it will print #' column names even if there aren't any in the `df` (i.e., they will) #' be `V1` etc., `NULL` will print them if they exist, and `FALSE` @@ -177,11 +177,11 @@ messageQuestion <- function(..., verboseLevel = 0, appendLF = TRUE) { #' @rdname messageColoured .messageFunctionFn <- function(..., appendLF = TRUE, verbose = getOption("reproducible.verbose"), verboseLevel = 1) { - fn <- getFromNamespace(getOption("reproducible.messageColourFunction"), asNamespace("crayon")) + fn <- cliCol(getOption("reproducible.messageColourFunction")) fn(...) } -#' @param colour Any colour that can be understood by `crayon` +#' @param colour Any colour that can be understood by `cli` #' @param hangingIndent Logical. If there are `\n`, should there be a handing indent of 2 spaces. #' Default is `TRUE` #' @param ... Any character vector, passed to `paste0(...)` @@ -195,10 +195,11 @@ messageColoured <- function(..., colour = NULL, indent = NULL, hangingIndent = T if (isTRUE(verboseLevel <= verbose)) { - if (getOption("reproducible.useCli", FALSE)) { - mess <- paste(..., collapse = " ") + if (getOption("reproducible.useCli", TRUE)) { + mess <- paste0(..., collapse = " ") if (!is.null(colour)) { - fn <- get(paste0("col_", colour), envir = asNamespace('cli')) + fn <- cliCol(colour) + # fn <- get(paste0("col_", colour), envir = asNamespace('cli')) mess <- fn(mess) } indentNum <- indent @@ -282,14 +283,14 @@ messageColoured <- function(..., colour = NULL, indent = NULL, hangingIndent = T } if (any(grepl(.spaceTmpChar, mess))) mess <- gsub(.spaceTmpChar, " ", mess) - if (needCrayon && requireNamespace("crayon", quietly = TRUE)) { - mess <- lapply(strsplit(mess, "\n"), function(m) paste0(getFromNamespace(colour, "crayon")(m)))[[1]] + if (needCrayon && requireNamespace("cli", quietly = TRUE)) { + mess <- lapply(strsplit(mess, "\n"), function(m) + paste0(cliCol(colour)(m)))[[1]] mess <- .addSlashNToAllButFinalElement(mess) message(mess, appendLF = appendLF) - # message(getFromNamespace(colour, "crayon")(mess), appendLF = appendLF) } else { - if (needCrayon && !isTRUE(.pkgEnv$.checkedCrayon) && !.requireNamespace("crayon")) { - message("To add colours to messages, install.packages('crayon')", appendLF = appendLF) + if (needCrayon && !isTRUE(.pkgEnv$.checkedCrayon) && !.requireNamespace("cli")) { + message("To add colours to messages, install.packages('cli')", appendLF = appendLF) .pkgEnv$.checkedCrayon <- TRUE } message(mess, appendLF = appendLF) @@ -365,4 +366,12 @@ messageColoured <- function(..., colour = NULL, indent = NULL, hangingIndent = T withr::deferred_clear(envir = envir) } +.spaceTmpChar <- "spAcE" + .txtUnableToAccessIndex <- "unable to access index" + +cliCol <- function(col) { + if (!startsWith(col, "col_")) + col <- paste0("col_", col) + getFromNamespace(col, asNamespace("cli")) +} From 5c5aaee2d8ab4778d0b197ec61ecad390f5fba8e Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 5 Dec 2024 12:10:08 -0800 Subject: [PATCH 09/11] rm crayon; update tests for cli --- DESCRIPTION | 1 - R/messages.R | 10 +++++----- tests/testthat/test-cache.R | 15 +++++++-------- 3 files changed, 12 insertions(+), 14 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 82c3d5694..fc43a73b5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -65,7 +65,6 @@ Imports: Suggests: archive, covr, - crayon, DBI, future, geodata, diff --git a/R/messages.R b/R/messages.R index 4a3d713e3..bb503c650 100644 --- a/R/messages.R +++ b/R/messages.R @@ -223,10 +223,10 @@ messageColoured <- function(..., colour = NULL, indent = NULL, hangingIndent = T } else { - needCrayon <- FALSE + needCli <- FALSE if (!is.null(colour)) { if (is.character(colour)) { - needCrayon <- TRUE + needCli <- TRUE } } mess <- paste0(..., collapse = "") @@ -283,15 +283,15 @@ messageColoured <- function(..., colour = NULL, indent = NULL, hangingIndent = T } if (any(grepl(.spaceTmpChar, mess))) mess <- gsub(.spaceTmpChar, " ", mess) - if (needCrayon && requireNamespace("cli", quietly = TRUE)) { + if (needCli && requireNamespace("cli", quietly = TRUE)) { mess <- lapply(strsplit(mess, "\n"), function(m) paste0(cliCol(colour)(m)))[[1]] mess <- .addSlashNToAllButFinalElement(mess) message(mess, appendLF = appendLF) } else { - if (needCrayon && !isTRUE(.pkgEnv$.checkedCrayon) && !.requireNamespace("cli")) { + if (needCli && !isTRUE(.pkgEnv$.checkedCli) && !.requireNamespace("cli")) { message("To add colours to messages, install.packages('cli')", appendLF = appendLF) - .pkgEnv$.checkedCrayon <- TRUE + .pkgEnv$.checkedCli <- TRUE } message(mess, appendLF = appendLF) } diff --git a/tests/testthat/test-cache.R b/tests/testthat/test-cache.R index f9c9b154d..259e2011a 100644 --- a/tests/testthat/test-cache.R +++ b/tests/testthat/test-cache.R @@ -564,7 +564,7 @@ test_that("test asPath", { .message$LoadedCacheResult("Memoised"), "|", .message$LoadedCacheResult() ), a2)) == 1) - expect_true(sum(grepl(paste(.message$LoadedCacheResult("Memoised"), "saveRDS call"), a3)) == 1) + expect_true(sum(grepl(paste(.message$LoadedCacheResult("Memoised"), ".*saveRDS.*call"), a3)) == 1) unlink("filename.RData") try(clearCache(tmpdir, ask = FALSE), silent = TRUE) @@ -585,7 +585,7 @@ test_that("test asPath", { .message$LoadedCacheResult("Memoised"), "|", .message$LoadedCacheResult() ), a2)) == 1) - expect_true(sum(grepl(paste(.message$LoadedCacheResult("Memoised"), "saveRDS call"), a3)) == 1) + expect_true(sum(cli::ansi_grepl(paste(.message$LoadedCacheResult("Memoised"), "saveRDS call"), a3)) == 1) }) test_that("test wrong ways of calling Cache", { @@ -654,7 +654,7 @@ test_that("test Cache argument inheritance to inner functions", { # does cachePath propagate to outer ones -- no message about cachePath being tempdir() out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir)) expect_true(length(out) == 2) - expect_true(sum(grepl(paste(.message$LoadedCacheResult(), "outer call"), out)) == 1) + expect_true(sum(cli::ansi_grepl(paste(.message$LoadedCacheResult(), "outer call"), out)) == 1) # check that the rnorm inside "outer" returns cached value even if outer "outer" function is changed outer <- function(n) { @@ -667,7 +667,7 @@ test_that("test Cache argument inheritance to inner functions", { "There is no similar item in the cachePath", sep = "|" ) - expect_true(sum(grepl(msgGrep, out)) == 1) + expect_true(sum(cli::ansi_grepl(msgGrep, out)) == 1) # Override with explicit argument outer <- function(n) { @@ -690,7 +690,7 @@ test_that("test Cache argument inheritance to inner functions", { # Second time will get a cache on outer out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir)) expect_true(length(out) == 2) - expect_true(sum(grepl(paste(.message$LoadedCacheResult(), "outer call"), out)) == 1) + expect_true(sum(cli::ansi_grepl(paste(.message$LoadedCacheResult(), "outer call"), out)) == 1) # doubly nested inner <- function(mean, useCache = TRUE) { @@ -728,7 +728,7 @@ test_that("test Cache argument inheritance to inner functions", { "There is no similar item in the cachePath", sep = "|" ) - expect_true(sum(grepl(msgGrep, out)) == 1) + expect_true(sum(cli::ansi_grepl(msgGrep, out)) == 1) # Check userTags -- all items have it clearCache(tmpdir, ask = FALSE) @@ -801,7 +801,7 @@ test_that("test future", { (dd <- system.time({ for (i in 1:3) d[[i]] <- Cache(cachePath = tmpCache, rnorm(1e6 + i)) })) - expect_true((dd[[3]] * 3) < aa[[3]]) + expect_true((dd[[3]] * 2) < aa[[3]]) for (i in 1:3) { expect_true(identical(attr(d[[i]], ".Cache")$newCache, FALSE)) } @@ -1361,7 +1361,6 @@ test_that("change to new capturing of FUN & base pipe", { # (function(xx) rnorm(1, 2, sd = xx))() |> Cache(cachePath = tmpCache) ") - browser() mess3 <- capture_messages( eval(parse(text = f2)) ) From d313e51ea481d1f5509bab8dbd680d906595c0e8 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 5 Dec 2024 12:16:41 -0800 Subject: [PATCH 10/11] grepl --> cli::ansi_grepl in test-cache.R --- tests/testthat/test-cache.R | 68 ++++++++++++++++++------------------- 1 file changed, 34 insertions(+), 34 deletions(-) diff --git a/tests/testthat/test-cache.R b/tests/testthat/test-cache.R index 259e2011a..7b61ea91f 100644 --- a/tests/testthat/test-cache.R +++ b/tests/testthat/test-cache.R @@ -60,7 +60,7 @@ test_that("test file-backed raster caching", { basename(tmpfile[1]) ), split = "[\\/]") )) - expect_true(any(grepl( + expect_true(any(cli::ansi_grepl( pattern = basename(tmpfile[1]), dir(file.path(tmpCache, "rasters")) ))) @@ -91,7 +91,7 @@ test_that("test file-backed raster caching", { # ._prepareOutputs_1 <<- ._prepareOutputs_2 <<- ._getFromRepo <<- 1 # Will silently update the filename of the RasterLayer, and recover it type <- gsub("Connection", "", class(getOption("reproducible.conn"))) - isSQLite <- grepl(type, "NULL") + isSQLite <- cli::ansi_grepl(type, "NULL") if (!isSQLite) { warn1 <- capture_warnings(movedCache(tmpdir, old = tmpCache)) } @@ -349,7 +349,7 @@ test_that("test 'quick' argument", { out1c <- Cache(quickFun, thePath, cachePath = tmpdir, quick = TRUE) }) - expect_true(sum(grepl( + expect_true(sum(cli::ansi_grepl( paste0( paste(.message$LoadedCache(.message$LoadedCacheResult(), "quickFun"), .message$AddingToMemoised), "|", .message$LoadedCache(.message$LoadedCacheResult("Memoised"), "quickFun") @@ -375,7 +375,7 @@ test_that("test 'quick' argument", { mess1 <- capture_messages({ out1c <- Cache(quickFun, r1, cachePath = tmpdir, quick = TRUE) }) - expect_true(sum(grepl( + expect_true(sum(cli::ansi_grepl( paste0( paste(.message$LoadedCache(.message$LoadedCacheResult(), "quickFun"), .message$AddingToMemoised), "|", paste(.message$LoadedCacheResult("Memoised"), "quickFun call") @@ -540,7 +540,7 @@ test_that("test asPath", { expect_equal(length(a1), 1) expect_equal(length(a2), 1) - expect_true(sum(grepl(paste( + expect_true(sum(cli::ansi_grepl(paste( .message$LoadedCacheResult("Memoised"), "|", .message$LoadedCacheResult() ), a3)) == 1) @@ -560,11 +560,11 @@ test_that("test asPath", { quick = TRUE, cachePath = tmpdir )) expect_equal(length(a1), 1) - expect_true(sum(grepl(paste( + expect_true(sum(cli::ansi_grepl(paste( .message$LoadedCacheResult("Memoised"), "|", .message$LoadedCacheResult() ), a2)) == 1) - expect_true(sum(grepl(paste(.message$LoadedCacheResult("Memoised"), ".*saveRDS.*call"), a3)) == 1) + expect_true(sum(cli::ansi_grepl(paste(.message$LoadedCacheResult("Memoised"), "saveRDS call"), a3)) == 1) unlink("filename.RData") try(clearCache(tmpdir, ask = FALSE), silent = TRUE) @@ -581,7 +581,7 @@ test_that("test asPath", { quick = TRUE, cachePath = tmpdir )) expect_equal(length(a1), 1) - expect_true(sum(grepl(paste( + expect_true(sum(cli::ansi_grepl(paste( .message$LoadedCacheResult("Memoised"), "|", .message$LoadedCacheResult() ), a2)) == 1) @@ -633,23 +633,23 @@ test_that("test Cache argument inheritance to inner functions", { } mess <- capture_messages(Cache(outer, n = 2)) - expect_equal(sum(grepl(.message$NoCacheRepoSuppliedGrep, mess)), 2) + expect_equal(sum(cli::ansi_grepl(.message$NoCacheRepoSuppliedGrep, mess)), 2) clearCache(ask = FALSE, x = tmpdir) # options(reproducible.cachePath = tmpCache) out <- capture_messages(Cache(outer, n = 2)) expect_true(all(unlist(lapply( c(.message$NoCacheRepoSuppliedGrep, .message$NoCacheRepoSuppliedGrep), - function(mess) any(grepl(mess, out)) + function(mess) any(cli::ansi_grepl(mess, out)) )))) # does Sys.time() propagate to outer ones out <- capture_messages(Cache(outer(n = 2, not = Sys.time() + 1), notOlderThan = Sys.time() + 1)) - expect_equal(sum(grepl(.message$NoCacheRepoSuppliedGrep, out)), 2) + expect_equal(sum(cli::ansi_grepl(.message$NoCacheRepoSuppliedGrep, out)), 2) # does Sys.time() propagate to outer ones -- no message about cachePath being tempdir() mess <- capture_messages(Cache(outer(n = 2, not = Sys.time()), notOlderThan = Sys.time(), cachePath = tmpdir)) - expect_equal(sum(grepl(.message$NoCacheRepoSuppliedGrep, mess)), 1) + expect_equal(sum(cli::ansi_grepl(.message$NoCacheRepoSuppliedGrep, mess)), 1) # does cachePath propagate to outer ones -- no message about cachePath being tempdir() out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir)) @@ -675,7 +675,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_equal(sum(grepl(.message$NoCacheRepoSuppliedGrep, out)), 1) + expect_equal(sum(cli::ansi_grepl(.message$NoCacheRepoSuppliedGrep, out)), 1) # change the outer function, so no cache on that, & have notOlderThan on rnorm, # so no Cache on that @@ -684,9 +684,9 @@ 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_equal(sum(grepl(.message$NoCacheRepoSuppliedGrep, out)), 1) + expect_equal(sum(cli::ansi_grepl(.message$NoCacheRepoSuppliedGrep, out)), 1) - # expect_true(all(grepl("There is no similar item in the cachePath", out))) + # expect_true(all(cli::ansi_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)) expect_true(length(out) == 2) @@ -711,9 +711,9 @@ test_that("test Cache argument inheritance to inner functions", { "There is no similar item in the cachePath", sep = "|" ) - expect_true(sum(grepl(.message$NoCacheRepoSuppliedGrep, out)) == 1) + expect_true(sum(cli::ansi_grepl(.message$NoCacheRepoSuppliedGrep, out)) == 1) - # expect_true(sum(grepl(msgGrep, out)) == 1) + # expect_true(sum(cli::ansi_grepl(msgGrep, out)) == 1) outer <- function(n) { Cache(inner, 0.1, notOlderThan = Sys.time()) @@ -843,7 +843,7 @@ test_that("test mergeCache", { mess <- capture_messages({ d1 <- mergeCache(tmpCache, tmpdir) }) - expect_true(any(grepl("Skipping", mess))) + expect_true(any(cli::ansi_grepl("Skipping", mess))) expect_true(identical(showCache(d), showCache(d1))) }) @@ -907,7 +907,7 @@ test_that("test cache-helpers", { bnfn3 <- basename(fn3[actualFiles]) bnfn2 <- unique(filePathSansExt(bnfn2)) bnfn3 <- unique(filePathSansExt(bnfn3)) - sameFileBase <- grepl(pattern = bnfn2, x = bnfn3) + sameFileBase <- cli::ansi_grepl(pattern = bnfn2, x = bnfn3) expect_true(sameFileBase) unlink(Filenames(s2)) @@ -927,7 +927,7 @@ test_that("test useCache = 'overwrite'", { b <- Cache(rnorm, 1, useCache = "overwrite", cachePath = tmpCache) }) expect_true(!identical(a, b)) - expect_true(any(grepl(pattern = "Overwriting", mess))) + expect_true(any(cli::ansi_grepl(pattern = "Overwriting", mess))) clearCache(x = tmpCache, ask = FALSE) @@ -942,14 +942,14 @@ test_that("test useCache = 'overwrite'", { b <- Cache(rnorm, 1, cachePath = tmpCache) }) expect_true(!identical(a, b)) - expect_true(any(grepl(pattern = "Overwriting", mess))) + expect_true(any(cli::ansi_grepl(pattern = "Overwriting", mess))) }) test_that("test rm large non-file-backed rasters", { ## This is a large object test! skip_on_cran() if (!is.null(getOption("reproducible.conn", NULL))) { - if (!grepl("SQLite", class(getOption("reproducible.conn", NULL)))) { + if (!cli::ansi_grepl("SQLite", class(getOption("reproducible.conn", NULL)))) { skip("This is not for non-SQLite") } } @@ -996,7 +996,7 @@ test_that("test cc", { expect_true(length(unique(b1[[.cacheTableHashColName()]])) == 0) mess <- capture_messages(cc(ask = FALSE, x = tmpCache)) # Cache is already empty - expect_true(any(grepl("Cache already empty", mess))) + expect_true(any(cli::ansi_grepl("Cache already empty", mess))) }) test_that("test pre-creating conn", { @@ -1016,8 +1016,8 @@ test_that("test pre-creating conn", { ) expect_true(file.exists(Filenames(r1))) expect_true(file.exists(Filenames(r2))) - expect_false(grepl(basename(dirname(Filenames(r1))), "rasters")) # changed behaviour as of reproducible 1.2.0.9020 - expect_false(grepl(basename(dirname(Filenames(r2))), "rasters")) # changed behaviour as of reproducible 1.2.0.9020 + expect_false(cli::ansi_grepl(basename(dirname(Filenames(r1))), "rasters")) # changed behaviour as of reproducible 1.2.0.9020 + expect_false(cli::ansi_grepl(basename(dirname(Filenames(r2))), "rasters")) # changed behaviour as of reproducible 1.2.0.9020 }) test_that("test .defaultUserTags", { @@ -1049,9 +1049,9 @@ test_that("test failed Cache recovery -- message to delete cacheId", { }) }) }) - expect_true(sum(grepl(paste0("(trying to recover).*(", ci, ")"), mess)) == 1) - expect_true(sum(grepl(paste0("(trying to recover).*(", ci, ")"), err)) == 0) - expect_true(any(grepl(paste0("[cannot|failed to] open"), paste(warn, err, mess)))) + expect_true(sum(cli::ansi_grepl(paste0("(trying to recover).*(", ci, ")"), mess)) == 1) + expect_true(sum(cli::ansi_grepl(paste0("(trying to recover).*(", ci, ")"), err)) == 0) + expect_true(any(cli::ansi_grepl(paste0("[cannot|failed to] open"), paste(warn, err, mess)))) expect_true(is.numeric(d)) }) @@ -1072,14 +1072,14 @@ test_that("test changing reproducible.cacheSaveFormat midstream", { b <- Cache(rnorm, 1, cachePath = tmpdir) }) expect_false(attr(b, ".Cache")$newCache) - expect_true(sum(grepl("Changing format of Cache entry from rds to qs", mess)) == 1) + expect_true(sum(cli::ansi_grepl("Changing format of Cache entry from rds to qs", mess)) == 1) opts <- options(reproducible.cacheSaveFormat = "rds") mess <- capture_messages({ b <- Cache(rnorm, 1, cachePath = tmpdir) }) expect_false(attr(b, ".Cache")$newCache) - expect_true(sum(grepl("Changing format of Cache entry from qs to rds", mess)) == 1) + expect_true(sum(cli::ansi_grepl("Changing format of Cache entry from qs to rds", mess)) == 1) }) test_that("test file link with duplicate Cache", { @@ -1114,7 +1114,7 @@ test_that("test file link with duplicate Cache", { g <- Cache(sam1, N, cachePath = tmpCache) }) - expect_true(sum(grepl("A file with identical", mess3)) == 1) + expect_true(sum(cli::ansi_grepl("A file with identical", mess3)) == 1) set.seed(123) mess1 <- capture_messages({ @@ -1130,8 +1130,8 @@ test_that("test file link with duplicate Cache", { mess2 <- capture_messages({ d <- Cache(sam1, N, cachePath = tmpCache) }) - expect_true(any(grepl(.message$LoadedCacheResult(), mess2))) - expect_true(any(grepl(.message$LoadedCacheResult(), mess1))) + expect_true(any(cli::ansi_grepl(.message$LoadedCacheResult(), mess2))) + expect_true(any(cli::ansi_grepl(.message$LoadedCacheResult(), mess1))) # There are intermittent "status 5" warnings on next line on Windows -- not relevant here warns <- capture_warnings({ out1 <- try(system2("du", paste0("\"", tmpCache, "\""), stdout = TRUE), silent = TRUE) @@ -1793,7 +1793,7 @@ test_that("terra files were creating file.link", { ras } mess <- capture_messages(Map(f = func, fn = tmpfile, ras = rasts)) - expect_false(any(grepl("file.link", mess))) + expect_false(any(cli::ansi_grepl("file.link", mess))) }) From 146807c6bf9671e748318d28d30ea7cb60aafdc7 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 5 Dec 2024 12:20:15 -0800 Subject: [PATCH 11/11] fix merge --- tests/testthat/test-cache.R | 244 ------------------------------------ 1 file changed, 244 deletions(-) diff --git a/tests/testthat/test-cache.R b/tests/testthat/test-cache.R index 7b61ea91f..2ff0ad342 100644 --- a/tests/testthat/test-cache.R +++ b/tests/testthat/test-cache.R @@ -609,205 +609,6 @@ test_that("test quoted FUN in Cache", { expect_true(all.equalWONewCache(A, C)) }) -test_that("test Cache argument inheritance to inner functions", { - testInit("terra", - 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( - { - newOnes <- setdiff(tmpDirFiles, dir(tempdir())) - unlink(newOnes, recursive = TRUE) - }, - add = TRUE - ) - - outer <- function(n, not = NULL) { - Cache(rnorm, n, notOlderThan = not) - } - - mess <- capture_messages(Cache(outer, n = 2)) - expect_equal(sum(cli::ansi_grepl(.message$NoCacheRepoSuppliedGrep, mess)), 2) - clearCache(ask = FALSE, x = tmpdir) - - # options(reproducible.cachePath = tmpCache) - out <- capture_messages(Cache(outer, n = 2)) - expect_true(all(unlist(lapply( - c(.message$NoCacheRepoSuppliedGrep, .message$NoCacheRepoSuppliedGrep), - function(mess) any(cli::ansi_grepl(mess, out)) - )))) - - # does Sys.time() propagate to outer ones - out <- capture_messages(Cache(outer(n = 2, not = Sys.time() + 1), notOlderThan = Sys.time() + 1)) - expect_equal(sum(cli::ansi_grepl(.message$NoCacheRepoSuppliedGrep, out)), 2) - - # does Sys.time() propagate to outer ones -- no message about cachePath being tempdir() - mess <- capture_messages(Cache(outer(n = 2, not = Sys.time()), notOlderThan = Sys.time(), cachePath = tmpdir)) - expect_equal(sum(cli::ansi_grepl(.message$NoCacheRepoSuppliedGrep, mess)), 1) - - # does cachePath propagate to outer ones -- no message about cachePath being tempdir() - out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir)) - expect_true(length(out) == 2) - expect_true(sum(cli::ansi_grepl(paste(.message$LoadedCacheResult(), "outer call"), out)) == 1) - - # check that the rnorm inside "outer" returns cached value even if outer "outer" function is changed - outer <- function(n) { - a <- 1 - Cache(rnorm, n) - } - out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir)) - expect_true(length(out) == 4) - msgGrep <- paste(paste(.message$LoadedCacheResult(), "rnorm call"), - "There is no similar item in the cachePath", - sep = "|" - ) - expect_true(sum(cli::ansi_grepl(msgGrep, out)) == 1) - - # Override with explicit argument - outer <- function(n) { - a <- 1 - Cache(rnorm, n, notOlderThan = Sys.time() + 1) - } - out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir)) - expect_equal(sum(cli::ansi_grepl(.message$NoCacheRepoSuppliedGrep, out)), 1) - - # change the outer function, so no cache on that, & have notOlderThan on rnorm, - # so no Cache on that - outer <- function(n) { - b <- 1 - Cache(rnorm, n, notOlderThan = Sys.time() + 1) - } - out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir)) - expect_equal(sum(cli::ansi_grepl(.message$NoCacheRepoSuppliedGrep, out)), 1) - - # expect_true(all(cli::ansi_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)) - expect_true(length(out) == 2) - expect_true(sum(cli::ansi_grepl(paste(.message$LoadedCacheResult(), "outer call"), out)) == 1) - - # doubly nested - inner <- function(mean, useCache = TRUE) { - d <- 1 - Cache(rnorm, n = 3, mean = mean, useCache = useCache) - } - outer <- function(n, useCache = TRUE, ...) { - Cache(inner, 0.1, useCache = useCache, ...) - } - out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir)) - - outer <- function(n) { - Cache(inner, 0.1, notOlderThan = Sys.time() - 1e4) - } - - out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir, notOlderThan = Sys.time())) - msgGrep <- paste(paste(.message$LoadedCacheResult(), "inner call"), - "There is no similar item in the cachePath", - sep = "|" - ) - expect_true(sum(cli::ansi_grepl(.message$NoCacheRepoSuppliedGrep, out)) == 1) - - # expect_true(sum(cli::ansi_grepl(msgGrep, out)) == 1) - - outer <- function(n) { - Cache(inner, 0.1, notOlderThan = Sys.time()) - } - inner <- function(mean) { - d <- 1 - Cache(rnorm, n = 3, mean = mean, notOlderThan = Sys.time() - 1e5) - } - - out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir, notOlderThan = Sys.time())) - msgGrep <- paste(paste(.message$LoadedCacheResult(), "rnorm call"), - "There is no similar item in the cachePath", - sep = "|" - ) - expect_true(sum(cli::ansi_grepl(msgGrep, out)) == 1) - - # Check userTags -- all items have it - clearCache(tmpdir, ask = FALSE) - outerTag <- "howdie" - aa <- Cache(outer, n = 2, cachePath = tmpdir, userTags = outerTag) - bb <- showCache(tmpdir, userTags = outerTag) - cc <- showCache(tmpdir) - data.table::setorderv(bb, c(.cacheTableHashColName(), "tagKey", "tagValue")) - data.table::setorderv(cc, c(.cacheTableHashColName(), "tagKey", "tagValue")) - expect_true(identical(bb, cc)) - - # Check userTags -- all items have the outer tag propagate, plus inner ones only have inner ones - innerTag <- "notHowdie" - inner <- function(mean) { - d <- 1 - Cache(rnorm, n = 3, mean = mean, notOlderThan = Sys.time() - 1e5, userTags = innerTag) - } - - clearCache(tmpdir, ask = FALSE) - aa <- Cache(outer, n = 2, cachePath = tmpdir, userTags = outerTag) - bb <- showCache(tmpdir, userTags = outerTag) - cc <- showCache(tmpdir) - data.table::setorderv(cc) - data.table::setorderv(bb) - expect_true(identical(bb, cc)) - - # - bb <- showCache(tmpdir, userTags = "notHowdie") - cc <- showCache(tmpdir) - data.table::setorderv(cc) - data.table::setorderv(bb) - expect_false(identical(bb, cc)) - expect_true(length(unique(bb[[.cacheTableHashColName()]])) == 1) - expect_true(length(unique(cc[[.cacheTableHashColName()]])) == 3) -}) - -test_that("test future", { - skip_on_cran() - skip_on_ci() - # skip_if_not_installed("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" - ) - ) - - # There is now a warning with future package - a <- list() - (aa <- system.time({ - for (i in c(1:3)) a[[i]] <- Cache(cachePath = tmpCache, rnorm, 1e6 + i) - })) - sca <- showCache(tmpCache) - expect_true(length(unique(sca[[.cacheTableHashColName()]])) == 3) - - try(unlink(tmpCache, recursive = TRUE)) - b <- list() - (bb <- system.time({ - for (i in 1:3) b[[i]] <- Cache(cachePath = tmpCache, rnorm(1e6 + i)) - })) - bb <- showCache(tmpCache) - expect_true(length(unique(bb[[.cacheTableHashColName()]])) == 3) - - # Test the speed of rerunning same line - d <- list() - (dd <- system.time({ - for (i in 1:3) d[[i]] <- Cache(cachePath = tmpCache, rnorm(1e6 + i)) - })) - expect_true((dd[[3]] * 2) < aa[[3]]) - for (i in 1:3) { - expect_true(identical(attr(d[[i]], ".Cache")$newCache, FALSE)) - } - # } -}) - test_that("test mergeCache", { testInit("data.table", verbose = TRUE) @@ -999,27 +800,6 @@ test_that("test cc", { expect_true(any(cli::ansi_grepl("Cache already empty", mess))) }) -test_that("test pre-creating conn", { - if (!useDBI()) skip("Only relevant for DBI backend") - testInit("terra", ask = FALSE, tmpFileExt = c(".tif", ".tif")) - on.exit({ - DBI::dbDisconnect(conn) - }) - - conn <- dbConnectAll(cachePath = tmpdir, conn = NULL) - ra <- terra::rast(terra::ext(0, 10, 0, 10), vals = sample(1:100)) - 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 - ) - expect_true(file.exists(Filenames(r1))) - expect_true(file.exists(Filenames(r2))) - expect_false(cli::ansi_grepl(basename(dirname(Filenames(r1))), "rasters")) # changed behaviour as of reproducible 1.2.0.9020 - expect_false(cli::ansi_grepl(basename(dirname(Filenames(r2))), "rasters")) # changed behaviour as of reproducible 1.2.0.9020 -}) - test_that("test .defaultUserTags", { testInit() @@ -1031,30 +811,6 @@ test_that("test .defaultUserTags", { expect_false(anyNewTags) }) -test_that("test failed Cache recovery -- message to delete cacheId", { - if (!useDBI()) skip("Not relevant for multipleDBfiles") - testInit(opts = list("reproducible.useMemoise" = FALSE)) - - b <- Cache(rnorm, 1, cachePath = tmpdir) - sc <- showCache(tmpdir) - ci <- unique(sc[[.cacheTableHashColName()]]) - unlink(CacheStoredFile(tmpdir, ci)) - - - rm(b) - mess <- capture_messages({ - warn <- capture_warnings({ - err <- capture_error({ - d <- Cache(rnorm, 1, cachePath = tmpdir) - }) - }) - }) - expect_true(sum(cli::ansi_grepl(paste0("(trying to recover).*(", ci, ")"), mess)) == 1) - expect_true(sum(cli::ansi_grepl(paste0("(trying to recover).*(", ci, ")"), err)) == 0) - expect_true(any(cli::ansi_grepl(paste0("[cannot|failed to] open"), paste(warn, err, mess)))) - expect_true(is.numeric(d)) -}) - test_that("test changing reproducible.cacheSaveFormat midstream", { skip_if_not_installed("qs")