dashboard-live.qmd

---
title: "Dashboard: Recently Archived CRAN Packages"

execute:
  freeze: false
---

<style>
tr { vertical-align: top; }
</style>

```{r setup, include = FALSE}
knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>",
  warning = FALSE,
  message = FALSE,
  echo = FALSE
)
```

```{r package-dependencies, include = FALSE}
## Install package dependencies, if missing
pkgs <- c("ciw", "dplyr", "DT", "jsonlite")
pkgs <- pkgs[!vapply(pkgs, FUN = requireNamespace, FUN.VALUE = FALSE)]
lapply(pkgs, FUN = install.packages, character.only = TRUE)
```


```{r params, include = FALSE}
max_days <- 5*7
```

```{r dashboard}
library("dplyr")

#' @importFrom jsonlite read_json
cranhaven_packages <- local({
  data <- NULL
  
  function(url = "https://raw.githubusercontent.com/cranhaven/cranhaven.r-universe.dev/main/packages.json") {
    if (!is.null(data)) return(data)
    db <- jsonlite::read_json(url)
    
    ## Patch missing fields
    names <- unique(unlist(lapply(db, FUN = names)))
    db <- lapply(db, FUN = function(x, names) {
      missing <- setdiff(names, names(x))
      for (name in missing) {
        x[[name]] <- NA_character_
      }
      as.data.frame(x)
    }, names = names)
    stopifnot(lengths(db) == length(db[[1]]))
    
    db <- do.call(rbind, db)

    ## Coerce to dates
    db$archived_on <- as.Date(db$archived_on)
    db$x_cran_comment_date <- as.Date(db$x_cran_comment_date)
    
    data <<- db
    data
  }
}) ## cranhaven_packages()

#' @importFrom ciw incoming
cran_incoming <- local({
  data <- NULL
  
  function() {
    if (!is.null(data)) return(data)
    folders <- ciw:::known_folders
    db <- ciw::incoming(folder = folders, check = FALSE)
    db <- as.data.frame(db)
    colnames(db) <- tolower(colnames(db))
    db$package <- gsub("_.*", "", db$name)
    db$version <- gsub("(.*_|[.]tar[.]gz)", "", db$name)
    db <- db[, c("package", "version", "folder", "time")]
    data <<- db
    data
  }
})

cran_archive_latest <- local({
  db <- NULL
  function(pkg) {
    if (is.null(db)) {
      db <<- tools:::CRAN_archive_db()
    }
    idx <- match(pkg, names(db))
    if (is.na(idx)) {
      ## Should not happen, but did happen to 'cycleRtools', which
      ## vanished on 2024-11-25
      return(data.frame(version = package_version("-1", strict = FALSE), date = as.Date(NA)))
    }
    info <- db[[idx]]
    filenames <- basename(rownames(info))    
    names <- sub("[.]tar[.]gz$", "", filenames)
    versions <- sub(sprintf("^%s_", pkg), "", names)
    versions <- lapply(versions, FUN = package_version)
    max <- 1L
    for (kk in seq_along(versions)) {
      if (versions[[kk]] > versions[[max]]) max <- kk
    }
    data.frame(version = versions[[max]], date = as.Date(info$mtime[max]))
  }
})

history <- cranhaven_packages()
incoming <- cran_incoming()

## NOTE: If the same package is submitted multiple times to CRAN, it may
## show up as multiple entries in CRAN incoming, e.g.
## 1 MetaNet 0.1.2   newbies 2024-03-22 00:19:00
## 2 MetaNet 0.1.2   inspect 2024-03-21 01:25:00
## We need to all, but the latest submission to avoid duplicated in
## the dashboard.
incoming <- incoming[order(incoming$time, decreasing = TRUE), ]
for (pkg in unique(incoming$package)) {
  idxs <- which(incoming$package == pkg)
  ## Drop any but the first
  if (length(idxs) > 1) incoming <- incoming[-idxs[-1], ]
}

incoming <- incoming[, c("package", "folder")]
colnames(incoming)[2] <- "cran_incoming"
history <- merge(history, incoming, by = "package", all.x = TRUE)

## Rename columns
history <- rename(history,
  "date"   = archived_on,
  "event"  = x_cran_comment_event,
  "reason" = x_cran_comment_reason
)

idxs <- which(!is.na(history$cran_incoming))
history$event[idxs] <- paste(history$event[idxs], sprintf('<small><a href="https://nx10.github.io/cransubs/pkg#%s">resubmitted/%s</a></small>', history$package[idxs], history$cran_incoming[idxs]), sep = "<br>")

history$reason <- gsub("'([[:alnum:].]+)'", '<a href="https://cran.r-project.org/package=\\1">\\1<a>', history$reason)

idxs <- which(!is.na(history$x_cran_history))
history$reason[idxs] <- paste(history$reason[idxs], sprintf("<br><small><em>Previously</em>: %s</small>", gsub("\n", " ", history$x_cran_history[idxs])), sep = ". ")
history$reason[-idxs] <- paste0(history$reason[-idxs], ".")
history$reason <- gsub("[.]+", ".", history$reason)

## SPECIAL CASE: Package has just returned to CRAN?
idxs <- which(is.na(history$event))
if (length(idxs) > 0) {
  for (idx in idxs) {
    pkg <- history$package[idx]
    url <- sprintf("https://cran.r-project.org/package=%s", pkg)
    bfr <- tryCatch(readLines(url, warn = FALSE), error = identity)
    if (inherits(bfr, "error")) {
      ## Should not happen, but did happen to
      ## https://cran.r-project.org/package=cycleRtools on 2024-11-25
      history$event[idx] <- "?"
      history$reason[idx] <- "CRANhaven cannot currently infer status, because CRAN package page is missing."
    } else {
      has_returned <- !any(grepl("was removed from the CRAN repository", bfr))
      if (has_returned) {
        history$package[idx] <- NA_character_
      } else {
        history$event[idx] <- "?"
        history$reason[idx] <- "CRANhaven cannot currently infer status."
      }
    }
  }
  history <- subset(history, !is.na(package))
}

links <- with(history, paste(
  sprintf('<a href="https://cran-archive.r-project.org/web/checks/%s/%s_check_results_%s.html">checks</a>', sub("-.*", "", date), date, package),
  sprintf('<a href="https://github.com/cran/%s">source</a>', package),
  sep = ", "
))

values <- vapply(history$package_url, FUN.VALUE = NA_character_, FUN = function(url) {
  if (is.na(url)) return(url)
  url <- strsplit(url, split = ",")[[1]]
  url <- gsub("(^[[:space:]]+|[[:space:]]+$)", "", url)
  names(url) <- sprintf("url%d", seq_along(url))
  names(url)[1] <- "url"
  url <- sprintf('<a href="%s">%s</a>', url, names(url))
  paste(url, collapse = ", ")
})
values <- unname(values)
keep <- !is.na(values)
links[keep] <- paste(links[keep], values[keep], sep = ", ")
history$links <- links

values <- vapply(history$maintainer, FUN.VALUE = NA_character_, FUN = function(value) {
  if (is.na(value)) return(value)
  pattern <- "^[[:space:]]*([^<]*)[[:space:]]*<([^>]*)>.*$"
  name <- sub(pattern, "\\1", value)
  name <- gsub("(^[[:space:]]*|[[:space:]]*$)", "", name)
  name <- gsub("(^\"|\"$)", "", name)
  email <- sub(pattern, "\\2", value)
  email <- gsub("(^[[:space:]]*|[[:space:]]*$)", "", email)
  email <- sub("@", "-at-", email)
  sprintf('<a href="mailto:%s">%s</a>', email, name)
})
values <- unname(values)
history$maintainer <- values

package_meta <- vapply(history$package, FUN.VALUE = "", FUN = function(pkg) {
  info <- cran_archive_latest(pkg)
  sprintf("%s<br><small>(%s)</small>", as.character(info$version), format(info$date, format = "%F"))
})

history$package <- sprintf('<a href="https://cran.r-project.org/package=%s">%s</a> %s', history$package, history$package, package_meta)


age <- difftime(Sys.Date(), history$date, units = "days")
age_label <- sprintf("%s&nbsp;days&nbsp;ago", age)
age_label[age == 1] <- "1&nbsp;day&nbsp;ago"
age_label[age == 0] <- "today"
history$date <- sprintf("%s<br><small>(%s)</small>", history$date, age_label)

history <- history[, c("date", "package", "event", "reason", "maintainer", "links")]

n <- nrow(history)
n_resubmitted <- nrow(subset(history, grepl("resubmitted", event)))
resubmitted_info <- if (n_resubmitted == 0) {
  "no packages"
} else if (n_resubmitted == 1) {
  "one package"
} else {
  sprintf("%d packages", n_resubmitted)
}
```

