Run a single test (#1840)

Fixes #1776

Author: hadley

NEWS.md

@@ -1,5 +1,8 @@
 # testthat (development version)
 
+* `test_file()` gains a `desc` argument which allows you to run a single 
+  test from a file (#1776).
+
 * `expect_setequal()` correctly displays results when only one of actual and
   expected is missing values (#1835).
 

R/source.R

@@ -5,13 +5,18 @@
 #' @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 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.
 #' @export
 #' @keywords internal
-source_file <- function(path, env = test_env(), chdir = TRUE,
-                        wrap = TRUE) {
+source_file <- function(path,
+                        env = test_env(),
+                        chdir = TRUE,
+                        desc = NULL,
+                        wrap = TRUE,
+                        error_call = caller_env()) {
   stopifnot(file.exists(path))
   stopifnot(is.environment(env))
 
@@ -23,6 +28,7 @@ source_file <- function(path, env = test_env(), chdir = TRUE,
   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)
 
   n <- length(exprs)
   if (n == 0L) return(invisible())
@@ -46,13 +52,52 @@ source_file <- function(path, env = test_env(), chdir = TRUE,
       error = function(err) {
         abort(
           paste0("In path: ", encodeString(path, quote = '"')),
-          parent = err
+          parent = err,
+          call = error_call
         )
       }
     )
   }
 }
 
+filter_desc <- function(exprs, desc = NULL, error_call = caller_env()) {
+  if (is.null(desc)) {
+    return(exprs)
+  }
+
+  found <- FALSE
+  include <- rep(FALSE, length(exprs))
+
+  for (i in seq_along(exprs)) {
+    expr <- exprs[[i]]
+
+    if (!is_call(expr, "test_that", 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
+    }
+  }
+
+  if (!found) {
+    abort("Failed to find test with specified description", call = error_call)
+  }
+
+  exprs[include]
+}
+
 #' @rdname source_file
 #' @export
 source_dir <- function(path, pattern = "\\.[rR]$", env = test_env(),

R/test-files.R

@@ -100,7 +100,7 @@ test_dir <- function(path,
   )
 }
 
-#' Run all tests in a single file
+#' Run tests in a single file
 #'
 #' Helper, setup, and teardown files located in the same directory as the
 #' test will also be run. See `vignette("special-files")` for details.
@@ -109,12 +109,19 @@ test_dir <- function(path,
 #' @inheritSection test_dir Environments
 #' @param path Path to file.
 #' @param ... Additional parameters passed on to `test_dir()`
+#' @param desc Optionally, supply a string here to run only a single
+#'   test that has this `desc`ription.
 #' @export
 #' @examples
 #' path <- testthat_example("success")
 #' test_file(path)
+#' test_file(path, desc = "some tests have warnings")
 #' test_file(path, reporter = "minimal")
-test_file <- function(path, reporter = default_compact_reporter(), package = NULL, ...) {
+test_file <- function(path,
+                      reporter = default_compact_reporter(),
+                      desc = NULL,
+                      package = NULL,
+                      ...) {
   if (!file.exists(path)) {
     stop("`path` does not exist", call. = FALSE)
   }
@@ -124,6 +131,7 @@ test_file <- function(path, reporter = default_compact_reporter(), package = NUL
     test_package = package,
     test_paths = basename(path),
     reporter = reporter,
+    desc = desc,
     ...
   )
 }
@@ -136,9 +144,11 @@ test_files <- function(test_dir,
                        env = NULL,
                        stop_on_failure = FALSE,
                        stop_on_warning = FALSE,
+                       desc = NULL,
                        wrap = TRUE,
                        load_package = c("none", "installed", "source"),
-                       parallel = FALSE) {
+                       parallel = FALSE,
+                       error_call = caller_env()) {
 
   if (is_missing(wrap)) {
     wrap <- TRUE
@@ -171,8 +181,10 @@ test_files <- function(test_dir,
       env = env,
       stop_on_failure = stop_on_failure,
       stop_on_warning = stop_on_warning,
+      desc = desc,
       wrap = wrap,
-      load_package = load_package
+      load_package = load_package,
+      error_call = error_call
     )
   }
 
@@ -186,8 +198,10 @@ test_files_serial <- function(test_dir,
                        env = NULL,
                        stop_on_failure = FALSE,
                        stop_on_warning = FALSE,
+                       desc = NULL,
                        wrap = TRUE,
-                       load_package = c("none", "installed", "source")) {
+                       load_package = c("none", "installed", "source"),
+                       error_call = caller_env()) {
 
   env <- test_files_setup_env(test_package, test_dir, load_package, env)
   # record testing env for mocks
@@ -197,7 +211,14 @@ test_files_serial <- function(test_dir,
   reporters <- test_files_reporter(reporter)
 
   with_reporter(reporters$multi,
-    lapply(test_paths, test_one_file, env = env, wrap = wrap)
+    lapply(
+      test_paths,
+      test_one_file,
+      env = env,
+      desc = desc,
+      wrap = wrap,
+      error_call = error_call
+    )
   )
 
   test_files_check(reporters$list$get_results(),
@@ -301,12 +322,22 @@ test_files_check <- function(results, stop_on_failure = TRUE, stop_on_warning =
   invisible(results)
 }
 
-test_one_file <- function(path, env = test_env(), wrap = TRUE) {
+test_one_file <- function(path,
+                          env = test_env(),
+                          desc = NULL,
+                          wrap = TRUE,
+                          error_call = caller_env()) {
   reporter <- get_reporter()
   on.exit(teardown_run(), add = TRUE)
 
   reporter$start_file(path)
-  source_file(path, env(env), wrap = wrap)
+  source_file(
+    path,
+    env = env(env),
+    wrap = wrap,
+    desc = desc,
+    error_call = error_call
+  )
   reporter$end_context_if_started()
   reporter$end_file()
 }

man/source_file.Rd

@@ -3,8 +3,33 @@
     Code
       source_file(test_path("reporters/error-setup.R"), wrap = FALSE)
     Condition
-      Error in `source_file()`:
+      Error:
       ! In path: "reporters/error-setup.R"
       Caused by error in `h()`:
       ! !
 
+# can find only matching test
+
+    Code
+      filter_desc(code, "baz")
+    Condition
+      Error:
+      ! Failed to find test with specified description
+
+# preserve srcrefs
+
+    Code
+      filter_desc(code, "foo")
+    Output
+      expression(test_that("foo", {
+            # this is a comment
+          }))
+
+# errors if duplicate labels
+
+    Code
+      filter_desc(code, "baz")
+    Condition
+      Error:
+      ! Found multiple tests with specified description
+

man/test_file.Rd

@@ -45,3 +45,40 @@ test_that("source_file wraps error", {
     source_file(test_path("reporters/error-setup.R"), wrap = FALSE)
   })
 })
+
+
+# filter_label -------------------------------------------------------------
+
+test_that("can find only matching test", {
+  code <- exprs(
+    f(),
+    test_that("foo", {}),
+    g(),
+    test_that("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)
+})
+
+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 duplicate labels", {
+  code <- exprs(
+    f(),
+    test_that("baz", {}),
+    test_that("baz", {}),
+    g()
+  )
+
+  expect_snapshot(filter_desc(code, "baz"), error = TRUE)
+})