build-cran-binaries/local/proposal-tracking-lib.R

# Pure, IO-free helpers for the proposal feedback loop (issue #115, step 4):
# a small ledger of what the classifier proposed, plus metrics derived from the
# live triage report and the registry (signature hit rate, proposed-vs-merged,
# retirement candidates).
#
# Kept free of DB/HTTP/clock so it can be sourced by the proposer, the tracker
# entrypoint, and the unit tests. Timestamps are passed in by callers.

# Split proposal candidates into the ones safe to emit and the ambiguous ones.
# A candidate is a list with at least `package` and `signature`. A package that
# maps to more than one distinct auto-proposable signature is genuinely
# ambiguous (two conflicting fix tiers, e.g. makevars vs source patch): emitting
# both would create colliding registry entries, so those are routed to human
# triage instead of guessed at. Returns list(keep = ..., ambiguous = ...), where
# `ambiguous` is a named list of package -> the distinct signatures seen.
dedupe_candidates <- function(candidates) {
  if (length(candidates) == 0L) {
    return(list(keep = list(), ambiguous = list()))
  }
  pkgs <- vapply(candidates, function(c) as.character(c$package), character(1L))
  by_pkg <- split(candidates, pkgs)
  keep <- list()
  ambiguous <- list()
  for (pkg in names(by_pkg)) {
    cs <- by_pkg[[pkg]]
    sigs <- unique(vapply(
      cs,
      function(c) as.character(c$signature),
      character(1L)
    ))
    if (length(sigs) == 1L) {
      keep[[length(keep) + 1L]] <- cs[[1L]] # one signature -> take the first
    } else {
      ambiguous[[pkg]] <- sigs
    }
  }
  list(keep = keep, ambiguous = ambiguous)
}

# Stable identity of a ledger record: one proposal per (package, signature).
ledger_key <- function(record) {
  paste0(
    if (is.null(record$package)) "?" else record$package,
    "|",
    if (is.null(record$signature)) "?" else record$signature
  )
}

# Merge freshly-generated proposals into an existing ledger without clobbering
# history: a record whose (package, signature) already exists is left as-is
# (its status/PR/issue are preserved); genuinely new proposals are appended.
# Returns the combined list. Pure: callers stamp `proposed_at` before passing.
merge_ledger <- function(existing, new_records) {
  if (is.null(existing)) {
    existing <- list()
  }
  seen <- vapply(existing, ledger_key, character(1L))
  out <- existing
  for (rec in new_records) {
    if (!(ledger_key(rec) %in% seen)) {
      out[[length(out) + 1L]] <- rec
      seen <- c(seen, ledger_key(rec))
    }
  }
  out
}

# Per-signature hit rate from a triage report (list of group records from
# build_triage_report) crossed with the set of already-registered packages.
# For each *matched* signature: how many failing builds/packages it explains,
# and how many of those packages are already addressed by a registry entry.
signature_hit_rate <- function(report, registered_pkgs = character(0L)) {
  matched <- Filter(function(g) isTRUE(g$matched), report)
  by_sig <- split(
    matched,
    vapply(matched, function(g) g$signature, character(1L))
  )
  lapply(names(by_sig), function(sig) {
    grps <- by_sig[[sig]]
    pkgs <- unique(unlist(lapply(grps, function(g) g$packages)))
    addressed <- intersect(pkgs, registered_pkgs)
    list(
      signature = sig,
      builds = sum(vapply(grps, function(g) g$build_count, integer(1L))),
      packages = length(pkgs),
      addressed = length(addressed),
      open = length(setdiff(pkgs, registered_pkgs)),
      auto_proposable = any(vapply(
        grps,
        function(g) isTRUE(g$auto_proposable),
        logical(1L)
      ))
    )
  })
}

# Proposed-vs-merged: a ledger record counts as "merged" once its package
# appears in the registry. Returns per-record status plus a rollup.
proposed_vs_merged <- function(ledger, registered_pkgs = character(0L)) {
  if (is.null(ledger)) {
    ledger <- list()
  }
  rows <- lapply(ledger, function(rec) {
    merged <- !is.null(rec$package) && rec$package %in% registered_pkgs
    list(
      package = rec$package,
      signature = rec$signature,
      status = if (merged) "merged" else (rec$status %||% "proposed"),
      merged = merged
    )
  })
  list(
    records = rows,
    total = length(rows),
    merged = sum(vapply(rows, function(r) isTRUE(r$merged), logical(1L)))
  )
}

