R/install.R

In rstudio/packrat: A Dependency Management System for Projects and their R Package Dependencies

#' Install a local development package.
#'
#' Uses \code{R CMD INSTALL} to install the package. Will also try to install
#' dependencies of the package from CRAN, if they're not already installed.
#'
#' By default, installation takes place using the current package directory.
#' If you have compiled code, this means that artefacts of compilation will be
#' created in the \code{src/} directory. If you want to avoid this, you can
#' use \code{local = FALSE} to first build a package bundle and then install
#' it from a temporary directory. This is slower, but keeps the source
#' directory pristine.
#'
#' If the package is loaded, it will be reloaded after installation.
#'
#' @param pkg package description, can be path or package name.
#' @param reload if \code{TRUE} (the default), will automatically reload the
#'   package after installing.
#' @param quick if \code{TRUE} skips docs, multiple-architectures,
#'   demos, and vignettes, to make installation as fast as possible.
#' @param local if \code{FALSE} \code{\link{build}}s the package first:
#'   this ensures that the installation is completely clean, and prevents any
#'   binary artefacts (like \file{.o}, \code{.so}) from appearing in your local
#'   package directory, but is considerably slower, because every compile has
#'   to start from scratch.
#' @param args An optional character vector of additional command line
#'   arguments to be passed to \code{R CMD install}. This defaults to the
#'   value of the option \code{"devtools.install.args"}.
#' @param quiet if \code{TRUE} suppresses output from this function.
#' @param dependencies \code{logical} indicating to also install uninstalled
#'   packages which this \code{pkg} depends on/links to/suggests. See
#'   argument \code{dependencies} of \code{\link{install.packages}}.
#' @param build_vignettes if \code{TRUE}, will build vignettes. Normally it is
#'   \code{build} that's responsible for creating vignettes; this argument makes
#'   sure vignettes are built even if a build never happens (i.e. because
#'   \code{local = TRUE}.
#' @param keep_source If \code{TRUE} will keep the srcrefs from an installed
#'   package. This is useful for debugging (especially inside of RStudio).
#'   It defaults to the option \code{"keep.source.pkgs"}.
#' @export
#' @importFrom tools pkgVignettes
install <- function(pkg = ".", reload = TRUE, quick = FALSE, local = TRUE,
                    args = getOption("devtools.install.args"), quiet = FALSE,
                    dependencies = NA, build_vignettes = !quick,
                    keep_source = getOption("keep.source.pkgs")) {

  pkg <- as.package(pkg)

  if (!quiet) message("Installing ", pkg$package)

  # Build the package. Only build locally if it doesn't have vignettes
  has_vignettes <- length(pkgVignettes(dir = pkg$path)$doc > 0)
  if (local && !(has_vignettes && build_vignettes)) {
    built_path <- pkg$path
  } else {
    built_path <- build(pkg, tempdir(), vignettes = build_vignettes, quiet = quiet)
    on.exit(unlink(built_path))
  }

  opts <- c(
    paste("--library=", shQuote(getLibPaths()[1]), sep = ""),
    if (keep_source) "--with-keep.source",
    "--install-tests"
  )
  if (quick) {
    opts <- c(opts, "--no-docs", "--no-multiarch", "--no-demo")
  }
  opts <- paste(paste(opts, collapse = " "), paste(args, collapse = " "))

  R(paste("CMD INSTALL --preclean ", shQuote(built_path), " ", opts, sep = ""),
    quiet = quiet)

  if (reload) reload(pkg$package, quiet = quiet)

  invisible(TRUE)
}

