Forward merge develop into dev-1.5.0

.github/CONTRIBUTING.md

@@ -63,6 +63,57 @@ of a parameter recovery for the new model:
 
 Attach the script as a gist or in a collapsed block in the PR.
 
+### Model fits for the website articles
+
+The articles load cached fits through `bmm(..., file = )`. Do not commit new
+or refitted fits. The `file-size` check fails a PR when any of its commits adds
+a file larger than 1 MiB, or a new version of one, even if a later commit
+removes the file again, because a merge commit keeps every commit of the PR in
+the history. A squash merge would not, but the check cannot know which one will
+be used ([ADR 0003](../.dev/decisions/0003-model-fit-files.md)). A file whose
+content is already in the history of `develop` or of the PR's base does not
+count, wherever it sits. A changed version of a tracked large file counts as
+new. If the check names a commit of yours, rewrite the branch without that
+file, for example with an interactive rebase.
+
+- Load a fit with `bmm(..., file = "fits/<name>")` or
+  `readRDS(file = "fits/<name>.rds")`, with the path written as a string
+  literal. The folder `vignettes/articles/fits/` is gitignored. Fits that are
+  already tracked in `assets/` stay there until their article is refitted.
+  Release fits work only for articles directly in `vignettes/articles/`. The
+  build downloads them to `vignettes/articles/fits/`, and an article in a
+  subfolder looks for `fits/` next to itself.
+- Say in the PR where we can get the fit. A maintainer uploads it to the
+  `article-fits` release, and the website build downloads it from there.
+- The website build checks every relative `file = "..."` that an evaluated R
+  chunk passes as a string literal to `bmm()`, `brm()`, `readRDS()` or
+  `read_rds()`. A `fits/<name>` file must be in the release. Any other file,
+  such as `assets/<name>`, must be tracked. Both must be readable. The build
+  stops, naming the article and the file, when one is not.
+- A string that names a `fits/` path and is not such a literal fails the
+  build, because the check cannot read it. This includes
+  `readRDS("fits/<name>")` without `file =`, a path built with `paste0()` or
+  `file.path()`, and inline code. Paths passed to a writer, such as
+  `saveRDS()`, `write.csv()`, `ggsave()` or `png()`, are ignored. A path that
+  reaches a reader only through a variable or a computed value is not seen
+  unless the string itself names `fits/`. Sourced code and child documents
+  are not checked.
+- Articles that pkgdown does not build (names starting with `_`,
+  `vignettes/tutorials/`) are not checked.
+- Chunks are found as knitr finds them. A chunk opens at any line like
+  `` ```{r} ``, also inside a longer fenced block that only shows it, because
+  knitr runs it there. `#| ` options count only at the top of the chunk.
+- Upload the fit before the PR is merged into a branch that builds the site.
+- Give a refitted fit a new file name instead of replacing the old asset. The
+  website builds from `develop` and reads whatever the release holds at that
+  moment.
+
+To build the articles locally, download the fits first:
+
+```sh
+gh release download article-fits --dir vignettes/articles/fits --skip-existing
+```
+
 ## Review and merging
 
 How many reviews a PR needs depends on what it touches.

.github/scripts/check-article-fits.R

