R/updatePackages.R

In RevolutionAnalytics/miniCRAN: Create a Mini Version of CRAN Containing Only Selected Packages

#' Check for available package updates in a miniCRAN repo.
#'
#' `oldPackages()` indicates packages which have a (suitable) later version on
#' the repositories whereas `updatePackages()` offers to download and install
#' such packages.
#'
#' These functions are based on [update.packages()].  However, rather than
#' looking for locally installed packages they look for the package source and
#' binaries in the miniCRAN repository.
#'
#' @name updatePackages
#'
#' @inheritParams makeRepo
#' @inheritParams pkgDep
#'
#' @param method  Download method, see [download.file()].
#'
#' @param availableLocal all packages hosted in the miniCRAN repo, as returned
#'   by [pkgAvail()]. A subset can be specified; currently this must be in the
#'   same (character matrix) format as returned by [pkgAvail()].
#'
#' @return `oldPackages()` returns a matrix with one row per package and columns
#'   for "Package", "LocalVer", "ReposVer" and "Repository".  The matrix row
#'   names the package names.
#'
#' @seealso [updatePackages()], [pkgAvail()].
#'
#' @export
#' @family update repo functions
#'
#' @example /inst/examples/example_updatePackages.R
#'
oldPackages <- function(
  path = NULL,
  repos = getOption("repos"),
  availPkgs = pkgAvail(repos = repos, type = type, Rversion = Rversion),
  method,
  availableLocal = pkgAvail(
    repos = path,
    type = type,
    Rversion = Rversion,
    quiet = quiet
  ),
  type = "source",
  Rversion = R.version,
  quiet = FALSE
) {
  if (is.null(path)) stop("path to miniCRAN repo must be specified")
  if (!missing(availPkgs)) {
    if (!is.matrix(availPkgs) || !is.character(availPkgs[, "Package"]))
      stop("ill-formed 'availPkgs' matrix")
  }
  if (NROW(availPkgs) == 0L) stop("Invalid remote repository")
  if (NROW(availableLocal) == 0L) stop("Invalid local repository")

  idx <- match(availableLocal[, "Package"], availPkgs[, "Package"])
  compare <- sapply(seq_along(idx), function(i) {
    compareVersion(
      (availPkgs[idx[i], "Version"]),
      (availableLocal[i, "Version"])
    ) >
      0
  })

  update <- cbind(
    availableLocal[compare, c("Package", "Version"), drop = FALSE],
    availPkgs[idx[compare], c("Version", "Repository"), drop = FALSE]
  )
  colnames(update) <- c("Package", "LocalVer", "ReposVer", "Repository")
  update
}


simplifyRepos <- function(repos, t, Rversion) {
  tail <- substring(contribUrl("---", type = t, Rversion = Rversion), 4)
  ind <- regexpr(tail, repos, fixed = TRUE)
  ind <- ifelse(ind > 0, ind - 1, nchar(repos, type = "c"))
  substr(repos, 1, ind)
}

graphics_capable <- function() {
  .Platform$OS.type == "windows" ||
    .Platform$GUI == "AQUA" ||
    (capabilities("tcltk") && capabilities("X11"))
}

select_from_list <- function(choices, preselect, multiple, title, graphics) {
  utils::select.list(choices, preselect, multiple, title, graphics)
}

ask_to_update <- function(oldPkgs, t, Rversion, ask = FALSE) {
  z <-
    if (is.character(ask) && ask == "graphics") {
      if (graphics_capable()) {
        k <- select_from_list(
          choices = oldPkgs[, 1L],
          preselect = oldPkgs[, 1L],
          multiple = TRUE,
          title = "Packages to be updated",
          graphics = TRUE
        )
        oldPkgs[match(k, oldPkgs[, 1L]), , drop = FALSE]
      } else {
        ask_to_update_package(oldPkgs, t, Rversion)
      }
    } else {
      if (isTRUE(ask)) {
        ask_to_update_package(oldPkgs, t, Rversion)
      } else {
        oldPkgs
      }
    }
  rownames(z) <- unname(z[, "Package"])
  z
}

read_line_wrapper <- function(prompt = "") {
  base::readline(prompt)
}

ask_to_update_package <- function(old, t, Rversion) {
  update <- NULL
  for (k in seq_len(nrow(old))) {
    cat(
      old[k, "Package"],
      ":\n",
      "Local Version",
      old[k, "LocalVer"],
      "\n",
      "Repos Version",
      old[k, "ReposVer"],
      "available at",
      simplifyRepos(old[k, "Repository"], t, Rversion)
    )
    cat("\n")
    answer <- tolower(substr(read_line_wrapper("Update (y/N/c)?  "), 1L, 1L))
    if (answer == "c") {
      cat("cancelled by user\n")
      return(invisible())
    }
    if (answer == "y") {
      update <- rbind(update, old[k, ])
    }
  }
  update
}


#' @inheritParams makeRepo
#'
#' @param oldPkgs if specified as non-NULL, `updatePackages()` only considers
#'   these packages for updating. This may be a character vector of package
#'   names or a matrix as returned by `oldPackages()`.
#'
#' @param ask logical indicating whether to ask user before packages are
#'   actually downloaded and installed.  Alternatively, the value `"graphics"`
#'   starts an interactive widget to allow the user to (de-)select from the list of
#'   packages which could be updated or added. The latter value only works on
#'   systems with a GUI version of [select.list()], and is otherwise equivalent
#'   to `ask = TRUE`.
#'
#' @return `updatePackages` returns `NULL` invisibly.
#'
#' @export
#'
updatePackages <- function(
  path = NULL,
  repos = getOption("repos"),
  method = NULL,
  ask = TRUE,
  availPkgs = pkgAvail(repos = repos, type = type, Rversion = Rversion),
  oldPkgs = NULL,
  type = "source",
  Rversion = R.version,
  quiet = FALSE
) {
  assert_that(is_path(path))

  do_one <- function(t, Rversion, ask) {
    if (!is.matrix(oldPkgs) && is.character(oldPkgs)) {
      subset <- oldPkgs
      oldPkgs <- NULL
    } else {
      subset <- NULL
    }
    if (is.null(oldPkgs)) {
      oldPkgs <- oldPackages(
        path = path,
        repos = repos,
        method = method,
        availPkgs = availPkgs,
        type = t,
        Rversion = Rversion
      )
      if (is.null(oldPkgs)) {
        message("All packages are up to date from repos: ", names(repos))
        return(invisible())
      }
    } else {
      if (!(is.matrix(oldPkgs) && is.character(oldPkgs))) {
        msg <- paste0(
          "invalid 'oldPkgs'; ",
          "must be a character vector or a result from oldPackages()"
        )
        stop(msg)
      }
    }
    if (!is.null(subset)) {
      oldPkgs <- oldPkgs[rownames(oldPkgs) %in% subset, , drop = FALSE]
      if (nrow(oldPkgs) == 0) return(invisible())
    }

    update <- ask_to_update(
      oldPkgs = oldPkgs,
      t = t,
      Rversion = Rversion,
      ask = ask
    )

    if (length(update[, "Package"])) {
      addPackage(
        update[, "Package"],
        path = path,
        repos = repos,
        type = t,
        quiet = quiet,
        deps = FALSE,
        Rversion = Rversion
      )
    }
  }

  lapply(type, do_one, Rversion = Rversion, ask = ask)
}