Re-implement and polish

Author: hadley

NEWS.md

@@ -1,5 +1,6 @@
 # testthat (development version)
 
+* Test filtering now works with `it()`, and the `desc` argument can take a character vector in order to recursively filter subtests (i.e. `it()` nested inside of `describe()`) (#2118).
 * New `SlowReporter` makes it easier to find the slowest tests in your package. The easiest way to run it is with `devtools::test(reporter = "slow")` (#1466).
 * Power `expect_mapequal()` with `waldo::compare(list_as_map = TRUE)` (#1521).
 * On CRAN, `test_that()` now automatically skips if a package is not installed (#1585). Practically, this means that you no longer need to check that suggested packages are installed. (We don't do this in the tidyverse because we think it has limited payoff, but other styles advise differently.)

R/source.R

@@ -5,7 +5,9 @@
 #' @param path Path to files.
 #' @param pattern Regular expression used to filter files.
 #' @param env Environment in which to evaluate code.
-#' @param desc If not-`NULL`, will run only test with this `desc`ription.
+#' @param desc A character vector used to filter tests. This is used to
+#'   (recursively) filter the content of the file, so that only the non-test
+#'   code up to and including the match test is run.
 #' @param chdir Change working directory to `dirname(path)`?
 #' @param wrap Automatically wrap all code within [test_that()]? This ensures
 #'   that all expectations are reported, even if outside a test block.
@@ -41,7 +43,7 @@ source_file <- function(
   con <- textConnection(lines, encoding = "UTF-8")
   withr::defer(try(close(con), silent = TRUE))
   exprs <- parse(con, n = -1, srcfile = srcfile, encoding = "UTF-8")
-  exprs <- filter_subtests(exprs, desc, error_call = error_call)
+  exprs <- filter_desc(exprs, desc, error_call = error_call)
 
   n <- length(exprs)
   if (n == 0L) {
@@ -74,34 +76,32 @@ source_file <- function(
   }
 }
 
-filter_subtests <- function(exprs, descs, error_call = caller_env()) {
+filter_desc <- function(exprs, descs, error_call = caller_env()) {
   if (length(descs) == 0) {
     return(exprs)
   }
+  desc <- descs[[1]]
 
-  is_subtest <- unname(map_lgl(exprs, is_subtest))
-
-  subtest_idx <- which(is_subtest)
-  code_idx <- which(!is_subtest)
-  matching_idx <- keep(subtest_idx, \(idx) {
-    exprs[[idx]][[2]] == descs[[1]]
-  })
+  subtest_idx <- which(unname(map_lgl(exprs, is_subtest)))
 
+  matching_idx <- keep(subtest_idx, \(idx) exprs[[idx]][[2]] == desc)
   if (length(matching_idx) == 0) {
     cli::cli_abort(
-      "Failed to find test with specified description",
+      "Failed to find test with description {.str {desc}}.",
       call = error_call
     )
   } else if (length(matching_idx) > 1) {
     cli::cli_abort(
-      "Found multiple tests with specified description",
+      "Found multiple tests with description {.str {desc}}.",
       call = error_call
     )
   }
 
-  keep_idx <- intersect(seq_along(exprs), c(matching_idx, code_idx))
-  exprs[[matching_idx]] <- filter_subtests(
-    exprs[[matching_idx]],
+  # Want all code up to and including the matching test, except for subtests
+  keep_idx <- setdiff(seq2(1, matching_idx), setdiff(subtest_idx, matching_idx))
+  # Recursively inspect the components of the subtest
+  exprs[[matching_idx]][[3]] <- filter_desc(
+    exprs[[matching_idx]][[3]],
     descs[-1],
     error_call = error_call
   )
@@ -112,7 +112,6 @@ is_subtest <- function(expr) {
   is_call(expr, c("test_that", "describe", "it"), n = 2) && is_string(expr[[2]])
 }
 
-
 #' @rdname source_file
 #' @export
 source_dir <- function(

tests/testthat/_snaps/source.md

@@ -26,14 +26,6 @@
       Error:
       ! `env` must be an environment, not the string "x".
 
-# can find only matching test
-
-    Code
-      filter_desc(code, "baz")
-    Condition
-      Error:
-      ! Failed to find test with specified description
-
 # preserve srcrefs
 
     Code
@@ -43,11 +35,16 @@
             # this is a comment
           }))
 
-# errors if duplicate labels
+# errors if zero or duplicate labels
 
     Code
       filter_desc(code, "baz")
     Condition
       Error:
-      ! Found multiple tests with specified description
+      ! Found multiple tests with description "baz".
+    Code
+      filter_desc(code, "missing")
+    Condition
+      Error:
+      ! Failed to find test with description "missing".
 

tests/testthat/_snaps/source.new.md

@@ -82,20 +82,54 @@ test_that("checks its inputs", {
   })
 })
 
+# filter_desc -------------------------------------------------------------
 
-# filter_label -------------------------------------------------------------
+test_that("works with all tests types", {
+  code <- exprs(
+    test_that("foo", {}),
+    describe("bar", {}),
+    it("baz", {})
+  )
+  expect_equal(filter_desc(code, "foo"), code[1])
+  expect_equal(filter_desc(code, "bar"), code[2])
+  expect_equal(filter_desc(code, "baz"), code[3])
+})
 
-test_that("can find only matching test", {
+test_that("only returns code before subtest", {
   code <- exprs(
     f(),
-    test_that("foo", {}),
+    describe("foo", {}),
     g(),
-    describe("bar", {}),
     h()
   )
-  expect_equal(filter_subtests(code, "foo"), code[c(1, 2)])
-  expect_equal(filter_subtests(code, "bar"), code[c(1, 3, 4)])
-  expect_snapshot(filter_subtests(code, "baz"), error = TRUE)
+  expect_equal(filter_desc(code, "foo"), code[c(1, 2)])
+})
+
+test_that("can select recursively", {
+  code <- exprs(
+    x <- 1,
+    describe("a", {
+      y <- 1
+      describe("b", {
+        z <- 1
+      })
+      y <- 2
+    }),
+    x <- 2
+  )
+
+  expect_equal(
+    filter_desc(code, c("a", "b")),
+    exprs(
+      x <- 1,
+      describe("a", {
+        y <- 1
+        describe("b", {
+          z <- 1
+        })
+      })
+    )
+  )
 })
 
 test_that("preserve srcrefs", {
@@ -110,16 +144,18 @@ test_that("preserve srcrefs", {
   expect_snapshot(filter_desc(code, "foo"))
 })
 
-
-test_that("errors if duplicate labels", {
+test_that("errors if zero or duplicate labels", {
   code <- exprs(
     f(),
     test_that("baz", {}),
     test_that("baz", {}),
     g()
   )
 
-  expect_snapshot(filter_desc(code, "baz"), error = TRUE)
+  expect_snapshot(error = TRUE, {
+    filter_desc(code, "baz")
+    filter_desc(code, "missing")
+  })
 })
 
 test_that("source_dir()", {
@@ -145,76 +181,3 @@ test_that("source_dir()", {
   )
   expect_equal(res[[1]](), "Hello World")
 })
-
-test_that("you can select deeply nested describe(...)", {
-  code <- exprs(
-    f(),
-    describe("level 0", {
-      g()
-      describe("level 1 A", {
-        h()
-        describe("level 2 A", {
-          i()
-          it("level 3 A", {
-            expect_equal(1, 1)
-          })
-          j()
-        })
-        k()
-        describe("level 2 B", {
-          l()
-          it("level 3 B", {
-            o()
-            expect_equal(1, 1)
-            p()
-          })
-          m()
-          it("level 3 C", {
-            o()
-            expect_equal(1, 1)
-            p()
-          })
-          n()
-          it("level 3 D", {
-            expect_equal(1, 1)
-          })
-          o()
-        })
-        p()
-        describe("level 2 C", {
-          expect_equal(1, 1)
-        })
-        r()
-      })
-      s()
-      describe("level 1 B", {})
-      t()
-    }),
-    x()
-  )
-
-  expected <- exprs(
-    f(),
-    describe("level 0", {
-      g()
-      describe("level 1 A", {
-        h()
-        k()
-        describe("level 2 B", {
-          l()
-          m()
-          it("level 3 C", {
-            o()
-            expect_equal(1, 1)
-            p()
-          })
-        })
-      })
-    })
-  )
-
-  expect_equal(
-    filter_subtests(code, c("level 0", "level 1 A", "level 2 B", "level 3 C")),
-    expected
-  )
-})