build <- function(pkg = ".", path = NULL, binary = FALSE, vignettes = TRUE,
                  args = NULL, quiet = FALSE) {
  pkg <- as.package(pkg)
  if (is.null(path)) {
    path <- dirname(pkg$path)
  }

  if (getRversion() < "3.1.0") {
    noBuildVignettes <- "--no-vignettes"
  } else {
    noBuildVignettes <- "--no-build-vignettes"
  }

  if (binary) {
    args <- c("--build", args)
    cmd <- paste0("CMD INSTALL --preclean ", shQuote(pkg$path), " ",
                  paste0(args, collapse = " "))
    ext <- if (.Platform$OS.type == "windows") "zip" else "tgz"
  } else {
    args <- c(args, "--no-manual", "--no-resave-data")

    if (!vignettes) {
      args <- c(args, noBuildVignettes)

    } else if (!nzchar(Sys.which("pdflatex"))) {
      message("pdflatex not found. Not building PDF vignettes.")
      args <- c(args, noBuildVignettes)
    }

    cmd <- paste0("CMD build ", shQuote(pkg$path), " ",
                  paste0(args, collapse = " "))

    ext <- "tar.gz"
  }
  with_libpaths(c(tempdir(), getLibPaths()), R(cmd, path, quiet = quiet))
  targz <- paste0(pkg$package, "_", pkg$version, ".", ext)

  file.path(path, targz)
}

R.path <- function() file.path(R.home("bin"), "R")

R <- function(options, path = tempdir(), ...) {
  options <- paste("--vanilla", options)
  r_path <- file.path(R.home("bin"), "R")

  # If rtools has been detected, add it to the path only when running R...
  if (!is.null(get_rtools_path())) {
    old <- add_path(get_rtools_path(), 0)
    on.exit(set_path(old))
  }

  in_dir(
    path,
    system_check(
      cmd = r_path,
      args = options,
      env = c(r_env_vars(), envvar_mask()),
      ...
    )
  )
}

r_env_vars <- function() {
  c(
    "R_LIBS" = paste(getLibPaths(), collapse = .Platform$path.sep),
    "CYGWIN" = "nodosfilewarning",
    # When R CMD check runs tests, it sets R_TESTS. When the tests
    # themeselves run R CMD xxxx, as is the case with the tests in
    # devtools, having R_TESTS set causes errors because it confuses
    # the R subprocesses. Unsetting it here avoids those problems.
    "R_TESTS" = "",
    "NOT_CRAN" = "true",
    "TAR" = tar_binary()
  )
}

envvar_mask <- function() {
  # Mask tokens unless told not to.
  git_token_vars <- if (getOption("packrat.mask.git.service.envvars", TRUE)) {
    c(
      "GITHUB_PAT",
      "GITLAB_PAT",
      "BITBUCKET_USERNAME",
      "BITBUCKET_USER",
      "BITBUCKET_PASSWORD",
      "BITBUCKET_PASS",
      # Varnames that may have been used previously
      "GITHUB_USERNAME",
      "GITHUB_USER",
      "GITHUB_PASSWORD",
      "GITHUB_PASS",
      "GITLAB_USERNAME",
      "GITLAB_USER",
      "GITLAB_PASSWORD",
      "GITLAB_PASS"
    )
  } else {
    NULL
  }

  user_specified_vars <- getOption("packrat.masked.envvars", NULL)
  all_vars <- c(git_token_vars, user_specified_vars)
  envvar_mask <- as.character(rep(NA, length(all_vars)))
  names(envvar_mask) <- all_vars

  return(envvar_mask)
}

with_something <- function(set) {
  function(new, code) {
    old <- set(new)
    on.exit(set(old))
    force(code)
  }
}

in_dir <- with_something(setwd)

set_libpaths <- function(paths) {
  old <- getLibPaths()
  setLibPaths(paths)
  invisible(old)
}

with_libpaths <- with_something(set_libpaths)

# Modifies environment variables, executes the code in `code` and then restores
# the environment variables to their prior values.
# - `new` should be a named character vector of values for environment variables
#   to take during execution. Variables can be temporarily unset with an `NA`
#   value.
# - `action` can be "prefix" or "suffix" to combine `new` with existing
#   variables instead of replacing.
# See `set_envvar` for more details.
with_envvar <- function(new, code, action = "replace") {
  old <- set_envvar(new, action)
  on.exit(set_envvar(old, "replace"))
  force(code)
}

install_local_path <- function(path, subdir = NULL, ...) {
  invisible(lapply(path, install_local_path_single, subdir = subdir, ...))
}

