Replaced filter_desc with dynamic label checking

Author: kubajal

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())
+  }
 }

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]])
 }

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()

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

tests/testthat/_snaps/source.md

@@ -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)
+})
+

tests/testthat/test-source.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))
+    })
+  })
+})