Merge pull request #26 from wlandau/revdep

Dependency filters for production

DESCRIPTION

@@ -2,7 +2,7 @@ Package: multiverse.internals
 Title: Internal Infrastructure for R-multiverse
 Description: R-multiverse requires this internal internal infrastructure
   package to automate contribution reviews and populate universes.
-Version: 0.2.1
+Version: 0.2.2
 License: MIT + file LICENSE
 URL: https://github.com/r-multiverse/multiverse.internals
 BugReports: https://github.com/r-multiverse/multiverse.internals/issues
@@ -29,6 +29,7 @@ Depends:
   R (>= 3.5.0)
 Imports:
   gh,
+  igraph,
   jsonlite,
   nanonext,
   pkgsearch,

NAMESPACE

@@ -6,6 +6,7 @@ export(assert_package)
 export(assert_release_exists)
 export(get_current_versions)
 export(issues_checks)
+export(issues_dependencies)
 export(issues_descriptions)
 export(issues_versions)
 export(meta_checks)
@@ -16,6 +17,10 @@ export(review_pull_request)
 export(review_pull_requests)
 export(try_message)
 importFrom(gh,gh)
+importFrom(igraph,V)
+importFrom(igraph,graph)
+importFrom(igraph,neighbors)
+importFrom(igraph,subcomponent)
 importFrom(jsonlite,parse_json)
 importFrom(jsonlite,read_json)
 importFrom(jsonlite,stream_in)

NEWS.md

@@ -1,3 +1,7 @@
+# multiverse.internals 0.2.2
+
+* Add `issues_dependencies()`.
+
 # multiverse.internals 0.2.1
 
 * Bump version to trigger rebuild.

R/issues_checks.R

@@ -17,7 +17,7 @@
 #'   meta <- meta_checks(repo = "https://wlandau.r-universe.dev")
 #'   issues <- issues_checks(meta = meta)
 #'   str(issues)