install_local_path_single <- function(path, subdir = NULL, before_install = NULL, ..., quiet = FALSE) {
  stopifnot(file.exists(path))
  if (!quiet) {
    message("Installing package from '", path, "'")
  }

  if (!file.info(path)$isdir) {
    bundle <- path
    target <- tempfile("packrat-install-")
    dir.create(target)
    path <- decompress(path, target)
    on.exit(unlink(target, recursive = TRUE), add = TRUE)
  } else {
    bundle <- NULL
  }

  pkg_path <- if (is.null(subdir)) path else file.path(path, subdir)

  # Check it's an R package
  if (!file.exists(file.path(pkg_path, "DESCRIPTION"))) {
    stop("Does not appear to be an R package (no DESCRIPTION)", call. = FALSE)
  }

  # Check configure is executable if present
  config_path <- file.path(pkg_path, "configure")
  if (file.exists(config_path)) {
    Sys.chmod(config_path, "777")
  }

  # Call before_install for bundles (if provided)
  if (!is.null(bundle) && !is.null(before_install))
    before_install(bundle, pkg_path)

  # Finally, run install
  with_build_tools({
    install(pkg_path, quiet = quiet, ...)
  })
}

with_build_tools <- function(code) {
  check <- getOption("buildtools.check", NULL)
  if (!is.null(check)) {
    if (check("Installing R packages from source")) {
      with <- getOption("buildtools.with", NULL)
      if (!is.null(with))
        with(code)
      else
        force(code)
    }
  }
  else {
    force(code)
  }
}

decompress <- function(src, target = tempdir()) {
  tryCatch(
    suppressWarnings(decompressImpl(src, target)),
    error = function(e) {
      fmt <- paste(
        "Failed to extract archive:",
        "- '%s' => '%s'",
        "Reason: %s",
        sep = "\n"
      )
      msg <- sprintf(fmt, src, target, e$message)
      message(msg, sep = "\n")
    }
  )
}

decompressImpl <- function(src, target = tempdir()) {
  stopifnot(file.exists(src))

  if (grepl("\\.zip$", src)) {
    unzip(src, exdir = target, unzip = getOption("unzip"))
    outdir <- getrootdir(as.vector(unzip(src, list = TRUE)$Name))

  } else if (grepl("\\.tar$", src)) {
    untar(src, exdir = target, tar = tar_binary())
    outdir <- getrootdir(untar(src, list = TRUE, tar = tar_binary()))

  } else if (grepl("\\.(tar\\.gz|tgz)$", src)) {
    untar(src, exdir = target, compressed = "gzip", tar = tar_binary())
    outdir <- getrootdir(untar(src, compressed = "gzip", list = TRUE, tar = tar_binary()))

  } else if (grepl("\\.(tar\\.bz2|tbz)$", src)) {
    untar(src, exdir = target, compressed = "bzip2", tar = tar_binary())
    outdir <- getrootdir(untar(src, compressed = "bzip2", list = TRUE, tar = tar_binary()))

  } else {
    ext <- gsub("^[^.]*\\.", "", src)
    stop("Don't know how to decompress files with extension ", ext,
         call. = FALSE)
  }

  file.path(target, outdir)
}

getdir <- function(path)  sub("/[^/]*$", "", path)

getrootdir <- function(file_list) {
  getdir(file_list[which.min(nchar(gsub("[^/]", "", file_list)))])
}

as.package <- function(x = NULL) {
  if (is.package(x)) return(x)

  x <- check_dir(x)
  load_pkg_description(x)
}

check_dir <- function(x) {
  if (is.null(x)) {
    stop("Path is null", call. = FALSE)
  }

  # Normalise path and strip trailing slashes
  x <- gsub("\\\\", "/", x, fixed = TRUE)
  x <- sub("/*$", "", x)

  if (!file.exists(x)) {
    stop("Can't find directory ", x, call. = FALSE)
  }
  if (!file.info(x)$isdir) {
    stop(x, " is not a directory", call. = FALSE)
  }

  x
}

