In R CMD check, only notify about snapshots once

NEWS.md

@@ -1,5 +1,6 @@
 # testthat (development version)
 
+* In `R CMD check`, snapshots now only advise on how to resolve failures once (#2207).
 * `snapshot_review()` includes a reject button and only displays the file navigation and the skip button if there are multiple files to review (#2025).
 * New `snapshot_download_gh()` makes it easy to get snapshots off GitHub and into your local package (#1779).
 * New `local_mocked_s3_method()`, `local_mocked_s4_method()`, and `local_mocked_r6_class()` allow you to mock S3 and S4 methods and R6 classes (#1892, #1916)

R/expect-that.R

@@ -41,18 +41,25 @@ fail <- function(
   trace_env = caller_env(),
   trace = NULL
 ) {
-  if (is.null(trace)) {
-    trace <- trace_back(top = getOption("testthat_topenv"), bottom = trace_env)
-  }
-  # Only show if there's at least one function apart from the expectation
-  if (trace_length(trace) <= 1) {
-    trace <- NULL
-  }
-
+  trace <- trace %||% capture_trace(trace_env)
   message <- paste(c(message, info), collapse = "\n")
   expectation("failure", message, srcref = srcref, trace = trace)
 }
 
+snapshot_fail <- function(message, trace_env = caller_env()) {
+  trace <- capture_trace(trace_env)
+  expectation("failure", message, trace = trace, snapshot = TRUE)
+}
+
+capture_trace <- function(trace_env) {
+  trace <- trace_back(top = getOption("testthat_topenv"), bottom = trace_env)
+  # Only include trace if there's at least one function apart from the expectation
+  if (!is.null(trace) && trace_length(trace) <= 1) {
+    trace <- NULL
+  }
+  trace
+}
+
 #' @rdname fail
 #' @param value Value to return, typically the result of evaluating the
 #'   `object` argument to the expectation.

R/expectation.R

@@ -49,8 +49,8 @@ expect <- function(
 #' @keywords internal
 #' @inheritParams expect
 #' @export
-expectation <- function(type, message, srcref = NULL, trace = NULL) {
-  exp <- new_expectation(type, message, srcref = srcref, trace = trace)
+expectation <- function(type, message, ..., srcref = NULL, trace = NULL) {
+  exp <- new_expectation(type, message, ..., srcref = srcref, trace = trace)
   exp_signal(exp)
 }
 #' @rdname expectation

R/reporter-check.R

@@ -13,6 +13,7 @@ CheckReporter <- R6::R6Class(
     skips = NULL,
     warnings = NULL,
     n_ok = 0L,
+    old_in_check_reporter = NULL,
 
     initialize = function(...) {
       self$capabilities$parallel_support <- TRUE
@@ -35,7 +36,14 @@ CheckReporter <- R6::R6Class(
       }
     },
 
+    start_reporter = function() {
+      self$old_in_check_reporter <- in_check_reporter()
+      the$in_check_reporter <- TRUE
+    },
+
     end_reporter = function() {
+      the$in_check_reporter <- self$old_in_check_reporter
+
       if (self$skips$size() || self$warnings$size() || self$problems$size()) {
         self$cat_line(summary_line(
           n_fail = self$problems$size(),
@@ -64,6 +72,11 @@ CheckReporter <- R6::R6Class(
         self$rule("Failed tests", line = 2)
         self$cat_line(map_chr(problems, issue_summary, rule = TRUE))
         self$cat_line()
+
+        if (some(problems, \(x) isTRUE(attr(x, "snapshot")))) {
+          self$rule("To resolve snapshot failures", line = 1)
+          self$cat_line(snapshot_check_hint())
+        }
       } else {
         # clean up
         unlink("testthat-problems.rds")
@@ -105,3 +118,36 @@ summary_line <- function(n_fail, n_warn, n_skip, n_pass) {
     " ]"
   )
 }
+
+snapshot_check_hint <- function() {
+  if (on_gh()) {
+    repository <- Sys.getenv("GITHUB_REPOSITORY")
+    run_id <- Sys.getenv("GITHUB_RUN_ID")
+
+    call <- sprintf(
+      "testthat::snapshot_download_gh(\"%s\", \"%s\")",
+      repository,
+      run_id
+    )
+    copy <- sprintf("* Run `%s` to download snapshots.", call)
+  } else {
+    copy <- c(
+      if (on_ci()) {
+        "* Download and unzip artifact."
+      } else {
+        "* Locate check directory."
+      },
+      "* Copy 'tests/testthat/_snaps' to local package."
+    )
+  }
+
+  action <- c(
+    "* Run `testthat::snapshot_accept()` to accept all changes.",
+    "* Run `testthat::snapshot_review()` to review all changes."
+  )
+  c(copy, action)
+}
+
+run <- function(x) {
+  cli::format_inline(paste0("{.run testthat::", x, "}"))
+}

R/snapshot-file.R

@@ -142,7 +142,11 @@ expect_snapshot_file <- function(
     return(equal)
   }
 
-  hint <- snapshot_review_hint(snapshotter$file, name)
+  if (in_check_reporter()) {
+    hint <- ""
+  } else {
+    hint <- snapshot_review_hint(snapshotter$file, name)
+  }
 
   if (!equal) {
     msg <- sprintf(
@@ -151,7 +155,7 @@ expect_snapshot_file <- function(
       paste0(snapshotter$file, "/", name),
       hint
     )
-    return(fail(msg))
+    return(snapshot_fail(msg))
   }
   pass(NULL)
 }
@@ -167,45 +171,16 @@ announce_snapshot_file <- function(path, name = basename(path)) {
   }
 }
 
-snapshot_review_hint <- function(
-  test,
-  name,
-  ci = on_ci(),
-  check = in_rcmd_check(),
-  reset_output = TRUE
-) {
+snapshot_review_hint <- function(test, name, reset_output = TRUE) {
   if (reset_output) {
     local_reporter_output()
   }
 
-  path <- paste0("tests/testthat/_snaps/", test, "/", new_name(name))
-
-  if (check) {
-    if (on_gh()) {
-      bullets <- snap_download_hint()
-    } else {
-      bullets <- c(
-        if (ci) "* Download and unzip run artifact\n",
-        if (!ci) "* Locate check directory\n",
-        paste0("* Copy '", path, "' to local test directory\n")
-      )
-    }
-  } else {
-    bullets <- NULL
-  }
-
-  paste0(
-    c(
-      bullets,
-      cli::format_inline(
-        "* Run {.run testthat::snapshot_review('{test}/')} to review changes"
-      )
-    ),
-    collapse = ""
+  cli::format_inline(
+    "* Run {.run testthat::snapshot_review('{test}/{name}')} to review the change."
   )
 }
 
-
 snapshot_file_equal <- function(
   snap_dir, # _snaps/
   snap_test, # test file name
@@ -254,7 +229,7 @@ snapshot_file_equal <- function(
     # We want to fail on CI since this suggests that the user has failed
     # to record the value locally
     if (fail_on_new) {
-      return(fail(message, trace_env = trace_env))
+      return(snapshot_fail(message, trace_env = trace_env))
     }
     testthat_warn(message)
     TRUE

R/snapshot-github.R

@@ -40,17 +40,6 @@ snapshot_download_gh <- function(repository, run_id, dest_dir = ".") {
   dir_copy(src_snaps, dest_snaps)
 }
 
-snap_download_hint <- function() {
-  repository <- Sys.getenv("GITHUB_REPOSITORY")
-  run_id <- Sys.getenv("GITHUB_RUN_ID")
-
-  sprintf(
-    "* Call `snapshot_download_gh(\"%s\", \"%s\")` to download the snapshots from GitHub.\n",
-    repository,
-    run_id
-  )
-}
-
 gh_find_job <- function(repository, run_id) {
   jobs_json <- gh::gh(
     "/repos/{repository}/actions/runs/{run_id}/jobs",

R/snapshot.R

@@ -289,7 +289,7 @@ expect_snapshot_condition_ <- function(
         class
       )
     }
-    return(fail(msg, trace_env = trace_env))
+    return(snapshot_fail(msg, trace_env = trace_env))
   }
 
   expect_snapshot_helper(
@@ -340,7 +340,11 @@ expect_snapshot_helper <- function(
   } else {
     variant_lab <- ""
   }
-  hint <- snapshot_accept_hint(variant, snapshotter$file)
+  if (in_check_reporter()) {
+    hint <- ""
+  } else {
+    hint <- snapshot_accept_hint(variant, snapshotter$file)
+  }
 
   if (length(comp) != 0) {
     msg <- sprintf(
@@ -350,7 +354,7 @@ expect_snapshot_helper <- function(
       paste0(comp, collapse = "\n\n"),
       hint
     )
-    return(fail(msg, trace_env = trace_env))
+    return(snapshot_fail(msg, trace_env = trace_env))
   }
 
   pass(NULL)
@@ -368,13 +372,12 @@ snapshot_accept_hint <- function(variant, file, reset_output = TRUE) {
   }
 
   paste0(
-    if (on_gh()) snap_download_hint(),
     cli::format_inline(
       "* Run {.run testthat::snapshot_accept('{name}')} to accept the change."
     ),
     "\n",
     cli::format_inline(
-      "* Run {.run testthat::snapshot_review('{name}')} to interactively review the change."
+      "* Run {.run testthat::snapshot_review('{name}')} to review the change."
     )
   )
 }

R/testthat-package.R

@@ -22,6 +22,7 @@ the <- new.env(parent = emptyenv())
 the$description <- character()
 the$top_level_test <- TRUE
 the$test_expectations <- 0
+the$in_check_reporter <- FALSE
 
 # The following block is used by usethis to automatically manage
 # roxygen namespace tags. Modify with care!

R/utils.R

@@ -51,8 +51,8 @@ first_upper <- function(x) {
   x
 }
 
-in_rcmd_check <- function() {
-  nzchar(Sys.getenv("_R_CHECK_PACKAGE_NAME_", ""))
+in_check_reporter <- function() {
+  isTRUE(the$in_check_reporter)
 }
 
 r_version <- function() paste0("R", getRversion()[, 1:2])

tests/testthat/_snaps/reporter-check.md

@@ -96,3 +96,32 @@
 
     [ FAIL 4 | WARN 1 | SKIP 3 | PASS 1 ]
 
+# generates informative snapshot hints
+
+    Code
+      base::writeLines(snapshot_check_hint())
+    Output
+      * Locate check directory.
+      * Copy 'tests/testthat/_snaps' to local package.
+      * Run `testthat::snapshot_accept()` to accept all changes.
+      * Run `testthat::snapshot_review()` to review all changes.
+
+---
+
+    Code
+      base::writeLines(snapshot_check_hint())
+    Output
+      * Download and unzip artifact.
+      * Copy 'tests/testthat/_snaps' to local package.
+      * Run `testthat::snapshot_accept()` to accept all changes.
+      * Run `testthat::snapshot_review()` to review all changes.
+
+---
+
+    Code
+      base::writeLines(snapshot_check_hint())
+    Output
+      * Run `testthat::snapshot_download_gh("r-lib/testthat", "123")` to download snapshots.
+      * Run `testthat::snapshot_accept()` to accept all changes.
+      * Run `testthat::snapshot_review()` to review all changes.
+

tests/testthat/_snaps/snapshot-file.md

@@ -22,38 +22,12 @@
       Error in `snapshot_file_equal_()`:
       ! 'doesnt-exist.txt' not found.
 
-# snapshot_hint output differs in R CMD check
+# generates informative hint
 
     Code
-      cat(snapshot_review_hint("lala", "foo.r", check = FALSE, ci = FALSE))
+      cat(snapshot_review_hint("lala", "foo.r", reset_output = FALSE))
     Output
-      * Run `testthat::snapshot_review('lala/')` to review changes
-
----
-
-    Code
-      cat(snapshot_review_hint("lala", "foo.r", check = TRUE, ci = FALSE))
-    Output
-      * Locate check directory
-      * Copy 'tests/testthat/_snaps/lala/foo.new.r' to local test directory
-      * Run `testthat::snapshot_review('lala/')` to review changes
-
----
-
-    Code
-      cat(snapshot_review_hint("lala", "foo.r", check = TRUE, ci = TRUE))
-    Output
-      * Download and unzip run artifact
-      * Copy 'tests/testthat/_snaps/lala/foo.new.r' to local test directory
-      * Run `testthat::snapshot_review('lala/')` to review changes
-
----
-
-    Code
-      cat(snapshot_review_hint("lala", "foo.r", check = TRUE, ci = TRUE))
-    Output
-      * Call `snapshot_download_gh("r-lib/testthat", "123")` to download the snapshots from GitHub.
-      * Run `testthat::snapshot_review('lala/')` to review changes
+      * Run `testthat::snapshot_review('lala/foo.r')` to review the change.
 
 # expect_snapshot_file validates its inputs