Augmented update_packages to update those installed from remote repos

DESCRIPTION

@@ -28,7 +28,7 @@ Imports:
     roxygen2 (>= 4.1.1.9001),
     rversions,
     stats,
-    git2r (>= 0.11.0),
+    git2r (>= 0.13.1),
     withr
 Suggests:
     testthat (>= 0.7),
@@ -41,4 +41,4 @@ Suggests:
     bitops
 License: GPL (>= 2)
 VignetteBuilder: knitr
-RoxygenNote: 5.0.0
+RoxygenNote: 5.0.1

NAMESPACE

@@ -118,6 +118,7 @@ export(test)
 export(uninstall)
 export(unload)
 export(update_packages)
+export(update_remotes)
 export(use_appveyor)
 export(use_build_ignore)
 export(use_code_of_conduct)

R/deps.R

@@ -293,25 +293,3 @@ standardise_dep <- function(x) {
     stop("Dependencies must be a boolean or a character vector", call. = FALSE)
   }
 }
-
-#' Update packages that are missing or out-of-date.
-#'
-#' Works similarly to \code{install.packages()} but doesn't install packages
-#' that are already installed, and also upgrades out dated dependencies.
-#'
-#' @param pkgs Character vector of packages to update.
-#' @inheritParams package_deps
-#' @seealso \code{\link{package_deps}} to see which packages are out of date/
-#'   missing.
-#' @export
-#' @examples
-#' \dontrun{
-#' update_packages("ggplot2")
-#' update_packages(c("plyr", "ggplot2"))
-#' }
-update_packages <- function(pkgs, dependencies = NA,
-                            repos = getOption("repos"),
-                            type = getOption("pkgType")) {
-  pkgs <- package_deps(pkgs, repos = repos, type = type)
-  update(pkgs)
-}

R/update.R

@@ -0,0 +1,116 @@
+#' Update packages that are missing or out-of-date.
+#'
+#' Works similarly to \code{install.packages()} but doesn't install packages
+#' that are already installed, and also upgrades out dated dependencies. Can
+#' also update packages installed from remote repositories. Currently only
+#' works with packages installed from git and GitHub repositories. This feature
+#' does not require git to be installed.
+#'
+#' @param pkgs Character vector of packages to update. Leave out to update all
+#'   installed packages.
+#' @param repos character vector, the base URL(s) of the repositories to use.
+#' @param type character, indicating the type of package to download and install.
+#' @param include_remote A logical flag to update packages installed from git
+#'   and GitHub repositories.
+#' @param ... Additional parameters to pass to \code{update_remotes}
+#'   (e.g. \code{ask}).
+#' @seealso \code{\link{package_deps}} to see which packages are out of date/
+#'   missing.
+#' @examples
+#' \dontrun{
+#' update_packages("ggplot2")
+#'
+#' # install_git("git://github.com/hadley/stringr.git")
+#' update_remotes("stringr")
+#'
+#' # A mix of CRAN and git-installed packages:
+#' update_packages(c("plyr", "ggplot2", "stringr"), ask = FALSE)
+#' }
+#' @export
+update_packages <- function(pkgs = NULL,
+                            repos = getOption("repos"),
+                            type = getOption("pkgType"),
+                            include_remote = FALSE,
+                            ...) {
+  if (!is.null(pkgs)) {
+    message("Updating all installed packages.")
+    pkgs <- unname(installed.packages()[, 'Package'])
+  }
+  pkgs <- package_deps(pkgs, repos = repos, type = type)
+  status <- update(pkgs)
+  if (include_remote) {
+    update_remotes(pkgs$package[is.na(pkgs$available)], ...)
+  }
+}
+
+#' @title Update packages installed from remote repositories.
+#' @description It is vectorised so you can update multiple packages
+#'   with a single command. Currently only works with packages
+#'   installed from git and GitHub. You do not need to have git installed.
+#' @param pkgs Character vector of package names. If omitted,
+#'   will find all packages installed from remote repositories.
+#' @param ask Forces the process to ask the user for confirmation.
+#' @examples
+#' \dontrun{
+#' # install_git("git://github.com/hadley/stringr.git")
+#' update_remotes("stringr")
+#'
+#' update_remotes(ask = FALSE)
+#'}
+#' @export
+update_remotes <- function(pkgs = NULL, ask = TRUE) {
+
+  if (is.null(pkgs)) {
+    if (ask) {
+      user_response <- readline(prompt = "Are you sure you can't provide specific packages? y/n: ")
+      if (user_response != "y") {
+        return(invisible())
+      }
+    }
+    message("Checking ALL installed packages for remote-ness.")
+    pkgs <- installed.packages()[, 'Package']
+  }
+
+  message("Acquiring local and remote metadata.")
+  local_info <- get_local_info(pkgs)
+  local_info <- local_info[local_info$git, ]
+  local_info$remote_sha1 <- get_remote_sha1(local_info$url)
+  sha1_different <- local_info$sha1 != local_info$remote_sha1
+
+  if (!any(sha1_different)) {
+    message("None of the packages need to be updated.")
+    return(invisible())
+  }
+
+  if (sum(sha1_different) == 1) {
+    message(paste("1 package has a different SHA-1 and will be reinstalled from its remote repository:",
+                  rownames(local_info)[sha1_different]))
+  } else {
+    message(sum(sha1_different), " packages have different SHA-1's and will be reinstalled from their remote repositories: ",
+            paste0(rownames(local_info)[sha1_different], collapse =', '))
+  }
+
+  if (ask) {
+    user_response <- readline(prompt = "Reinstall? y/n: ")
+    if (user_response != "y") {
+      return(invisible())
+    }
+  }
+
+  temp <- apply(local_info[sha1_different, ], 1, function(package) {
+    if (grepl('github', package['url'])) {
+      return(tryCatch(install_github(sub('https://github.com/', '', package['url']), ref = package['ref']),
+                      error = function(e) { return(FALSE) }))
+    } else {
+      return(tryCatch(return(install_git(package['url'])),
+                      error = function(e) { return(FALSE) }))
+    }
+  })
+  if (any(temp)) {
+    message(sum(temp), " package(s) installed successfully: ", paste(names(temp), collapse = ', '))
+  }
+  if (any(!temp)) {
+    message(sum(!temp), " package(s) failed to install: ", paste(names(temp), collapse = ', '))
+  }
+  return(invisible())
+}

