Add repo status functions

DESCRIPTION

@@ -27,6 +27,7 @@ Imports:
     processx (>= 3.3.0.9001),
     rappdirs,
     rlang,
+    stats,
     tibble,
     tools,
     utils,
@@ -46,4 +47,4 @@ Suggests:
 Depends: 
     R (>= 3.1)
 Roxygen: list(packages = "roxygenlabs", markdown = TRUE, r6 = FALSE)
-RoxygenNote: 7.1.0
+RoxygenNote: 7.1.1

NAMESPACE

@@ -1,6 +1,14 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method("[",pkgcache_repo_status_summary)
+S3method(print,pkgcache_repo_status_summary)
+S3method(summary,pkgcache_repo_status)
+export(bioc_version)
+export(bioc_version_map)
 export(cranlike_metadata_cache)
+export(current_r_platform)
+export(default_cran_mirror)
+export(default_platforms)
 export(get_cranlike_metadata_cache)
 export(meta_cache_cleanup)
 export(meta_cache_deps)
@@ -15,6 +23,7 @@ export(pkg_cache_find)
 export(pkg_cache_get_file)
 export(pkg_cache_list)
 export(pkg_cache_summary)
+export(repo_status)
 import(rlang)
 importFrom(R6,R6Class)
 importFrom(assertthat,"on_failure<-")

NEWS.md

@@ -1,6 +1,18 @@
 
 # development version
 
+* New `repo_status()` function to query the status and response time
+  of CRAN-like repositories.
+
+* New `bioc_version()` and `bioc_version_map()` functions to query
+  Bioconductor repositories.
+
+* pkgcache now does not fail if some repositories do not provide
+  some package types.
+
+* New `current_r_platform()`, `default_cran_mirror()` and
+  `default_platforms()` functions.
+
 * pkgcache now works for R 4.0.x macOS binaries.
 
 # pkgcache 1.0.7

R/async-http.R

