From 96e78624ab370366a314575dc003d8cf945033de Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 8 Oct 2025 09:33:13 -0500 Subject: [PATCH 01/11] Extract a reprex from a failing expectation --- NAMESPACE | 1 + NEWS.md | 1 + R/extract.R | 100 ++++++++++++++++++++++++++++++++++++++++++++ man/extract_test.Rd | 19 +++++++++ 4 files changed, 121 insertions(+) create mode 100644 R/extract.R create mode 100644 man/extract_test.Rd diff --git a/NAMESPACE b/NAMESPACE index 426dbf1b4..3ebfd4fa2 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -139,6 +139,7 @@ export(expect_vector) export(expect_visible) export(expect_warning) export(expectation) +export(extract_test) export(fail) export(find_test_scripts) export(get_reporter) diff --git a/NEWS.md b/NEWS.md index 207716bf1..25939e493 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # testthat (development version) +* New `extract_test()` function to extract a reprex from a failing expectation. * Expectations now consistently return the value of the first argument, regardless of whether the expectation succeeds or fails. The primary exception are `expect_message()` and friends which will return the condition. This shouldn't affect existing tests, but will make failures clearer when you chain together multiple expectations (#2246). * `set_state_inspector()` gains `tolerance` argument and ignores minor FP differences by default (@mcol, #2237). * `expect_vector()` fails, instead of erroring, if `object` is not a vector (@plietar, #2224). diff --git a/R/extract.R b/R/extract.R new file mode 100644 index 000000000..a2490c951 --- /dev/null +++ b/R/extract.R @@ -0,0 +1,100 @@ +#' Extract a reprex from an failed expectation +#' +#' `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. +#' +#' @param location A string giving the location in the form +#' `FILE:LINE[:COLUMN]`. +#' @param path Path to write the reprex to. Defaults to `stdout()`. +#' @export +extract_test <- function(location, path = stdout()) { + check_string(location) + + pieces <- strsplit(location, ":")[[1]] + if (!length(pieces) %in% c(2, 3)) { + cli::cli_abort( + "Expected {.arg location} to be of the form FILE:LINE[:COLUMN]" + ) + } + + test_path <- test_path(pieces[[1]]) + line <- as.integer(pieces[2]) + + lines <- extract_test_lines(test_path, line) + base::writeLines(lines, con = path) +} + +extract_test_lines <- function(path, line, error_call = caller_env()) { + check_string(path) + if (!file.exists(path)) { + cli::cli_abort( + "{.arg path} ({.path path}) does not exist.", + call = error_call + ) + } + check_number_whole(line, min = 1, call = error_call) + + exprs <- parse(file = path, keep.source = TRUE) + srcrefs <- attr(exprs, "srcref") + + # Focus on srcrefs before the selected line + keep <- start_line(srcrefs) <= line + exprs <- exprs[keep] + srcrefs <- srcrefs[keep] + + # We first capture the prequel, all code outside of tests + is_subtest <- map_lgl(exprs, is_subtest) + if (any(!is_subtest)) { + prequel <- c( + comment_header("prequel"), + map_chr(srcrefs[!is_subtest], as.character), + "" + ) + } else { + prequel <- NULL + } + + # Now we extract the contents of the test + test_idx <- rev(which(is_subtest))[[1]] + call <- exprs[[test_idx]] + check_test_call(call, error_call = error_call) + + test_contents <- attr(call[[3]], "srcref")[-1] # drop `{` + keep <- start_line(test_contents) <= line + test <- map_chr(test_contents[keep], as.character) + + c( + paste0("# Extracted from tests/testthat/", path, ":", line), + prequel, + comment_header("test"), + test + ) +} + +# Helpers --------------------------------------------------------------------- + +check_test_call <- function(expr, error_call = caller_env()) { + if (!is_call(expr, n = 2)) { + cli::cli_abort( + "test call has unexpected number of arguments", + internal = TRUE, + call = error_call + ) + } + if (!is_call(expr[[3]], "{")) { + cli::cli_abort( + "test call has use {", + internal = TRUE, + call = error_call + ) + } +} + +comment_header <- function(x) { + paste0("# ", x, " ", strrep("-", 80 - nchar(x) - 3)) +} + +start_line <- function(srcrefs) { + map_int(srcrefs, \(x) x[[1]]) +} diff --git a/man/extract_test.Rd b/man/extract_test.Rd new file mode 100644 index 000000000..914fa7897 --- /dev/null +++ b/man/extract_test.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/extract.R +\name{extract_test} +\alias{extract_test} +\title{Extract a reprex from an failed expectation} +\usage{ +extract_test(location, path = stdout()) +} +\arguments{ +\item{location}{A string giving the location in the form +\verb{FILE:LINE[:COLUMN]}.} + +\item{path}{Path to write the reprex to. Defaults to \code{stdout()}.} +} +\description{ +\code{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. +} From 4e5b189e37fe3c23ccf1a305a4c6fa34ab323da8 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 8 Oct 2025 09:40:16 -0500 Subject: [PATCH 02/11] Ensure it never errors so could be automated --- R/extract.R | 25 ++++++++++++++++++------- man/extract_test.Rd | 5 +++++ 2 files changed, 23 insertions(+), 7 deletions(-) diff --git a/R/extract.R b/R/extract.R index a2490c951..dd33ba6b3 100644 --- a/R/extract.R +++ b/R/extract.R @@ -7,6 +7,9 @@ #' @param location A string giving the location in the form #' `FILE:LINE[:COLUMN]`. #' @param path Path to write the reprex to. Defaults to `stdout()`. +#' @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 extract_test <- function(location, path = stdout()) { check_string(location) @@ -20,8 +23,18 @@ extract_test <- function(location, path = stdout()) { test_path <- test_path(pieces[[1]]) line <- as.integer(pieces[2]) + source <- paste0("# Extracted from tests/testthat/", path, ":", line) + + lines <- tryCatch( + extract_test_lines(test_path, line), + error = function(cnd) { + lines <- strsplit(conditionMessage(cnd), "\n")[[1]] + lines <- c("Failed to extract test", lines) + paste0("# ", lines) + } + ) + lines <- c(source, lines) - lines <- extract_test_lines(test_path, line) base::writeLines(lines, con = path) } @@ -62,14 +75,12 @@ extract_test_lines <- function(path, line, error_call = caller_env()) { test_contents <- attr(call[[3]], "srcref")[-1] # drop `{` keep <- start_line(test_contents) <= line - test <- map_chr(test_contents[keep], as.character) - - c( - paste0("# Extracted from tests/testthat/", path, ":", line), - prequel, + test <- c( comment_header("test"), - test + map_chr(test_contents[keep], as.character) ) + + c(prequel, test) } # Helpers --------------------------------------------------------------------- diff --git a/man/extract_test.Rd b/man/extract_test.Rd index 914fa7897..ce8f9b7b3 100644 --- a/man/extract_test.Rd +++ b/man/extract_test.Rd @@ -12,6 +12,11 @@ extract_test(location, path = stdout()) \item{path}{Path to write the reprex to. Defaults to \code{stdout()}.} } +\value{ +This function is called for its side effect of rendering a +reprex to \code{path}. This function will never error: if extraction +fails, the error message will be written to \code{path}. +} \description{ \code{extract_test()} creates a minimal reprex for a failed expectation. It extracts all non-test code before the failed expectation as well as From 20a533f6c1e6b9357a1ea23e60abfad488dbca69 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 8 Oct 2025 12:17:06 -0500 Subject: [PATCH 03/11] Claude feedback --- R/extract.R | 13 ++++++++----- man/extract_test.Rd | 2 +- tests/testthat/test-expect-output.R | 2 ++ 3 files changed, 11 insertions(+), 6 deletions(-) diff --git a/R/extract.R b/R/extract.R index dd33ba6b3..875491a1b 100644 --- a/R/extract.R +++ b/R/extract.R @@ -1,4 +1,4 @@ -#' Extract a reprex from an failed expectation +#' Extract a reprex from a failed expectation #' #' `extract_test()` creates a minimal reprex for a failed expectation. #' It extracts all non-test code before the failed expectation as well as @@ -23,13 +23,13 @@ extract_test <- function(location, path = stdout()) { test_path <- test_path(pieces[[1]]) line <- as.integer(pieces[2]) - source <- paste0("# Extracted from tests/testthat/", path, ":", line) + source <- paste0("# Extracted from ", test_path, ":", line) lines <- tryCatch( extract_test_lines(test_path, line), error = function(cnd) { lines <- strsplit(conditionMessage(cnd), "\n")[[1]] - lines <- c("Failed to extract test", lines) + lines <- c("", "Failed to extract test: ", lines) paste0("# ", lines) } ) @@ -68,7 +68,10 @@ extract_test_lines <- function(path, line, error_call = caller_env()) { prequel <- NULL } - # Now we extract the contents of the test + # Now we extract the contents of the last test + if (!any(is_subtest)) { + cli::cli_abort("Failed to find test at line {line}.", call = error_call) + } test_idx <- rev(which(is_subtest))[[1]] call <- exprs[[test_idx]] check_test_call(call, error_call = error_call) @@ -95,7 +98,7 @@ check_test_call <- function(expr, error_call = caller_env()) { } if (!is_call(expr[[3]], "{")) { cli::cli_abort( - "test call has use {", + "test call doesn't use `{`", internal = TRUE, call = error_call ) diff --git a/man/extract_test.Rd b/man/extract_test.Rd index ce8f9b7b3..8d237388b 100644 --- a/man/extract_test.Rd +++ b/man/extract_test.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/extract.R \name{extract_test} \alias{extract_test} -\title{Extract a reprex from an failed expectation} +\title{Extract a reprex from a failed expectation} \usage{ extract_test(location, path = stdout()) } diff --git a/tests/testthat/test-expect-output.R b/tests/testthat/test-expect-output.R index 52e2adbd2..d8e0034b0 100644 --- a/tests/testthat/test-expect-output.R +++ b/tests/testthat/test-expect-output.R @@ -1,6 +1,8 @@ f <- function() NULL g <- function() cat("!") +writeLines("Hi!", "../someoutput.txt") + test_that("expect = NA checks for no output", { expect_success(expect_output(f(), NA)) expect_snapshot_failure(expect_output(g(), NA)) From 141ad83cd5bdc05eef9cfd696c3b32619b9d3de7 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 8 Oct 2025 12:19:26 -0500 Subject: [PATCH 04/11] Refactor to simplify testing --- R/extract.R | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) diff --git a/R/extract.R b/R/extract.R index 875491a1b..a2583cb87 100644 --- a/R/extract.R +++ b/R/extract.R @@ -24,9 +24,10 @@ extract_test <- function(location, path = stdout()) { test_path <- test_path(pieces[[1]]) line <- as.integer(pieces[2]) source <- paste0("# Extracted from ", test_path, ":", line) + exprs <- parse_file(test_path) lines <- tryCatch( - extract_test_lines(test_path, line), + extract_test_lines(exprs, line), error = function(cnd) { lines <- strsplit(conditionMessage(cnd), "\n")[[1]] lines <- c("", "Failed to extract test: ", lines) @@ -38,17 +39,9 @@ extract_test <- function(location, path = stdout()) { base::writeLines(lines, con = path) } -extract_test_lines <- function(path, line, error_call = caller_env()) { - check_string(path) - if (!file.exists(path)) { - cli::cli_abort( - "{.arg path} ({.path path}) does not exist.", - call = error_call - ) - } +extract_test_lines <- function(exprs, line, error_call = caller_env()) { check_number_whole(line, min = 1, call = error_call) - exprs <- parse(file = path, keep.source = TRUE) srcrefs <- attr(exprs, "srcref") # Focus on srcrefs before the selected line @@ -88,6 +81,17 @@ extract_test_lines <- function(path, line, error_call = caller_env()) { # 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) +} + check_test_call <- function(expr, error_call = caller_env()) { if (!is_call(expr, n = 2)) { cli::cli_abort( From bc9fa1f34cb05f20d70111a5a36f99ff27e9f289 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 8 Oct 2025 13:31:06 -0500 Subject: [PATCH 05/11] Add some basic tests & refine implementation --- R/extract.R | 76 +++++++++++++------------------- R/source.R | 4 +- tests/testthat/_snaps/extract.md | 30 +++++++++++++ tests/testthat/test-extract.R | 46 +++++++++++++++++++ 4 files changed, 110 insertions(+), 46 deletions(-) create mode 100644 tests/testthat/_snaps/extract.md create mode 100644 tests/testthat/test-extract.R diff --git a/R/extract.R b/R/extract.R index a2583cb87..d9f7d8eed 100644 --- a/R/extract.R +++ b/R/extract.R @@ -43,40 +43,33 @@ extract_test_lines <- function(exprs, line, error_call = caller_env()) { check_number_whole(line, min = 1, call = error_call) srcrefs <- attr(exprs, "srcref") - - # Focus on srcrefs before the selected line - keep <- start_line(srcrefs) <= line - exprs <- exprs[keep] - srcrefs <- srcrefs[keep] - - # We first capture the prequel, all code outside of tests is_subtest <- map_lgl(exprs, is_subtest) - if (any(!is_subtest)) { - prequel <- c( - comment_header("prequel"), - map_chr(srcrefs[!is_subtest], as.character), - "" - ) - } else { - prequel <- NULL - } - # Now we extract the contents of the last test - if (!any(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) } - test_idx <- rev(which(is_subtest))[[1]] - call <- exprs[[test_idx]] - check_test_call(call, error_call = error_call) - + call <- exprs[[which(is_test)[[1]]]] test_contents <- attr(call[[3]], "srcref")[-1] # drop `{` keep <- start_line(test_contents) <= line - test <- c( - comment_header("test"), - map_chr(test_contents[keep], as.character) - ) + 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)) { + return(test) + } - c(prequel, test) + c( + "# prequel ---------------------------------------------------------------", + srcref_to_character(srcrefs[is_prequel]), + "", + "# test ------------------------------------------------------------------", + test + ) } # Helpers --------------------------------------------------------------------- @@ -92,27 +85,20 @@ parse_file <- function(path, error_call = caller_env()) { parse(path, keep.source = TRUE) } -check_test_call <- function(expr, error_call = caller_env()) { - if (!is_call(expr, n = 2)) { - cli::cli_abort( - "test call has unexpected number of arguments", - internal = TRUE, - call = error_call - ) - } - if (!is_call(expr[[3]], "{")) { - cli::cli_abort( - "test call doesn't use `{`", - internal = TRUE, - call = error_call - ) - } -} +parse_text <- function(text) { + text <- sub("^\n", "", text) + indent <- regmatches(text, regexpr("^ *", text)) + text <- gsub(paste0("(?m)^", indent), "", text, perl = TRUE) -comment_header <- function(x) { - paste0("# ", x, " ", strrep("-", 80 - nchar(x) - 3)) + 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]]) +} diff --git a/R/source.R b/R/source.R index 3c069d9f9..e80bbd413 100644 --- a/R/source.R +++ b/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 diff --git a/tests/testthat/_snaps/extract.md b/tests/testthat/_snaps/extract.md new file mode 100644 index 000000000..044b4fbe5 --- /dev/null +++ b/tests/testthat/_snaps/extract.md @@ -0,0 +1,30 @@ +# 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 + expect_true(TRUE) + diff --git a/tests/testthat/test-extract.R b/tests/testthat/test-extract.R new file mode 100644 index 000000000..36716a608 --- /dev/null +++ b/tests/testthat/test-extract.R @@ -0,0 +1,46 @@ +test_that("can extract prequel", { + # fmt: skip + exprs <- parse_text(" + x <- 1 + y <- 2 + test_that('foo', { + expect_true(TRUE) + }) + ") + expect_snapshot(base::writeLines(extract_test_lines(exprs, 4))) +}) + +test_that("preserves code format but not comments", { + # fmt: skip + exprs <- parse_text(" + 1 + 1 # 2 + test_that('foo', { + 2 + 2 # 4 + }) + ") + expect_snapshot(base::writeLines(extract_test_lines(exprs, 3))) +}) + +test_that("can extract selected expectation", { + # fmt: skip + exprs <- parse_text(" + test_that('foo', { + expect_true(TRUE) + expect_false(FALSE) + }) + ") + expect_snapshot(base::writeLines(extract_test_lines(exprs, 2))) +}) + +test_that("errors if can't find test", { + # fmt: skip + exprs <- parse_text(" + # line 1 + test_that('foo', { + expect_true(TRUE) + }) + # line 5 + ") + expect_error(extract_test_lines(exprs, 1), "Failed to find test") + expect_error(extract_test_lines(exprs, 5), "Failed to find test") +}) From d78f8aa699eb114db74a1967d4b14ccbb4d9b1fd Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 8 Oct 2025 14:38:20 -0500 Subject: [PATCH 06/11] Add to reference index --- _pkgdown.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/_pkgdown.yml b/_pkgdown.yml index 0b9aa2f12..fbe3de2c2 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -54,6 +54,7 @@ reference: - title: Test helpers contents: - is_testing + - extract_test - local_edition - local_reproducible_output - set_state_inspector From 23d8276238462b69de1ec61eac77e034f91bb7dd Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 8 Oct 2025 14:40:54 -0500 Subject: [PATCH 07/11] Add example --- R/extract.R | 15 +++++++++++++++ man/extract_test.Rd | 15 +++++++++++++++ 2 files changed, 30 insertions(+) diff --git a/R/extract.R b/R/extract.R index d9f7d8eed..c0533fd71 100644 --- a/R/extract.R +++ b/R/extract.R @@ -1,9 +1,13 @@ #' 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()`. @@ -11,6 +15,17 @@ #' 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()) { check_string(location) diff --git a/man/extract_test.Rd b/man/extract_test.Rd index 8d237388b..30d4aa585 100644 --- a/man/extract_test.Rd +++ b/man/extract_test.Rd @@ -21,4 +21,19 @@ fails, the error message will be written to \code{path}. \code{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. +} +\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 } From 12cbf69bc40361d36c8863d8749cdeb32602bc40 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 10 Nov 2025 09:45:59 -0600 Subject: [PATCH 08/11] Fix NEWS --- NEWS.md | 18 +----------------- 1 file changed, 1 insertion(+), 17 deletions(-) diff --git a/NEWS.md b/NEWS.md index fbb1bab60..d7634f015 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,22 +1,5 @@ # testthat (development version) -* New `extract_test()` function to extract a reprex from a failing expectation. -* `expect_all_equal()`, `expect_all_true()`, and `expect_all_false()` are a new family of expectations that checks that every element of a vector has the same value. Compared to using `expect_true(all(...))` they give better failure messages (#1836, #2235). -* Expectations now consistently return the value of the first argument, regardless of whether the expectation succeeds or fails. The primary exception are `expect_message()` and friends which will return the condition. This shouldn't affect existing tests, but will make failures clearer when you chain together multiple expectations (#2246). -* `set_state_inspector()` gains `tolerance` argument and ignores minor FP differences by default (@mcol, #2237). -* `expect_vector()` fails, instead of erroring, if `object` is not a vector (@plietar, #2224). -* New `vignette("mocking")` explains mocking in detail (#1265). -* New `vignette("challenging-functions")` provides an index to other documentation organised by testing challenges (#1265). -* When running a test interactively, testthat now reports the number of successes. The results should also be more useful if you are using nested tests. -* The hints generated by `expect_snapshot()` and `expect_snapshot_file()` now include the path to the package, if it's not in the current working directory (#1577). -* `expect_snapshot_file()` now clearly errors if the `path` doesn't exist (#2191). -* `expect_snapshot_file()` now considers `.json` to be a text file (#1593). -* `expect_snapshot_file()` now shows differences for text files (#1593). -* The failure messages for all `expect_` functions have been rewritten to first state what was expected and then what was actually received (#2142). -* `test_file(desc = ...)` no longer loses snapshot results (#2066). -* In `R CMD check`, snapshots now only advise on how to resolve failures once (#2207). -* `snapshot_review()` includes a reject button and only displays the file navigation and the skip button if there are multiple files to review (#2025). -* New `snapshot_download_gh()` makes it easy to get snapshots off GitHub and into your local package (#1779). ## Lifecycle changes * testthat now requires R 4.1. @@ -39,6 +22,7 @@ ## Other new features +* New `extract_test()` function to extract a reprex from a failing expectation. * 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. From 3d0a983a1630ff005704ced3afc74ae026626b1c Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 10 Nov 2025 14:16:38 -0600 Subject: [PATCH 09/11] Include test setup --- R/extract.R | 80 +++++++++++++++++++++++------ man/extract_test.Rd | 2 +- tests/testthat/_snaps/extract.md | 14 +++++ tests/testthat/test-expect-output.R | 2 - tests/testthat/test-extract.R | 10 ++++ 5 files changed, 88 insertions(+), 20 deletions(-) diff --git a/R/extract.R b/R/extract.R index c0533fd71..fa6232f6e 100644 --- a/R/extract.R +++ b/R/extract.R @@ -11,6 +11,8 @@ #' @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`. @@ -26,23 +28,38 @@ #' # 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()) { +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( - "Expected {.arg location} to be of the form FILE:LINE[:COLUMN]" - ) + 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]) + + base::writeLines(lines, con = path) +} + +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), + extract_test_lines(exprs, line, package), error = function(cnd) { lines <- strsplit(conditionMessage(cnd), "\n")[[1]] lines <- c("", "Failed to extract test: ", lines) @@ -50,11 +67,28 @@ extract_test <- function(location, path = stdout()) { } ) lines <- c(source, lines) + lines +} - base::writeLines(lines, con = path) +save_test <- function(srcref, package = Sys.getenv("TESTTHAT_PKG")) { + test_path <- getSrcFilename(srcref) + if (is.null(test_path)) { + return() + } + line <- srcref[[1]] + extracted <- extract_test_(test_path, line, package) + + test_name <- tools::file_path_sans_ext(base_name(test_path)) + problems_path <- paste0("problems/", test_name, "-", line, ".R") + writeLines(extracted, problems_path) } -extract_test_lines <- function(exprs, line, error_call = caller_env()) { +extract_test_lines <- function( + exprs, + line, + package = "", + error_call = caller_env() +) { check_number_whole(line, min = 1, call = error_call) srcrefs <- attr(exprs, "srcref") @@ -70,21 +104,33 @@ extract_test_lines <- function(exprs, line, error_call = caller_env()) { call <- exprs[[which(is_test)[[1]]]] test_contents <- attr(call[[3]], "srcref")[-1] # drop `{` keep <- start_line(test_contents) <= line - test <- srcref_to_character(test_contents[keep]) + lines <- 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)) { - return(test) + if (any(is_prequel)) { + lines <- c( + "# prequel ---------------------------------------------------------------", + srcref_to_character(srcrefs[is_prequel]), + "", + "# test ------------------------------------------------------------------", + lines + ) } - c( - "# prequel ---------------------------------------------------------------", - srcref_to_character(srcrefs[is_prequel]), - "", - "# test ------------------------------------------------------------------", - test - ) + if (package != "") { + lines <- c( + "library(testthat)", + sprintf('test_env <- test_that("%s")', package), + 'source_test_helpers("..", env = test_env)', + 'attach(test_env)', + "", + lines, + "", + 'detach("test_env")' + ) + } + lines } # Helpers --------------------------------------------------------------------- diff --git a/man/extract_test.Rd b/man/extract_test.Rd index 30d4aa585..705ed3484 100644 --- a/man/extract_test.Rd +++ b/man/extract_test.Rd @@ -4,7 +4,7 @@ \alias{extract_test} \title{Extract a reprex from a failed expectation} \usage{ -extract_test(location, path = stdout()) +extract_test(location, path = stdout(), package = Sys.getenv("TESTTHAT_PKG")) } \arguments{ \item{location}{A string giving the location in the form diff --git a/tests/testthat/_snaps/extract.md b/tests/testthat/_snaps/extract.md index 044b4fbe5..a5f410012 100644 --- a/tests/testthat/_snaps/extract.md +++ b/tests/testthat/_snaps/extract.md @@ -1,3 +1,17 @@ +# can include test env setup + + Code + base::writeLines(extract_test_lines(exprs, 2, "test")) + Output + library(testthat) + test_env <- test_that("test") + source_test_helpers("..", env = test_env) + attach(test_env) + + expect_true(TRUE) + + detach("test_env") + # can extract prequel Code diff --git a/tests/testthat/test-expect-output.R b/tests/testthat/test-expect-output.R index d8e0034b0..52e2adbd2 100644 --- a/tests/testthat/test-expect-output.R +++ b/tests/testthat/test-expect-output.R @@ -1,8 +1,6 @@ f <- function() NULL g <- function() cat("!") -writeLines("Hi!", "../someoutput.txt") - test_that("expect = NA checks for no output", { expect_success(expect_output(f(), NA)) expect_snapshot_failure(expect_output(g(), NA)) diff --git a/tests/testthat/test-extract.R b/tests/testthat/test-extract.R index 36716a608..cf2f4def3 100644 --- a/tests/testthat/test-extract.R +++ b/tests/testthat/test-extract.R @@ -1,3 +1,13 @@ +test_that("can include test env setup", { + # fmt: skip + exprs <- parse_text(" + test_that('foo', { + expect_true(TRUE) + }) + ") + expect_snapshot(base::writeLines(extract_test_lines(exprs, 2, "test"))) +}) + test_that("can extract prequel", { # fmt: skip exprs <- parse_text(" From df882b4feb575abe4d19f32863329becee692b84 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 10 Nov 2025 15:28:49 -0600 Subject: [PATCH 10/11] More work --- NAMESPACE | 1 + NEWS.md | 2 +- R/extract.R | 65 +++++++++++++++++++++++--------- R/reporter-check.R | 1 + R/skip.R | 4 ++ man/extract_test.Rd | 3 ++ man/topic-name.Rd | 14 +++++++ tests/testthat/_snaps/extract.md | 31 ++++++++++----- tests/testthat/extract/simple.R | 3 ++ tests/testthat/test-extract.R | 11 ++++++ 10 files changed, 107 insertions(+), 28 deletions(-) create mode 100644 man/topic-name.Rd create mode 100644 tests/testthat/extract/simple.R diff --git a/NAMESPACE b/NAMESPACE index 3b1913143..985a05b7a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -186,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) diff --git a/NEWS.md b/NEWS.md index d7634f015..de7f2a741 100644 --- a/NEWS.md +++ b/NEWS.md @@ -22,7 +22,7 @@ ## Other new features -* New `extract_test()` function to extract a reprex from a failing expectation. +* 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. diff --git a/R/extract.R b/R/extract.R index fa6232f6e..d8ac9f5a3 100644 --- a/R/extract.R +++ b/R/extract.R @@ -46,10 +46,32 @@ extract_test <- function( 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 +#' @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() +} + extract_test_ <- function( test_path, line, @@ -66,21 +88,28 @@ extract_test_ <- function( paste0("# ", lines) } ) - lines <- c(source, lines) + lines <- c(source, "", lines) lines } -save_test <- function(srcref, package = Sys.getenv("TESTTHAT_PKG")) { - test_path <- getSrcFilename(srcref) - if (is.null(test_path)) { +save_test <- function(srcref, dir, package = Sys.getenv("TESTTHAT_PKG")) { + if (env_var_is_false("TESTTHAT_PROBLEMS")) { return() } - line <- srcref[[1]] + + 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(base_name(test_path)) - problems_path <- paste0("problems/", test_name, "-", line, ".R") + test_name <- tools::file_path_sans_ext(basename(test_path)) + dir_create(dir) + problems_path <- file.path(dir, paste0(test_name, "-", line, ".R")) writeLines(extracted, problems_path) + + invisible(problems_path) } extract_test_lines <- function( @@ -104,30 +133,26 @@ extract_test_lines <- function( call <- exprs[[which(is_test)[[1]]]] test_contents <- attr(call[[3]], "srcref")[-1] # drop `{` keep <- start_line(test_contents) <= line - lines <- srcref_to_character(test_contents[keep]) + 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( - "# prequel ---------------------------------------------------------------", + header("prequel"), srcref_to_character(srcrefs[is_prequel]), "", - "# test ------------------------------------------------------------------", lines ) } if (package != "") { lines <- c( + header("setup"), "library(testthat)", - sprintf('test_env <- test_that("%s")', package), - 'source_test_helpers("..", env = test_env)', - 'attach(test_env)', - "", - lines, - "", - 'detach("test_env")' + sprintf('simulate_test_env(package = "%s", path = "..")', package), + "attach(test_env)", + lines ) } lines @@ -139,7 +164,7 @@ 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.", + "{.arg path} ({.path {path}}) does not exist.", call = error_call ) } @@ -163,3 +188,7 @@ start_line <- function(srcrefs) { end_line <- function(srcrefs) { map_int(srcrefs, \(x) x[[3]]) } + +header <- function(x) { + paste0("# ", x, " ", strrep("-", 80 - nchar(x) - 3)) +} diff --git a/R/reporter-check.R b/R/reporter-check.R index e70736ae0..1d5ac7d51 100644 --- a/R/reporter-check.R +++ b/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)) { diff --git a/R/skip.R b/R/skip.R index 9b862acdb..b89f70cc1 100644 --- a/R/skip.R +++ b/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"))) +} diff --git a/man/extract_test.Rd b/man/extract_test.Rd index 705ed3484..cc574297e 100644 --- a/man/extract_test.Rd +++ b/man/extract_test.Rd @@ -11,6 +11,9 @@ extract_test(location, path = stdout(), package = Sys.getenv("TESTTHAT_PKG")) \verb{FILE:LINE[:COLUMN]}.} \item{path}{Path to write the reprex to. Defaults to \code{stdout()}.} + +\item{package}{If supplied, will be used to construct a test environment +for the extracted code.} } \value{ This function is called for its side effect of rendering a diff --git a/man/topic-name.Rd b/man/topic-name.Rd new file mode 100644 index 000000000..ba6b594f7 --- /dev/null +++ b/man/topic-name.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/extract.R +\name{simulate_test_env} +\alias{simulate_test_env} +\title{Simulate a test environment} +\usage{ +simulate_test_env(package, path) +} +\description{ +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. +} +\keyword{internal} diff --git a/tests/testthat/_snaps/extract.md b/tests/testthat/_snaps/extract.md index a5f410012..df915f05e 100644 --- a/tests/testthat/_snaps/extract.md +++ b/tests/testthat/_snaps/extract.md @@ -1,27 +1,39 @@ +# can extract test from file + + Code + base::writeLines(readLines(out_path)) + Output + # Extracted from extract/simple.R:3 + + # setup ------------------------------------------------------------------------ + library(testthat) + simulate_test_env(package = "testthat", path = "..") + attach(test_env) + # test ------------------------------------------------------------------------- + expect_true(TRUE) + # can include test env setup Code base::writeLines(extract_test_lines(exprs, 2, "test")) Output + # setup ------------------------------------------------------------------------ library(testthat) - test_env <- test_that("test") - source_test_helpers("..", env = test_env) + simulate_test_env(package = "test", path = "..") attach(test_env) - + # test ------------------------------------------------------------------------- expect_true(TRUE) - - detach("test_env") # can extract prequel Code base::writeLines(extract_test_lines(exprs, 4)) Output - # prequel --------------------------------------------------------------- + # prequel ---------------------------------------------------------------------- x <- 1 y <- 2 - # test ------------------------------------------------------------------ + # test ------------------------------------------------------------------------- expect_true(TRUE) # preserves code format but not comments @@ -29,10 +41,10 @@ Code base::writeLines(extract_test_lines(exprs, 3)) Output - # prequel --------------------------------------------------------------- + # prequel ---------------------------------------------------------------------- 1 + 1 - # test ------------------------------------------------------------------ + # test ------------------------------------------------------------------------- 2 + 2 # can extract selected expectation @@ -40,5 +52,6 @@ Code base::writeLines(extract_test_lines(exprs, 2)) Output + # test ------------------------------------------------------------------------- expect_true(TRUE) diff --git a/tests/testthat/extract/simple.R b/tests/testthat/extract/simple.R new file mode 100644 index 000000000..61fba27ae --- /dev/null +++ b/tests/testthat/extract/simple.R @@ -0,0 +1,3 @@ +test_that('foo', { + expect_true(TRUE) +}) diff --git a/tests/testthat/test-extract.R b/tests/testthat/test-extract.R index cf2f4def3..d779d3712 100644 --- a/tests/testthat/test-extract.R +++ b/tests/testthat/test-extract.R @@ -1,3 +1,14 @@ +test_that("can extract test from file", { + exprs <- parse_file(test_path("extract/simple.R")) + + dir <- withr::local_tempdir() + out_path <- save_test(attr(exprs, "srcref")[[1]], dir = dir) + + expect_snapshot(base::writeLines(readLines(out_path))) +}) + +# extract_test_lines ----------------------------------------------------------- + test_that("can include test env setup", { # fmt: skip exprs <- parse_text(" From f5815df19d8b317ca1789317fdc296acdf38cbc1 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 10 Nov 2025 15:45:20 -0600 Subject: [PATCH 11/11] Polishing --- R/extract.R | 14 ++++++++++---- tests/testthat/_snaps/extract.md | 10 ++++++---- 2 files changed, 16 insertions(+), 8 deletions(-) diff --git a/R/extract.R b/R/extract.R index d8ac9f5a3..e6d9430d4 100644 --- a/R/extract.R +++ b/R/extract.R @@ -58,7 +58,8 @@ extract_test <- function( #' will need to restart your R session. #' #' @keywords internal -#' @param +#' @param package Name of installed package. +#' @param path Path to `tests/testthat`. #' @export #' @rdname topic-name simulate_test_env <- function(package, path) { @@ -69,7 +70,7 @@ simulate_test_env <- function(package, path) { source_test_helpers(path, env = env) source_test_setup(path, env = env) - invisible() + invisible(env) } extract_test_ <- function( @@ -107,6 +108,7 @@ save_test <- function(srcref, dir, package = Sys.getenv("TESTTHAT_PKG")) { 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) @@ -150,8 +152,12 @@ extract_test_lines <- function( lines <- c( header("setup"), "library(testthat)", - sprintf('simulate_test_env(package = "%s", path = "..")', package), - "attach(test_env)", + sprintf( + 'test_env <- simulate_test_env(package = "%s", path = "..")', + package + ), + "attach(test_env, warn.conflicts = FALSE)", + "", lines ) } diff --git a/tests/testthat/_snaps/extract.md b/tests/testthat/_snaps/extract.md index df915f05e..9faeeb457 100644 --- a/tests/testthat/_snaps/extract.md +++ b/tests/testthat/_snaps/extract.md @@ -7,8 +7,9 @@ # setup ------------------------------------------------------------------------ library(testthat) - simulate_test_env(package = "testthat", path = "..") - attach(test_env) + test_env <- simulate_test_env(package = "testthat", path = "..") + attach(test_env, warn.conflicts = FALSE) + # test ------------------------------------------------------------------------- expect_true(TRUE) @@ -19,8 +20,9 @@ Output # setup ------------------------------------------------------------------------ library(testthat) - simulate_test_env(package = "test", path = "..") - attach(test_env) + test_env <- simulate_test_env(package = "test", path = "..") + attach(test_env, warn.conflicts = FALSE) + # test ------------------------------------------------------------------------- expect_true(TRUE)