R/utils.r

@@ -105,3 +105,54 @@ is_bioconductor <- function(x) {
 trim_ws <- function(x) {
   gsub("^[[:space:]]+|[[:space:]]+$", "", x)
 }
+
+# For update_remotes:
+get_local_info <- function(packages) {
+  safe_strsplit <- function(x) {
+    if (length(x) == 0) {
+      return(NULL)
+    }
+    return(strsplit(x, ': ')[[1]][2])
+  }
+  message("Getting remote metadata from installed packages' DESCRIPTIONs.")
+  temp <- t(sapply(packages, function(package) {
+    remote_info <- readLines(file.path(find.package(package), 'DESCRIPTION'))
+    type <- suppressWarnings(safe_strsplit(grep('RemoteType', remote_info, value = TRUE)))
+    # Note: there might be a warning "input string # is invalid in this locale"
+    #       when running update_packages without specifying packages and it
+    #       starts going through all the installed packages.
+    if (length(type) == 0) {
+      return(c("non-remote", NA, NA, NA))
+    }
+    # The user may have listed packages that
+    # weren't installed from a remote git repo:
+    if (!(type %in% c('git', 'github'))) {
+      return(c("non-git", NA, NA, NA))
+    }
+    url <- safe_strsplit(grep('RemoteUrl', remote_info, value = TRUE))
+    repo <- safe_strsplit(grep('RemoteRepo', remote_info, value = TRUE))
+    username <- safe_strsplit(grep('RemoteUsername', remote_info, value = TRUE))
+    ref <- safe_strsplit(grep('RemoteRef', remote_info, value = TRUE))
+    sha <- safe_strsplit(grep('RemoteSha', remote_info, value = TRUE))
+    if (length(url) == 0 & type == 'github') {
+      url <- paste('https://github.com', username, repo, sep = '/')
+    }
+    if (length(ref) == 0 || is.na(ref)) {
+      ref <- 'master'
+    }
+    return(c(type, url, ref, sha))
+  }))
+  df <- as.data.frame(temp, stringsAsFactors = FALSE)
+  names(df) <- c('git', 'url', 'ref', 'sha1')
+  df$git <- df$git %in% c('git', 'github')
+  return(df)
+}
+
+get_remote_sha1 <- function(urls, refs = "master") {
+  message("Fetching remote SHA-1 hashes.")
+  temp <- unname(apply(data.frame(url = urls, ref = refs), 1, function(repo) {
+    sha1 <- git2r::remote_ls(as.character(repo['url']))
+    return(sha1[paste0('refs/heads/', as.character(repo['ref']))])
+  }))
+  return(temp)
+}