@@ -382,6 +382,7 @@ download_files <- function(data, error_on_status = TRUE,
     if (isTRUE(row$mayfail)) {
       dx$catch(error = function(err) {
         cat("", file = row$path, append = TRUE)
+        err
       })
     } else {
       dx

R/metadata-cache.R

@@ -23,7 +23,7 @@ cmc__data <- new.env(parent = emptyenv())
 #' ```
 #' cmc <- cranlike_metadata_cache$new(
 #'   primary_path = NULL, replica_path = tempfile(),
-#'   platforms = default_platforms(), r_version = current_r_version(),
+#'   platforms = default_platforms(), r_version = getRversion(),
 #'   bioc = TRUE, cran_mirror = default_cran_mirror(),
 #'   repos = getOption("repos"),
 #'   update_after = as.difftime(7, units = "days"))
@@ -169,7 +169,7 @@ cranlike_metadata_cache <- R6Class(
     initialize = function(primary_path = NULL,
                           replica_path = tempfile(),
                           platforms = default_platforms(),
-                          r_version = current_r_version(), bioc = TRUE,
+                          r_version = getRversion(), bioc = TRUE,
                           cran_mirror = default_cran_mirror(),
                           repos = getOption("repos"),
                           update_after = as.difftime(7, units = "days"))
@@ -268,6 +268,7 @@ cmc_init <- function(self, private, primary_path, replica_path, platforms,
                      r_version, bioc, cran_mirror, repos, update_after) {
 
   "!!DEBUG Init metadata cache in '`replica_path`'"
+  r_version <- as.character(r_version)
   private$primary_path <- primary_path %||% get_user_cache_dir()$root
   private$replica_path <- replica_path
   private$platforms <- platforms
@@ -431,6 +432,7 @@ cmc__get_cache_files <- function(self, private, which) {
   pkgs_files2 <- file.path(pkgs_dirs, "PACKAGES")
   mirror <- rep(private$repos$url, each = nrow(private$dirs))
   type <- rep(private$repos$type, each = nrow(private$dirs))
+  r_version <- rep(private$dirs$rversion, nrow(private$repos))
   bioc_version <- rep(private$repos$bioc_version, each = nrow(private$dirs))
 
   pkg_path <- file.path(root, "_metadata", repo_enc, pkgs_files)
@@ -460,6 +462,7 @@ cmc__get_cache_files <- function(self, private, which) {
       fallback_url = paste0(mirror, "/", pkgs_files2),
       platform = rep(private$dirs$platform, nrow(private$repos)),
       type = type,
+      r_version = r_version,
       bioc_version = bioc_version,
       meta_path = meta_path,
       meta_etag = meta_etag,
@@ -680,9 +683,44 @@ cmc__update_replica_pkgs <- function(self, private) {
     path = c(pkgs$path, pkgs$meta_path[meta]),
     etag = c(pkgs$etag, pkgs$meta_etag[meta]),
     timeout = rep(c(200, 100), c(nrow(pkgs), sum(meta))),
-    mayfail = rep(c(FALSE, TRUE), c(nrow(pkgs), sum(meta))))
+    mayfail = TRUE
+  )
+
+  download_files(dls)$
+    then(function(result) {
+      missing_pkgs_note(pkgs, result)
+      result
+    })
+}
+
+# E.g. "R 4.1 macos packages are missing from CRAN and Bioconductor"
+
+missing_pkgs_note <- function(pkgs, result) {
+  bad <- vlapply(result[seq_len(nrow(pkgs))], inherits, "error")
+  if (!any(bad)) return()
+
+  repo_name <- function(type, url) {
+    if (type == "cran") return("CRAN")
+    if (type == "bioc") return("Bioconductor")
+    sub("^https?://([^/]*).*$", "\\1", url)
+  }
+
+  msgs <- lapply(which(bad), function(i) {
+    list(
+      paste0(
+        if (pkgs$r_version[i] != "*") paste0("R ", pkgs$r_version[i], " "),
+        pkgs$platform[i]
+      ),
+      repo_name(pkgs$type[i], pkgs$mirror[i])
+    )
+  })
 
-  download_files(dls)
+  what <- vcapply(msgs, "[[", 1)
+  where <- vcapply(msgs, "[[", 2)
+  for (wt in unique(what)) {
+    wh <- unique(where[what == wt])
+    cli_alert_info("{wt} package are missing from {wh}")
+  }
 }
 
 #' Update the replica RDS from the PACKAGES files
@@ -864,26 +902,27 @@ cmc__get_repos <- function(repos, bioc, cran_mirror, r_version) {
     name = names(repos),
     url = unname(repos),
     type = ifelse(names(repos) == "CRAN", "cran", "cranlike"),
-    bioc_version = NA_character_)
+    r_version = "*",
+    bioc_version = NA_character_
+  )
 
   if (bioc) {
-    bioc_version <- as.character(bioconductor$get_bioc_version(r_version))
-    bioc_repos <- bioconductor$get_repos(bioc_version)
-
-    miss <- setdiff(names(bioc_repos), res$name)
-    bioc_res <- tibble(
-      name = miss,
-      url = unname(bioc_repos[miss]),
-      type = "bioc",
-      bioc_version = bioc_version
-    )
-    res <- rbind(res, bioc_res)
-    res$type[res$name %in% names(bioc_repos)] <- "bioc"
-    res$bioc_version[res$name %in% names(bioc_repos)] <- bioc_version
+    for (rver in r_version) {
+      bioc_version <- as.character(bioconductor$get_bioc_version(rver))
+      bioc_repos <- bioconductor$get_repos(bioc_version)
+
+      bioc_res <- tibble(
+        name = names(bioc_repos),
+        url = unname(bioc_repos),
+        type = "bioc",
+        r_version = rver,
+        bioc_version = bioc_version
+      )
+      res <- rbind(res, bioc_res)
+    }
   }
 
   res <- res[!duplicated(res$url), ]
-  res <- res[!duplicated(res$name), ]
 
   res
 }

R/platform.R

@@ -0,0 +1,98 @@
+
+#' Platform and R version information of the current session
+#'
+#' Currently used platforms:
+#' - `"source"`
+#' - `"macos"`
+#' - `"windows"`
+#'
+#' @return `current_r_platform()` returns a character scalar.
+#' @export
+#' @examples
+#' current_r_platform()
+
+current_r_platform <- function() {
+  type <- get_platform()$pkgType
+  if (!is_string(type))
+    "source"
+  else if (grepl("^mac", type)) {
+    "macos"
+  } else if (grepl("^win", type)) {
+    "windows"
+  } else {
+    "source"
+  }
+}
+
+#' @rdname current_r_platform
+#' @return `default_platform()` returns a character vector of the
+#' default platforms.
+#' @export
+#' @examples
+#' default_platforms()
+
+default_platforms <- function() {
+  unique(c(current_r_platform(), "source"))
+}
+
+#' Query the default CRAN repository for this session
+#'
+#' If `options("repos")` (see [options()]) contains an entry called
+#' `"CRAN"`, then that is returned. If it is a list, it is converted
+#' to a character vector.
+#'
+#' Otherwise the RStudio CRAN mirror is used.
+#'
+#' @return A named character vector of length one, where the
+#'   name is `"CRAN"`.
+#'
+#' @export
+#' @examples
+#' default_cran_mirror()
+
+default_cran_mirror <- function() {
+  mirror <- getOption("repos")["CRAN"]
+  if (is.null(mirror) || is.na(mirror) || mirror == "@CRAN@") {
+    c(CRAN = "https://cran.rstudio.com")
+  } else {
+    unlist(mirror)
+  }
+}
+
+#' Query Bioconductor version information
+#'
+#' `bioc_version()` queries the matching Bioconductor version for
+#' and R version, defaulting to the current R version
+#'
+#' @param r_version The R version number to match.
+#' @param forget Use `TRUE` to avoid caching the Bioconductor mapping.
+#' @return `bioc_version()` returns a [package_version] object.
+#'
+#' @export
+#' @examplesIf pkgcache:::is_online()
+#' bioc_version()
+#' bioc_version("4.0")
+#' bioc_version("4.1")
+
+bioc_version <- function(r_version = getRversion(), forget = FALSE) {
+  bioconductor$get_bioc_version(r_version, forget)
+}
+
+#' @describeIn bioc_version
+#'
+#' `bioc_version_map()` returns the current mapping between R versions
+#' and Bioconductor versions.
+#'
+#' @return `bioc_version_map()` returns a tibble with columns:
+#' * `bioc_version`: [package_version] object, Bioconductor versions.
+#' * `r_version`: [package_version] object, the matching R versions.
+#' * `bioc_status`: factor, with levels: `out-of-date`, `release`,
+#'   `devel`, `future`.
+#'
+#' @export
+#' @examplesIf pkgcache:::is_online()
+#' bioc_version_map()
+
+bioc_version_map <- function(forget = FALSE) {
+  tibble::as_tibble(bioconductor$get_version_map(forget))
+}