Merge commit '387a9fcde9e3391d80b9d1f669938c8200c818dc'

Author: hadley

.claude/settings.local.json

@@ -4,8 +4,9 @@
     "allow": [
       "Bash(find:*)",
       "Bash(R:*)",
+      "Bash(rm:*)",
       "Bash(air format:*)"
     ],
     "deny": []
   }
-}
+}

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::document()` - Generate documentation
 - `devtools::check()` - Run R CMD check

NAMESPACE

@@ -114,6 +114,7 @@ export(expect_no_warning)
 export(expect_null)
 export(expect_output)
 export(expect_output_file)
+export(expect_r6_class)
 export(expect_reference)
 export(expect_s3_class)
 export(expect_s4_class)

NEWS.md

@@ -2,6 +2,9 @@
 
 * `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). 
 * `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).

R/expect-inheritance.R

@@ -12,21 +12,25 @@
 #' * `expect_s4_class(x, class)` checks that `x` is an S4 object that
 #'   [is()] `class`.
 #' * `expect_s4_class(x, NA)` checks that `x` isn't an S4 object.
+#' * `expect_r6_class(x, class)` checks that `x` an R6 object that
+#'   inherits from `class`.
 #' * `expect_s7_class(x, Class)` checks that `x` is an S7 object that
 #'   [S7::S7_inherits()] from `Class`
 #'
 #' 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_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
@@ -82,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)
 
@@ -154,6 +158,26 @@ expect_s4_class <- function(object, class) {
   pass(act$val)
 }
 
+#' @export
+#' @rdname inheritance-expectations
+expect_r6_class <- function(object, class) {
+  act <- quasi_label(enquo(object))
+  check_string(class)
+
+  if (!inherits(act$val, "R6")) {
+    return(fail(sprintf("%s is not an R6 object.", act$lab)))
+  }
+
+  if (!inherits(act$val, class)) {
+    act_class <- format_class(class(act$val))
+    exp_class <- format_class(class)
+    msg <- sprintf("%s inherits from %s not %s.", act$lab, act_class, exp_class)
+    return(fail(msg))
+  }
+
+  pass(act$val)
+}
+
 #' @export
 #' @rdname inheritance-expectations
 expect_s7_class <- function(object, class) {

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/snapshot-serialize.R

@@ -19,9 +19,13 @@ snap_from_md <- function(lines) {
     sep <- grepl("^-{3,}", lines)
     case_group <- cumsum(sep)
 
-    # Remove first line and last line, separator, line above and line below
+    # Remove first line, separator, line above and line below
+    # Only remove last line if it's empty (to handle missing final newlines)
     sep_loc <- which(sep)
-    drop <- c(1, sep_loc, sep_loc + 1, sep_loc - 1, length(lines))
+    drop <- c(1, sep_loc, sep_loc + 1, sep_loc - 1)
+    if (length(lines) > 0 && lines[length(lines)] == "") {
+      drop <- c(drop, length(lines))
+    }
 
     cases <- unname(split(lines[-drop], case_group[-drop]))
     code_unblock <- function(x) paste0(indent_del(x), collapse = "\n")

R/utils.R

@@ -37,7 +37,13 @@ rstudio_tickle <- function() {
   }
 
   rstudioapi::executeCommand("vcsRefresh")
-  rstudioapi::executeCommand("refreshFiles")
+  if (!is_positron()) {
+    rstudioapi::executeCommand("refreshFiles")
+  }
+}
+
+is_positron <- function() {
+  nzchar(Sys.getenv("POSITRON", ""))
 }
 
 first_upper <- function(x) {

man/inheritance-expectations.Rd

@@ -47,6 +47,18 @@
 
     `x` inherits from 'a'/'b' not 'c'/'d'.
 
+# expect_r6_class generates useful failures
+
+    `x` is not an R6 object.
+
+# expect_r6_class validates its inputs
+
+    Code
+      expect_r6_class(1, c("Person", "Student"))
+    Condition
+      Error in `expect_r6_class()`:
+      ! `class` must be a single string, not a character vector.
+
 # can check with actual class
 
     Foo() inherits from <Foo> not <Bar>.