Remove uses of is_testing()

.github/workflows/R-CMD-check-hard.yaml

@@ -47,7 +47,8 @@ jobs:
           cache: false
           extra-packages: |
             any::rcmdcheck
-            github::r-lib/testthat
+            any::testthat
+            any::mockery
             any::knitr
             any::rmarkdown
           needs: check

DESCRIPTION

@@ -60,7 +60,7 @@ Suggests:
     rsconnect,
     shiny,
     sodium,
-    testthat (>= 3.0.0),
+    testthat (>= 3.1.7),
     webfakes,
     xml2,
     zip

R/board_azure.R

@@ -254,11 +254,11 @@ azure_dir_exists <- function(board, path) {
   AzureStor::storage_dir_exists(board$container, dir)
 }
 
-local_azure_progress <- function(progress = !is_testing(), env = parent.frame()) {
+local_azure_progress <- function(progress = is_interactive(), env = parent.frame()) {
   withr::local_options(list(azure_storage_progress_bar = progress), .local_envir = env)
 }
 
-azure_download <- function(board, keys, progress = !is_testing()) {
+azure_download <- function(board, keys, progress = is_interactive()) {
   local_azure_progress(progress)
 
   paths <- fs::path(board$cache, keys)

R/pin-read-write.R

@@ -145,21 +145,21 @@ object_write <- function(x, path, type = "rds") {
 }
 
 write_rds <- function(x, path) {
-  if (!is_testing()) {
-    saveRDS(x, path, version = 2)
-  } else {
-    # compression algorithm changed in 4.1
-    saveRDS(x, path, version = 2, compress = FALSE)
+  saveRDS(x, path, version = 2)
+  invisible(path)
+}
 
-    old <- readBin(path, "raw", fs::file_size(path))
+write_rds_test <- function(x, path) {
+  saveRDS(x, path, version = 2, compress = FALSE)
 
-    # Record fixed R version number (3.5.3) to avoid spurious hash changes
-    con <- file(path, open = "wb")
-    writeBin(old[1:7], con)
-    writeBin(as.raw(c(3, 5, 3)), con)
-    writeBin(old[-(1:10)], con)
-    close(con)
-  }
+  old <- readBin(path, "raw", fs::file_size(path))
+
+  # Record fixed R version number (3.5.3) to avoid spurious hash changes
+  con <- file(path, open = "wb")
+  writeBin(old[1:7], con)
+  writeBin(as.raw(c(3, 5, 3)), con)
+  writeBin(old[-(1:10)], con)
+  close(con)
   invisible(path)
 }
 

R/pin_versions.R

@@ -146,11 +146,7 @@ versions_template <- function(version = character()) {
 }
 
 version_name <- function(metadata) {
-  if (is_testing()) {
-    paste0("20120304T050607Z-", substr(metadata$pin_hash, 1, 5))
-  } else {
-    paste0(metadata$created, "-", substr(metadata$pin_hash, 1, 5))
-  }
+  paste0(metadata$created, "-", substr(metadata$pin_hash, 1, 5))
 }
 
 version_from_path <- function(x) {

R/testthat.R

@@ -131,6 +131,13 @@ test_api_versioning <- function(board) {
   })
 
   testthat::test_that("pin_read() returns latest version", {
+    mock_version_name <-
+      mockery::mock(
+        "20130104T050607Z-xxxxx",
+        "20130204T050607Z-yyyyy",
+        "20130304T050607Z-zzzzz"
+      )
+    testthat::local_mocked_bindings(version_name = mock_version_name)
     name <- local_pin(board, 1)
     pin_write(board, 2, name)
     pin_write(board, 3, name)

R/utils.R

@@ -27,10 +27,6 @@ end_with_slash <- function(x) {
   x
 }
 
-is_testing <- function() {
-  identical(Sys.getenv("TESTTHAT"), "true")
-}
-
 #' Pin Logging
 #'
 #' Log message for diagnosing the `pins` package.
@@ -40,7 +36,7 @@ is_testing <- function() {
 #' @export
 #' @keywords internal
 pin_log <- function(...) {
-  if (getOption("pins.verbose", FALSE) && !is_testing()) {
+  if (getOption("pins.verbose", FALSE)) {
     message(...)
   }
 }
@@ -59,7 +55,7 @@ last <- function(x) x[[length(x)]]
 
 pins_inform <- function(...) {
   opt <- getOption("pins.quiet", NA)
-  if (identical(opt, FALSE) || (identical(opt, NA) && !is_testing())) {
+  if (identical(opt, FALSE) || (identical(opt, NA))) {
     inform(glue(..., .envir = caller_env()))
   }
 }

tests/testthat/_snaps/board_folder.md

@@ -46,16 +46,16 @@
     Code
       pin_write(b, 1:5, "x", type = "rds")
     Message
-      Creating new version '20120304T050607Z-ab444'
+      Creating new version '20130104T050607Z-xxxxx'
       Writing to pin 'x'
     Code
       pin_write(b, 1:5, "x", type = "rds")
     Message
-      Replacing version '20120304T050607Z-ab444' with '20120304T050607Z-ab444'
+      Replacing version '20130104T050607Z-xxxxx' with '20130204T050607Z-yyyyy'
       Writing to pin 'x'
     Code
       pin_write(b, 1:6, "x", type = "rds")
     Message
-      Replacing version '20120304T050607Z-ab444' with '20120304T050607Z-ab6b5'
+      Replacing version '20130204T050607Z-yyyyy' with '20130304T050607Z-zzzzz'
       Writing to pin 'x'
 

tests/testthat/_snaps/pin-read-write.md

@@ -38,7 +38,7 @@
     Message
       Using `name = 'mtcars'`
       Guessing `type = 'rds'`
-      Creating new version '20120304T050607Z-dfa6c'
+      Creating new version '20120304T050607Z-xxxxx'
       Writing to pin 'mtcars'
     Code
       pin_write(b, data.frame(x = 1))
@@ -52,7 +52,7 @@
       b <- board_temp()
       pin_write(b, mtcars, name = "mtcars", type = "rds")
     Message
-      Creating new version '20120304T050607Z-dfa6c'
+      Creating new version '20120304T050607Z-xxxxx'
       Writing to pin 'mtcars'
     Code
       pin_read(b, "mtcars", hash = "ABCD")

tests/testthat/_snaps/pin-upload-download.md

@@ -15,7 +15,7 @@
       pin_upload(board, path)
     Message
       Guessing `name = 'test.txt'`
-      Creating new version '20120304T050607Z-ef46d'
+      Creating new version '20120304T050607Z-xxxxx'
 
 # can pin file called data.txt
 

tests/testthat/_snaps/pin_versions.md

@@ -34,7 +34,7 @@
     Code
       pin_versions_prune(board, "x", n = 1)
     Message
-      Deleting versions: 20120304T050607Z-3de1f, 20120304T050607Z-caa1b, 20120304T050607Z-e4e08
+      Deleting versions: 20130104T050607Z-xxxxx, 20130204T050607Z-yyyyy, 20130304T050607Z-zzzzz
     Code
       pin_versions_prune(board, "x", n = 1)
     Message

tests/testthat/setup.R

@@ -0,0 +1,2 @@
+options(pins.verbose = FALSE)
+options(pins.quiet = TRUE)

tests/testthat/test-board_connect_server.R

@@ -1,4 +1,5 @@
 skip_if_not_installed("mockery")
+skip_if_not_installed("rsconnect")
 
 test_that("auth allows manual, envvar and rsconnect values", {
   expect_equal(check_auth("manual"), "manual")

tests/testthat/test-board_folder.R

@@ -74,6 +74,15 @@ test_that("contents of manifest match", {
 
 
 test_that("generates useful messages", {
+  skip_if_not_installed("mockery")
+
+  mock_version_name <- mockery::mock(
+    "20130104T050607Z-xxxxx",
+    "20130204T050607Z-yyyyy",
+    "20130304T050607Z-zzzzz"
+  )
+ local_mocked_bindings(version_name = mock_version_name)
+
   ui_loud()
   b <- board_temp()
   expect_snapshot({

tests/testthat/test-meta.R

@@ -5,7 +5,7 @@ test_that("non-existent file returns default data", {
 test_that("standard metadata is useful", {
   df <- data.frame(x = 1:10)
   path <- withr::local_tempfile()
-  write_rds(df, path)
+  write_rds_test(df, path)
 
   meta <- standard_meta(path, "arrow", title = "title")
   meta$file <- "df.rds"

tests/testthat/test-pin-read-write.R

@@ -54,6 +54,7 @@ test_that("guess_type() works as expected", {
 
 test_that("pin_write() noisily generates name and type", {
   ui_loud()
+  local_mocked_bindings(version_name = function(metadata) "20120304T050607Z-xxxxx")
   expect_snapshot(error = TRUE, {
     b <- board_temp()
     pin_write(b, mtcars)
@@ -71,6 +72,10 @@ test_that("user can supply metadata", {
 })
 
 test_that("can request specific hash", {
+  local_mocked_bindings(
+    version_name = function(metadata) "20120304T050607Z-xxxxx",
+    write_rds = write_rds_test
+    )
   ui_loud()
   expect_snapshot(error = TRUE, {
     b <- board_temp()
@@ -86,3 +91,4 @@ test_that("informative error for legacy boards", {
     board %>% pin_read("x")
   })
 })
+

tests/testthat/test-pin-upload-download.R

@@ -10,6 +10,7 @@ test_that("can round-trip a file", {
 })
 
 test_that("pin_upload generated useful messages", {
+  local_mocked_bindings(version_name = function(metadata) "20120304T050607Z-xxxxx")
   ui_loud()
   board <- board_temp()
 

tests/testthat/test-pin_versions.R

@@ -39,8 +39,16 @@ test_that("can parse versions from path", {
 # versions pruning --------------------------------------------------------
 
 test_that("can prune old versions", {
-  board <- board_temp(versioned = TRUE)
+  skip_if_not_installed("mockery")
 
+  board <- board_temp(versioned = TRUE)
+  mock_version_name <- mockery::mock(
+    "20130104T050607Z-xxxxx",
+    "20130204T050607Z-yyyyy",
+    "20130304T050607Z-zzzzz",
+    "20130404T050607Z-aaaaa"
+  )
+  local_mocked_bindings(version_name = mock_version_name)
   pin_write(board, 1, "x")
   pin_write(board, 2, "x")
   pin_write(board, 3, "x")