Merged origin/main into slow-reporter

Author: hadley

.claude/settings.local.json

@@ -1,10 +1,12 @@
 {
+  "$schema": "https://json.schemastore.org/claude-code-settings.json",
   "permissions": {
     "allow": [
       "Bash(find:*)",
-      "Bash(R:*)"
+      "Bash(R:*)",
+      "Bash(rm:*)",
+      "Bash(air format:*)"
     ],
     "deny": []
-  },
-  "$schema": "https://json.schemastore.org/claude-code-settings.json"
-}
+  }
+}

CLAUDE.md

@@ -16,6 +16,7 @@ General advice:
 
 - `devtools::test()` - Run all tests
 - `devtools::test_file("tests/testthat/test-filename.R")` - Run tests in a specific file
+- DO NOT USE `devtools::test_active_file()`
 - `devtools::load_all()` - Load package for development
 - `devtools::check()` - Run R CMD check
 - `devtools::install()` - Install package locally

NEWS.md

@@ -1,7 +1,13 @@
 # testthat (development version)
 
+* Parallel testthat now does not ignore test files with syntax errors (#1360).
+* `expect_lt()`, `expect_gt()`, and friends have a refined display that is more likely to display the correct number of digits and shows you the actual values compared.
+* `describe()`, `it()`, and `test_that()` now have a shared stack of descriptions so that if you nest any inside of each other, any resulting failures will show you the full path.
+* `describe()` now correctly scopes `skip()` (#2007).
+* `ParallelProgressReporter` now respect `max_failures` (#1162).
+* The last snapshot is no longer lost if the snapshot file is missing the final newline (#2092). It's easy to accidentally remove this because there are two trailing new lines in snapshot files and many editors will automatically remove if you touch the file.
 * New `expect_r6_class()` (#2030).
-* `expect_*()` functions consistently and rigorously check their inputs (#1754). 
+* `expect_*()` functions consistently and rigorously check their inputs (#1754).
 * `JunitReporter()` no longer fails with `"no applicable method for xml_add_child"` for warnings outside of tests (#1913). Additionally, warnings now save their backtraces.
 * `JunitReporter()` strips ANSI escapes in more placese (#1852, #2032).
 * `try_again()` is now publicised. The first argument is now the number of retries, not tries (#2050).

R/describe.R

@@ -56,43 +56,17 @@
 #'     it("can handle division by 0") #not yet implemented
 #'   })
 #' })
-
 describe <- function(description, code) {
-  check_string(description, allow_empty = FALSE)
-  describe_description <- description
-
-  # prepares a new environment for each it-block
-  describe_environment <- new.env(parent = parent.frame())
-  describe_environment$it <- function(description, code = NULL) {
-    check_string(description, allow_empty = FALSE)
-    code <- substitute(code)
-
-    description <- paste0(describe_description, ": ", description)
-    describe_it(description, code, describe_environment)
-  }
-
-  eval(substitute(code), describe_environment)
-  invisible()
-}
-
-describe_it <- function(description, code, env = parent.frame()) {
-  reporter <- get_reporter() %||% local_interactive_reporter()
-  local_test_context()
+  local_description_push(description)
 
-  test_code(
-    description,
-    code,
-    env = env,
-    reporter = reporter,
-    skip_on_empty = FALSE
-  )
+  test_code(code, parent.frame(), skip_on_empty = FALSE)
 }
 
 #' @export
 #' @rdname describe
 it <- function(description, code = NULL) {
-  check_string(description, allow_empty = FALSE)
+  local_description_push(description)
 
   code <- substitute(code)
-  describe_it(description, code, env = parent.frame())
+  test_code(code, env = parent.frame(), skip_on_empty = FALSE)
 }

R/expect-comparison.R

@@ -31,21 +31,31 @@ expect_compare_ <- function(
   msg <- c(
     "<" = "not strictly less than",
     "<=" = "not less than",
-    ">" = "not strictly more than",
-    ">=" = "not more than"
+    ">" = "not strictly greater than",
+    ">=" = "not greater than"
   )[[operator]]
 
+  negated_op <- switch(operator, "<" = ">=", "<=" = ">", ">" = "<=", ">=" = "<")
+
   cmp <- op(act$val, exp$val)
   if (length(cmp) != 1 || !is.logical(cmp)) {
     abort("Result of comparison must be a single logical value")
   }
   if (!isTRUE(cmp)) {
+    digits <- max(
+      digits(act$val),
+      digits(exp$val),
+      min_digits(act$val, exp$val)
+    )
     msg <- sprintf(
-      "%s is %s %s. Difference: %.3g",
+      "%s is %s %s.\n%s - %s = %s %s 0",
       act$lab,
       msg,
       exp$lab,
-      act$val - exp$val
+      num_exact(act$val, digits),
+      num_exact(exp$val, digits),
+      num_exact(act$val - exp$val, digits),
+      negated_op
     )
     return(fail(msg, trace_env = trace_env))
   }
@@ -109,3 +119,39 @@ expect_more_than <- function(...) {
   warning("Deprecated: please use `expect_gt()` instead", call. = FALSE)
   expect_gt(...)
 }
+
+
+# Helpers -----------------------------------------------------------------
+
+num_exact <- function(x, digits = 6) {
+  sprintf(paste0("%0.", digits, "f"), x)
+}
+
+min_digits <- function(x, y, tolerance = testthat_tolerance()) {
+  if (is.integer(x) && is.integer(y)) {
+    return(0L)
+  }
+
+  attributes(x) <- NULL
+  attributes(y) <- NULL
+
+  n <- digits(abs(x - y))
+  if (!is.null(tolerance)) {
+    n <- min(n, digits(tolerance))
+  }
+
+  as.integer(n) + 1L
+}
+
+digits <- function(x) {
+  x <- x[!is.na(x) & x != 0]
+  if (length(x) == 0) {
+    return(0)
+  }
+  scale <- -log10(min(x))
+  if (scale <= 0) {
+    0L
+  } else {
+    ceiling(round(scale, digits = 2))
+  }
+}

R/expect-inheritance.R

@@ -20,16 +20,17 @@
 #' See [expect_vector()] for testing properties of objects created by vctrs.
 #'
 #' @param type String giving base type (as returned by [typeof()]).
-#' @param class
-#'  * `expect_type()`: a single string giving an R base type.
-#'  * `expect_s3_class()`: a character vector of class names or `NA` to assert
-#'    that `object` isn't an S3 object. If you provide multiple class names,
-#'    the test will pass if `object` inherits from any of them, unless
-#'    `exact = TRUE`.
-#'  * `expect_s4_class()`: a character vector of class names or `NA` to assert
-#'    that `object` isn't an S4 object.
-#'  * `expect_r6_class()`: a string.
-#'  * `expect_s7_class()`: an [S7::S7_class()] object.
+#' @param class The required type varies depending on the function:
+#'   * `expect_type()`: a string.
+#'   * `expect_s3_class()`: a string or character vector. The behaviour of
+#'     multiple values (i.e. a character vector) is controlled by the
+#'     `exact` argument.
+#'   * `expect_s4_class()`: a string.
+#'   * `expect_r6_class()`: a string.
+#'   * `expect_s7_class()`: an [S7::S7_class()] object.
+#'
+#'   For historical reasons, `expect_s3_class()` and `expect_s4_class()` also
+#'   take `NA` to assert that the `object` is not an S3 or S4 object.
 #' @inheritParams expect_that
 #' @family expectations
 #' @examples
@@ -85,7 +86,7 @@ expect_type <- function(object, type) {
 #' @rdname inheritance-expectations
 #' @param exact If `FALSE`, the default, checks that `object` inherits
 #'   from any element of `class`. If `TRUE`, checks that object has a class
-#'   that's identical to `class`.
+#'   that exactly matches `class`.
 expect_s3_class <- function(object, class, exact = FALSE) {
   check_bool(exact)
 

R/parallel-taskq.R

@@ -78,6 +78,9 @@ task_q <- R6::R6Class(
             private$tasks$state[[i]] <- "ready"
             msg <- NULL
           } else if (msg$code == PROCESS_DONE) {
+            if (!is.null(msg$error)) {
+              private$handle_error(msg, i)
+            }
             private$tasks$state[[i]] <- "ready"
           } else if (msg$code %in% PROCESS_FAILURES) {
             private$handle_error(msg, i)

R/reporter-progress.R

@@ -221,16 +221,20 @@ ProgressReporter <- R6::R6Class(
       self$report_issues(self$ctxt_issues)
 
       if (self$is_full()) {
-        snapshotter <- get_snapshotter()
-        if (!is.null(snapshotter)) {
-          snapshotter$end_file()
-        }
+        self$report_full()
+      }
+    },
 
-        stop_reporter(c(
-          "Maximum number of failures exceeded; quitting at end of file.",
-          i = "Increase this number with (e.g.) {.run testthat::set_max_fails(Inf)}"
-        ))
+    report_full = function() {
+      snapshotter <- get_snapshotter()
+      if (!is.null(snapshotter)) {
+        snapshotter$end_file()
       }
+
+      stop_reporter(c(
+        "Maximum number of failures exceeded; quitting at end of file.",
+        i = "Increase this number with (e.g.) {.run testthat::set_max_fails(Inf)}"
+      ))
     },
 
     add_result = function(context, test, result) {
@@ -258,6 +262,10 @@ ProgressReporter <- R6::R6Class(
     },
 
     end_reporter = function() {
+      if (self$is_full()) {
+        return()
+      }
+
       self$cat_line()
 
       colour_if <- function(n, type) {
@@ -465,7 +473,13 @@ ParallelProgressReporter <- R6::R6Class(
       self$report_issues(fsts$issues)
 
       self$files[[self$file_name]] <- NULL
-      if (length(self$files)) self$update(force = TRUE)
+      if (length(self$files)) {
+        self$update(force = TRUE)
+      }
+
+      if (self$is_full()) {
+        self$report_full()
+      }
     },
 
     end_reporter = function() {

R/reporter-silent.R

@@ -28,3 +28,11 @@ SilentReporter <- R6::R6Class(
     }
   )
 )
+
+# Useful for testing test_that() and friends which otherwise swallow
+# all expectations by design
+capture_expectations <- function(code) {
+  reporter <- SilentReporter$new()
+  with_reporter(reporter, code)
+  reporter$expectations()
+}

R/reporter-zzz.R

@@ -36,6 +36,8 @@ get_reporter <- function() {
 #' @rdname reporter-accessors
 #' @export
 with_reporter <- function(reporter, code, start_end_reporter = TRUE) {
+  # Ensure we don't propagate the local description to the new reporter
+  local_description_set()
   reporter <- find_reporter(reporter)
 
   old <- set_reporter(reporter)