From c04eb3d5e39350f4caeab3e6ab2d82c9618789cc Mon Sep 17 00:00:00 2001 From: Kuba Jalowiec Date: Fri, 1 Aug 2025 18:40:12 +0200 Subject: [PATCH 1/3] Implemented selection of deeply nested tests --- R/source.R | 72 +++++++++++++++++++++--------------- tests/testthat/test-source.R | 70 +++++++++++++++++++++++++++++++++++ 2 files changed, 113 insertions(+), 29 deletions(-) diff --git a/R/source.R b/R/source.R index 56c91f2bd..92712df03 100644 --- a/R/source.R +++ b/R/source.R @@ -73,43 +73,57 @@ filter_desc <- function(exprs, desc = NULL, error_call = caller_env()) { if (is.null(desc)) { return(exprs) } + desc_levels <- if (is.list(desc)) { + desc + } else { + as.list(desc) + } - found <- FALSE - include <- rep(FALSE, length(exprs)) - - for (i in seq_along(exprs)) { - expr <- exprs[[i]] - - if (!is_call(expr, c("test_that", "describe"), n = 2)) { - if (!found) { - include[[i]] <- TRUE - } + find_matching_expr <- function(exprs, queue) { + if (length(queue) == 0) { + exprs } else { - if (!is_string(expr[[2]])) { - next + found <- FALSE + include <- rep(FALSE, length(exprs)) + desc <- queue[[1]] + + for (i in seq_along(exprs)) { + expr <- exprs[[i]] + + if (!is_call(expr, c("test_that", "describe", "it"), n = 2)) { + if (!found) { + include[[i]] <- TRUE + } + } else { + if (!is_string(expr[[2]])) { + next + } + + test_desc <- as.character(expr[[2]]) + if (test_desc != desc) { + next + } + + if (found) { + abort( + "Found multiple tests with specified description", + call = error_call + ) + } + include[[i]] <- TRUE + found <- TRUE + exprs[[i]][[3]] <- find_matching_expr(expr[[3]], queue[-1]) + } } - test_desc <- as.character(expr[[2]]) - if (test_desc != desc) { - next + if (!found) { + abort("Failed to find test with specified description", call = error_call) } - if (found) { - abort( - "Found multiple tests with specified description", - call = error_call - ) - } - include[[i]] <- TRUE - found <- TRUE + exprs[include] } } - - if (!found) { - abort("Failed to find test with specified description", call = error_call) - } - - exprs[include] + find_matching_expr(exprs, desc_levels) } #' @rdname source_file diff --git a/tests/testthat/test-source.R b/tests/testthat/test-source.R index a7b33b140..896fb7b2a 100644 --- a/tests/testthat/test-source.R +++ b/tests/testthat/test-source.R @@ -137,3 +137,73 @@ 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_desc(code, c("level 0", "level 1 A", "level 2 B", "level 3 C")), expected) +}) From 560dd012fc1f452cf622805e5c599afc605f3ac6 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 6 Aug 2025 09:41:52 -0500 Subject: [PATCH 2/3] WIP --- R/source.R | 83 ++++++++++++----------------- tests/testthat/_snaps/source.new.md | 18 +++++++ tests/testthat/test-source.R | 11 ++-- 3 files changed, 58 insertions(+), 54 deletions(-) create mode 100644 tests/testthat/_snaps/source.new.md diff --git a/R/source.R b/R/source.R index 92712df03..8af55bde9 100644 --- a/R/source.R +++ b/R/source.R @@ -21,6 +21,7 @@ source_file <- function( ) { stopifnot(file.exists(path)) stopifnot(is.environment(env)) + check_character(desc, allow_null = TRUE) lines <- brio::read_lines(path) srcfile <- srcfilecopy( @@ -35,7 +36,7 @@ source_file <- function( con <- textConnection(lines, encoding = "UTF-8") on.exit(try(close(con), silent = TRUE), add = TRUE) exprs <- parse(con, n = -1, srcfile = srcfile, encoding = "UTF-8") - exprs <- filter_desc(exprs, desc, error_call = error_call) + exprs <- filter_subtests(exprs, desc, error_call = error_call) n <- length(exprs) if (n == 0L) { @@ -69,63 +70,45 @@ source_file <- function( } } -filter_desc <- function(exprs, desc = NULL, error_call = caller_env()) { - if (is.null(desc)) { +filter_subtests <- function(exprs, descs, error_call = caller_env()) { + if (length(descs) == 0) { return(exprs) } - desc_levels <- if (is.list(desc)) { - desc - } else { - as.list(desc) - } - find_matching_expr <- function(exprs, queue) { - if (length(queue) == 0) { - exprs - } else { - found <- FALSE - include <- rep(FALSE, length(exprs)) - desc <- queue[[1]] - - for (i in seq_along(exprs)) { - expr <- exprs[[i]] - - if (!is_call(expr, c("test_that", "describe", "it"), n = 2)) { - if (!found) { - include[[i]] <- TRUE - } - } else { - if (!is_string(expr[[2]])) { - next - } - - test_desc <- as.character(expr[[2]]) - if (test_desc != desc) { - next - } - - if (found) { - abort( - "Found multiple tests with specified description", - call = error_call - ) - } - include[[i]] <- TRUE - found <- TRUE - exprs[[i]][[3]] <- find_matching_expr(expr[[3]], queue[-1]) - } - } + is_subtest <- unname(map_lgl(exprs, is_subtest)) - if (!found) { - abort("Failed to find test with specified description", call = error_call) - } + subtest_idx <- which(is_subtest) + code_idx <- which(!is_subtest) + matching_idx <- keep(subtest_idx, \(idx) { + exprs[[idx]][[2]] == descs[[1]] + }) - exprs[include] - } + if (length(matching_idx) == 0) { + cli::cli_abort( + "Failed to find test with specified description", + call = error_call + ) + } else if (length(matching_idx) > 1) { + cli::cli_abort( + "Found multiple tests with specified description", + call = error_call + ) } - find_matching_expr(exprs, desc_levels) + + keep_idx <- intersect(seq_along(exprs), c(matching_idx, code_idx)) + exprs[[matching_idx]] <- filter_subtests( + exprs[[matching_idx]], + descs[-1], + error_call = error_call + ) + exprs[keep_idx] } +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( diff --git a/tests/testthat/_snaps/source.new.md b/tests/testthat/_snaps/source.new.md new file mode 100644 index 000000000..5e74546c5 --- /dev/null +++ b/tests/testthat/_snaps/source.new.md @@ -0,0 +1,18 @@ +# source_file wraps error + + Code + source_file(test_path("reporters/error-setup.R"), wrap = FALSE) + Condition + Error: + ! In path: "reporters/error-setup.R" + Caused by error in `h()`: + ! ! + +# errors if duplicate labels + + Code + filter_desc(code, "baz") + Condition + Error in `filter_desc()`: + ! could not find function "filter_desc" + diff --git a/tests/testthat/test-source.R b/tests/testthat/test-source.R index 896fb7b2a..4c7b3ec3f 100644 --- a/tests/testthat/test-source.R +++ b/tests/testthat/test-source.R @@ -85,9 +85,9 @@ test_that("can find only matching test", { describe("bar", {}), h() ) - expect_equal(filter_desc(code, "foo"), code[c(1, 2)]) - expect_equal(filter_desc(code, "bar"), code[c(1, 3, 4)]) - expect_snapshot(filter_desc(code, "baz"), error = TRUE) + 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) }) test_that("preserve srcrefs", { @@ -205,5 +205,8 @@ test_that("you can select deeply nested describe(...)", { }) ) - expect_equal(filter_desc(code, c("level 0", "level 1 A", "level 2 B", "level 3 C")), expected) + expect_equal( + filter_subtests(code, c("level 0", "level 1 A", "level 2 B", "level 3 C")), + expected + ) }) From 2b1a8cac66875e516df0ce7645d365d08570ddc7 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 6 Aug 2025 09:56:49 -0500 Subject: [PATCH 3/3] Re-implement and polish --- NEWS.md | 1 + R/source.R | 31 ++++--- tests/testthat/_snaps/source.md | 17 ++-- tests/testthat/_snaps/source.new.md | 18 ---- tests/testthat/test-source.R | 129 ++++++++++------------------ 5 files changed, 69 insertions(+), 127 deletions(-) delete mode 100644 tests/testthat/_snaps/source.new.md diff --git a/NEWS.md b/NEWS.md index c049ea22e..c4a97ea24 100644 --- a/NEWS.md +++ b/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.) diff --git a/R/source.R b/R/source.R index 785f9266b..fafa00175 100644 --- a/R/source.R +++ b/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( diff --git a/tests/testthat/_snaps/source.md b/tests/testthat/_snaps/source.md index 48519c770..25646a294 100644 --- a/tests/testthat/_snaps/source.md +++ b/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". diff --git a/tests/testthat/_snaps/source.new.md b/tests/testthat/_snaps/source.new.md deleted file mode 100644 index 5e74546c5..000000000 --- a/tests/testthat/_snaps/source.new.md +++ /dev/null @@ -1,18 +0,0 @@ -# source_file wraps error - - Code - source_file(test_path("reporters/error-setup.R"), wrap = FALSE) - Condition - Error: - ! In path: "reporters/error-setup.R" - Caused by error in `h()`: - ! ! - -# errors if duplicate labels - - Code - filter_desc(code, "baz") - Condition - Error in `filter_desc()`: - ! could not find function "filter_desc" - diff --git a/tests/testthat/test-source.R b/tests/testthat/test-source.R index 496a4af5e..9977f4503 100644 --- a/tests/testthat/test-source.R +++ b/tests/testthat/test-source.R @@ -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,8 +144,7 @@ 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", {}), @@ -119,7 +152,10 @@ test_that("errors if duplicate labels", { 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 - ) -})