Merged origin/main into llm-reporter

Author: hadley

NEWS.md

@@ -3,6 +3,11 @@
 * `test_dir()` will no longer run tests in parallel if only a single file is being tested (#2305). 
 * `default_parallel_reporter()` is no longer exported; use `default_reporter(parallel = TRUE)` instead  (#2305).
 * New `LlmReporter()` designed for LLMs to read. It's currently used automatically inside Claude code, cursor, and gemini cli, and you can set `AGENT=1` to use with any coding agent (#2287).
+* `local_mocked_s3_method()` and `local_mocked_s4_method()` can now mock methods that don't already exist, and can use `definition = NULL` to temporarily remove a method. `local_mocked_s4_method()` now also works when the generic is defined in another package (#2302).
+* `expect_snapshot()` now reports the original error class for base errors, rather than `rlang_error` (#2286).
+* `expect_success()` and `expect_failure()` are more clear about what the expectation actually did (#2297).
+* The hint to use `snapshot_download_gh()` is now only emitted when running in a job named "R-CMD-check" (#2300).
+* `expect_snapshot_file()` correctly reports file name if duplicated (@MichaelChirico, #2296).
 * Fixed support for `shinytest2::AppDriver$expect_values()` screenshot snapshot failing on CI (#2293, #2288).
 
 * testthat now emits OpenTelemetry traces for tests when tracing is enabled. Requires the otel and otelsdk packages (#2282).

R/expect-comparison.R

@@ -74,7 +74,6 @@ failure_compare <- function(act, exp, operator) {
         actual_op
       )
     }
-
   } else {
     msg_act <- sprintf(
       "Actual comparison: \"%s\" %s \"%s\"",

R/expect-constant.R

@@ -19,7 +19,7 @@
 #' a <- 1:4
 #' show_failure(expect_true(length(a) == 3))
 #' show_failure(expect_equal(length(a), 3))
-#' 
+#'
 #' x <- c(TRUE, TRUE, FALSE, TRUE)
 #' show_failure(expect_true(all(x)))
 #' show_failure(expect_all_true(x))

R/expect-self-test.R

@@ -26,6 +26,36 @@ capture_success_failure <- function(expr) {
   )
 }
 
+format_success_failure <- function(status, exp_n_success, exp_n_failure) {
+  pluralise <- function(n, singular, plural) {
+    paste(n, ngettext(n, singular, plural))
+  }
+
+  tick <- cli::col_green(cli::symbol$tick)
+  cross <- cli::col_red(cli::symbol$cross)
+
+  success_ok <- status$n_success == exp_n_success
+  failure_ok <- status$n_failure == exp_n_failure
+
+  c(
+    sprintf(
+      "Expected %s and %s.",
+      pluralise(exp_n_success, "success", "successes"),
+      pluralise(exp_n_failure, "failure", "failures")
+    ),
+    sprintf(
+      "%s Observed %s.",
+      if (success_ok) tick else cross,
+      pluralise(status$n_success, "success", "successes")
+    ),
+    sprintf(
+      "%s Observed %s.",
+      if (failure_ok) tick else cross,
+      pluralise(status$n_failure, "failure", "failures")
+    )
+  )
+}
+
 #' Test your custom expectations
 #'
 #' @description
@@ -44,17 +74,11 @@ capture_success_failure <- function(expr) {
 expect_success <- function(expr) {
   status <- capture_success_failure(expr)
 
-  expected <- "Expected exactly one success and no failures."
-  if (status$n_success != 1) {
-    actual <- sprintf("Actually succeeded %i times", status$n_success)
-    fail(c(expected, actual))
-  } else if (status$n_failure > 0) {
-    actual <- sprintf("Actually failed %i times", status$n_failure)
-    fail(c(expected, actual))
-  } else {
+  if (status$n_success == 1 && status$n_failure == 0) {
     pass()
+    return(invisible())
   }
-
+  fail(format_success_failure(status, exp_n_success = 1, exp_n_failure = 0))
   invisible()
 }
 
@@ -63,21 +87,17 @@ expect_success <- function(expr) {
 expect_failure <- function(expr, message = NULL, ...) {
   status <- capture_success_failure(expr)
 
-  expected <- "Expected exactly one failure and no successes."
-  if (status$n_failure != 1) {
-    actual <- sprintf("Actually failed %i times", status$n_failure)
-    fail(c(expected, actual))
-  } else if (status$n_success != 0) {
-    actual <- sprintf("Actually succeeded %i times", status$n_success)
-    fail(c(expected, actual))
-  } else {
+  if (status$n_failure == 1 && status$n_success == 0) {
     if (is.null(message)) {
       pass()
     } else {
       act <- labelled_value(status$last_failure$message, "failure message")
       expect_match_(act, message, ..., title = "message")
     }
+    return(invisible())
   }
+
+  fail(format_success_failure(status, exp_n_success = 0, exp_n_failure = 1))
   invisible()
 }
 

R/mock-oo.R

@@ -1,15 +1,16 @@
 #' Mock S3 and S4 methods
 #'
 #' @description
-#' These functions allow you to temporarily override S3 and S4 methods that
-#' already exist. It works by using [registerS3method()]/[setMethod()] to
-#' temporarily replace the original definition.
+#' These functions temporarily override S3 or S4 methods. They can mock
+#' methods that don't already exist, or temporarily remove a method by setting
+#' `definition = NULL`.
 #'
 #' Learn more about mocking in `vignette("mocking")`.
 #'
 #' @param generic A string giving the name of the generic.
 #' @param signature A character vector giving the signature of the method.
-#' @param definition A function providing the method definition.
+#' @param definition A function providing the method definition, or `NULL` to
+#'   temporarily remove the method.
 #' @param frame Calling frame which determines the scope of the mock.
 #'   Only needed when wrapping in another local helper.
 #' @export
@@ -29,16 +30,41 @@ local_mocked_s3_method <- function(
 ) {
   check_string(generic)
   check_string(signature)
-  check_function(definition)
+  check_function(definition, allow_null = TRUE)
 
   old <- utils::getS3method(generic, signature, optional = TRUE)
+
+  # Set the new method, or a pass-through stub if removing
+  definition <- definition %||% function(...) NextMethod()
+  registerS3method(generic, signature, definition, envir = frame)
+
+  # On cleanup, restore old method or remove the one we added
   if (is.null(old)) {
-    cli::cli_abort(
-      "Can't find existing S3 method {.code {generic}.{signature}()}."
+    withr::defer(remove_s3_method(generic, signature, envir = frame), frame)
+  } else {
+    withr::defer(
+      registerS3method(generic, signature, old, envir = frame),
+      frame
     )
   }
-  registerS3method(generic, signature, definition, envir = frame)
-  withr::defer(registerS3method(generic, signature, old, envir = frame), frame)
+
+  invisible()
+}
+
+remove_s3_method <- function(generic, class, envir) {
+  # Extracted from registerS3method()
+  group_generics <- c("Math", "Ops", "matrixOps", "Summary", "Complex")
+  if (generic %in% group_generics) {
+    s3_envir <- .BaseNamespaceEnv
+  } else {
+    genfun <- get(generic, envir = envir)
+    s3_envir <- environment(genfun) %||% .BaseNamespaceEnv
+  }
+
+  if (env_has(s3_envir, ".__S3MethodsTable__.")) {
+    table <- env_get(s3_envir, ".__S3MethodsTable__.")
+    env_unbind(table, paste0(generic, ".", class))
+  }
 }
 
 #' @rdname local_mocked_s3_method
@@ -51,20 +77,28 @@ local_mocked_s4_method <- function(
 ) {
   check_string(generic)
   check_character(signature)
-  check_function(definition)
+  check_function(definition, allow_null = TRUE)
 
-  old <- methods::getMethod(generic, signature, optional = TRUE)
-  if (is.null(old)) {
-    name <- paste0(generic, "(", paste0(signature, collapse = ","), ")")
-    cli::cli_abort(
-      "Can't find existing S4 method {.code {name}}."
-    )
+  generic_def <- methods::getGeneric(generic)
+  if (is.null(generic_def)) {
+    cli::cli_abort("Can't find generic {.fn {generic}}.")
   }
-  methods::setMethod(generic, signature, definition, where = topenv(frame))
-  withr::defer(
-    methods::setMethod(generic, signature, old, where = topenv(frame)),
-    frame
-  )
+
+  set_method <- function(generic, signature, def) {
+    env <- topenv(frame)
+    old <- methods::getMethod(generic, signature, optional = TRUE)
+    if (is.null(def)) {
+      methods::removeMethod(generic, signature, env)
+    } else {
+      suppressMessages(methods::setMethod(generic, signature, def, env))
+    }
+    old
+  }
+
+  old <- set_method(generic_def, signature, definition)
+  withr::defer(set_method(generic_def, signature, old), frame)
+
+  invisible()
 }
 
 

R/reporter-check.R

@@ -123,7 +123,7 @@ summary_line <- function(n_fail, n_warn, n_skip, n_pass) {
 snapshot_check_hint <- function() {
   intro <- "To review and process snapshots locally:"
 
-  if (on_gh()) {
+  if (on_gh() && Sys.getenv("GITHUB_JOB") == "R-CMD-check") {
     repository <- Sys.getenv("GITHUB_REPOSITORY")
     run_id <- Sys.getenv("GITHUB_RUN_ID")
 

R/snapshot-github.R

@@ -7,11 +7,13 @@
 #' take the artifacts from.
 #'
 #' Note that you should not generally need to use this function manually;
-#' instead copy and paste from the hint emitted on GitHub.
+#' instead copy and paste from the hint emitted on GitHub. This hint is only
+#' emitted when running in a job named "R-CMD-check", since that's where the
+#' testthat artifact is typically uploaded.
 #'
 #' @param repository Repository owner/name, e.g. `"r-lib/testthat"`.
 #' @param run_id Run ID, e.g. `"47905180716"`. You can find this in the action url.
-#' @param dest_dir Directory to download to. Defaults to the current directory.
+#' @param dest_dir Package root directory. Defaults to the current directory.
 #' @export
 snapshot_download_gh <- function(repository, run_id, dest_dir = ".") {
   check_string(repository)

R/snapshot-reporter.R

@@ -135,7 +135,7 @@ SnapshotReporter <- R6::R6Class(
       save_path <- paste0(c(self$file, variant, name), collapse = "/")
       if (save_path %in% self$snap_file_saved) {
         cli::cli_abort(
-          "Snapshot file names must be unique. {.arg name} has already been used.",
+          "Snapshot file names must be unique. {.val {name}} has already been used.",
           call = trace_env
         )
       }

R/snapshot.R

@@ -185,12 +185,22 @@ snapshot_replay.condition <- function(
   }
 
   if (cnd_class) {
-    type <- paste0(type, " <", class(x)[[1]], ">")
+    type <- paste0(type, " <", error_class(x), ">")
   }
 
   c(snap_header(state, type), snapshot_lines(msg, transform))
 }
 
+error_class <- function(x) {
+  # If error was entraced from base R error, use original error class
+  # This is a little fragile because entrace() does not document this behaviour
+  if (inherits(x, "rlang_error") && !is.null(x$error)) {
+    x <- x$error
+  }
+  class(x)[[1]]
+}
+
+
 snapshot_lines <- function(x, transform = NULL) {
   x <- split_lines(x)
   if (!is.null(transform)) {