-issues_checks <- function(meta) {
+issues_checks <- function(meta = meta_checks()) {
   fields_check <- c(
     "_linuxdevel",
     "_macbinary",

R/issues_dependencies.R

@@ -0,0 +1,92 @@
+#' @title Report package dependency issues
+#' @export
+#' @family issues
+#' @description Flag packages which have issues in their strong dependencies
+#'   (`Imports:`, `Depends:`, and `LinkingTo:` in the `DESCRIPTION`.)
+#'   These include indirect/upstream dependencies, as well, not just
+#'   the explicit mentions in the `DESCRIPTION` file.
+#' @inheritSection record_issues Package issues
+#' @return A nested list of problems triggered by dependencies.
+#'   The names of top-level elements are packages affected downstream.
+#'   The value of each top-level element is a list whose names are
+#    packages at the source of a problem upstream.
+#'   Each element of this inner list is a character
+#'   vector of relevant dependencies of the downstream package.
+#'
+#'   For example, consider a linear dependency graph where `crew.cluster`
+#'   depends on `crew`, `crew` depends on `mirai`, and
+#'   `mirai` depends on `nanonext`. We represent the graph like this:
+#'      `nanonext -> mirai -> crew -> crew.cluster`.
+#'   If `nanonext` has an issue, then [issues_dependencies()] returns
+#'   `list(crew.cluster = list(nanonext = "crew"), ...)`, where `...`
+#'   stands for additional named list entries. From this list, we deduce
+#'   that `nanonext` is causing an issue affecting `crew.cluster` through
+#'   the direct dependency on `crew`.
+#'
+#'   The choice in output format from [issues_dependencies()] allows package
+#'   maintainers to more easily figure out which direct dependencies
+#'   are contributing issues and drop those direct dependencies if necessary.
+#' @param packages Character vector of names of packages with other issues.
+#' @param meta A data frame with R-universe package check results
+#'   returned by [meta_checks()].
+#' @param verbose `TRUE` to print progress while checking issues with
+#'   dependencies, `FALSE` otherwise.
+#' @examples
+#'   meta <- meta_packages(repo = "https://wlandau.r-universe.dev")
+#'   issues_dependencies(packages = character(0L), meta = meta)
+#'   issues_dependencies(packages = "crew.aws.batch", meta = meta)
+#'   issues_dependencies(packages = "nanonext", meta = meta)
+#'   issues_dependencies(packages = "crew", meta = meta)
+#'   issues_dependencies(packages = c("crew", "mirai"), meta = meta)
+issues_dependencies <- function(
+  packages,
+  meta = meta_packages(),
+  verbose = FALSE
+) {
+  if (verbose) message("Constructing the package dependency graph")
+  graph <- issues_dependencies_graph(meta)
+  vertices <- names(igraph::V(graph))
+  edges <- igraph::as_long_data_frame(graph)
+  from <- tapply(
+    X = edges$from_name,
+    INDEX = edges$to_name,
+    FUN = identity,
+    simplify = FALSE
+  )
+  issues <- list()
+  for (package in intersect(packages, vertices)) {
+    if (verbose) message("Flagging reverse dependencies of ", package)
+    revdeps <- names(igraph::subcomponent(graph, v = package, mode = "out"))
+    revdeps <- setdiff(revdeps, package)
+    for (revdep in revdeps) {
+      neighbors <- from[[revdep]]
+      keep <- match(neighbors, revdeps, nomatch = 0L) > 0L
+      issues[[revdep]][[package]] <- neighbors[keep]
+    }
+  }
+  issues
+}
+
+issues_dependencies_graph <- function(meta) {
+  repo_packages <- meta$package
+  repo_dependencies <- meta[["_dependencies"]]
+  from <- list()
+  to <- list()
+  for (index in seq_len(nrow(meta))) {
+    package <- .subset2(repo_packages, index)
+    all <- .subset2(repo_dependencies, index)
+    packages <- .subset2(all, "package")
+    role <- .subset2(all, "role")
+    strong <- packages[role %in% c("Depends", "Imports", "LinkingTo")]
+    strong <- setdiff(unique(strong), "R")
+    from[[index]] <- strong
+    to[[index]] <- rep(package, length(strong))
+  }
+  from <- unlist(from, recursive = FALSE, use.names = FALSE)
+  to <- unlist(to, recursive = FALSE, use.names = FALSE)
+  keep <- match(from, repo_packages, nomatch = 0L) > 0L
+  from <- from[keep]
+  to <- to[keep]
+  edges <- as.character(rbind(from, to))
+  igraph::graph(edges = edges)
+}

R/issues_descriptions.R

@@ -17,7 +17,7 @@
 #'   meta <- meta_packages(repo = "https://wlandau.r-universe.dev")
 #'   issues <- issues_descriptions(meta = meta)
 #'   str(issues)
-issues_descriptions <- function(meta) {
+issues_descriptions <- function(meta = meta_packages()) {
   meta <- issues_descriptions_remotes(meta)
   fields <- "remotes"
   meta <- meta[, c("package", fields)]

R/package.R

@@ -1,4 +1,5 @@
 #' @importFrom gh gh
+#' @importFrom igraph graph neighbors subcomponent V
 #' @importFrom jsonlite parse_json read_json stream_in write_json
 #' @importFrom nanonext ncurl parse_url status_code
 #' @importFrom pkgsearch cran_package

R/record_issues.R

@@ -25,6 +25,7 @@
 #'   all package are resolved.
 #' @return `NULL` (invisibly).
 #' @inheritParams issues_checks
+#' @inheritParams issues_dependencies
 #' @inheritParams issues_versions
 #' @inheritParams meta_checks
 #' @param output Character of length 1, file path to the folder to record
@@ -58,16 +59,27 @@ record_issues <- function(
   repo = "https://multiverse.r-multiverse.org",
   versions = "versions.json",
   output = "issues",
-  mock = NULL
+  mock = NULL,
+  verbose = FALSE
 ) {
   today <- mock$today %||% format(Sys.Date(), fmt = "yyyy-mm-dd")
   checks <- mock$checks %||% meta_checks(repo = repo)
   packages <- mock$packages %||% meta_packages(repo = repo)
   issues <- list() |>
     add_issues(issues_checks(meta = checks), "checks") |>
     add_issues(issues_descriptions(meta = packages), "descriptions") |>
-    add_issues(issues_versions(versions = versions), "versions") |>
-    overwrite_issues(output = output, today = today)
+    add_issues(issues_versions(versions = versions), "versions")
+  issues <- issues |>
+    add_issues(
+      issues_dependencies(names(issues), packages, verbose = verbose),
+      "dependencies"
+    )
+  overwrite_issues(
+    issues = issues,
+    output = output,
+    today = today,
+    packages = packages
+  )
   invisible()
 }
 
@@ -78,15 +90,15 @@ add_issues <- function(total, subset, category) {
   total
 }
 
-overwrite_issues <- function(issues, output, today) {
-  packages <- list.files(output)
+overwrite_issues <- function(issues, output, today, packages) {
+  with_issues <- list.files(output)
   dates <- lapply(
-    X = packages,
+    X = with_issues,
     FUN = function(path) {
       jsonlite::read_json(file.path(output, path), simplifyVector = TRUE)$date
     }
   )
-  names(dates) <- packages
+  names(dates) <- with_issues
   unlink(output, recursive = TRUE)
   dir.create(output)
   lapply(
@@ -95,7 +107,8 @@ overwrite_issues <- function(issues, output, today) {
     issues = issues,
     output = output,
     today = today,
-    dates = dates
+    dates = dates,
+    packages = packages
   )
 }
 
@@ -104,10 +117,14 @@ overwrite_package_issues <- function(
   issues,
   output,
   today,
-  dates
+  dates,
+  packages
 ) {
   path <- file.path(output, package)
   issues[[package]]$date <- dates[[package]] %||% today
+  index <- packages$package == package
+  issues[[package]]$version <- packages[["version"]][index]
+  issues[[package]]$remote_hash <- packages[["remotesha"]][index]
   jsonlite::write_json(
     x = issues[[package]],
     path = file.path(output, package),

_pkgdown.yml

@@ -16,6 +16,7 @@ reference:
 - title: Check issues
   contents:
   - issues_checks
+  - issues_dependencies
   - issues_descriptions
   - issues_versions
 - title: Record issues