Markdown summary on GHA

R/gha-summary.R

@@ -0,0 +1,92 @@
+
+create_gha_summary <- function(results) {
+  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 <- file(out, open = "a+b", encoding = "unknown")
+  on.exit(close(out), add = TRUE)
+
+  p <- function(...) {
+    s <- paste0(...)
+    Encoding(s) <- "unknown"
+    cat(s, file = out, append = TRUE)
+  }
+  fmt_time <- function(x) sprintf("%.3fs", x)
+
+  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
+  p("### Test summary\n\n")
+  p("| \u274c FAIL | \u26a0 WARN | \u23ed\ufe0f SKIP | \u2705 PASS | \u23f1 Time |\n")
+  p("|------------:|------------:|------------------:|------------:|:------------|\n")
+
+  p(paste0(
+    "|", if (totals$n_fail > 0) paste0("\u274c **", totals$n_fail, "**"),
+    "|", if (totals$n_warn > 0) paste0("\u26a0 **", totals$n_warn, "**"),
+    "|", if (totals$n_skip > 0) paste0("\u23ed\ufe0f **", totals$n_skip, "**"),
+    "|", paste0("\u2705 **", totals$n_ok, "**"),
+    "|", fmt_time(totals$real),
+    "|\n"
+  ))
+
+  # tests with issues
+  p("\n<details>\n\n")
+
+  p("### Test details\n\n")
+  p("| \u274c FAIL | \u26a0 WARN | \u23ed\ufe0f SKIP | \u2705 PASS | context | test | \u23f1 Time |\n")
+  p("|------------:|------------:|------------------:|------------:|:--------|:-----|:------------|\n")
+
+  escape <- function(x) {
+    x <- gsub("|", "\\|", x, fixed = TRUE)
+    x <- gsub("\n", " ", x, fixed = TRUE)
+    x
+  }
+
+  issues <- Filter(function(x) length(x$results) != x$n_ok, results)
+  for (issue in issues) {
+    p(paste0(
+      "|", if (issue$n_fail > 0) paste0("\u274c **", issue$n_fail, "**"),
+      "|", if (issue$n_warn > 0) paste0("\u26a0 **", issue$n_warn, "**"),
+      "|", if (issue$n_skip > 0) paste0("\u23ed\ufe0f **", issue$n_skip, "**"),
+      "|", if (issue$n_ok   > 0) paste0("\u2705 **", issue$n_ok, "**"),
+      "|", escape(context_name(issue$file)),
+      "|", escape(issue$test),
+      "|", fmt_time(issue$real),
+      "|\n"
+    ))
+  }
+
+  p("\n</details>\n\n\n")
+
+  invisible(results)
+}
+
+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
+}

R/parallel.R

@@ -78,6 +78,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,
       stop_on_warning = stop_on_warning

R/test-files.R

@@ -125,6 +125,8 @@ test_file <- function(path,
     stop("`path` does not exist", call. = FALSE)
   }
 
+  withr::local_envvar(TESTTHAT_GHA_SUMMARY = "false")
+
   test_files(
     test_dir = dirname(path),
     test_package = package,
@@ -214,6 +216,8 @@ test_files_serial <- function(test_dir,
     )
   )
 
