Markdown summary on GHA

R/gha-summary.R

@@ -0,0 +1,100 @@
+create_gha_summary <- function(results) {
+  results <- lapply(results, gha_summarize_test)
+  totals <- list(
+    n_fail = sum(vapply(results, "[[", integer(1), "n_fail")),
+    n_warn = sum(vapply(results, "[[", integer(1), "n_warn")),
+    n_skip = sum(vapply(results, "[[", integer(1), "n_skip")),
+    n_ok = sum(vapply(results, "[[", integer(1), "n_ok")),
+    real = sum(vapply(results, "[[", double(1), "real"))
+  )
+
+  # summary -----------------------------------------------------------------
+  gha_summary_write("### Test summary")
+  gha_summary_write()
+  gha_summary_write("| FAIL | WARN | SKIP | PASS | Time |")
+  gha_summary_write("|-----:|-----:|-----:|-----:|:-----|")
+  gha_summary_write(
+    c("|", if (totals$n_fail > 0) totals$n_fail),
+    c("|", if (totals$n_warn > 0) totals$n_warn),
+    c("|", if (totals$n_skip > 0) totals$n_skip),
+    c("|", totals$n_ok),
+    c("|", num_exact(totals$real, 2), "|")
+  )
+
+  # issue details -----------------------------------------------------------
+  gha_summary_write()
+  gha_summary_write("<details>")
+  gha_summary_write("<summary>Test details</summary>")
+
+  gha_summary_write("")
+  gha_summary_write()
+  gha_summary_write("| File | Test | FAIL | WARN | SKIP | PASS | Time |")
+  gha_summary_write("|:-----|:-----|-----:|-----:|-----:|-----:|:-----|")
+
+  issues <- Filter(function(x) length(x$results) != x$n_ok, results)
+  for (issue in issues) {
+    gha_summary_write(
+      c("|", issue$file),
+      c("|", md_escape(issue$test)),
+      c("|", if (totals$n_fail > 0) issue$n_fail),
+      c("|", if (totals$n_warn > 0) issue$n_warn),
+      c("|", if (totals$n_skip > 0) issue$n_skip),
+      c("|", issue$n_ok),
+      c("|", num_exact(issue$real, 2), "|")
+    )
+  }
+  gha_summary_write()
+  gha_summary_write("</details>")
+  gha_summary_write()
+
+  invisible(results)
+}
+
+# Helpers ----------------------------------------------------------------------
+
+gha_summarize_test <- function(test) {
+  test$n_fail <- test$n_skip <- test$n_warn <- test$n_ok <- 0L
+  for (exp in test$results) {
+    if (expectation_broken(exp)) {
+      test$n_fail <- test$n_fail + 1L
+    } else if (expectation_skip(exp)) {
+      test$n_skip <- test$n_skip + 1L
+    } else if (expectation_warning(exp)) {
+      test$n_warn <- test$n_warn + 1L
+    } else {
+      test$n_ok <- test$n_ok + 1L
+    }
+  }
+
+  test
+}
+
+gha_path <- function() {
+  nope <- c("false", "no", "off", "n", "0", "nope", "nay")
+  if (tolower(Sys.getenv("TESTTHAT_GHA_SUMMARY")) %in% nope) {
+    return()
+  }
+
+  if ((out <- Sys.getenv("GITHUB_STEP_SUMMARY")) == "") {
+    return()
+  }
+  out
+}
+
+
+gha_summary_write <- function(...) {
+  path <- gha_path()
+  if (is.null(path)) {
+    return()
+  }
+
+  string <- paste0(c(..., "\n"), collapse = "")
+  Encoding(string) <- "unknown"
+  cat(string, file = path, append = TRUE)
+}
+
+md_escape <- function(x) {
+  x <- gsub("|", "\\|", x, fixed = TRUE)
+  x <- gsub("\n", " ", x, fixed = TRUE)
+  x
+}

R/parallel.R