@@ -0,0 +1,205 @@
+# Run from the repository root. Checks every string literal that an evaluated R
+# chunk of a pkgdown article passes as file = "<relative path>" to a reader, and
+# fails when that file is missing next to the article or cannot be read, because
+# bmm() and brm() refit a missing fit during the build instead of failing it.
+# Readers are bmm(), brm(), readRDS() and read_rds(); writers are ignored.
+# Any other string that names a fits/ path fails, in a chunk or inline, because
+# it cannot be checked. A path that reaches a reader only through a variable or
+# a computed value is not seen unless the string itself names fits/.
+# Code that an article sources or includes as a child document is not seen.
+
+chunk_begin <- "^[\t >]*```+\\s*\\{([a-zA-Z0-9_]+( *[ ,].*)?)\\}\\s*$"
+chunk_end <- "^[\t >]*```+\\s*$"
+inline_fits <- "`r[ #][^`]*(fits/|[\"']fits[\"'])"
+fits_path <- "(^|/)fits(/|$)"
+not_evaluated <- "eval\\s*(=|:)\\s*(FALSE|F|false)\\b"
+readers <- c("bmm", "brm", "readRDS", "read_rds")
+writers <- c(
+  "saveRDS", "save", "write_rds", "write.csv", "write.table", "writeLines", "cat", "sink",
+  "ggsave", "png", "jpeg", "pdf", "svg"
+)
+# update() of a brm() fit reads file, update.bmmfit() only writes it: in neither
+# list, so a fits/ path there cannot be checked and any other path is ignored
+# a bare "fits" names the folder only as a path component
+path_builders <- c("file.path", "here", "path")
+
+if (!dir.exists("vignettes")) {
+  cat("::error::No vignettes/ folder in ", getwd(), ", so no article fits can be checked. Run the script from the repository root.\n", sep = "")
+  quit(save = "no", status = 1L)
+}
+
+finding <- function(article, line, kind, text, call = "") {
+  n <- length(line)
+  data.frame(
+    article = rep_len(article, n), line = as.integer(line), kind = rep_len(kind, n),
+    text = rep_len(text, n), call = rep_len(call, n)
+  )
+}
+
+# knitr 1.52 (group_indices(), match_chunk_end()): plain fences are text; a
+# header such as ```{r} opens a chunk wherever it stands, and only a fence with
+# the header's own prefix and backtick count closes it, or the end of the file.
+scan_chunks <- function(lines) {
+  header <- last <- integer()
+  in_chunk <- logical(length(lines))
+  fence <- NA_character_
+  for (i in seq_along(lines)) {
+    opens <- grepl(chunk_begin, lines[i])
+    if (is.na(fence)) {
+      if (opens) {
+        header <- c(header, i)
+        # knitr sets no closing pattern for a chunk that opens on line 1
+        fence <- if (i == 1L) chunk_end else sub("(^[\t >]*```+).*", "^\\1\\\\s*$", lines[i])
+      }
+    } else if (opens && grepl(sub("^([^`]*`+).*", "^\\1\\\\{", fence), lines[i])) {
+      last <- c(last, i - 1L)
+      header <- c(header, i)
+    } else if (grepl(fence, lines[i])) {
+      last <- c(last, i - 1L)
+      fence <- NA_character_
+      in_chunk[i] <- TRUE
+    }
+    in_chunk[i] <- in_chunk[i] || !is.na(fence)
+  }
+  if (!is.na(fence)) last <- c(last, length(lines))
+  list(chunks = data.frame(header = header, last = last), text = !in_chunk)
+}
+
+chunk_engine <- function(header) sub("^([a-zA-Z0-9_]+).*$", "\\1", trimws(sub(chunk_begin, "\\1", header)))
+
+strip_indent <- function(header, code) {
+  indent <- sub("^([\t >]*).*", "\\1", header)
+  if (nzchar(indent)) sub(paste0("^", sub("\\s+$", "", indent)), "", sub(paste0("^", indent), "", code)) else code
+}
+
+evaluated <- function(header, code) {
+  options <- code[seq_len(match(FALSE, startsWith(code, "#| "), nomatch = length(code) + 1L) - 1L)]
+  !grepl(not_evaluated, paste(c(header, options), collapse = " "))
+}
+
+parent_of <- function(pd, id) pd$parent[pd$id == id]
+
+after_file_equals <- function(pd, id) {
+  parent <- parent_of(pd, id)
+  siblings <- pd[pd$parent == parent, ]
+  siblings <- siblings[order(siblings$line1, siblings$col1), ]
+  at <- which(siblings$id == id)
+  parent > 0 && at > 2L &&
+    siblings$token[at - 1L] == "EQ_SUB" &&
+    siblings$token[at - 2L] == "SYMBOL_SUB" && gsub("`", "", siblings$text[at - 2L]) == "file"
+}
+
+file_argument_call <- function(pd, id) {
+  while (id > 0L && !after_file_equals(pd, id)) id <- parent_of(pd, id)
+  if (id > 0L) parent_of(pd, id) else NA_integer_
+}
+
+call_name <- function(pd, id) {
+  heads <- pd$id[pd$parent == id & pd$token == "expr"]
+  c(pd$text[pd$token == "SYMBOL_FUNCTION_CALL" & pd$parent %in% heads], "")[1]
+}
+
+enclosing_call_name <- function(pd, id) {
+  while (id > 0L && !nzchar(call_name(pd, id))) id <- parent_of(pd, id)
+  if (id > 0L) call_name(pd, id) else ""
+}
+
+normalize_path <- function(path) sub("^(\\./)+", "", path)
+
+relative_path <- function(path) {
+  path <- normalize_path(path)
+  nzchar(path) && !endsWith(path, "/") && !grepl("^(/|~|\\\\|[A-Za-z]:)", path) &&
+    !grepl("://", path, fixed = TRUE) && !grepl("(^|/)\\.{1,2}(/|$)", path)
+}
+
+check_string <- function(article, line, pd, k) {
+  value <- tryCatch(str2lang(pd$text[k]), error = function(e) "")
+  literal <- pd$parent[k]
+  holder <- file_argument_call(pd, literal)
+  caller <- if (is.na(holder)) enclosing_call_name(pd, literal) else call_name(pd, holder)
+  if (caller %in% writers) {
+    NULL
+  } else if (caller %in% readers && after_file_equals(pd, literal) && sum(pd$parent == literal) == 1L && relative_path(value)) {
+    finding(article, line, "reference", value, caller)
+  } else if (grepl(fits_path, value) && (grepl("fits/", value, fixed = TRUE) || !is.na(holder) ||
+                                         enclosing_call_name(pd, literal) %in% path_builders)) {
+    finding(article, line, "problem", paste0(
+      "The string \"", value, "\" cannot be checked. Pass the fit as a literal file argument, ",
+      "readRDS(file = \"fits/<name>.rds\") or bmm(..., file = \"fits/<name>\"), so that the build can check it."
+    ))
+  }
+}
+
+check_chunk <- function(article, header, code) {
+  parsed <- tryCatch(parse(text = paste(code, collapse = "\n"), keep.source = TRUE, encoding = "UTF-8"), error = function(e) NULL)
+  pd <- if (!is.null(parsed)) utils::getParseData(parsed)
+  if (is.null(parsed) && any(grepl("[\"']fits[/\"']", code))) {
+    finding(article, header + 1L, "problem", "A code chunk that mentions fits/ cannot be parsed, so its fits cannot be checked.")
+  } else if (!is.null(pd)) {
+    do.call(rbind, lapply(which(pd$token == "STR_CONST"), function(k) check_string(article, header + pd$line1[k], pd, k)))
+  }
+}
+
+check_article <- function(article) {
+  lines <- iconv(readLines(article, warn = FALSE, encoding = "UTF-8"), "UTF-8", "UTF-8", sub = "?")
+  scanned <- scan_chunks(lines)
+  inline <- which(scanned$text & grepl(inline_fits, lines))
+  chunks <- scanned$chunks
+  rbind(
+    finding(article, inline, "problem", "Inline code names a fits/ path, which cannot be checked. Load the fit in a chunk with file = \"fits/<name>\"."),
+    do.call(rbind, lapply(seq_len(nrow(chunks)), function(k) {
+      header <- lines[chunks$header[k]]
+      code <- strip_indent(header, lines[seq_len(chunks$last[k] - chunks$header[k]) + chunks$header[k]])
+      if (tolower(chunk_engine(header)) == "r" && evaluated(header, code)) check_chunk(article, chunks$header[k], code)
+    }))
+  )
+}
+
+# bmm() appends .rds unless the extension is a lower-case rds (check_rds_file()),
+# brm() ignores the case, and the RDS readers take the path as it is written
+resolve <- function(article, path, call) {
+  path <- normalize_path(path)
+  as_written <- call %in% c("readRDS", "read_rds") | grepl("\\.rds$", path) |
+    (call == "brm" & grepl("\\.rds$", path, ignore.case = TRUE))
+  file.path(dirname(article), ifelse(as_written, path, paste0(path, ".rds")))
+}
+
+file_status <- function(file) {
+  if (!file.exists(file)) {
+    "missing"
+  } else {
+    unreadable <- function(e) paste0("cannot be read (", conditionMessage(e), ")")
+    tryCatch({ readRDS(file); "ok" }, error = unreadable, warning = unreadable)
+  }
+}
+
+reference_problem <- function(article, path, file, status) {
+  release <- startsWith(normalize_path(path), "fits/")
+  missing <- ifelse(release, "is not in the article-fits release", "is not in the tree")
+  advice <- ifelse(release, " Upload it to the article-fits release before the site is built.",
+                   ifelse(status == "missing", " Commit it, or load it from fits/ and upload it to the article-fits release.", ""))
+  paste0(basename(article), " loads ", path, ", which ", ifelse(status == "missing", missing, status),
+         ". It is expected at ", file, ".", advice)
+}
+
+escape_data <- function(x) gsub("\n", "%0A", gsub("\r", "%0D", gsub("%", "%25", x, fixed = TRUE), fixed = TRUE), fixed = TRUE)
+escape_property <- function(x) gsub(",", "%2C", gsub(":", "%3A", escape_data(x), fixed = TRUE), fixed = TRUE)
+
+articles <- list.files("vignettes", pattern = "\\.[Rrq]md$", recursive = TRUE)
+articles <- file.path("vignettes", articles[!startsWith(basename(articles), "_") & !grepl("^tutorials", dirname(articles))])
+findings <- do.call(rbind, c(list(finding(character(), integer(), character(), character())), lapply(articles, check_article)))
+
+references <- findings[findings$kind == "reference", ]
+files <- resolve(references$article, references$text, references$call)
+checked <- vapply(unique(files), file_status, character(1))
+status <- unname(checked[match(files, unique(files))])
+bad <- status != "ok"
+problems <- rbind(
+  findings[findings$kind == "problem", ],
+  finding(references$article[bad], references$line[bad], "problem",
+          reference_problem(references$article[bad], references$text[bad], files[bad], status[bad]))
+)
+
+cat(sprintf("::error file=%s,line=%d::%s\n", escape_property(problems$article), problems$line, escape_data(problems$text)), sep = "")
+cat(sprintf("Checked %d fit references in %d articles; %d problems\n", nrow(references), length(articles), nrow(problems)))
+if (nrow(problems) > 0L) quit(save = "no", status = 1L)