+  create_gha_summary(reporters$list$get_results())
+
   test_files_check(reporters$list$get_results(),
     stop_on_failure = stop_on_failure,
     stop_on_warning = stop_on_warning

tests/testthat/test-parallel-crash.R

@@ -4,7 +4,10 @@ test_that("crash", {
 
   skip_on_cran()
   skip_on_covr()
-  withr::local_envvar(TESTTHAT_PARALLEL = "TRUE")
+  withr::local_envvar(c(
+    TESTTHAT_PARALLEL = "TRUE",
+    TESTTHAT_GHA_SUMMARY = "FALSE"
+  ))
 
   do <- function() {
     err <- NULL

tests/testthat/test-parallel-outside.R

@@ -1,6 +1,9 @@
 
 test_that("error outside of test_that()", {
-  withr::local_envvar(TESTTHAT_PARALLEL = "TRUE")
+  withr::local_envvar(c(
+    TESTTHAT_PARALLEL = "TRUE",
+    TESTTHAT_GHA_SUMMARY = "FALSE"
+  ))
   err <- tryCatch(
     capture.output(suppressMessages(testthat::test_local(
       test_path("test-parallel", "outside"),

tests/testthat/test-parallel-setup.R

@@ -1,7 +1,10 @@
 
 test_that("error in parallel setup code", {
   skip_on_covr()
-  withr::local_envvar(TESTTHAT_PARALLEL = "TRUE")
+  withr::local_envvar(c(
+    TESTTHAT_PARALLEL = "TRUE",
+    TESTTHAT_GHA_SUMMARY = "FALSE"
+  ))
   err <- tryCatch(
     capture.output(suppressMessages(testthat::test_local(
       test_path("test-parallel", "setup"),

tests/testthat/test-parallel-startup.R

@@ -1,7 +1,10 @@
 
 test_that("startup error", {
   skip_on_covr()
-  withr::local_envvar(TESTTHAT_PARALLEL = "TRUE")
+  withr::local_envvar(c(
+    TESTTHAT_PARALLEL = "TRUE",
+    TESTTHAT_GHA_SUMMARY = "FALSE"
+  ))
   err <- tryCatch(
     capture.output(suppressMessages(testthat::test_local(
       test_path("test-parallel", "startup"),

tests/testthat/test-parallel-teardown.R

@@ -1,7 +1,10 @@
 
 test_that("teardown error", {
   skip("teardown errors are ignored")
-  withr::local_envvar(TESTTHAT_PARALLEL = "TRUE")
+  withr::local_envvar(c(
+    TESTTHAT_PARALLEL = "TRUE",
+    TESTTHAT_GHA_SUMMARY = "FALSE"
+  ))
   err <- tryCatch(
     capture.output(suppressMessages(testthat::test_local(
       test_path("test-parallel", "teardown"),

tests/testthat/test-parallel.R

@@ -23,9 +23,10 @@ test_that("detect number of cpus to use", {
 })
 
 test_that("ok", {
-  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
+  withr::local_envvar(c(
+    TESTTHAT_PARALLEL = "TRUE",
+    TESTTHAT_GHA_SUMMARY = "FALSE"
+  ))
   capture.output(suppressMessages(ret <- test_local(
     test_path("test-parallel", "ok"),
     reporter = "summary",

tests/testthat/test-reporter-list.R

@@ -1,6 +1,7 @@
 
 # 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_error(test_file(test_path(test_file_path), reporter = NULL), NA)
 })
@@ -9,6 +10,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)
 
@@ -31,6 +33,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)
 
@@ -40,6 +43,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")
@@ -60,6 +64,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)
 

tests/testthat/test-snapshot-reporter.R

@@ -139,6 +139,7 @@ test_that("errors in test doesn't change snapshot", {
 })
 
 test_that("skips and unexpected errors reset snapshots", {
+  withr::local_envvar(TESTTHAT_GHA_SUMMARY = "FALSE")
   regenerate <- FALSE
 
   if (regenerate) {
@@ -161,6 +162,7 @@ test_that("skips and unexpected errors reset snapshots", {
 })
 
 test_that("`expect_error()` can fail inside `expect_snapshot()`", {
+  withr::local_envvar(TESTTHAT_GHA_SUMMARY = "FALSE")
   out <- test_file(
     test_path("test-snapshot", "test-expect-condition.R"),
     reporter = NULL

tests/testthat/test-teardown.R

@@ -26,6 +26,7 @@ test_that("teardowns runs in order", {
 })
 
 test_that("teardown run after tests complete", {
+  withr::local_envvar(TESTTHAT_GHA_SUMMARY = "FALSE")
   test_file(test_path("test-teardown/test-teardown.R"), "silent")
   expect_false(file.exists(test_path("test-teardown/teardown.txt")))
 })

tests/testthat/test-test-files.R

@@ -1,14 +1,20 @@
 # test_dir() --------------------------------------------------------------
 
 test_that("stops on failure", {
-  withr::local_envvar(TESTTHAT_PARALLEL = "FALSE")
+  withr::local_envvar(c(
+    TESTTHAT_PARALLEL = "FALSE",
+    TESTTHAT_GHA_SUMMARY = "FALSE"
+  ))
   expect_error(
     test_dir(test_path("test_dir"), reporter = "silent")
   )
 })
 
 test_that("runs all tests and records output", {
-  withr::local_envvar(TESTTHAT_PARALLEL = "FALSE")
+  withr::local_envvar(c(
+    TESTTHAT_PARALLEL = "FALSE",
+    TESTTHAT_GHA_SUMMARY = "FALSE"
+  ))
   res <- test_dir(test_path("test_dir"), reporter = "silent", stop_on_failure = FALSE)
   df <- as.data.frame(res)
   df$user <- df$system <- df$real <- df$result <- NULL
@@ -27,7 +33,10 @@ test_that("complains if no files", {
 })
 
 test_that("can control if failures generate errors", {
-  withr::local_envvar(TESTTHAT_PARALLEL = "FALSE")
+  withr::local_envvar(c(
+    TESTTHAT_PARALLEL = "FALSE",
+    TESTTHAT_GHA_SUMMARY = "FALSE"
+  ))
   test_error <- function(...) {
     test_dir(test_path("test-error"), reporter = "silent", ...)
   }
@@ -37,7 +46,11 @@ test_that("can control if failures generate errors", {
 })
 
 test_that("can control if warnings errors", {
-  withr::local_envvar(TESTTHAT_PARALLEL = "FALSE")
+  withr::local_envvar(c(
+    TESTTHAT_PARALLEL = "FALSE",
+    TESTTHAT_GHA_SUMMARY = "FALSE"
+  ))
+
   test_warning <- function(...) {
     test_dir(test_path("test-warning"), reporter = "silent", ...)
   }
@@ -49,6 +62,10 @@ test_that("can control if warnings errors", {
 # test_file ---------------------------------------------------------------
 
 test_that("can test single file", {
+  withr::local_envvar(c(
+    TESTTHAT_PARALLEL = "FALSE",
+    TESTTHAT_GHA_SUMMARY = "FALSE"
+  ))
   out <- test_file(test_path("test_dir/test-basic.R"), reporter = "silent")
   expect_length(out, 5)
 })