diff --git a/R/describe.R b/R/describe.R index 5a3300062..ee8604895 100644 --- a/R/describe.R +++ b/R/describe.R @@ -58,17 +58,21 @@ #' }) #' }) describe <- function(description, code) { - local_description_push(description) + for (desc in eval(description)) { + local_description_push(desc) - code <- substitute(code) - test_code(code, parent.frame()) + code <- substitute(code) + test_code(code, parent.frame()) + } } #' @export #' @rdname describe it <- function(description, code = NULL) { - local_description_push(description) + for (desc in eval(description)) { + local_description_push(desc) - code <- substitute(code) - test_code(code, parent.frame()) + code <- substitute(code) + test_code(code, parent.frame()) + } } diff --git a/R/source.R b/R/source.R index 3c069d9f9..427de0906 100644 --- a/R/source.R +++ b/R/source.R @@ -24,6 +24,12 @@ source_file <- function( shuffle = FALSE, error_call = caller_env() ) { + old_description <- the$description + the$description <- character() + withr::defer(the$description <- old_description) + if (!is.null(desc)) { + the$selected_description <- desc + } check_string(path, call = error_call) if (!file.exists(path)) { cli::cli_abort("{.arg path} does not exist.", call = error_call) @@ -49,7 +55,6 @@ source_file <- function( if (shuffle) { exprs <- sample(exprs) } - exprs <- filter_desc(exprs, desc, error_call = error_call) n <- length(exprs) if (n == 0L) { @@ -82,38 +87,6 @@ source_file <- function( } } -filter_desc <- function(exprs, descs, error_call = caller_env()) { - if (length(descs) == 0) { - return(exprs) - } - desc <- 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 description {.str {desc}}.", - call = error_call - ) - } else if (length(matching_idx) > 1) { - cli::cli_abort( - "Found multiple tests with description {.str {desc}}.", - call = error_call - ) - } - - # 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 - ) - exprs[keep_idx] -} - is_subtest <- function(expr) { is_call(expr, c("test_that", "describe", "it"), n = 2) && is_string(expr[[2]]) } diff --git a/R/test-that.R b/R/test-that.R index 1308976ff..59cd107ce 100644 --- a/R/test-that.R +++ b/R/test-that.R @@ -33,16 +33,41 @@ #' expect_equal(sin(pi / 4), 1) #' }) #' } -test_that <- function(desc, code) { - local_description_push(desc) +test_that <- function(description, code) { + for (desc in eval(description)) { + local_description_push(desc) - code <- substitute(code) - test_code(code, parent.frame()) + code <- substitute(code) + test_code(code, parent.frame()) + } +} + +vgrepl <- function(x, pattern, ...) { + if (length(pattern) != length(x)) stop("pattern and x must have the same length") + mapply(function(p, s) grepl(p, s, ...), pattern, x, USE.NAMES = FALSE) +} + +# This utility function checks if the left vector of labels is a prefix of the +# right vector of labels. +is_prefix <- function(a, b) { + if (length(a) == 0 || length(b) == 0) { + TRUE + } else if (length(a) <= length(b)) { + all(vgrepl(a, head(b, length(a)))) + } else { + all(vgrepl(b, head(a, length(b)))) + } } # Access error fields with `[[` rather than `$` because the # `$.Throwable` from the rJava package throws with unknown fields test_code <- function(code, env, reporter = NULL, skip_on_empty = TRUE) { + + # Check if the selected descriptions match the current stack + check <- !is_prefix(the$description, the$selected_description) + if (check) { + return() + } # Must initialise interactive reporter before local_test_context() reporter <- get_reporter() %||% local_interactive_reporter() local_test_context() diff --git a/R/testthat-package.R b/R/testthat-package.R index 61fa9b316..3cbab2c9c 100644 --- a/R/testthat-package.R +++ b/R/testthat-package.R @@ -20,6 +20,7 @@ NULL the <- new.env(parent = emptyenv()) the$description <- character() +the$selected_description <- character() the$top_level_test <- TRUE the$test_expectations <- 0 the$in_check_reporter <- FALSE diff --git a/tests/testthat/_snaps/source.md b/tests/testthat/_snaps/source.md deleted file mode 100644 index 9b78894f7..000000000 --- a/tests/testthat/_snaps/source.md +++ /dev/null @@ -1,58 +0,0 @@ -# source_file wraps error - - Code - source_file(test_path("reporters/error-setup.R"), wrap = FALSE) - Condition - Error: - ! Failed to evaluate 'reporters/error-setup.R'. - Caused by error in `h()`: - ! ! - -# checks its inputs - - Code - source_file(1) - Condition - Error: - ! `path` must be a single string, not the number 1. - Code - source_file("x") - Condition - Error: - ! `path` does not exist. - Code - source_file(".", "x") - Condition - Error: - ! `env` must be an environment, not the string "x". - -# works on code like the describe() example - - Code - filter_desc(code, c("math library", "division()", "can handle division by 0")) - Condition - Error: - ! Failed to find test with description "can handle division by 0". - -# preserve srcrefs - - Code - filter_desc(code, "foo") - Output - expression(test_that("foo", { - # this is a comment - })) - -# errors if zero or duplicate labels - - Code - filter_desc(code, "baz") - Condition - Error: - ! 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/test-source.R b/tests/testthat/test-source.R index 395e5bd27..f3fbf3178 100644 --- a/tests/testthat/test-source.R +++ b/tests/testthat/test-source.R @@ -82,134 +82,6 @@ test_that("checks its inputs", { }) }) -# filter_desc ------------------------------------------------------------- - -test_that("works with all subtest 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("only returns non-subtest code before subtest", { - code <- exprs( - f(), - test_that("bar", {}), - describe("foo", {}), - g(), - h() - ) - expect_equal(filter_desc(code, "foo"), code[c(1, 3)]) -}) - -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("works on code like the describe() example", { - code <- exprs( - describe("math library", { - x1 <- 1 - x2 <- 1 - describe("addition()", { - it("can add two numbers", { - expect_equal(x1 + x2, addition(x1, x2)) - }) - }) - describe("division()", { - x1 <- 10 - x2 <- 2 - it("can divide two numbers", { - expect_equal(x1 / x2, division(x1, x2)) - }) - it("can handle division by 0") #not yet implemented - }) - }) - ) - - expect_equal( - filter_desc( - code, - c("math library", "division()", "can divide two numbers") - ), - exprs( - describe("math library", { - x1 <- 1 - x2 <- 1 - describe("division()", { - x1 <- 10 - x2 <- 2 - it("can divide two numbers", { - expect_equal(x1 / x2, division(x1, x2)) - }) - }) - }) - ) - ) - - # what happens for an unimplemented specification? - expect_snapshot( - error = TRUE, - filter_desc( - code, - c("math library", "division()", "can handle division by 0") - ) - ) -}) - -test_that("preserve srcrefs", { - code <- parse( - keep.source = TRUE, - text = ' - test_that("foo", { - # this is a comment - }) - ' - ) - expect_snapshot(filter_desc(code, "foo")) -}) - -test_that("errors if zero or duplicate labels", { - code <- exprs( - f(), - test_that("baz", {}), - test_that("baz", {}), - g() - ) - - expect_snapshot(error = TRUE, { - filter_desc(code, "baz") - filter_desc(code, "missing") - }) -}) - test_that("source_dir()", { res <- source_dir("test_dir", pattern = "hello", chdir = TRUE, wrap = FALSE) expect_equal(res[[1]](), "Hello World") @@ -233,3 +105,14 @@ test_that("source_dir()", { ) expect_equal(res[[1]](), "Hello World") }) + +test_that("source_file selects correct descriptions", { + reporter <- CheckReporter$new() + with_reporter(reporter, { + source_file("/home/kubajal/development/testthat/tests/testthat/test_dir/test-desc.R", desc = c("math library", "addition|division", "works for 4 and (1|7)"), wrap = FALSE) + }) + expect_equal(reporter$problems$size(), 1) + expect_equal(reporter$skips$size(), 1) + expect_equal(reporter$n_ok, 3) +}) + diff --git a/tests/testthat/test_dir/test-desc.R b/tests/testthat/test_dir/test-desc.R new file mode 100644 index 000000000..24bd927ed --- /dev/null +++ b/tests/testthat/test_dir/test-desc.R @@ -0,0 +1,42 @@ + +addition <- function(a, b) { a + b } +division <- function(a, b) { + if (b == 1) { + 100 + } else if (b != 0) { + a / b + } else { + NULL + } +} + +describe("math library", { + x1 <- 1 + x2 <- 1 + describe("addition()", { + for (i in seq(1, 10)) { + for (j in seq(1, 10)) { + it(paste0("works for ", i, " and ", j), { + expect_equal(addition(i, j), i + j) + }) + } + } + }) + describe("division()", { + x1 <- 10 + x2 <- 2 + for (i in seq(1, 10)) { + for (j in seq(1, 10)) { + if (i == 4 && j == 7) { + skip() + } + it(paste0("works for ", i, " and ", j), { + expect_equal(division(i, j), i / j) + }) + } + } + it("can handle division by 0", { + expect_null(division(x1, 0)) + }) + }) +}) \ No newline at end of file