load_pkg_description <- function(path) {
  path <- normalizePath(path)
  path_desc <- file.path(path, "DESCRIPTION")

  if (!file.exists(path_desc)) {
    stop("No description at ", path_desc, call. = FALSE)
  }

  desc <- as.list(readDcf(path_desc)[1, ])
  names(desc) <- tolower(names(desc))
  desc$path <- path

  structure(desc, class = "package")
}

is.package <- function(x) inherits(x, "package")

if (!exists("set_rtools_path")) {
  set_rtools_path <- NULL
  get_rtools_path <- NULL
  local({
    rtools_paths <- NULL
    set_rtools_path <<- function(rtools) {
      stopifnot(is.rtools(rtools))
      path <- file.path(rtools$path, version_info[[rtools$version]]$path)

      rtools_paths <<- path
    }
    get_rtools_path <<- function() {
      rtools_paths
    }
  })
}

find_rtools <- function(debug = FALSE) {
  # Non-windows users don't need rtools
  if (.Platform$OS.type != "windows") return(TRUE)

  # First try the path
  from_path <- scan_path_for_rtools(debug)
  if (is_compatible(from_path)) {
    set_rtools_path(from_path)
    return(TRUE)
  }

  if (!is.null(from_path)) {
    # Installed
    if (is.null(from_path$version)) {
      # but not from rtools
      if (debug) "gcc and ls on path, assuming set up is correct\n"
      return(TRUE)
    } else {
      # Installed, but not compatible
      message("WARNING: Rtools ", from_path$version, " found on the path",
              " at ", from_path$path, " is not compatible with R ", getRversion(), ".\n\n",
              "Please download and install ", rtools_needed(), " from ", rtools_url,
              ", remove the incompatible version from your PATH, then run find_rtools().")
      return(invisible(FALSE))
    }
  }

  # Not on path, so try registry
  registry_candidates <- scan_registry_for_rtools(debug)

  if (length(registry_candidates) == 0) {
    # Not on path or in registry, so not installled
    message("WARNING: Rtools is required to build R packages, but is not ",
            "currently installed.\n\n",
            "Please download and install ", rtools_needed(), " from ", rtools_url,
            " and then run find_rtools().")
    return(invisible(FALSE))
  }

  from_registry <- Find(is_compatible, registry_candidates, right = TRUE)
  if (is.null(from_registry)) {
    # In registry, but not compatible.
    versions <- vapply(registry_candidates, function(x) x$version, character(1))
    message("WARNING: Rtools is required to build R packages, but no version ",
            "of Rtools compatible with R ", getRversion(), " was found. ",
            "(Only the following incompatible version(s) of Rtools were found:",
            paste(versions, collapse = ","), ")\n\n",
            "Please download and install ", rtools_needed(), " from ", rtools_url,
            " and then run find_rtools().")
    return(invisible(FALSE))
  }

  installed_ver <- installed_version(from_registry$path, debug = debug)
  if (is.null(installed_ver)) {
    # Previously installed version now deleted
    message("WARNING: Rtools is required to build R packages, but the ",
            "version of Rtools previously installed in ", from_registry$path,
            " has been deleted.\n\n",
            "Please download and install ", rtools_needed(), " from ", rtools_url,
            " and then run find_rtools().")
    return(invisible(FALSE))
  }

  if (installed_ver != from_registry$version) {
    # Installed version doesn't match registry version
    message("WARNING: Rtools is required to build R packages, but no version ",
            "of Rtools compatible with R ", getRversion(), " was found. ",
            "Rtools ", from_registry$version, " was previously installed in ",
            from_registry$path, " but now that directory contains Rtools ",
            installed_ver, ".\n\n",
            "Please download and install ", rtools_needed(), " from ", rtools_url,
            " and then run find_rtools().")
    return(invisible(FALSE))
  }

  # Otherwise it must be ok :)
  set_rtools_path(from_registry)
  TRUE
}

