plan_installation <- function(packages, db, lib, installed_action,
local_drat = NULL) {
if (installed_action == "skip") {
skip <- .packages(TRUE, lib)
} else {
skip <- NULL
}
base <- base_packages()
builtin <- builtin_packages()
requested <- setdiff(packages, base_packages())
available <- union(.packages(TRUE, lib), builtin)
## TODO: drop the setdiff here, which also drops the lib argument?
msg <- setdiff(packages, c(db$all[, "Package"], c(skip, base)))
if (length(msg) > 0L) {
stop(sprintf("Can't find installation candidate for: %s",
paste(msg, collapse = ", ")))
}
packages <- setdiff(recursive_deps(packages, db$all), base)
msg <- setdiff(packages, db$all[, "Package"])
if (length(msg) > 0L) {
stop(sprintf("Can't find installation candidate for dependencies: %s",
paste(msg, collapse = ", ")))
}
if (installed_action == "skip") {
packages <- setdiff(packages, available)
}
binary <- packages %in% rownames(db$bin)
if (installed_action == "upgrade" || installed_action == "upgrade_all") {
if (installed_action == "upgrade") {
check <- union(setdiff(packages, available), requested)
} else {
check <- packages
}
packages <- check_version(check, lib, db, local_drat)
}
## Check the versions here to prefer source packages where they
## are newer
nv <- function(x) {
x[is.na(x)] <- "0.0.0"
numeric_version(x)
}
v_bin <- nv(db$bin[match(packages, rownames(db$bin)), "Version"])
v_src <- nv(db$src[match(packages, rownames(db$src)), "Version"])
avoid_bin <- intersect(packages[v_src > v_bin], rownames(db$bin))
if (length(avoid_bin) > 0L) {
is_from_cran <- function(p, cran) {
if (length(cran) == 0L) {
FALSE
} else {
## We could either use
## any(x & y)
## or
## any(x) && any(y)
## But the latter performs better when there are two repos
## claiming to be CRAN
any(string_starts_with(db$bin[p, "Repository"], cran)) &&
any(string_starts_with(db$src[p, "Repository"], cran))
}
}
cran_update <- vlapply(avoid_bin, is_from_cran, db$repos[db$is_cran])
if (any(cran_update)) {
msg <- sprintf(
"Preferring old CRAN binary for %s",
paste(sprintf('"%s"', avoid_bin[cran_update]), collapse = ", "))
provisionr_log("note", msg)
avoid_bin <- avoid_bin[!cran_update]
}
if (length(avoid_bin) > 0L) {
db$bin <- db$bin[-match(avoid_bin, rownames(db$bin)), ]
}
}
compile <- rep_len(FALSE, length(packages))
binary <- packages %in% rownames(db$bin)
if (any(!binary)) {
j <- match(packages[!binary], db$src[, "Package"])
compile[!binary] <- db$src[j, "NeedsCompilation"] == "yes"
}
ret <- list(packages = packages,
binary = binary,
compile = compile,
db = db)
class(ret) <- "provisionr_plan"
ret
}
check_installed_packages <- function(packages, lib, cols = NULL) {
if (is.null(cols)) {
cols <- c("Depends", "Imports")
}
## packages we do not *need* to see in the library
builtin <- builtin_packages()
## packages that we can see in the library
installed <- union(.packages(TRUE, lib), builtin)
## packages known to be missing
missing <- setdiff(packages, installed)
check <- setdiff(packages, missing)
checked <- installed
while (length(check) > 0L) {
p <- check[[1L]]
desc <- find_description(p, lib)
if (is.na(desc)) {
missing <- c(missing, p)
extra <- character(0)
} else {
deps <- parse_deps(na.omit(read.dcf(desc, cols)[1L, ]))
## add them to our package list:
extra <- setdiff(deps, checked)
}
checked <- c(checked, p)
check <- c(check[-1L], extra)
}
missing
}
find_description <- function(p, lib) {
full <- file.path(lib, p, "DESCRIPTION")
found <- file.exists(full)
if (any(found)) {
full[which(found)[[1L]]]
} else {
NA_character_
}
}
## TODO: we need to drop recommended from here, unless I deal with the
## issue seen with Hmisc vs survival not working with R 3.3.2 unless
## survival (a recommended package) is manually updated. So going
## through versions might fix things.
base_packages <- function() {
rownames(installed.packages(priority = "base"))
}
builtin_packages <- function() {
rownames(installed.packages(priority = c("base", "recommended")))
}
recursive_deps <- function(x, db, suggests = FALSE) {
done <- character()
base <- base_packages()
cols <- c("Depends", "Imports", "LinkingTo",
if (suggests) "Suggests")
while (length(x) > 0L) {
done <- c(done, x)
deps <- parse_deps(na.omit(c(db[match(x, db[, "Package"]), cols])))
x <- setdiff(deps, c(x, base))
}
sort(unique(done))
}
parse_deps <- function(x) {
## TODO: This does not support returning version numbers (so
## depending on particular versions of packages is not going to work
## here).
##
## Somewhere I had the version parsing thing; I will need that back
## soon. For now this just strips version information entirely.
## This could be something good to push into remotes, perhaps?
val <- unlist(strsplit(x, ","), use.names=FALSE)
val <- gsub("(\\s|\\().*", "", trimws(val))
val[val != "R"]
}
parse_deps_version <- function(x) {
xx <- strsplit(trimws(sub("\n", " ", x, fixed = TRUE)),
"\\s*,\\s*", perl = TRUE)
re <- "^([^\\s(]+)\\s*(.*)"
xx[vlapply(xx, identical, NA_character_)] <- list(character(0))
i <- lengths(xx, FALSE)
j <- factor(rep(seq_along(i), i), seq_along(i))
s <- unlist(xx, use.names = FALSE)
pkg <- sub(re, "\\1", s, perl = TRUE)
ver <- sub(re, "\\2", s, perl = TRUE)
ver[!nzchar(ver)] <- NA_character_
re_ver <- "^\\(([^\\s]+)\\s+([^)]+)\\)"
op <- sub(re_ver, "\\1", ver, perl = TRUE)
ver <- sub(re_ver, "\\2", ver, perl = TRUE)
dat <- cbind(name = pkg, operator = op, version = ver)
ret <- lapply(split(dat, j), matrix, ncol = 3, dimnames = dimnames(dat))
if (!is.null(names(x))) {
names(ret) <- names(x)
}
ret
}
drat_ensure_PACKAGES <- function(path) {
path_PACKAGES <- file.path(path, "PACKAGES")
if (!file.exists(path_PACKAGES)) {
dir.create(path, FALSE, TRUE)
writeLines(character(0), path_PACKAGES)
}
}
check_version <- function(packages, lib, db, local_drat) {
current <- packages %in% .packages(TRUE, lib)
if (any(current)) {
check <- packages[current]
desc <- setNames(file.path(find.package(check, lib), "DESCRIPTION"), check)
v_current <- numeric_version(vcapply(desc, read.dcf, "Version"))
binary <- check %in% rownames(db$bin)
v_db <- setNames(character(length(check)), check)
v_db[binary] <- db$bin[check[binary], "Version"]
v_db[!binary] <- db$src[check[!binary], "Version"]
v_db <- numeric_version(v_db)
current[current] <- v_current >= v_db
if (any(current) && !is.null(local_drat)) {
## Extra check for non-version-number-indicated change in
## packages that are in the package_source-controlled repo.
## This is not that straightforward to do though as I don't
## always have access to the same fields in installed packages
## and in the storr database. The best I have is for "Packaged"
## field.
st <- drat_storr(local_drat)
dat_drat <- st$mget(st$list())
names(dat_drat) <- vcapply(dat_drat, "[[", "Package")
for (p in intersect(names(dat_drat), packages[current])) {
t_drat <- sub(";.*", "", dat_drat[[p]]$Packaged)
t_lib <- sub(";.*", "", drop(read.dcf(desc[[p]], "Packaged")))
if (isTRUE(as.POSIXct(t_drat) > as.POSIXct(t_lib))) {
provisionr_log("force",
sprintf("upgrade '%s' as detected newer source", p))
current[packages == p] <- FALSE
}
}
}
}
packages[!current]
}
plan_force_binary <- function(packages, plan, local_drat) {
i <- which(rownames(plan$db$bin) %in% packages)
drop <- i[plan$db$bin[i, "Repository"] != file_url(local_drat)]
if (length(drop) > 0L) {
## Need to update the plan, too, here.
packages_bin <- intersect(rownames(plan$db$bin)[i], plan$packages)
j <- match(packages_bin, plan$packages)
plan$binary[j] <- FALSE
plan$compile[j] <- plan$db$src[packages_bin, "NeedsCompilation"] == "yes"
plan$db$bin <- plan$db$bin[-i, , drop = FALSE]
}
plan
}
##' @export
print.provisionr_plan <- function(x, ...) {
cat("<provisionr_plan>\n")
pkgs <- strwrap(paste(x$packages, collapse = ", "),
initial = " - packages: ", exdent = 13)
cat(paste0(pkgs, "\n", collapse = ""))
invisible(x)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.