Merge pull request #56 from wlandau/main

Staging fixes

.lintr

@@ -1,5 +1,5 @@
 linters: linters_with_defaults(
-  cyclocomp_linter = NULL,
+  return_linter = NULL,
   infix_spaces_linter = NULL,
   object_length_linter = NULL,
   object_name_linter = NULL,

DESCRIPTION

@@ -2,7 +2,7 @@ Package: multiverse.internals
 Title: Internal Infrastructure for R-multiverse
 Description: R-multiverse requires this internal infrastructure package to
   automate contribution reviews and populate universes.
-Version: 0.3.5
+Version: 0.3.6
 License: MIT + file LICENSE
 URL:
   https://r-multiverse.org/multiverse.internals/,

NEWS.md

@@ -1,3 +1,10 @@
+# multiverse.internals 0.3.6
+
+* Detect source failures as issues.
+* Flag R-multiverse packages whose CRAN versions from the day of the Staging freeze are higher than the current versions in R-multiverse.
+* Use the whole R version in `propose_snapshot()` so downstream automation can grep the snapshot URL for the version instead of needing to install R and the `rversions` package.
+* Write `config.json` in Staging to select the CRAN snapshot from the start of the freeze.
+
 # multiverse.internals 0.3.5
 
 * Depend on R >= 4.4.0 for the base coalescing operator `%||%`.

R/interpret_status.R

@@ -19,6 +19,7 @@ interpret_status <- function(package, issues) {
       interpret_checks(issue),
       interpret_dependencies(issue, package),
       interpret_remotes(issue),
+      interpert_version_conflicts(issue),
       interpret_versions(issue)
     ),
     collapse = ""
@@ -31,13 +32,13 @@ interpret_title <- function(issue, package) {
     "R-multiverse found issues with package ",
     package
   )
-  if (is.character(issue$versions)) {
+  if (is.character(issue$version)) {
     title <- paste(title, "version", issue$version)
   }
   if (is.character(issue$remote_hash)) {
     title <- paste(title, "remote hash", issue$remote_hash)
   }
-  paste0(title, " since ", issue$date, ".<br><br>")
+  paste0(title, " (as of ", issue$date, ").<br><br>")
 }
 
 interpret_advisories <- function(issue) {
@@ -158,6 +159,24 @@ interpret_versions <- function(issue) {
   )
 }
 
+interpert_version_conflicts <- function(issues) {
+  out <- character(0L)
+  if (!is.null(issues$descriptions$cran)) {
+    out <- paste(
+      out,
+      "On CRAN, this package had version",
+      issues$descriptions$cran,
+      "during the first day of the most recent R-multiverse Staging period.",
+      "The version on R-multiverse is lower,",
+      "which causes install.packages() to prefer CRAN.",
+      "If you have not already done so, please ensure the latest",
+      "GitHub/GitLab release has a suitably recent version",
+      "in the DESCRIPTION file.<br><br>"
+    )
+  }
+  trimws(out)
+}
+
 yaml_html <- function(x) {
   out <- yaml::as.yaml(x, line.sep = "\n")
   out <- sprintf("<pre>%s</pre>", out)

R/issues_descriptions.R

@@ -8,6 +8,8 @@
 #'     <https://github.com/RConsortium/r-advisory-database>.
 #'   2. Licenses that cannot be verified as free and open-source.
 #'   3. The presence of a `"Remotes"` field.
+#'   4. A lower version number on R-multiverse than on CRAN,
+#'     if the package is also published there.
 #' @inheritSection record_issues Package issues
 #' @return A named list of information about packages which do not comply
 #'   with `DESCRPTION` checks. Each name is a package name,
@@ -24,8 +26,16 @@ issues_descriptions <- function(meta = meta_packages()) {
   meta <- issues_descriptions_advisories(meta)
   meta <- issues_descriptions_licenses(meta)
   meta <- issues_descriptions_remotes(meta)
+  meta <- issues_descriptions_version_conflict(meta, repo = "cran")
   meta <- meta[meta$issue,, drop = FALSE] # nolint
-  issues_list(meta[, c("package", "advisories", "license", "remotes")])
+  fields <- c(
+    "package",
+    "advisories",
+    "license",
+    "remotes",
+    "cran"
+  )
+  issues_list(meta[, fields])
 }
 
 issues_descriptions_advisories <- function(meta) {
@@ -53,3 +63,19 @@ issues_descriptions_remotes <- function(meta) {
   meta$issue <- meta$issue | vapply(meta$remotes, length, integer(1L)) > 0L
   meta
 }
+
+issues_descriptions_version_conflict <- function(meta, repo) {
+  conflict <- vapply(
+    X = seq_len(nrow(meta)),
+    FUN = function(index) {
+      utils::compareVersion(
+        a = meta$version[index],
+        b = meta[[repo]][index]
+      ) < 0L
+    },
+    FUN.VALUE = logical(1L)
+  )
+  meta[[repo]][!conflict] <- NA_character_
+  meta$issue <- meta$issue | conflict
+  meta
+}

R/meta_checks.R

@@ -11,21 +11,30 @@
 #' meta_checks(repo = "https://wlandau.r-universe.dev")
 meta_checks <- function(repo = "https://community.r-multiverse.org") {
   base <- file.path(trim_url(repo), "api", "packages?stream=true&fields=")
-  out <- jsonlite::stream_in(
-    con = gzcon(url(paste0(base, "_buildurl,_binaries"))),
+  json <- jsonlite::stream_in(
+    con = gzcon(url(paste0(base, "_buildurl,_binaries,_failure"))),
     verbose = FALSE,
     simplifyVector = TRUE,
     simplifyDataFrame = TRUE,
     simplifyMatrix = TRUE
   )
-  out$url <- out[["_buildurl"]]
-  out$issues <- lapply(out[["_binaries"]], meta_checks_issues)
-  colnames(out) <- tolower(colnames(out))
-  rownames(out) <- out$package
-  out[, c("package", "url", "issues")]
+  meta_checks_process_json(json)
 }
 
-meta_checks_issues <- function(binaries) {
+meta_checks_process_json <- function(json) {
+  json$url <- json[["_failure"]]$buildurl %||% rep(NA_character_, nrow(json))
+  success_source <- is.na(json$url)
+  json$url[success_source] <- json[["_buildurl"]][success_source]
+  json$issues <- lapply(json[["_binaries"]], meta_checks_issues_binaries)
+  for (index in which(!success_source)) {
+    json$issues[[index]]$source <- "FAILURE"
+  }
+  colnames(json) <- tolower(colnames(json))
+  rownames(json) <- json$package
+  json[, c("package", "url", "issues")]
+}
+
+meta_checks_issues_binaries <- function(binaries) {
   check <- .subset2(binaries, "check")
   os <- .subset2(binaries, "os")
   arch <- .subset2(binaries, "arch")

R/meta_packages.R

@@ -3,7 +3,18 @@
 #' @family meta
 #' @description List package metadata in an R universe.
 #' @return A data frame with one row per package and columns with package
-#'   metadata.
+#'   metadata. The most important columns are:
+#'   * `package`: character vector of package names.
+#'   * `version`: character vector of package versions in the repo.
+#'   * `license`: character vector of license names.
+#'   * `remotesha`: character vector of GitHub/GitLab commit hashes.
+#'   * `remotes`: list of character vectors with dependencies in the
+#'     `Remotes:` field of the `DESCRIPTION` files.
+#'   * `foss`: `TRUE` if the package has a valid free open-source license,
+#'     `FALSE` otherwise.
+#'   * `cran`: character vector of versions. Each version is the version of
+#'     the package that was on CRAN during the first day of the most recent
+#'     R-multiverse staging period.
 #' @inheritParams meta_checks
 #' @param fields Character string of fields to query.
 #' @examples
@@ -29,5 +40,14 @@ meta_packages <- function(
   foss <- utils::available.packages(repos = repo, filters = "license/FOSS")
   out$foss <- FALSE
   out[as.character(foss[, "Package"]), "foss"] <- TRUE
+  freeze <- date_staging_freeze()
+  p3m <- "https://packagemanager.posit.co"
+  repo_cran <- file.path(p3m, "cran", freeze)
+  cran <- utils::available.packages(repos = repo_cran)
+  cran <- data.frame(
+    package = as.character(cran[, "Package"]),
+    cran = as.character(cran[, "Version"])
+  )
+  out <- merge(x = out, y = cran, all.x = TRUE, all.y = FALSE)
   out
 }

R/propose_snapshot.R

@@ -39,7 +39,7 @@ propose_snapshot <- function(
   path_staging,
   repo_staging = "https://staging.r-multiverse.org",
   types = c("src", "win", "mac"),
-  r_versions = gsub("\\.[0-9]*$", "", rversions::r_release()$version),
+  r_versions = rversions::r_release()$version,
   mock = NULL
 ) {
   path_issues <- file.path(path_staging, "issues.json")

R/update_staging.R

@@ -76,5 +76,13 @@ update_staging <- function(
   json_new <- rbind(json_freeze, json_update)
   json_new <- json_new[order(json_new$package), ]
   jsonlite::write_json(json_new, file_staging, pretty = TRUE)
+  file_config <- file.path(path_staging, "config.json")
+  json_config <- list(cran_version = date_staging_freeze())
+  jsonlite::write_json(
+    json_config,
+    file_config,
+    pretty = TRUE,
+    auto_unbox = TRUE
+  )
   invisible()
 }

R/utils_date.R

@@ -0,0 +1,8 @@
+date_staging_freeze <- function() {
+  today <- Sys.Date()
+  year <- as.integer(format(today, "%Y"))
+  years <- as.character(rep(c(year - 1L, year), each = 4L))
+  months <- rep(c("01-15", "04-15", "07-15", "10-15"), times = 2L)
+  freezes <- as.Date(paste(years, months, sep = "-"))
+  as.character(max(freezes[freezes <= today]))
+}

tests/testthat/helper-mock.R

@@ -639,7 +639,12 @@ mock_meta_packages <- structure(
       c("hyunjimoon/SBC", "stan-dev/cmdstanr", ""), NULL, NULL,
       "markvanderloo/tinytest/pkg", NULL, NULL, NULL
     ),
-    foss = c(rep(TRUE, 15L), FALSE, rep(TRUE, 4L))
+    foss = c(rep(TRUE, 15L), FALSE, rep(TRUE, 4L)),
+    cran = c(
+      "1.0.0", NA, NA, NA, "0.0.1", "0.0.1", "0.0.1", "1.1.0",
+      NA, NA, "0.0.1", NA, "0.0.1", NA, "0.0.1", NA, NA, NA, "0.0.1",
+      NA
+    )
   ),
   class = "data.frame",
   row.names = c(NA, 20L)
@@ -770,7 +775,8 @@ mock_meta_packages_graph <- structure(
       )
     ),
     distro = c("noble", "noble", "noble", "noble", "noble"),
-    foss = rep(TRUE, 5L)
+    foss = rep(TRUE, 5L),
+    cran = rep(NA_character_, 5L)
   ),
   class = "data.frame",
   row.names = c(NA, 5L)

tests/testthat/test-interpret_status.R

@@ -119,6 +119,12 @@ test_that("interpret_status() checks etc.", {
       fixed = TRUE
     )
   )
+  expect_true(
+    grepl(
+      "On CRAN",
+      interpret_status("SBC", issues)
+    )
+  )
   issues$tidypolars$dependencies <- list(x = "y")
   expect_true(
     grepl(

tests/testthat/test-issues_descriptions.R

@@ -5,10 +5,13 @@ test_that("issues_descriptions() mocked", {
     stantargets = list(
       remotes = c("hyunjimoon/SBC", "stan-dev/cmdstanr")
     ),
+    SBC = list(cran = "1.0.0"),
     targetsketch = list(license = "non-standard"),
     tidypolars = list(remotes = "markvanderloo/tinytest/pkg")
   )
-  expect_equal(issues, expected)
+  names <- sort(names(issues))
+  expect_equal(names, sort(names(expected)))
+  expect_equal(issues[names], expected[names])
 })
 
 test_that("issues_descriptions() on a small repo", {
@@ -46,9 +49,14 @@ test_that("issues_descriptions() with security advisories", {
         "blob/main/vulns/readxl/RSEC-2023-2.yaml"
       )
     ),
-    stantargets = list(remotes = c("hyunjimoon/SBC", "stan-dev/cmdstanr")),
+    stantargets = list(
+      remotes = c("hyunjimoon/SBC", "stan-dev/cmdstanr")
+    ),
+    SBC = list(cran = "1.0.0"),
     targetsketch = list(license = "non-standard"),
     tidypolars = list(remotes = "markvanderloo/tinytest/pkg")
   )
-  expect_equal(out, exp)
+  names <- sort(names(out))
+  expect_equal(names, sort(names(exp)))
+  expect_equal(out[names], exp[names])
 })