Extract a reprex from a failing expectation

NAMESPACE

@@ -143,6 +143,7 @@ export(expect_vector)
 export(expect_visible)
 export(expect_warning)
 export(expectation)
+export(extract_test)
 export(fail)
 export(find_test_scripts)
 export(get_reporter)
@@ -185,6 +186,7 @@ export(set_state_inspector)
 export(setup)
 export(show_failure)
 export(shows_message)
+export(simulate_test_env)
 export(skip)
 export(skip_if)
 export(skip_if_not)

NEWS.md

@@ -22,6 +22,7 @@
 
 ## Other new features
 
+* New `extract_test()` function to extract a reprex from a failing expectation. tests run in `R CMD check` will use this to automatically create a reprex in the `_problems/` directory for each failing expectation. You can turn this behaviour off by setting `TESTTHAT_PROBLEMS=false` (#2263).
 * New `local_mocked_s3_method()`, `local_mocked_s4_method()`, and `local_mocked_r6_class()` allow you to mock S3 and S4 methods and R6 classes (#1892, #1916)
 * New `local_on_cran(TRUE)` allows you to simulate how your tests will run on CRAN (#2112).
 * `test_dir()`, `test_file()`, `test_package()`, `test_check()`, `test_local()`, `source_file()` gain a `shuffle` argument that uses `sample()` to randomly reorder the top-level expressions in each test file (#1942). This random reordering surfaces dependencies between tests and code outside of any test, as well as dependencies between tests. This helps you find and eliminate unintentional dependencies.

R/extract.R

@@ -0,0 +1,200 @@
+#' Extract a reprex from a failed expectation
+#'
+#' @description
+#' `extract_test()` creates a minimal reprex for a failed expectation.
+#' It extracts all non-test code before the failed expectation as well as
+#' all code inside the test up to and including the failed expectation.
+#'
+#' This is particularly useful when you're debugging test failures in
+#' someone else's package.
+#'
+#' @param location A string giving the location in the form
+#'   `FILE:LINE[:COLUMN]`.
+#' @param path Path to write the reprex to. Defaults to `stdout()`.
+#' @param package If supplied, will be used to construct a test environment
+#'   for the extracted code.
+#' @return This function is called for its side effect of rendering a
+#'   reprex to `path`. This function will never error: if extraction
+#'   fails, the error message will be written to `path`.
+#' @export
+#' @examples
+#' # If you see a test failure like this:
+#' # ── Failure (test-extract.R:46:3): errors if can't find test ───────────────
+#' # Expected FALSE to be TRUE.
+#' # Differences:
+#' # `actual`:   FALSE
+#' # `expected`: TRUE
+#'
+#' # You can run this:
+#' \dontrun{extract_test("test-extract.R:46:3")}
+#' # to see just the code needed to reproduce the failure
+extract_test <- function(
+  location,
+  path = stdout(),
+  package = Sys.getenv("TESTTHAT_PKG")
+) {
+  check_string(location)
+  check_string(package)
+
+  pieces <- strsplit(location, ":")[[1]]
+  if (!length(pieces) %in% c(2, 3)) {
+    cli::cli_abort(c(
+      "Expected {.arg location} to be of the form FILE:LINE[:COLUMN]",
+      i = "Got {.arg location}: {.val {location}}"
+    ))
+  }
+
+  test_path <- test_path(pieces[[1]])
+  line <- as.integer(pieces[2])
+  lines <- extract_test_(test_path, line, package)
+
+  base::writeLines(lines, con = path)
+}
+
+#' Simulate a test environment
+#'
+#' This function is designed to allow you to simulate testthat's testing
+#' environment in an interactive session. To undo it's affect, you
+#' will need to restart your R session.
+#'
+#' @keywords internal
+#' @param package Name of installed package.
+#' @param path Path to `tests/testthat`.
+#' @export
+#' @rdname topic-name
+simulate_test_env <- function(package, path) {
+  check_string(package)
+  check_string(path)
+
+  env <- test_env(package)
+  source_test_helpers(path, env = env)
+  source_test_setup(path, env = env)
+
+  invisible(env)
+}
+
+extract_test_ <- function(
+  test_path,
+  line,
+  package = Sys.getenv("TESTTHAT_PKG")
+) {
+  source <- paste0("# Extracted from ", test_path, ":", line)
+  exprs <- parse_file(test_path)
+
+  lines <- tryCatch(
+    extract_test_lines(exprs, line, package),
+    error = function(cnd) {
+      lines <- strsplit(conditionMessage(cnd), "\n")[[1]]
+      lines <- c("", "Failed to extract test: ", lines)
+      paste0("# ", lines)
+    }
+  )
+  lines <- c(source, "", lines)
+  lines
+}
+
+save_test <- function(srcref, dir, package = Sys.getenv("TESTTHAT_PKG")) {
+  if (env_var_is_false("TESTTHAT_PROBLEMS")) {
+    return()
+  }
+
+  test_path <- utils::getSrcFilename(srcref, full.names = TRUE)
+  if (is.null(test_path) || !file.exists(test_path)) {
+    return()
+  }
+  line <- srcref[[3]]
+  extracted <- extract_test_(test_path, line, package)
+
+  test_name <- tools::file_path_sans_ext(basename(test_path))
+  dir_create(dir)
+  problems_path <- file.path(dir, paste0(test_name, "-", line, ".R"))
+  cat("Saving ", problems_path, "\n", sep = "")
+  writeLines(extracted, problems_path)
+
+  invisible(problems_path)
+}
+
+extract_test_lines <- function(
+  exprs,
+  line,
+  package = "",
+  error_call = caller_env()
+) {
+  check_number_whole(line, min = 1, call = error_call)
+
+  srcrefs <- attr(exprs, "srcref")
+  is_subtest <- map_lgl(exprs, is_subtest)
+
+  # First we find the test
+  is_test <- is_subtest &
+    start_line(srcrefs) <= line &
+    end_line(srcrefs) >= line
+  if (!any(is_test)) {
+    cli::cli_abort("Failed to find test at line {line}.", call = error_call)
+  }
+  call <- exprs[[which(is_test)[[1]]]]
+  test_contents <- attr(call[[3]], "srcref")[-1] # drop `{`
+  keep <- start_line(test_contents) <= line
+  lines <- c(header("test"), srcref_to_character(test_contents[keep]))
+
+  # We first find the prequel, all non-test code before the test
+  is_prequel <- !is_subtest & start_line(srcrefs) < line
+  if (any(is_prequel)) {
+    lines <- c(
+      header("prequel"),
+      srcref_to_character(srcrefs[is_prequel]),
+      "",
+      lines
+    )
+  }
+
+  if (package != "") {
+    lines <- c(
+      header("setup"),
+      "library(testthat)",
+      sprintf(
+        'test_env <- simulate_test_env(package = "%s", path = "..")',
+        package
+      ),
+      "attach(test_env, warn.conflicts = FALSE)",
+      "",
+      lines
+    )
+  }
+  lines
+}
+
+# Helpers ---------------------------------------------------------------------
+
+parse_file <- function(path, error_call = caller_env()) {
+  check_string(path, call = error_call)
+  if (!file.exists(path)) {
+    cli::cli_abort(
+      "{.arg path} ({.path {path}}) does not exist.",
+      call = error_call
+    )
+  }
+  parse(path, keep.source = TRUE)
+}
+
+parse_text <- function(text) {
+  text <- sub("^\n", "", text)
+  indent <- regmatches(text, regexpr("^ *", text))
+  text <- gsub(paste0("(?m)^", indent), "", text, perl = TRUE)
+
+  parse(text = text, keep.source = TRUE)
+}
+
+srcref_to_character <- function(x) {
+  unlist(map(x, as.character))
+}
+start_line <- function(srcrefs) {
+  map_int(srcrefs, \(x) x[[1]])
+}
+end_line <- function(srcrefs) {
+  map_int(srcrefs, \(x) x[[3]])
+}
+
+header <- function(x) {
+  paste0("# ", x, " ", strrep("-", 80 - nchar(x) - 3))
+}

R/reporter-check.R

@@ -27,6 +27,7 @@ CheckReporter <- R6::R6Class(
     add_result = function(context, test, result) {
       if (expectation_broken(result)) {
         self$problems$push(result)
+        try(save_test(result$srcref, "_problems"), silent = TRUE)
       } else if (expectation_warning(result)) {
         self$warnings$push(result)
       } else if (expectation_skip(result)) {

R/skip.R

@@ -323,3 +323,7 @@ on_cran <- function() {
 env_var_is_true <- function(x) {
   isTRUE(as.logical(Sys.getenv(x, "false")))
 }
+
+env_var_is_false <- function(x) {
+  isFALSE(as.logical(Sys.getenv(x, "true")))
+}

R/source.R

@@ -115,7 +115,9 @@ filter_desc <- function(exprs, descs, error_call = caller_env()) {
 }
 
 is_subtest <- function(expr) {
-  is_call(expr, c("test_that", "describe", "it"), n = 2) && is_string(expr[[2]])
+  is_call(expr, c("test_that", "describe", "it"), n = 2) &&
+    is_string(expr[[2]]) &&
+    is_call(expr[[3]], "{")
 }
 
 #' @rdname source_file

_pkgdown.yml

@@ -55,6 +55,7 @@ reference:
 - title: Test helpers
   contents:
   - is_testing
+  - extract_test
   - local_edition
   - local_reproducible_output
   - set_state_inspector

tests/testthat/_snaps/extract.md

@@ -0,0 +1,59 @@
+# can extract test from file
+
+    Code
+      base::writeLines(readLines(out_path))
+    Output
+      # Extracted from extract/simple.R:3
+
+      # setup ------------------------------------------------------------------------
+      library(testthat)
+      test_env <- simulate_test_env(package = "testthat", path = "..")
+      attach(test_env, warn.conflicts = FALSE)
+
+      # test -------------------------------------------------------------------------
+      expect_true(TRUE)
+
+# can include test env setup
+
+    Code
+      base::writeLines(extract_test_lines(exprs, 2, "test"))
+    Output
+      # setup ------------------------------------------------------------------------
+      library(testthat)
+      test_env <- simulate_test_env(package = "test", path = "..")
+      attach(test_env, warn.conflicts = FALSE)
+
+      # test -------------------------------------------------------------------------
+      expect_true(TRUE)
+
+# can extract prequel
+
+    Code
+      base::writeLines(extract_test_lines(exprs, 4))
+    Output
+      # prequel ----------------------------------------------------------------------
+      x <- 1
+      y <- 2
+
+      # test -------------------------------------------------------------------------
+      expect_true(TRUE)
+
+# preserves code format but not comments
+
+    Code
+      base::writeLines(extract_test_lines(exprs, 3))
+    Output
+      # prequel ----------------------------------------------------------------------
+      1 +   1
+
+      # test -------------------------------------------------------------------------
+      2 +   2
+
+# can extract selected expectation
+
+    Code
+      base::writeLines(extract_test_lines(exprs, 2))
+    Output
+      # test -------------------------------------------------------------------------
+      expect_true(TRUE)
+

tests/testthat/extract/simple.R

@@ -0,0 +1,3 @@
+test_that('foo', {
+  expect_true(TRUE)
+})