# Registry entries whose package no longer appears in any current failure are
# retirement candidates: the upstream cause was likely fixed, so the entry can
# be reviewed for removal. `failing_pkgs` is the set of currently-failing
# package names (from the live report).
retirement_candidates <- function(registry_entries, failing_pkgs) {
  if (is.null(registry_entries)) {
    registry_entries <- list()
  }
  keep <- Filter(
    function(e) !is.null(e$package) && !(e$package %in% failing_pkgs),
    registry_entries
  )
  vapply(keep, function(e) as.character(e$package), character(1L))
}

# Discovery view: the failure groups the classifier could NOT auto-propose, so
# they get the same visibility as proposals. `report` is a build_triage_report
# result. Returns the unclassified groups (unknown signature -> candidates for a
# new signature) ranked by build count, capped to `max_groups`, each with up to
# `max_pkgs` example packages. `dropped_groups`/`packages_truncated` record any
# cap so nothing is silently hidden.
unclassified_summary <- function(report, max_groups = 30L, max_pkgs = 15L) {
  un <- Filter(function(g) !isTRUE(g$matched), report)
  un <- un[order(-vapply(un, function(g) g$build_count, integer(1L)))]
  shown <- utils::head(un, max_groups)
  groups <- lapply(shown, function(g) {
    pkgs <- g$packages
    list(
      fingerprint = g$fingerprint,
      build_count = g$build_count,
      n_packages = length(pkgs),
      packages = utils::head(pkgs, max_pkgs),
      packages_truncated = length(pkgs) > max_pkgs,
      platforms = g$platforms
    )
  })
  list(
    groups = groups,
    total_groups = length(un),
    dropped_groups = max(0L, length(un) - length(shown)),
    total_builds = sum(vapply(un, function(g) g$build_count, integer(1L)))
  )
}

# Aggregate blocked packages across ALL groups by the dependency they wait on,
# so one dependency (RcppParallel, rstan, sf, ...) is a single line -- deduped
# and ranked by how many distinct dependents it blocks -- instead of repeating
# once per fingerprint group. Reads each group's `blocked_map` (package -> the
# dependency it is blocked on). Returns records sorted by dependent count desc,
# each with up to `max_pkgs` example dependents.
blocked_by_dependency <- function(report, max_pkgs = 15L) {
  acc <- list() # dependency -> character vector of dependent packages
  for (g in report) {
    bm <- g$blocked_map
    if (is.null(bm) || length(bm) == 0L) {
      next
    }
    for (pkg in names(bm)) {
      for (dep in as.character(unlist(bm[[pkg]]))) {
        acc[[dep]] <- unique(c(acc[[dep]], pkg))
      }
    }
  }
  if (length(acc) == 0L) {
    return(list())
  }
  out <- lapply(names(acc), function(dep) {
    pkgs <- acc[[dep]]
    list(
      dependency = dep,
      n_packages = length(pkgs),
      packages = utils::head(pkgs, max_pkgs),
      packages_truncated = length(pkgs) > max_pkgs
    )
  })
  out[order(-vapply(out, function(x) x$n_packages, integer(1L)))]
}

# Does a registry entry's `platforms` apply to a build on `os` (e.g.
# "ubuntu-2604")? Mirrors bincraft's token match: an entry applies if any of its
# platform tokens is "*", the OS codename, or the distro family ("ubuntu").
entry_applies_to_os <- function(entry_platforms, os) {
  toks <- as.character(unlist(entry_platforms))
  family <- sub("-.*$", "", os) # ubuntu-2604 -> ubuntu
  any(toks %in% c("*", os, family))
}

# Registry entries present in `current` but not in `base` (matched on
# package|platforms|versions), optionally restricted to those that apply to a
# given `os`. Used by the trial-build gate to build only the entries a PR adds.
new_registry_packages <- function(current, base, os = NULL) {
  key <- function(e) {
    sprintf(
      "%s|%s|%s",
      e$package %||% "?",
      paste(sort(as.character(unlist(e$platforms))), collapse = ","),
      e$versions %||% "?"
    )
  }
  base_keys <- vapply(base %||% list(), key, character(1L))
  added <- Filter(function(e) !(key(e) %in% base_keys), current %||% list())
  if (!is.null(os)) {
    added <- Filter(function(e) entry_applies_to_os(e$platforms, os), added)
  }
  unique(vapply(
    added,
    function(e) as.character(e$package %||% ""),
    character(1L)
  ))
}

`%||%` <- function(a, b) if (is.null(a)) b else a