@@ -74,6 +74,8 @@ test_files_parallel <- function(
       }
     })
 
+    create_gha_summary(reporters$list$get_results())
+
     test_files_check(
       reporters$list$get_results(),
       stop_on_failure = stop_on_failure,

R/test-files.R

@@ -129,6 +129,8 @@ test_file <- function(
     cli::cli_abort("{.arg path} does not exist.")
   }
 
+  withr::local_envvar(TESTTHAT_GHA_SUMMARY = "false")
+
   test_files(
     test_dir = dirname(path),
     test_package = package,
@@ -235,6 +237,8 @@ test_files_serial <- function(
     )
   )
 
+  create_gha_summary(reporters$list$get_results())
+
   test_files_check(
     reporters$list$get_results(),
     stop_on_failure = stop_on_failure,

tests/testthat/_snaps/gha-summary.md

@@ -0,0 +1,21 @@
+# multiplication works
+
+    Code
+      create_gha_summary(list())
+    Output
+      ### Test summary
+
+      | FAIL | WARN | SKIP | PASS | Time |
+      |-----:|-----:|-----:|-----:|:-----|
+      ||||0|0.00|
+
+      <details>
+      <summary>Test details</summary>
+
+
+      | File | Test | FAIL | WARN | SKIP | PASS | Time |
+      |:-----|:-----|-----:|-----:|-----:|-----:|:-----|
+
+      </details>
+
+

tests/testthat/helper.R

@@ -0,0 +1,20 @@
+local_parallel_test_config <- function(frame = caller_env()) {
+  skip_on_covr()
+  withr::local_envvar(
+    c(
+      TESTTHAT_PARALLEL = "TRUE",
+      TESTTHAT_GHA_SUMMARY = "FALSE"
+    ),
+    .local_envir = frame
+  )
+}
+
+capture_parallel_error <- function(path) {
+  tryCatch(
+    capture.output(suppressMessages(testthat::test_local(
+      path,
+      reporter = "summary"
+    ))),
+    error = function(e) e
+  )
+}

tests/testthat/test-gha-summary.R

@@ -0,0 +1,4 @@
+test_that("multiplication works", {
+  local_mocked_bindings(gha_path = function() stdout())
+  expect_snapshot(create_gha_summary(list()))
+})

tests/testthat/test-parallel-crash.R

@@ -1,10 +1,8 @@
 test_that("crash", {
+  local_parallel_test_config()
   skip_on_cran()
-  skip_on_covr()
   skip_if_not(getRversion() >= "4.4.0")
 
-  withr::local_envvar(TESTTHAT_PARALLEL = "TRUE")
-
   pkg <- test_path("test-parallel", "crash")
   err <- callr::r(
     function() {

tests/testthat/test-parallel-errors.R

@@ -1,13 +1,7 @@
 test_that("error in parallel setup code", {
-  skip_on_covr()
-  withr::local_envvar(TESTTHAT_PARALLEL = "TRUE")
-  err <- tryCatch(
-    capture.output(suppressMessages(testthat::test_local(
-      test_path("test-parallel", "syntax-error"),
-      reporter = "summary"
-    ))),
-    error = function(e) e
-  )
+  local_parallel_test_config()
+
+  err <- capture_parallel_error(test_path("test-parallel", "syntax-error"))
   expect_s3_class(err, "testthat_process_error")
   # contains test file's name
   expect_match(conditionMessage(err), "test-error-1.R")

tests/testthat/test-parallel-outside.R

@@ -1,13 +1,6 @@
 test_that("error outside of test_that()", {
-  skip_on_covr()
-  withr::local_envvar(TESTTHAT_PARALLEL = "TRUE")
-  err <- tryCatch(
-    capture.output(suppressMessages(testthat::test_local(
-      test_path("test-parallel", "outside"),
-      reporter = "summary"
-    ))),
-    error = function(e) e
-  )
+  local_parallel_test_config()
 
+  err <- capture_parallel_error(test_path("test-parallel", "outside"))
   expect_match(err$message, "Test failures")
 })

tests/testthat/test-parallel-setup.R

@@ -1,13 +1,7 @@
 test_that("error in parallel setup code", {
-  skip_on_covr()
-  withr::local_envvar(TESTTHAT_PARALLEL = "TRUE")
-  err <- tryCatch(
-    capture.output(suppressMessages(testthat::test_local(
-      test_path("test-parallel", "setup"),
-      reporter = "summary"
-    ))),
-    error = function(e) e
-  )
+  local_parallel_test_config()
+
+  err <- capture_parallel_error(test_path("test-parallel", "setup"))
   expect_s3_class(err, "testthat_process_error")
   expect_match(conditionMessage(err), "Error in setup", fixed = TRUE)
 })

tests/testthat/test-parallel-startup.R

@@ -1,13 +1,7 @@
 test_that("startup error", {
-  skip_on_covr()
-  withr::local_envvar(TESTTHAT_PARALLEL = "TRUE")
-  err <- tryCatch(
-    capture.output(suppressMessages(testthat::test_local(
-      test_path("test-parallel", "startup"),
-      reporter = "summary"
-    ))),
-    error = function(e) e
-  )
+  local_parallel_test_config()
+
+  err <- capture_parallel_error(test_path("test-parallel", "startup"))
   expect_s3_class(err, "testthat_process_error")
   expect_match(conditionMessage(err), "This will fail", fixed = TRUE)
 })

tests/testthat/test-parallel-stdout.R

@@ -1,6 +1,5 @@
 test_that("stdout/stderr in parallel code", {
-  skip_on_covr()
-  withr::local_envvar(TESTTHAT_PARALLEL = "TRUE")
+  local_parallel_test_config()
 
   assemble_msgs <- function(txt, test_name) {
     prefix <- paste0("> ", test_name, ": ")

tests/testthat/test-parallel-teardown.R

@@ -1,14 +1,8 @@
 test_that("teardown error", {
   skip("teardown errors are ignored")
-  skip_on_covr()
-  withr::local_envvar(TESTTHAT_PARALLEL = "TRUE")
-  err <- tryCatch(
-    capture.output(suppressMessages(testthat::test_local(
-      test_path("test-parallel", "teardown"),
-      reporter = "summary"
-    ))),
-    error = function(e) e
-  )
+  local_parallel_test_config()
+
+  err <- capture_parallel_error(test_path("test-parallel", "teardown"))
   expect_s3_class(err, "testthat_process_error")
   expect_match(err$message, "Error in teardown", fixed = TRUE)
 })

tests/testthat/test-parallel.R

@@ -26,10 +26,7 @@ test_that("good error if bad option", {
 })
 
 test_that("ok", {
-  skip_on_covr()
-  withr::local_envvar(c(TESTTHAT_PARALLEL = "TRUE"))
-  # we cannot run these with the silent reporter, because it is not
-  # parallel compatible, and they'll not run in parallel
+  local_parallel_test_config()
   capture.output(suppressMessages(
     ret <- test_local(
       test_path("test-parallel", "ok"),
@@ -44,8 +41,7 @@ test_that("ok", {
 })
 
 test_that("fail", {
-  skip_on_covr()
-  withr::local_envvar(c(TESTTHAT_PARALLEL = "TRUE"))
+  local_parallel_test_config()
   # we cannot run these with the silent reporter, because it is not
   # parallel compatible, and they'll not run in parallel
   capture.output(suppressMessages(
@@ -61,9 +57,7 @@ test_that("fail", {
 })
 
 test_that("snapshots", {
-  skip_on_covr()
-  skip_on_cran()
-  withr::local_envvar(c(TESTTHAT_PARALLEL = "TRUE"))
+  local_parallel_test_config()
 
   tmp <- withr::local_tempdir("testthat-snap-")
   file.copy(test_path("test-parallel", "snap"), tmp, recursive = TRUE)
@@ -86,9 +80,8 @@ test_that("snapshots", {
 })
 
 test_that("new snapshots are added", {
-  skip_on_covr()
-  skip_on_cran()
-  withr::local_envvar(c(TESTTHAT_PARALLEL = "TRUE", CI = "false"))
+  local_parallel_test_config()
+  withr::local_envvar(CI = "false")
 
   tmp <- withr::local_tempdir("testthat-snap-")
   file.copy(test_path("test-parallel", "snap"), tmp, recursive = TRUE)
@@ -113,9 +106,7 @@ test_that("new snapshots are added", {
 })
 
 test_that("snapshots are removed if test file has no snapshots", {
-  skip_on_covr()
-  skip_on_cran()
-  withr::local_envvar(c(TESTTHAT_PARALLEL = "TRUE"))
+  local_parallel_test_config()
 
   tmp <- withr::local_tempdir("testthat-snap-")
   file.copy(test_path("test-parallel", "snap"), tmp, recursive = TRUE)
@@ -143,10 +134,8 @@ test_that("snapshots are removed if test file has no snapshots", {
 })
 
 test_that("snapshots are removed if test file is removed", {
-  skip_on_covr()
-  skip_on_cran()
+  local_parallel_test_config()
 
-  withr::local_envvar(c(TESTTHAT_PARALLEL = "TRUE"))
   withr::defer(unlink(tmp, recursive = TRUE))
   dir.create(tmp <- tempfile("testthat-snap-"))
   file.copy(test_path("test-parallel", "snap"), tmp, recursive = TRUE)

tests/testthat/test-reporter-list.R

@@ -1,5 +1,6 @@
 # regression test: test_file() used to crash with a NULL reporter
 test_that("ListReporter with test_file and NULL reporter", {
+  withr::local_envvar(TESTTHAT_GHA_SUMMARY = "FALSE")
   test_file_path <- 'test-list-reporter/test-exercise-list-reporter.R'
   expect_no_error(test_file(test_path(test_file_path), reporter = NULL))
 })
@@ -8,6 +9,7 @@ test_that("ListReporter with test_file and NULL reporter", {
 # of a test (test_that() call).
 # N.B: the exception here happens between two tests: "before" and "after"
 test_that("ListReporter - exception outside of test_that()", {
+  withr::local_envvar(TESTTHAT_GHA_SUMMARY = "FALSE")
   test_file_path <- 'test-list-reporter/test-exception-outside-tests.R'
   res <- test_file(test_path(test_file_path), reporter = NULL)
 
@@ -30,6 +32,7 @@ test_that("ListReporter - exception outside of test_that()", {
 
 
 test_that("captures error if only thing in file", {
+  withr::local_envvar(TESTTHAT_GHA_SUMMARY = "FALSE")
   test_file_path <- 'test-list-reporter/test-only-error.R'
   res <- test_file(test_path(test_file_path), reporter = NULL)
 
@@ -39,6 +42,7 @@ test_that("captures error if only thing in file", {
 
 # ListReporter on a "standard" test file: 2 contexts, passing, failing and crashing tests
 test_that("exercise ListReporter", {
+  withr::local_envvar(TESTTHAT_GHA_SUMMARY = "FALSE")
   test_file_path <- 'test-list-reporter/test-exercise-list-reporter.R'
   res <- test_file(test_path(test_file_path), reporter = NULL)
   expect_s3_class(res, "testthat_results")
@@ -62,6 +66,7 @@ test_that("exercise ListReporter", {
 
 # bare expectations are ignored
 test_that("ListReporter and bare expectations", {
+  withr::local_envvar(TESTTHAT_GHA_SUMMARY = "FALSE")
   test_file_path <- 'test-list-reporter/test-bare-expectations.R'
   res <- test_file(test_path(test_file_path), reporter = NULL)