Add pkg_status

Returns times to repositories asynchronously

DESCRIPTION

@@ -10,7 +10,9 @@ ByteCompile: true
 RoxygenNote: 6.0.1
 Imports:
     pkgdepends,
-    pkginstall
+    pkginstall,
+    tibble,
+    async
 Remotes:
   r-lib/pkgdepends,
   r-lib/pkginstall

NAMESPACE

@@ -10,3 +10,9 @@ export(pkg_remove)
 export(repo_activate)
 export(repo_deactivate)
 export(repo_status)
+importFrom(async,async)
+importFrom(async,async_map)
+importFrom(async,http_head)
+importFrom(async,http_stop_for_status)
+importFrom(async,synchronise)
+importFrom(tibble,tibble)

R/library.R

@@ -10,7 +10,7 @@ lib_create <- function(lib) {
 
 #' Activate or deactivate a given library
 #'
-#' @param action `[character(1)]` Should lib `"replace'`, `"prepend"` or `"append"` the existing library paths.
+#' @param action `[character(1)]` Should lib `"replace"`, `"prepend"` or `"append"` the existing library paths.
 #' @inheritParams lib_create
 #' @export
 lib_activate <- function(lib, action = "replace") {

R/package.R

@@ -41,6 +41,14 @@ local_pkg_install <- function(path, lib = .libPaths()[[1L]], num_workers = 1L) {
   pkg_install(pkgdepends::remotes$new(pkg, library = lib), lib = lib, num_workers = num_workers)
 }
 
+##' Display installed locations of a package
+#pkg_status <- function(package, libraries = .libPaths()) {
+  #desc <- lapply(libraries, function(lib) {
+    #packageDescription(package, lib.loc = lib, fields = c("Version", "Built"))
+  #})
+  #desc
+#}
+
 #' Remove installed packages
 #'
 #' @param pkg A character vector of packages to remove.

R/repo.R

@@ -3,8 +3,7 @@
 #' @param ... One or more repositories to set. If a repository is unnamed it is
 #'   assumed to be the CRAN repository.
 #' @export
-repo_activate <- function(...) {
-  repo <- unlist(list(...))
+repo_activate <- function(repo) {
   nms <- names2(repo)
 
   if (sum(nms == "") > 1) {
@@ -42,8 +41,29 @@ repo_deactivate <- function(repo) {
 }
 
 #' Repository status
+#' @importFrom async async http_head async_map synchronise http_stop_for_status
+#' @importFrom tibble tibble
+#' @return A data.frame with the following columns
+#' - type - The repository type
+#' - url - The repository URL
+#' - time - Total time in seconds taken for a HEAD request to the repositiory
+#' - last_modified - Last time the repositiory was updated
 #' @export
 repo_status <- function() {
   repos <- getOption("repos")
-  data.frame(type = names(repos), url = repos, row.names = NULL)
+
+  # TODO: how to hangdle
+  resp_vals <- async(function(url, ...) {
+      http_head(url, ...)$
+      then(http_stop_for_status)$
+      then(function(resp) list(time = resp$times[["total"]], last_modified = resp$modified))$
+      catch(function(err) list(time = NA_real_, last_modified = as.POSIXct(NA)))#, last_modified = as.POSIXct(0)))
+  })
+
+  res <- synchronise(async_map(unname(repos), resp_vals, timeout = 2))
+  time <- vdapply(res, "[[", "time")
+  last_modified <- do.call(c, lapply(res, "[[", "last_modified"))
+
+  tibble(type = names(repos), url = repos, time = time, last_modified = last_modified)
 }
+

R/utils.R

@@ -23,3 +23,19 @@ names2 <- function(x) {
     nms
   }
 }
+
+vcapply <- function(X, FUN, ...) {
+  vapply(X, FUN, FUN.VALUE = character(1), ...)
+}
+
+vlapply <- function(X, FUN, ...) {
+  vapply(X, FUN, FUN.VALUE = logical(1), ...)
+}
+
+viapply <- function(X, FUN, ...) {
+  vapply(X, FUN, FUN.VALUE = integer(1), ...)
+}
+
+vdapply <- function(X, FUN, ...) {
+  vapply(X, FUN, FUN.VALUE = double(1), ...)
+}