Download snapshots from GitHub (#2206)

Don't see any obvious way to test this, but I tried it out a bunch interactively. 

Fixes #1779

Author: hadley

.github/workflows/claude-code-review.yml

@@ -2,7 +2,7 @@ name: Claude Code Review
 
 on:
   pull_request:
-    types: [opened, synchronize]
+    types: [opened]
     # Optional: Only run on specific file changes
     # paths:
     #   - "src/**/*.ts"
@@ -48,7 +48,7 @@ jobs:
             to add, just reply LGTM.
 
           # Optional: Use sticky comments to make Claude reuse the same comment on subsequent pushes to the same PR
-          use_sticky_comment: true
+          # use_sticky_comment: true
 
           # Optional: Add specific tools for running tests or linting
           # allowed_tools: "Bash(npm run test),Bash(npm run lint),Bash(npm run typecheck)"

DESCRIPTION

@@ -40,6 +40,7 @@ Suggests:
     curl (>= 0.9.5),
     diffviewer (>= 0.1.0),
     digest (>= 0.6.33),
+    gh,
     knitr,
     rmarkdown,
     rstudioapi,

NAMESPACE

@@ -195,6 +195,7 @@ export(skip_on_os)
 export(skip_on_travis)
 export(skip_unless_r)
 export(snapshot_accept)
+export(snapshot_download_gh)
 export(snapshot_reject)
 export(snapshot_review)
 export(source_dir)

NEWS.md

@@ -1,5 +1,6 @@
 # testthat (development version)
 
+* New `snapshot_download_gh()` makes it easy to get snapshots off GitHub and into your local package (#1779).
 * 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)
 * `expect_snapshot_file(name=)` must have a unique file path. If a snapshot file attempts to be saved with a duplicate `name`, an error will be thrown. (#1592)
 * `test_dir()`, `test_file()`, `test_package()`, `test_check()`, `test_local()`, `source_file()` gain a `shuffle` argument 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/snapshot-file.R

@@ -180,14 +180,28 @@ snapshot_review_hint <- function(
 
   path <- paste0("tests/testthat/_snaps/", test, "/", new_name(name))
 
+  if (check) {
+    if (on_gh()) {
+      bullets <- snap_download_hint()
+    } else {
+      bullets <- c(
+        if (ci) "* Download and unzip run artifact\n",
+        if (!ci) "* Locate check directory\n",
+        paste0("* Copy '", path, "' to local test directory\n")
+      )
+    }
+  } else {
+    bullets <- NULL
+  }
+
   paste0(
-    if (check && ci) "* Download and unzip run artifact\n",
-    if (check && !ci) "* Locate check directory\n",
-    if (check) paste0("* Copy '", path, "' to local test directory\n"),
-    if (check) "* ",
-    cli::format_inline(
-      "Run {.run testthat::snapshot_review('{test}/')} to review changes"
-    )
+    c(
+      bullets,
+      cli::format_inline(
+        "* Run {.run testthat::snapshot_review('{test}/')} to review changes"
+      )
+    ),
+    collapse = ""
   )
 }
 

R/snapshot-github.R

@@ -0,0 +1,148 @@
+#' Download snapshots from GitHub
+#'
+#' @description
+#' If your snapshots fail on GitHub, it can be a pain to figure out exactly
+#' why, or to incorporate them into your local package. This function makes it
+#' easy, only requiring you to interactively select which job you want to
+#' take the artifacts from.
+#'
+#' Note that you should not generally need to use this function manually;
+#' instead copy and paste from the hint emitted on GitHub.
+#'
+#' @param repository Repository owner/name, e.g. `"r-lib/testthat"`.
+#' @param run_id Run ID, e.g. `"47905180716"`. You can find this in the action url.
+#' @param dest_dir Directory to download to. Defaults to the current directory.
+#' @export
+snapshot_download_gh <- function(repository, run_id, dest_dir = ".") {
+  check_string(repository)
+  check_string(run_id)
+  check_string(dest_dir)
+
+  check_installed("gh")
+
+  dest_snaps <- file.path(dest_dir, "tests", "testthat", "_snaps")
+  if (!dir.exists(dest_snaps)) {
+    cli::cli_abort("No snapshot directory found in {.file {dest_dir}}.")
+  }
+
+  job_id <- gh_find_job(repository, run_id)
+  artifact_id <- gh_find_artifact(repository, job_id)
+
+  path <- withr::local_tempfile(pattern = "gh-snaps-")
+  gh_download_artifact(repository, artifact_id, path)
+
+  files <- dir(path, full.names = TRUE)
+  if (length(files) != 1) {
+    cli::cli_abort("Unexpected artifact format.")
+  }
+  inner_dir <- files[[1]]
+  src_snaps <- file.path(inner_dir, "tests", "testthat", "_snaps")
+  dir_copy(src_snaps, dest_snaps)
+}
+
+snap_download_hint <- function() {
+  repository <- Sys.getenv("GITHUB_REPOSITORY")
+  run_id <- Sys.getenv("GITHUB_RUN_ID")
+
+  sprintf(
+    "* Call `snapshot_download_gh(\"%s\", \"%s\")` to download the snapshots from GitHub.\n",
+    repository,
+    run_id
+  )
+}
+
+gh_find_job <- function(repository, run_id) {
+  jobs_json <- gh::gh(
+    "/repos/{repository}/actions/runs/{run_id}/jobs",
+    repository = repository,
+    run_id = run_id
+  )
+  jobs <- data.frame(
+    id = map_dbl(jobs_json$jobs, \(x) x$id),
+    name = map_chr(jobs_json$jobs, \(x) x$name)
+  )
+  jobs <- jobs[order(jobs$name), ]
+
+  idx <- utils::menu(jobs$name, title = "Which job?")
+  if (idx == 0) {
+    cli::cli_abort("Selection cancelled.")
+  }
+  jobs$id[[idx]]
+}
+
+gh_find_artifact <- function(repository, job_id) {
+  job_logs <- gh::gh(
+    "GET /repos/{repository}/actions/jobs/{job_id}/logs",
+    repository = repository,
+    job_id = job_id,
+    .send_headers = c("Accept" = "application/vnd.github.v3+json")
+  )
+
+  log_lines <- strsplit(job_logs$message, "\r?\n")[[1]]
+  matches <- re_match(log_lines, "Artifact download URL: (?<artifact_url>.*)")
+  matches <- matches[!is.na(matches$artifact_url), ]
+  if (nrow(matches) == 0) {
+    cli::cli_abort("Failed to find artifact.")
+  }
+
+  # Take last artifact URL; if the job has failed the previous artifact will
+  # be the R CMD check logs
+  artifact_url <- matches$artifact_url[nrow(matches)]
+  basename(artifact_url)
+}
+
+gh_download_artifact <- function(repository, artifact_id, path) {
+  zip_path <- withr::local_tempfile(pattern = "gh-zip-")
+  gh::gh(
+    "/repos/{repository}/actions/artifacts/{artifact_id}/{archive_format}",
+    repository = repository,
+    artifact_id = artifact_id,
+    archive_format = "zip",
+    .destfile = zip_path
+  )
+  utils::unzip(zip_path, exdir = path)
+  invisible(path)
+}
+
+# Directory helpers ------------------------------------------------------------
+
+dir_create <- function(paths) {
+  for (path in paths) {
+    dir.create(path, recursive = TRUE, showWarnings = FALSE)
+  }
+  invisible(paths)
+}
+
+dir_copy <- function(src_dir, dst_dir) {
+  # First create directories
+  dirs <- list.dirs(src_dir, recursive = TRUE, full.names = FALSE)
+  dir_create(file.path(dst_dir, dirs))
+
+  # Then copy files
+  files <- dir(src_dir, recursive = TRUE)
+  src_files <- file.path(src_dir, files)
+  dst_files <- file.path(dst_dir, files)
+  same <- map_lgl(seq_along(files), \(i) {
+    same_file(src_files[[i]], dst_files[[i]])
+  })
+
+  n_new <- sum(!same)
+  if (n_new == 0) {
+    cli::cli_inform(c(i = "No new snapshots."))
+  } else {
+    cli::cli_inform(c(
+      v = "Copying {n_new} new snapshots: {.file {files[!same]}}."
+    ))
+  }
+
+  file.copy(src_files[!same], dst_files[!same], overwrite = TRUE)
+  invisible()
+}
+
+same_file <- function(x, y) {
+  file.exists(x) && file.exists(y) && hash_file(x) == hash_file(y)
+}
+
+on_gh <- function() {
+  Sys.getenv("GITHUB_ACTIONS") == "true"
+}

R/snapshot.R

@@ -368,6 +368,7 @@ snapshot_accept_hint <- function(variant, file, reset_output = TRUE) {
   }
 
   paste0(
+    if (on_gh()) snap_download_hint(),
     cli::format_inline(
       "* Run {.run testthat::snapshot_accept('{name}')} to accept the change."
     ),

R/utils.R

@@ -67,3 +67,28 @@ no_wrap <- function(x) {
 paste_c <- function(...) {
   paste0(c(...), collapse = "")
 }
+
+# from rematch2
+re_match <- function(text, pattern, perl = TRUE, ...) {
+  stopifnot(is.character(pattern), length(pattern) == 1, !is.na(pattern))
+  text <- as.character(text)
+  match <- regexpr(pattern, text, perl = perl, ...)
+  start <- as.vector(match)
+  length <- attr(match, "match.length")
+  end <- start + length - 1L
+  matchstr <- substring(text, start, end)
+  matchstr[start == -1] <- NA_character_
+  res <- data.frame(stringsAsFactors = FALSE, .text = text, .match = matchstr)
+  if (!is.null(attr(match, "capture.start"))) {
+    gstart <- attr(match, "capture.start")
+    glength <- attr(match, "capture.length")
+    gend <- gstart + glength - 1L
+    groupstr <- substring(text, gstart, gend)
+    groupstr[gstart == -1] <- NA_character_
+    dim(groupstr) <- dim(gstart)
+    res <- cbind(groupstr, res, stringsAsFactors = FALSE)
+  }
+  names(res) <- c(attr(match, "capture.names"), ".text", ".match")
+  class(res) <- c("tbl_df", "tbl", class(res))
+  res
+}

man/snapshot_download_gh.Rd

@@ -27,7 +27,7 @@
     Code
       cat(snapshot_review_hint("lala", "foo.r", check = FALSE, ci = FALSE))
     Output
-      Run `testthat::snapshot_review('lala/')` to review changes
+      * Run `testthat::snapshot_review('lala/')` to review changes
 
 ---
 
@@ -47,6 +47,14 @@
       * Copy 'tests/testthat/_snaps/lala/foo.new.r' to local test directory
       * Run `testthat::snapshot_review('lala/')` to review changes
 
+---
+
+    Code
+      cat(snapshot_review_hint("lala", "foo.r", check = TRUE, ci = TRUE))
+    Output
+      * Call `snapshot_download_gh("r-lib/testthat", "123")` to download the snapshots from GitHub.
+      * Run `testthat::snapshot_review('lala/')` to review changes
+
 # expect_snapshot_file validates its inputs
 
     Code