Use a desription stack

Author: hadley

.claude/settings.local.json

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

NEWS.md

@@ -1,5 +1,7 @@
 # testthat (development version)
 
+* `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).
 * `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/describe.R

@@ -56,29 +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_env <- new.env(parent = parent.frame())
-  describe_env$it <- function(description, code = NULL) {
-    check_string(description, allow_empty = FALSE)
-    description <- paste0(describe_description, ": ", description)
-
-    code <- substitute(code)
-    test_code(description, code, env = describe_env, skip_on_empty = FALSE)
-  }
+  local_description_push(description)
 
-  test_code(description, code, describe_env, 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)
-  test_code(description, code, env = parent.frame(), skip_on_empty = FALSE)
+  test_code(code, env = parent.frame(), skip_on_empty = FALSE)
 }

R/expect-self-test.R

@@ -158,6 +158,7 @@ expect_snapshot_reporter <- function(
   reporter,
   paths = test_path("reporters/tests.R")
 ) {
+
   local_options(rlang_trace_format_srcrefs = FALSE)
   withr::local_seed(1014)
 

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)

R/snapshot-reporter.R

@@ -35,9 +35,11 @@ SnapshotReporter <- R6::R6Class(
     },
 
     start_test = function(context, test) {
-      if (is.character(test)) {
-        self$test <- gsub("\n", "", test)
+      if (is.null(test)) {
+        return()
       }
+
+      self$test <- paste0(gsub("\n", "", test), collapse = " / ")
     },
 
     # Called by expectation

R/source.R

@@ -55,7 +55,6 @@ source_file <- function(
   withr::local_options(testthat_topenv = env, testthat_path = path)
   if (wrap) {
     invisible(test_code(
-      test = NULL,
       code = exprs,
       env = env,
       reporter = get_reporter() %||% StopReporter$new()

R/test-example.R

@@ -47,24 +47,23 @@ test_examples_installed <- function(package = testing_package()) {
 #' @export
 #' @rdname test_examples
 test_rd <- function(rd, title = attr(rd, "Rdfile")) {
-  test_example(rd, title)
+  test_example(rd, title %||% "example")
 }
 
 #' @export
 #' @rdname test_examples
 test_example <- function(path, title = path) {
+  local_description_push(title)
+
   ex_path <- withr::local_tempfile(pattern = "test_example-", fileext = ".R")
   tools::Rd2ex(path, ex_path)
   if (!file.exists(ex_path)) {
     return(invisible(FALSE))
   }
 
-  env <- new.env(parent = globalenv())
-
   ok <- test_code(
-    test = title,
     code = parse(ex_path, encoding = "UTF-8"),
-    env = env,
+    env = globalenv(),
     reporter = get_reporter() %||% StopReporter$new(),
     skip_on_empty = FALSE
   )

R/test-that.R

@@ -34,7 +34,7 @@
 #' })
 #' }
 test_that <- function(desc, code) {
-  check_string(desc)
+  local_description_push(desc)
 
   code <- substitute(code)
   if (edition_get() >= 3) {
@@ -46,18 +46,19 @@ test_that <- function(desc, code) {
     }
   }
 
-  test_code(desc, code, env = parent.frame())
+  test_code(code, env = parent.frame())
 }
 
 # Access error fields with `[[` rather than `$` because the
 # `$.Throwable` from the rJava package throws with unknown fields
-test_code <- function(test, code, env, reporter = NULL, skip_on_empty = TRUE) {
+test_code <- function(code, env, reporter = NULL, skip_on_empty = TRUE) {
   # Must initialise interactive reporter before local_test_context()
   reporter <- get_reporter() %||% local_interactive_reporter()
   local_test_context()
 
   frame <- caller_env()
 
+  test <- test_description()
   if (!is.null(test)) {
     reporter$start_test(context = reporter$.context, test = test)
     withr::defer(reporter$end_test(context = reporter$.context, test = test))
@@ -210,3 +211,30 @@ test_code <- function(test, code, env, reporter = NULL, skip_on_empty = TRUE) {
 
   invisible(ok)
 }
+
+
+# Maintain a stack of descriptions
+local_description_push <- function(description, frame = caller_env()) {
+  check_string(description, call = frame)
+  local_description_set(c(the$description, description), frame = frame)
+}
+local_description_set <- function(
+  description = character(),
+  frame = caller_env()
+) {
+  check_character(description, call = frame)
+
+  old <- the$description
+  the$description <- description
+  withr::defer(the$description <- old, frame)
+
+  invisible(old)
+}
+
+test_description <- function() {
+  if (length(the$description) == 0) {
+    NULL
+  } else {
+    paste(the$description, collapse = " / ")
+  }
+}

R/testthat-package.R

@@ -19,7 +19,7 @@
 NULL
 
 the <- new.env(parent = emptyenv())
-
+the$description <- character()
 
 # The following block is used by usethis to automatically manage
 # roxygen namespace tags. Modify with care!