scan_path_for_rtools <- function(debug = FALSE) {
  if (debug) cat("Scanning path...\n")

  # First look for ls and gcc
  ls_path <- Sys.which("ls")
  if (ls_path == "") return(NULL)
  if (debug) cat("ls :", ls_path, "\n")

  gcc_path <- Sys.which("gcc")
  if (gcc_path == "") return(NULL)
  if (debug) cat("gcc:", gcc_path, "\n")

  # We have a candidate installPath
  install_path <- dirname(dirname(ls_path))
  install_path2 <- dirname(dirname(dirname(gcc_path)))
  if (install_path2 != install_path) return(NULL)

  version <- installed_version(install_path, debug = debug)
  if (debug) cat("Version:", version, "\n")

  rtools(install_path, version)
}

scan_registry_for_rtools <- function(debug = FALSE) {
  if (debug) cat("Scanning registry...\n")

  keys <- NULL
  try(keys <- utils::readRegistry("SOFTWARE\\R-core\\Rtools",
                                  hive = "HLM", view = "32-bit", maxdepth = 2), silent = TRUE)
  if (is.null(keys)) return(NULL)

  rts <- vector("list", length(keys))

  for (i in seq_along(keys)) {
    version <- names(keys)[[i]]
    key <- keys[[version]]
    if (!is.list(key) || is.null(key$InstallPath)) next
    install_path <- normalizePath(key$InstallPath,
                                  mustWork = FALSE, winslash = "/")

    if (debug) cat("Found", install_path, "for", version, "\n")
    rts[[i]] <- rtools(install_path, version)
  }

  Filter(Negate(is.null), rts)
}

installed_version <- function(path, debug) {
  if (!file.exists(file.path(path, "Rtools.txt"))) return(NULL)

  # Find the version path
  version_path <- file.path(path, "VERSION.txt")
  if (debug) {
    cat("VERSION.txt\n")
    cat(readLines(version_path), "\n")
  }
  if (!file.exists(version_path)) return(NULL)

  # Rtools is in the path -- now crack the VERSION file
  contents <- NULL
  try(contents <- readLines(version_path), silent = TRUE)
  if (is.null(contents)) return(NULL)

  # Extract the version
  contents <- gsub("^\\s+|\\s+$", "", contents)
  version_re <- "Rtools version (\\d\\.\\d+)\\.[0-9.]+$"

  if (!grepl(version_re, contents)) return(NULL)

  m <- regexec(version_re, contents)
  regmatches(contents, m)[[1]][2]
}

is_compatible <- function(rtools) {
  if (is.null(rtools)) return(FALSE)
  if (is.null(rtools$version)) return(FALSE)

  stopifnot(is.rtools(rtools))
  info <- version_info[[rtools$version]]
  if (is.null(info)) return(FALSE)

  r_version <- getRversion()
  r_version >= info$version_min && r_version <= info$version_max
}

rtools <- function(path, version) {
  structure(list(version = version, path = path), class = "rtools")
}
is.rtools <- function(x) inherits(x, "rtools")

rtools_url <- "https://cran.r-project.org/bin/windows/Rtools/"
version_info <- list(
  "2.11" = list(
    version_min = "2.10.0",
    version_max = "2.11.1",
    path = c("bin", "perl/bin", "MinGW/bin")
  ),
  "2.12" = list(
    version_min = "2.12.0",
    version_max = "2.12.2",
    path = c("bin", "perl/bin", "MinGW/bin", "MinGW64/bin")
  ),
  "2.13" = list(
    version_min = "2.13.0",
    version_max = "2.13.2",
    path = c("bin", "MinGW/bin", "MinGW64/bin")
  ),
  "2.14" = list(
    version_min = "2.13.0",
    version_max = "2.14.2",
    path = c("bin", "MinGW/bin", "MinGW64/bin")
  ),
  "2.15" = list(
    version_min = "2.14.2",
    version_max = "2.15.1",
    path = c("bin", "gcc-4.6.3/bin")
  ),
  "2.16" = list(
    version_min = "2.15.2",
    version_max = "3.0.0",
    path = c("bin", "gcc-4.6.3/bin")
  ),
  "3.0" = list(
    version_min = "2.15.2",
    version_max = "3.0.99",
    path = c("bin", "gcc-4.6.3/bin")
  ),
  "3.1" = list(
    version_min = "3.0.0",
    version_max = "3.1.99",
    path = c("bin", "gcc-4.6.3/bin")
  )
)