.github/workflows/file-size.yaml

@@ -0,0 +1,103 @@
+# Fails a pull request when any commit in it adds a file above the size limit,
+# even if a later commit removes the file: a merge commit carries every blob of
+# the branch into the history for good (a squash merge would not, but the check
+# cannot know which method will be used). Article fits go to the `article-fits`
+# release instead (ADR 0003, #438).
+# A blob that is held anywhere in the history of the base or of develop passes,
+# so renames, forward merges and restores of files tracked before this check do
+# not trip it.
+on:
+  pull_request:
+    branches: [master, develop, 'dev-*']
+    # A stacked PR is retargeted to develop when its base merges, which is an
+    # `edited` event; without it the check would never run for that PR. The
+    # event also fires for title and body edits, which only rerun the check
+    types: [opened, synchronize, reopened, edited]
+
+name: file-size
+
+jobs:
+  file-size:
+    runs-on: ubuntu-latest
+    env:
+      MAX_BYTES: 1048576
+    steps:
+      # fetch-depth 0 fetches all history of all branches and tags, so
+      # origin/develop and the pull request commits are present; filter
+      # blob:none leaves the blobs out, and the step below fetches the new
+      # ones in a single request
+      - uses: actions/checkout@v4
+        with:
+          fetch-depth: 0
+          filter: blob:none
+
+      - name: Check the size of every blob the pull request adds
+        shell: bash
+        env:
+          BASE_SHA: ${{ github.event.pull_request.base.sha }}
+          HEAD_SHA: ${{ github.event.pull_request.head.sha }}
+        run: |
+          set -euo pipefail
+          export LC_ALL=C
+          develop=refs/remotes/origin/develop
+          git rev-parse --verify --quiet "$develop" > /dev/null ||
+            git fetch --quiet --no-tags --filter=blob:none origin "+refs/heads/develop:$develop"
+          for sha in "$BASE_SHA" "$HEAD_SHA"; do
+            git cat-file -e "${sha}^{commit}" 2> /dev/null ||
+              git fetch --quiet --no-tags --filter=blob:none origin "$sha"
+          done
+          range=("$HEAD_SHA" "^$BASE_SHA" "^$develop")
+
+          listing=$(mktemp)
+          git rev-list --objects --missing=print "${range[@]}" > "$listing"
+
+          # The exclusions above only drop the trees of the two tips. A blob
+          # that sits elsewhere in their history is still listed, so it is
+          # removed here.
+          held=$(mktemp)
+          git rev-list --objects --missing=print "$BASE_SHA" "$develop" |
+            sed 's/^?//; s/ .*//' | sort -u > "$held"
+          candidates=$(mktemp)
+          sed 's/^?//; s/ .*//' "$listing" | sort -u | comm -23 - "$held" > "$candidates"
+
+          # One request for the candidate blobs the clone lacks. Looked up one
+          # by one, each blob arrives in its own pack, which takes about 0.4 s
+          # and ends in a fatal error after about 50 packs.
+          missing=$(mktemp)
+          sed -n 's/^?//p' "$listing" | sort -u | comm -12 - "$candidates" > "$missing"
+          if [ -s "$missing" ]; then
+            git -c fetch.negotiationAlgorithm=noop fetch --quiet --no-tags \
+              --no-write-fetch-head --filter=blob:none origin --stdin < "$missing"
+          fi
+
+          sizes=$(mktemp)
+          git cat-file --batch-check='%(objecttype) %(objectname) %(objectsize)' < "$candidates" > "$sizes"
+
+          # cat-file prints "<oid> missing" for an object the fetch did not
+          # deliver; the loop below skips such a line, so an unsized candidate
+          # would pass unchecked
+          status=0
+          unfetched=$(grep -c ' missing$' "$sizes" || true)
+          if [ "$unfetched" -gt 0 ]; then
+            echo "::error::${unfetched} objects could not be fetched, so their size is unknown. Rerun the check; if it fails again, the remote did not deliver the blobs."
+            status=1
+          fi
+          checked=0
+          while read -r type blob size; do
+            [ "$type" = blob ] || continue
+            checked=$((checked + 1))
+            [ "$size" -gt "$MAX_BYTES" ] || continue
+            where=$(git log -m --reverse --no-renames --raw --no-abbrev \
+              --format='commit %H' --find-object="$blob" "${range[@]}" |
+              awk -v b="$blob" '/^commit /{c=$2; next} /^:/ && $4==b && !done {split($0,a,"\t"); print c, a[2]; done=1}')
+            commit=${where%% *}
+            commit=${commit:0:10}
+            path=${where#* }
+            [ -n "$where" ] || { commit="an unknown commit"; path="(path not found)"; }
+            property=$(printf '%s' "$path" | sed 's/%/%25/g; s/,/%2C/g; s/:/%3A/g')
+            text=$(printf '%s' "$path" | sed 's/%/%25/g')
+            echo "::error file=${property}::${text} is ${size} bytes, above the limit of ${MAX_BYTES} (blob ${blob:0:10}, added in ${commit}). Upload article fits to the article-fits release instead of committing them, and drop the commit from the branch even if a later commit removes the file (see CONTRIBUTING)."
+            status=1
+          done < "$sizes"
+          echo "Checked ${checked} blobs that the pull request adds to the history"
+          exit "$status"