Make it possible to muffle CRAN skips (#2225)

This shouldn't have any effect on user code, but we need some way to ensure that CRAN skips aren't propagated across multiple `test_code()` boundaries so that we can properly test.

Also includes a few other CRAN related tweaks.

Author: hadley

R/skip.R

@@ -185,7 +185,7 @@ skip_on_cran <- function() {
 #' @rdname skip
 #' @param on_cran Pretend we're on CRAN (`TRUE`) or not (`FALSE`).
 #' @param frame Calling frame to tie change to; expect use only.
-local_on_cran <- function(on_cran, frame = caller_env()) {
+local_on_cran <- function(on_cran = TRUE, frame = caller_env()) {
   check_bool(on_cran)
   withr::local_envvar(NOT_CRAN = tolower(!on_cran), .local_envir = frame)
 }

R/snapshot-file.R

@@ -122,7 +122,7 @@ expect_snapshot_file <- function(
 
   announce_snapshot_file(name = name)
   if (!cran && on_cran()) {
-    signal(class = "snapshot_on_cran")
+    signal_snapshot_on_cran()
     return(invisible())
   }
 

R/snapshot-reporter.R

@@ -63,7 +63,7 @@ SnapshotReporter <- R6::R6Class(
         return()
       }
 
-      self$test <- paste0(gsub("\n", "", test), collapse = " / ")
+      self$test <- gsub("\n", "", test)
     },
 
     # Called by expectation
@@ -163,6 +163,10 @@ SnapshotReporter <- R6::R6Class(
       }
 
       # If expectation errors or skips, need to copy snapshots from old to cur
+      # TODO: the logic is not correct here for subtests, probably because
+      # the code was not written under the assumption that start_test()
+      # generates a stack of tests. You can see the problem by running
+      # local_on_cran() then testing describe.R.
       if (expectation_error(result) || expectation_skip(result)) {
         self$cur_snaps$reset(self$test, self$old_snaps)
       }

R/snapshot.R

@@ -344,7 +344,7 @@ expect_snapshot_helper <- function(
   trace_env = caller_env()
 ) {
   if (!cran && on_cran()) {
-    signal(class = "snapshot_on_cran")
+    signal_snapshot_on_cran()
     return(invisible())
   }
 
@@ -461,3 +461,10 @@ with_is_snapshotting <- function(code) {
   withr::local_envvar(TESTTHAT_IS_SNAPSHOT = "true")
   code
 }
+
+signal_snapshot_on_cran <- function() {
+  withRestarts(
+    signal(class = "snapshot_on_cran"),
+    muffle_cran_snapshot = function() {}
+  )
+}

R/test-that.R

@@ -179,6 +179,7 @@ test_code <- function(code, env, reporter = NULL, skip_on_empty = TRUE) {
         },
         snapshot_on_cran = function(cnd) {
           snapshot_skipped <<- TRUE
+          invokeRestart("muffle_cran_snapshot")
         },
         skip = handle_skip,
         warning = handle_warning,

man/skip.Rd

@@ -8,9 +8,9 @@
 # snapshot tests in describe / and in it
 
     Code
-      1 + 1
+      2 + 2
     Output
-      [1] 2
+      [1] 4
 
 # has to have a valid description for the block
 

tests/testthat/_snaps/describe.md

@@ -19,7 +19,7 @@ test_that("can write snaphot tests", {
   describe("snapshot tests in describe", {
     expect_snapshot(1 + 1)
     it("and in it", {
-      expect_snapshot(1 + 1)
+      expect_snapshot(2 + 2)
     })
   })
 })

tests/testthat/test-describe.R

@@ -63,7 +63,7 @@ test_that("skip_on_cran() works as expected", {
 
   local({
     local_on_cran(TRUE)
-    expect_snapshot_skip(skip_on_cran())
+    expect_skip(skip_on_cran())
   })
 
   withr::local_envvar(NOT_CRAN = NA)

tests/testthat/test-skip.R

@@ -196,10 +196,10 @@ test_that("can filter with desc", {
     snapper <- local_test_snapshotter(snap_dir = path)
     snapper$start_file("snapshot")
     snapper$start_test(test = "x")
-    expect_snapshot_output(cat("x"))
+    expect_snapshot_output(cat("x"), cran = TRUE)
     snapper$end_test()
     snapper$start_test(test = "y")
-    expect_snapshot_output(cat("y"))
+    expect_snapshot_output(cat("y"), cran = TRUE)
     snapper$end_test()
     snapper$end_file()
   })
@@ -209,7 +209,7 @@ test_that("can filter with desc", {
   snapper <- local_test_snapshotter(snap_dir = path, desc = "x")
   snapper$start_file("snapshot")
   snapper$start_test(test = "x")
-  expect_snapshot_output(cat("x"))
+  expect_snapshot_output(cat("x"), cran = TRUE)
   snapper$end_test()
   snapper$end_file()
   snaps_filtered <- readLines(file.path(path, "snapshot.md"))