rtools_needed <- function() {
  r_version <- getRversion()

  for (i in rev(seq_along(version_info))) {
    version <- names(version_info)[i]
    info <- version_info[[i]]
    ok <- r_version >= info$version_min && r_version <= info$version_max
    if (ok) return(paste("Rtools", version))
  }
  "the appropriate version of Rtools"
}

system_check <- function(cmd, args = character(), env = character(),
                         quiet = FALSE, return_output = FALSE, ...) {
  full <- paste(shQuote(cmd), paste(args, collapse = ", "))

  if (!quiet && !return_output) {
    message(wrap_command(full))
    message()
  }

  # Use system2 instead of system as we can then handle redirection
  # on Windows
  result <- suppressWarnings(with_envvar(
    env,
    if (quiet || return_output) {
      system2(cmd, args, stdout = TRUE, stderr = TRUE)
    } else {
      system2(cmd, args)
    }
  ))

  status <- attr(result, "status")
  if (!is.null(status) && status != 0) {

    stopMsg <- paste0(
      "Command failed (", status, ")",
      "\n\nFailed to run system command:\n\n",
      "\t", full
    )

    if (length(result)) {
      stopMsg <- paste0(
        stopMsg,
        "\n\nThe command failed with output:\n",
        paste(result, collapse = "\n")
      )
    }

    # issue #186
    if (nchar(stopMsg) > getOption("warning.length")) {
      print(stopMsg, file = stderr())
    }
    stop(stopMsg, call. = FALSE)
  }

  if (return_output) {
    return(result)
  }

  invisible(TRUE)
}


wrap_command <- function(x) {
  lines <- strwrap(x, getOption("width") - 2, exdent = 2)
  continue <- c(rep(" \\", length(lines) - 1), "")
  paste(lines, continue, collapse = "\n")
}

# `set_envvar` takes a named character vector and sets its contents to update
# environment variables. It returns the old value of the modified envvars.
# - All non-NA entries in the list will be written to the environment. The
#   default action overwrites the environment variables, but "prefix" and
#   "suffix" combine the new value with the existing value.
# - Any names in the list with NA values will be unset using `Sys.unsetenv`
# `with_envvar` uses this function to temporarily replace environment variables
# for execution of a code block.
set_envvar <- function(envs, action = "replace") {
  stopifnot(all_named(envs))
  stopifnot(is.character(action), length(action) == 1)
  action <- match.arg(action, c("replace", "prefix", "suffix"))

  old <- Sys.getenv(names(envs), names = TRUE, unset = NA)
  set <- !is.na(envs)

  both_set <- set & !is.na(old)
  if (any(both_set)) {
    if (action == "prefix") {
      envs[both_set] <- paste(envs[both_set], old[both_set])
    } else if (action == "suffix") {
      envs[both_set] <- paste(old[both_set], envs[both_set])
    }
  }

  if (any(set))  do.call("Sys.setenv", as.list(envs[set]))
  if (any(!set)) Sys.unsetenv(names(envs)[!set])

  invisible(old)
}

all_named <- function(x) {
  !is.null(names(x)) && all(names(x) != "")
}

"%||%" <- function(a, b) if (!is.null(a)) a else b

get_path <- function() {
  strsplit(Sys.getenv("PATH"), .Platform$path.sep)[[1]]
}

set_path <- function(path) {
  path <- normalizePath(path, mustWork = FALSE)

  old <- get_path()
  path <- paste(path, collapse = .Platform$path.sep)
  Sys.setenv(PATH = path)
  invisible(old)
}

add_path <- function(path, after = Inf) {
  set_path(append(get_path(), path, after))
}

reload <- function(pkg = ".", quiet = FALSE) {
  if (paste0("package:", pkg) %in% search()) {
    if (!quiet) message("Reloading installed package: \", pkg, \"")
    forceUnload(pkg)
    library(pkg, character.only = TRUE, quietly = TRUE)
  }
}