#' Symlink a package with the appropriate version into the current library.
#'
#' @param locked_package locked_package. In particular, the \code{version}
#' and \code{name} elements will be used.
align <- function(locked_package) {
if (is.list(locked_package) && !is.locked_package(locked_package)) {
return(lapply(locked_package, align))
}
stopifnot(is.locked_package(locked_package))
Make sure we have this package version in the lockbox secret library.
`ensure_package_exists_in_lockbox!`(locked_package)
Symlink the locked package to the correct lockbox version.
`symlink_to_lockbox!`(locked_package)
}
`symlink_to_lockbox!` <- function(locked_package) {
path <- file.path(libPath(), locked_package$name)
if (is.symlink(path)) unlink(path, force = TRUE)
symlink(lockbox_package_path(locked_package), path)
}
#' Remove all packages from lockbox library.
#'
#' @rdname cleanup
#' @export
emptybox <- function() {
quietly(unlink(lockbox_library(), recursive = TRUE))
}
#' Ensure package name and version exists in the lockbox secret library.
#'
#' The lockbox package keeps a secret directory with the packages for
#' each given version. By default, this is in
#' \code{getOption("lockbox.lib")} or \code{"~/.R/lockbox"} if that option
#' is not set.
#'
#' @param locked_package locked_package. In particular, \code{name} and
#' \code{version} elements will be used. If the package version is
#' not present in the lockbox, we will attempt to download it from
#' CRAN or github.
#' @note The weird name is a derivative of a \href{http://stackoverflow.com/questions/612189/why-are-exclamation-marks-used-in-ruby-methods}{Rubyism}
#' to indicate some serious side effects can occur! In this case, we
#' download the package from CRAN or github if the name + version combo
#' does not exist.
#' @name ensure_package_exists_in_lockbox
`ensure_package_exists_in_lockbox!` <- function(locked_package) {
if (!exists_in_lockbox(locked_package)) {
`place_in_lockbox!`(locked_package)
}
}
exists_in_lockbox <- function(locked_package) {
file.exists(lockbox_package_path(locked_package))
}
lockbox_package_path <- function(locked_package, library = lockbox_library()) {
# The final package is stored in lockbox_lib_path/pkg_name/version/pkg_name
# The trailing pkg_name is to ensure help files work, since these depend
# on the directory name:
# https://github.com/wch/r-source/blob/ed66b715221d2720f5b334470335635bada520b1/src/library/utils/R/help.R#L213
file.path(library, locked_package$name, locked_package$version, locked_package$name)
}
`place_in_lockbox!` <- function(locked_package) {
remote <- locked_package$remote %||% "CRAN"
install_package(structure(
locked_package,
class = c(remote, class(locked_package))
))
}
install_package <- function(locked_package) {
cat("Installing", crayon::green(locked_package$name),
as.character(locked_package$version), "from", class(locked_package)[1], "\n")
UseMethod("install_package")
}
install_package.local <- function(locked_package) {
stopifnot(is.element("dir", names(locked_package)))
install_locked_package(locked_package,
devtools::install(locked_package$dir,
quiet = notTRUE(getOption("lockbox.verbose"))))
}
# Helpfully borrowed from https://github.com/christophergandrud/repmis/blob/master/R/InstallOldPackages.R
# Did not simply import the function because it introduces too many dependencies
#' @author Kirill Sevastyanenko
install_old_CRAN_package <- function(name, version, repo = "http://cran.r-project.org") {
# List available packages on the repo. Maybe we can simply install.packages?
available <- available.packages(contriburl =
contrib.url(repos = "http://cran.us.r-project.org", type = "source"))
available <- data.frame(unique(available[, c("Package", "Version")]))
pkg <- available[available$Package == name, ]
# Simply install.packages if version happens to be the latest available on CRAN.
# You can specify the fastest CRAN mirror by setting the `lockbox.CRAN_mirror` option
# or Rstudio mirror will be used by default.
repos <- getOption('lockbox.CRAN_mirror') %||% c(CRAN = "http://cran.rstudio.com")
remote_version <- package_version(as.character(pkg$Version))
if (dim(pkg)[1] == 1 && remote_version == version) {
return(utils::install.packages(
name, repos = repos, INSTALL_opts = "--vanilla",
quiet = notTRUE(getOption('lockbox.verbose'))))
}
# If we did not find the package on CRAN - try CRAN archive.
from <- paste0(repo, "/src/contrib/Archive/", name, "/", name, "_", version, ".tar.gz")
pkg.tarball <- tempfile(fileext = ".tar.gz")
download.file(url = from, destfile = pkg.tarball)
# We need to switch directories to ensure no infinite loop happens when
# the .Rprofile calls lockbox::lockbox.
old_dir <- getwd()
on.exit(setwd(old_dir))
tmpdir <- file.path(tempdir(), "foo")
dir.create(tmpdir, FALSE, TRUE)
setwd(tmpdir)
utils::install.packages(pkg.tarball, repos = NULL, type = "source",
INSTALL_opts = "--vanilla",
quiet = notTRUE(getOption("lockbox.verbose")))
unlink(pkg.tarball)
}
install_package.CRAN <- function(locked_package) {
# TODO: (RK) Fetch correct version? Support install from source?
locked_package$repo <- locked_package$repo %||% "http://cran.r-project.org"
install_locked_package(locked_package,
install_old_CRAN_package(locked_package$name, locked_package$version))
}
#' @importFrom devtools install_github
install_package.github <- function(locked_package) {
stopifnot(is.element("repo", names(locked_package)))
ref <- locked_package$ref %||% locked_package$version
# TODO: (RK) What if we just want latest from master?
install_locked_package(locked_package, {
arguments <- list(
paste(locked_package$repo, ref, sep = "@"),
reload = FALSE,
quiet = notTRUE(getOption('lockbox.verbose'))
)
if (nzchar(token <- Sys.getenv("GITHUB_PAT"))) {
arguments$auth_token <- token
}
if (!is.null(locked_package$subdir)) {
arguments$subdir <- locked_package$subdir
}
do.call(devtools::install_github, arguments)
})
}
install_locked_package <- function(locked_package, installing_expr) {
temp_library <- staging_library()
pkgdir <- file.path(temp_library, locked_package$name)
# For some reason, if the package already exists, R CMD INSTALL does not
# let us install it.
unlink(pkgdir, TRUE, TRUE)
Pretend our library path is the staging library during installation.
testthatsomemore::package_stub("base", ".libPaths", function(...) temp_library, {
force(quietly(installing_expr))
})
if (!file.exists(pkgdir)) {
unlink(temp_library, TRUE, TRUE)
stop("Must have installed the package ",
crayon::red(as.character(locked_package$name)),
" of version ", sQuote(as.character(locked_package$version)))
}
if ((ver <- package_version_from_path(pkgdir)) != locked_package$version) {
unlink(temp_library, TRUE, TRUE)
stop(sprintf(paste0(
"Incorrect version of package %s installed. Expected ",
"%s but downloaded %s instead."), sQuote(locked_package$name),
sQuote(locked_package$version), sQuote(ver)), call. = FALSE)
}
copy_real_packages_to_lockbox_library(temp_library)
unlink(temp_library, TRUE, TRUE)
}
#' Find packages whose version does not match the current library's version.
#'
#' @param locked_package locked_package.
#' @return TRUE or FALSE according as the current library's package version
#' is incorrect.
version_mismatch <- function(locked_package) {
!identical(current_version(locked_package), locked_package$version)
}
#' The current version of this package in the current library.
#'
#' @param pkg character or locked_package. The name of the package.
#' @return a \code{\link{package_version}} object representing the version of
#' this package in the current library.
current_version <- function(pkg) {
UseMethod("current_version")
}
current_version.character <- function(package_name) {
dcf <- description_file_for(package_name)
if (is.null(dcf)) {
NA
} else {
package_version(unname(dcf[,"Version"]))
}
}
current_version.locked_package <- function(package) {
current_version(package$name)
}
description_file_for <- function(package_name) {
dcf_file <- file.path(libPath(), package_name, "DESCRIPTION")
if (file.exists(dcf_file)) {
read.dcf(dcf_file)
} else {
NULL
}
}
#' Re-organize Search Path to Use Lockbox Library.
#'
#' The lockbox package provides a separate directory, by default under
#' \code{"~/.R/.lockbox"} (although this is configurable from the global ption
#' \code{"lockbox.directory"}) that maintains different versions of packages
#' on demand. When a given set of versioned packages is requested, lockbox will
#' unload \emph{all other packages} and ensure only the given set of packages
#' with their respective versions are present.
#'
#' Since lockbox maintains a separate directory for its library, it will not
#' interfere with R's usual packages or libraries when R is restarted.
#'
#' @export
#' @param file_or_list character or list. A yaml-based lock file or its
#' parsed out list format. This set of packages will be loaded into the
#' search path and \emph{all other packages will be unloaded}.
lockbox <- function(file_or_list, env = getOption("lockbox.env", "!packages")) {
UseMethod("lockbox", file_or_list)
}
#' @export
lockbox.character <- function(file, env) {
lockbox(yaml::yaml.load_file(file), env)
}
#' @export
lockbox.list <- function(lock, env) {
if (missing(env)) env <- "!packages"
if (is.null(lock$packages))
stop("Invalid config. Make sure your config format is correct")
lock <-
if (identical(env, "!packages") || is.null(lock[[env]])) {
lock$packages
} else {
lock <- lapply(lock$packages, function(package) {
if(package$name %in% lock[[env]]) package else NULL
})
lock <- lock[!sapply(lock, is.null)]
}
lock <- lapply(lock, as.locked_package)
disallow_special_packages(lock)
set_transient_library()
Find the packages whose version does not match the current library.
mismatches <- vapply(lock, version_mismatch, logical(1))
sapply(lock[!mismatches], function(locked_package) {
cat('Using', crayon::green(locked_package$name), as.character(locked_package$version), '\n')
})
quietly({
Replace our library so that it has these packages instead.
align(lock[mismatches])
And re-build our search path.
rebuild(lock)
})
}
#' @export
lockbox.default <- function(obj) {
stop(
"Invalid parameters passed to ", sQuote("lockbox"), " method: ",
"must be a ", sQuote("character"), " or ", sQuote("list"), " but ",
"instead I got a ", sQuote(class(obj)[1]), "."
)
}
as.locked_package <- function(list) {
stopifnot(is.element("name", names(list)),
is.element("version", names(list)))
if (is.element("repo", names(list)) && !is.element("remote", names(list))) {
list$remote <- "github"
}
if (is.na(package_version(list$version))) {
stop(sprintf("Invalid package %s version %s.",
sQuote(list$name), sQuote(list$version)))
} else {
list$version <- package_version(list$version)
}
# TODO: (RK) Support CRAN version dependencies.
structure(list, class = "locked_package")
}
is.locked_package <- function(obj) is(obj, "locked_package")
#' The secret lockbox library path.
lockbox_library <- function() {
getOption("lockbox.directory") %||% normalizePath("~/.R/lockbox", mustWork = FALSE)
}
#' The transient lockbox library path.
lockbox_transient_dir <- function() {
getOption("lockbox.transient_dir") %||%
normalizePath("~/.R/lockbox_transient", mustWork = FALSE)
}
#' The transient staging lockbox library path.
#'
#' This will be used to copy interactively installed packages to
#' the vanilla library.
lockbox_transient_staging_dir <- function() {
paste0(lockbox_transient_dir(), "_staging")
}
disallow_special_packages <- function(lock) {
package_names <- vapply(lock, `[[`, character(1), "name")
if ("lockbox" %in% package_names) {
stop("Lockbox cannot manage itself, Mr. Hofstadter.", call. = FALSE)
}
if (any(package_names %in% special_namespaces)) {
stop("Version maintenance of the following packages is not currently ",
"supported by lockbox: ",
paste(intersect(special_namespaces, package_names), collapse = ", "),
".", call. = FALSE)
}
}
#' Bundler-style Package Management for R.
#'
#' @name lockbox
#' @import testthatsomemore yaml digest utils
#' @docType package
NULL
pending <- function() {
TRUE
}
#' Rebuild our current search path according to a list of locked packages.
#'
#' As with the \href{https://github.com/romainfrancois/nothing}{nothing package},
#' this function will unload everything except the base R packages from the
#' search path prior to re-building.
#'
#' @param packages list of locked_packages.
rebuild <- function(packages) {
reset_search_path()
invisible(vapply(packages, attach, character(1)))
}
reset_search_path <- function() {
# Helpfully borrowed from https://github.com/romainfrancois/nothing/blob/master/R/zzz.R
native_loaded_namespace <- intersect(loadedNamespaces(), native_namespaces)
on.exit(lapply(native_loaded_namespace, loadNamespace), add = TRUE)
repeat_count <- 0
repeat {
pkgs <- setdiff(loadedNamespaces(), special_namespaces)
if (!length(pkgs)) break
if (repeat_count > 25) {
warning("Could not unload the following namespaces when loading ",
"lockfile: ", paste(sQuote(pkgs), collapse = ", "), call. = FALSE)
break
}
for (pkg in pkgs) {
try(unloadNamespace(pkg), silent = TRUE)
}
repeat_count <- repeat_count + 1
}
}
attach <- function(locked_package) {
if (!identical(locked_package$load, FALSE)) {
library(locked_package$name, character.only = TRUE)
}
locked_package$name
}
# https://github.com/wch/r-source/tree/trunk/src/library
native_namespaces <-
c("base", "stats", "compiler", "datasets", "grDevices", "graphics", "grid",
"methods", "parallel", "profile", "splines", "stats4", "tcltk",
"tools", "translations", "utils", "lattice", "Matrix")
# These namespaces are particularly difficult to unload because of dependencies.
pesky_namespaces <-
c("lockbox", "httr", "RCurl", "bitops", "crayon", "yaml", "testthat",
"testthatsomemore", "stringr", "digest", "lubridate", "memoise",
"plyr", "magrittr", "devtools", "Rcpp", "roxygen")
special_namespaces <- c(native_namespaces, pesky_namespaces)
#' Construct a lockbox staging library.
#'
#' To install a new package to the lockbox library, a virtual library is
#' constructed that is used during the installation process. This
#' function generates that library and returns its (temporary)
#' directory name. See the vignette on "Libraries in Lockbox" for more details.
#'
#' @return the directory of the staging library. This should be unlinked
#' after use.
staging_library <- function() {
# We need to be careful to pick a directory the user will always
# have access to. The only guarantees we have are the lockbox directory
# and lockbox transient library themselves.
tempdir <- file.path(lockbox_library(), ".staging")
dir.create(tempdir, FALSE, TRUE)
tempdir <- normalizePath(tempdir)
# Iterate over libraries in reverse order so that libraries with overlapping
# packages get the relevant version of the package symlinked.
lapply(rev(.libPaths()), symlink_library, tempdir)
tempdir
}
#' Symlink all packages from a destination library to a target library.
#'
#' @param src character. The location of the library to use for
#' generating symlinks
#' @param target character. The location of the library which will be
#' populated with symlinked versions of the packages in the \code{destination}
#' library.
symlink_library <- function(src, target) {
packages <- list.files(src, full.names = TRUE)
if (length(packages)) {
new_packages <- file.path(target, basename(packages))
Map(symlink, packages, new_packages, force = TRUE)
}
}
#' Copy real (non-symlinked) packages to the lockbox library.
#'
#' @param staging_library character. The location of the staging library.
copy_real_packages_to_lockbox_library <- function(staging_library) {
with_real_packages(staging_library, move_package_to_lockbox_library)
}
move_package_to_lockbox_library <- function(pkg_path) {
tmp_path <- file.path(lockbox_library(), basename(pkg_path))
new_path <- file.path(tmp_path, package_version_from_path(pkg_path), basename(pkg_path))
dir.create(dirname(new_path), FALSE, TRUE)
unlink(new_path, TRUE, TRUE)
file.rename(pkg_path, new_path)
}
with_real_packages <- function(libpath, action) {
stopifnot(is.function(action))
packages <- list.files(libpath, full.names = TRUE)
packages <- Filter(Negate(is.symlink), packages)
for (i in seq_along(packages)) {
action(packages[[i]])
}
}
#' @export
setNames <- function(object = nm, nm) {
names(object) <- nm
object
}
#' @export
packageVersion <- function (pkg, lib.loc = NULL) {
res <- suppressWarnings(utils::packageDescription(pkg, lib.loc = lib.loc, fields = "Version"))
if (!is.na(res))
base::package_version(res)
else stop(gettextf("package %s not found", sQuote(pkg)), domain = NA)
}
#' @export
untar <- function(...) {
utils::untar(...)
}
`%||%` <- function(x, y) if (is.null(x)) y else x
notTRUE <- Negate(isTRUE)
libPath <- function() {
lib <- .libPaths()[2L] # We use the second index to skip the transient stagin library.
if (identical(lib, .Library)) {
# We *never* want to accidentally manipulate the system library!
stop("Something went wrong, restart R or lockbox.")
}
lib
}
lockbox_imports <- function() {
dcf <- system.file("DESCRIPTION", package = "lockbox", lib.loc = .Library)
Filter(nzchar, strsplit(read.dcf(dcf)[,"Imports"], "[\n, ]+")[[1]])
}
#' @author Kevin Ushey
#' @source \url{https://github.com/rstudio/packrat/blob/92492ebc882bd048f092238af033d8a6fd03902f/R/utils.R#L469}
symlink <- function(from, to, force = FALSE) {
if (isTRUE(force) && file.exists(to)) unlink(to, force = TRUE)
if (is.windows()) Sys.junction(from, to)
else file.symlink(from, to)
}
#' @author Kevin Ushey
#' @source \url{https://github.com/rstudio/packrat/blob/ce9fb1de3ed490d3f85b0cae4534a3e998db659e/R/platform.R#L1}
is.windows <- function() {
Sys.info()["sysname"] == "Windows"
}
#' @author Kevin Ushey
#' @source \url{https://github.com/rstudio/packrat/blob/ce9fb1de3ed490d3f85b0cae4534a3e998db659e/R/platform.R#L5}
is.mac <- function() {
Sys.info()["sysname"] == "Darwin"
}
#' @author Kevin Ushey
#' @source \url{https://github.com/rstudio/packrat/blob/ce9fb1de3ed490d3f85b0cae4534a3e998db659e/R/platform.R#L9}
is.linux <- function() {
Sys.info()["sysname"] == "Linux"
}
#' @author Kevin Ushey
#' @source \url{https://github.com/rstudio/packrat/blob/649097381ad702c56e6326ae4cee5c56713f6276/R/library-support.R#L140}
is.symlink <- function(path) {
Strip trailing '/'
path <- gsub("/*$", "", path)
Sys.readlink returns NA for error, “” for 'not a symlink', and
result <- Sys.readlink(path)
if (is.na(result)) FALSE
else nzchar(result)
}
quietly <- function(expr) {
suppressPackageStartupMessages(suppressMessages(suppressWarnings(expr)))
}
package_version_from_path <- function(pkg_path) {
package_version(unname(read.dcf(file.path(pkg_path, "DESCRIPTION"))[, "Version"]))
}
#' @useDynLib lockbox duplicate_lockbox_
duplicate <- function(x) {
.Call(duplicate_lockbox_, x, PACKAGE = "lockbox")
}
.lockbox_env <- new.env()
set_transient_library <- function() {
if (!is.null(.lockbox_env$old_dir)) return()
dir <- lockbox_transient_dir()
if (!file.exists(dir)) dir.create(dir, FALSE, TRUE)
.lockbox_env$old_dir <- .libPaths()
# We add one final library path: a transient staging library
# that is used to copy over installed packages to the vanilla
# library.
transient_staging_path <- lockbox_transient_staging_dir()
if (!file.exists(transient_staging_path)) {
unlink(transient_staging_path, TRUE, TRUE)
dir.create(transient_staging_path, FALSE, TRUE)
}
.libPaths(c(transient_staging_path, dir, .libPaths()))
}
set_default_mirror <- function() {
# Set default CRAN mirror to Rstudio's unless the user requests not to.
if (is.null(getOption("lockbox.disable_default_mirror"))) {
if (is.null(getOption("repos"))) {
.lockbox_env$old_opts <-
options(repos = structure(c(CRAN = "http://cran.rstudio.com/")))
}
}
}
# If a parent directory has a lockfile.yml, load it when the package is attached.
load_project <- function(path = getwd()) {
has_lockfile <- function(path) {
file.exists(file.path(path, "lockfile.yml"))
}
is_root <- function(path) {
identical(path, dirname(path))
}
path <- normalizePath(path, mustWork = FALSE)
while (!has_lockfile(path) && !is_root(path)) {
path <- dirname(path)
}
if (!is_root(path)) {
lockbox(file.path(path, 'lockfile.yml'))
} else if (!is.null(getOption("lockbox.default"))) {
lockbox(getOption("lockbox.default"))
}
}
# Move non-symlinks from transient library to real library in case
# user installs packages while using lockbox. See the addTaskCallback
# in .onLoad
sanitize_transient_library <- function(...) {
transient_staging_lib <- lockbox_transient_staging_dir()
# Exclude the lockbox transient library and transient staging library.
lib <- setdiff(.libPaths(), c(libPath(), transient_staging_lib))[1L]
pkg_moved <- character(0)
with_real_packages(transient_staging_lib, function(pkgpath) {
pkgname <- basename(pkgpath)
pkg_moved <<- c(pkg_moved, pkgname)
newpkg <- file.path(lib, pkgname)
unlink(newpkg, TRUE, TRUE)
file.rename(pkgpath, newpkg)
})
if (length(pkg_moved)) {
warning("You just installed the following packages while using lockbox:\n\n",
paste(paste("-", pkg_moved), collapse = "\n"),
"\n\nThese have been moved from ", sQuote(transient_staging_lib),
" to ", sQuote(lib), ". In general, you should only install ",
"packages in an R session that does not use lockbox, e.g., ",
"by calling ", sQuote("R --vanilla"), " in the terminal.",
call. = FALSE)
}
TRUE
}
.onLoad <- function(pkg, libPath) {
set_transient_library()
addTaskCallback(sanitize_transient_library, "lockbox_callback")
}
.onAttach <- function(pkg, libPath) {
if (isTRUE(getOption("lockbox.autoload", TRUE))) {
load_project()
}
}
.onUnLoad <- function(pkg) {
.libPaths(.lockbox_env$old_dir)
removeTaskCallback("lockbox_callback")
if (exists("old_opts", envir = .lockbox_env, inherits = FALSE)) {
options(.lockbox_env$old_opts)
}
}