The below table lists all `r nrow(history)` R packages that are no
longer on CRAN, because they have been either archived[^1] on or
removed[^2] from CRAN during the last `r max_days` days.  These
packages can be installed using:

```r
install.packages("pkgname", repos = c("https://cranhaven.r-universe.dev", "https://cloud.r-project.org"))
```

The table shows the date when a package was dropped by CRAN and their
reason[^3] for it. If a package has since been resubmitted and is
waiting in the CRAN incoming queue, it is marked as "resubmitted" (in
the 'event' column; currently `r resubmitted_info`).  Links to the
most recent CRAN checks and the source code are also provided.  If a
package does not return to CRAN within `r max_days` days, it is
removed also from CRANhaven[^4].

[^1]: When a package is _archived_, the archived version is still
available in the [CRAN archive area] together with all previous
versions.

[^2]: When a package is _removed_, which is a rare event, the removed
package version is completely removed from CRAN, and no longer
available for download. Earlier versions might be available in the
[CRAN archive area].

[^3]: The _reason_, which is based on the [CRAN Repository Policy], is
extracted from CRAN's manually curated [PACKAGES.in] database.

[^4]: If a package falls off also CRANhaven, it may still be
installable from the [CRAN mirror on R-universe].


```{r}
# Show only recent packages
library("DT")
datatable(history,
  rownames = FALSE,
  escape = FALSE,
  elementId = "live-dashboard",
  options = list(
    pageLength = 50,
    order = list(list(0, "desc"), list(1, "asc"))
  )
)
```


[CRAN archive area]: https://cran.r-project.org/src/contrib/Archive/
[CRAN mirror on R-universe]: https://cran.r-universe.dev/builds
[CRAN Repository Policy]: https://cran.r-project.org/web/packages/policies.html
[PACKAGES.in]: https://cran.r-project.org/src/contrib/PACKAGES.in