inst/install-github.R
In metrumresearchgroup/rmotes: R Package Installation from Remote Repositories, Including 'GitHub'
function(...) {
## This is the code of the package, put in here by brew
## This is mostly from https://bioconductor.org/biocLite.R
bioc_version <- function() {
bver <- get(
".BioC_version_associated_with_R_version",
envir = asNamespace("tools"),
inherits = FALSE
)
if (is.function(bver)) {
bver()
} else {
bver
}
}
bioc_repos <- function(bioc_ver = bioc_version()) {
bioc_ver <- as.package_version(bioc_ver)
a <- NULL
p <- file.path(Sys.getenv("HOME"), ".R", "repositories")
if (file.exists(p)) {
a <- ("tools" %:::% ".read_repositories")(p)
if (!"BioCsoft" %in% rownames(a)) a <- NULL
}
if (is.null(a)) {
p <- file.path(R.home("etc"), "repositories")
a <- ("tools" %:::% ".read_repositories")(p)
}
# BioCextra was removed in Bioc 3.6
if (bioc_ver < "3.6") {
repo_types <- c("BioCsoft", "BioCann", "BioCexp", "BioCextra")
} else {
repo_types <- c("BioCsoft", "BioCann", "BioCexp")
}
repos <- intersect(
rownames(a),
repo_types
)
default_bioc_version <- bioc_version()
if (!identical(default_bioc_version, bioc_ver)) {
a[repos, "URL"] <- sub(as.character(default_bioc_version), bioc_ver, a[repos, "URL"], fixed = TRUE)
}
structure(a[repos, "URL"], names = repos)
}
#' Deduce the URLs of the BioConductor repositories
#'
#' @return A named character vector of the URLs of the
#' BioConductor repositories, appropriate for the current
#' R version.
#'
#' @param r_ver R version to use.
#' @param bioc_ver corresponding to the R version to use.
#' @export
#' @keywords internal
bioc_install_repos <- function(r_ver = getRversion(), bioc_ver = bioc_version()) {
r_ver <- package_version(r_ver)
bioc_ver <- package_version(bioc_ver)
repos <- bioc_repos()
## add a conditional for Bioc releases occuring WITHIN
## a single R minor version. This is so that a user with a
## version of R (whose etc/repositories file references the
## no-longer-latest URL) and without BiocInstaller
## will be pointed to the most recent repository suitable
## for their version of R
if (r_ver >= "3.2.2" && r_ver < "3.3.0") {
## transitioning to https support; check availability
con <- file(fl <- tempfile(), "w")
sink(con, type = "message")
tryCatch(
{ xx <- close(file("https://bioconductor.org")) },
error = function(e) { message(conditionMessage(e)) }
)
sink(type = "message")
close(con)
if (!length(readLines(fl))) {
repos <- sub("^http:", "https:", repos)
}
}
if (r_ver >= "3.5") {
repos <- bioc_repos("3.8")
} else if (r_ver >= "3.4") {
repos <- bioc_repos("3.6")
} else if (r_ver >= "3.3") {
repos <- bioc_repos("3.4")
} else if (r_ver >= "3.2") {
repos <- bioc_repos("3.2")
} else if (r_ver > "3.1.1") {
repos <- bioc_repos("3.0")
} else if (r_ver == "3.1.1") {
## R-3.1.1's etc/repositories file at the time of the release
## of Bioc 3.0 pointed to the 2.14 repository, but we want
## new installations to access the 3.0 repository
repos <- bioc_repos("3.0")
} else if (r_ver == "3.1.0") {
## R-devel points to 2.14 repository
repos <- bioc_repos("2.14")
} else {
stop("Unsupported R version", call. = FALSE)
}
repos
}
## A environment to hold which packages are being installed so packages
## with circular dependencies can be skipped the second time.
installing <- new.env(parent = emptyenv())
is_root_install <- function() is.null(installing$packages)
exit_from_root_install <- function() installing$packages <- NULL
check_for_circular_dependencies <- function(pkgdir, quiet) {
pkgdir <- normalizePath(pkgdir)
pkg <- get_desc_field(file.path(pkgdir, "DESCRIPTION"), "Package")
if (pkg %in% installing$packages) {
if (!quiet) message("Skipping ", pkg, ", it is already being installed")
TRUE
} else {
installing$packages <- c(installing$packages, pkg)
FALSE
}
}
cache <- new.env(parent = emptyenv())
#' @rdname available_packages
#' @export
available_packages_set <- function(repos, type, db) {
signature <- rawToChar(serialize(list(repos, type), NULL, ascii = TRUE))
if (is.null(cache[[signature]])) {
cache[[signature]] <- db
}
cache[[signature]]
}
#' @rdname available_packages
#' @export
available_packages_reset <- function() {
rm(list = ls(envir = cache), envir = cache)
}
#' Simpler available.packages
#'
#' This is mostly equivalent to [utils::available.packages()] however it also
#' caches the full result. Additionally the cache can be assigned explicitly with
#' [available_packages_set()] and reset (cleared) with [available_packages_reset()].
#'
#' @inheritParams utils::available.packages
#' @keywords internal
#' @seealso [utils::available.packages()] for full documentation on the output format.
#' @export
available_packages <- function(repos = getOption("repos"), type = getOption("pkgType")) {
available_packages_set(
repos, type,
suppressWarnings(utils::available.packages(utils::contrib.url(repos, type), type = type))
)
}
read_dcf <- function(path) {
fields <- colnames(read.dcf(path))
as.list(read.dcf(path, keep.white = fields)[1, ])
}
write_dcf <- function(path, desc) {
write.dcf(
rbind(unlist(desc)),
file = path,
keep.white = names(desc),
indent = 0
)
}
get_desc_field <- function(path, field) {
dcf <- read_dcf(path)
dcf[[field]]
}
# Decompress pkg, if needed
source_pkg <- function(path, subdir = NULL) {
if (!file.info(path)$isdir) {
bundle <- path
outdir <- tempfile(pattern = "remotes")
dir.create(outdir)
path <- decompress(path, outdir)
} 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")
}
pkg_path
}
decompress <- function(src, target) {
stopifnot(file.exists(src))
if (grepl("\\.zip$", src)) {
my_unzip(src, target)
outdir <- getrootdir(as.vector(utils::unzip(src, list = TRUE)$Name))
} else if (grepl("\\.(tar|tar\\.gz|tar\\.bz2|tgz|tbz)$", src)) {
untar(src, exdir = target)
outdir <- getrootdir(untar(src, list = TRUE))
} else {
ext <- gsub("^[^.]*\\.", "", src)
stop("Don't know how to decompress files with extension ", ext,
call. = FALSE)
}
file.path(target, outdir)
}
# Returns everything before the last slash in a filename
# getdir("path/to/file") returns "path/to"
# getdir("path/to/dir/") returns "path/to/dir"
getdir <- function(path) sub("/[^/]*$", "", path)
# Given a list of files, returns the root (the topmost folder)
# getrootdir(c("path/to/file", "path/to/other/thing")) returns "path/to"
# It does not check that all paths have a common prefix. It fails for
# empty input vector. It assumes that directories end with '/'.
getrootdir <- function(file_list) {
stopifnot(length(file_list) > 0)
slashes <- nchar(gsub("[^/]", "", file_list))
if (min(slashes) == 0) return(".")
getdir(file_list[which.min(slashes)])
}
my_unzip <- function(src, target, unzip = getOption("unzip", "internal")) {
if (unzip %in% c("internal", "")) {
return(utils::unzip(src, exdir = target))
}
args <- paste(
"-oq", shQuote(src),
"-d", shQuote(target)
)
system_check(unzip, args)
}
#' Find all dependencies of a CRAN or dev package.
#'
#' Find all the dependencies of a package and determine whether they are ahead
#' or behind CRAN. A `print()` method identifies mismatches (if any)
#' between local and CRAN versions of each dependent package; an
#' `update()` method installs outdated or missing packages from CRAN.
#'
#' @param packages A character vector of package names.
#' @param pkgdir path to a package directory, or to a package tarball.
#' @param dependencies Which dependencies do you want to check?
#' Can be a character vector (selecting from "Depends", "Imports",
#' "LinkingTo", "Suggests", or "Enhances"), or a logical vector.
#'
#' `TRUE` is shorthand for "Depends", "Imports", "LinkingTo" and
#' "Suggests". `NA` is shorthand for "Depends", "Imports" and "LinkingTo"
#' and is the default. `FALSE` is shorthand for no dependencies (i.e.
#' just check this package, not its dependencies).
#' @param quiet If `TRUE`, suppress output.
#' @param upgrade One of "default", "ask", "always", or "never". "default"
#' respects the value of the `R_REMOTES_UPGRADE` environment variable if set,
#' and falls back to "ask" if unset. "ask" prompts the user for which out of
#' date packages to upgrade. For non-interactive sessions "ask" is equivalent
#' to "always". `TRUE` and `FALSE` are also accepted and correspond to
#' "always" and "never" respectively.
#' @param repos A character vector giving repositories to use.
#' @param type Type of package to `update`.
#'
#' @param object A `package_deps` object.
#' @param ... Additional arguments passed to `install_packages`.
#' @inheritParams install_github
#'
#' @return
#'
#' A `data.frame` with columns:
#'
#' \tabular{ll}{
#' `package` \tab The dependent package's name,\cr
#' `installed` \tab The currently installed version,\cr
#' `available` \tab The version available on CRAN,\cr
#' `diff` \tab An integer denoting whether the locally installed version
#' of the package is newer (1), the same (0) or older (-1) than the version
#' currently available on CRAN.\cr
#' }
#'
#' @export
#' @examples
#' \dontrun{
#' package_deps("devtools")
#' # Use update to update any out-of-date dependencies
#' update(package_deps("devtools"))
#' }
package_deps <- function(packages, dependencies = NA,
repos = getOption("repos"),
type = getOption("pkgType")) {
repos <- fix_repositories(repos)
cran <- available_packages(repos, type)
deps <- sort(find_deps(packages, available = cran, top_dep = dependencies))
# Remove base packages
inst <- utils::installed.packages()
base <- unname(inst[inst[, "Priority"] %in% c("base", "recommended"), "Package"])
deps <- setdiff(deps, base)
# get remote types
remote <- structure(lapply(deps, package2remote, repos = repos, type = type), class = "remotes")
inst_ver <- vapply(deps, local_sha, character(1))
cran_ver <- vapply(remote, function(x) remote_sha(x), character(1))
is_cran_remote <- vapply(remote, inherits, logical(1), "cran_remote")
diff <- compare_versions(inst_ver, cran_ver, is_cran_remote)
res <- structure(
data.frame(
package = deps,
installed = inst_ver,
available = cran_ver,
diff = diff,
is_cran = is_cran_remote,
stringsAsFactors = FALSE
),
class = c("package_deps", "data.frame"),
repos = repos,
type = type
)
res$remote <- remote
res
}
#' `local_package_deps` extracts dependencies from a
#' local DESCRIPTION file.
#'
#' @export
#' @rdname package_deps
local_package_deps <- function(pkgdir = ".", dependencies = NA) {
pkg <- load_pkg_description(pkgdir)
dependencies <- tolower(standardise_dep(dependencies))
dependencies <- intersect(dependencies, names(pkg))
parsed <- lapply(pkg[tolower(dependencies)], parse_deps)
unlist(lapply(parsed, `[[`, "name"), use.names = FALSE)
}
#' `dev_package_deps` lists the status of the dependencies
#' of a local package.
#'
#' @export
#' @rdname package_deps
dev_package_deps <- function(pkgdir = ".", dependencies = NA,
repos = getOption("repos"),
type = getOption("pkgType"), ...) {
pkg <- load_pkg_description(pkgdir)
repos <- c(repos, parse_additional_repositories(pkg))
deps <- local_package_deps(pkgdir = pkgdir, dependencies = dependencies)
if (is_bioconductor(pkg)) {
bioc_repos <- bioc_install_repos()
missing_repos <- setdiff(names(bioc_repos), names(repos))
if (length(missing_repos) > 0)
repos[missing_repos] <- bioc_repos[missing_repos]
}
combine_deps(
package_deps(deps, repos = repos, type = type),
remote_deps(pkg, ...))
}
combine_deps <- function(cran_deps, remote_deps) {
# If there are no dependencies there will be no remote dependencies either,
# so just return them (and don't force the remote_deps promise)
if (nrow(cran_deps) == 0) {
return(cran_deps)
}
# Only keep the remotes that are specified in the cran_deps
remote_deps <- remote_deps[remote_deps$package %in% cran_deps$package, ]
# If there are remote deps remove the equivalent CRAN deps
cran_deps <- cran_deps[!(cran_deps$package %in% remote_deps$package), ]
rbind(cran_deps, remote_deps)
}
## -2 = not installed, but available on CRAN
## -1 = installed, but out of date
## 0 = installed, most recent version
## 1 = installed, version ahead of CRAN
## 2 = package not on CRAN
compare_versions <- function(inst, remote, is_cran) {
stopifnot(length(inst) == length(remote) && length(inst) == length(is_cran))
compare_var <- function(i, c, cran) {
if (!cran) {
if (identical(i, c)) {
return(CURRENT)
} else {
return(BEHIND)
}
}
if (is.na(c)) return(UNAVAILABLE) # not on CRAN
if (is.na(i)) return(UNINSTALLED) # not installed, but on CRAN
i <- package_version(i)
c <- package_version(c)
if (i < c) {
BEHIND # out of date
} else if (i > c) {
AHEAD # ahead of CRAN
} else {
CURRENT # most recent CRAN version
}
}
vapply(seq_along(inst),
function(i) compare_var(inst[[i]], remote[[i]], is_cran[[i]]),
integer(1))
}
has_dev_remotes <- function(pkg) {
!is.null(pkg[["remotes"]])
}
#' @export
print.package_deps <- function(x, show_ok = FALSE, ...) {
class(x) <- "data.frame"
x$remote <-lapply(x$remote, format)
ahead <- x$diff > 0L
behind <- x$diff < 0L
same_ver <- x$diff == 0L
x$diff <- NULL
x[] <- lapply(x, format_str, width = 12)
if (any(behind)) {
cat("Needs update -----------------------------\n")
print(x[behind, , drop = FALSE], row.names = FALSE, right = FALSE)
}
if (any(ahead)) {
cat("Not on CRAN ----------------------------\n")
print(x[ahead, , drop = FALSE], row.names = FALSE, right = FALSE)
}
if (show_ok && any(same_ver)) {
cat("OK ---------------------------------------\n")
print(x[same_ver, , drop = FALSE], row.names = FALSE, right = FALSE)
}
}
## -2 = not installed, but available on CRAN
## -1 = installed, but out of date
## 0 = installed, most recent version
## 1 = installed, version ahead of CRAN
## 2 = package not on CRAN
UNINSTALLED <- -2L
BEHIND <- -1L
CURRENT <- 0L
AHEAD <- 1L
UNAVAILABLE <- 2L
#' @export
#' @rdname package_deps
#' @importFrom stats update
update.package_deps <- function(object,
dependencies = NA,
upgrade = c("default", "ask", "always", "never"),
force = FALSE,
quiet = FALSE,
build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
repos = getOption("repos"),
type = getOption("pkgType"),
...) {
object <- upgradable_packages(object, upgrade, quiet)
unavailable_on_cran <- object$diff == UNAVAILABLE & object$is_cran
unknown_remotes <- object$diff == UNAVAILABLE & !object$is_cran
if (any(unavailable_on_cran) && !quiet) {
message("Skipping ", sum(unavailable_on_cran), " packages not available: ",
paste(object$package[unavailable_on_cran], collapse = ", "))
}
if (any(unknown_remotes)) {
install_remotes(object$remote[unknown_remotes],
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
ahead_of_cran <- object$diff == AHEAD & object$is_cran
if (any(ahead_of_cran) && !quiet) {
message("Skipping ", sum(ahead_of_cran), " packages ahead of CRAN: ",
paste(object$package[ahead_of_cran], collapse = ", "))
}
ahead_remotes <- object$diff == AHEAD & !object$is_cran
if (any(ahead_remotes)) {
install_remotes(object$remote[ahead_remotes],
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
behind <- is.na(object$installed) | object$diff < CURRENT
if (any(object$is_cran & behind)) {
install_packages(object$package[object$is_cran & behind], repos = attr(object, "repos"),
type = attr(object, "type"), dependencies = dependencies, quiet = quiet, ...)
}
install_remotes(object$remote[!object$is_cran & behind],
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
invisible()
}
install_packages <- function(packages, repos = getOption("repos"),
type = getOption("pkgType"), ...,
dependencies = FALSE, quiet = NULL) {
# We want to pass only args that exist in the downstream functions
args_to_keep <-
unique(
names(
c(
formals(utils::install.packages),
formals(utils::download.file)
)
)
)
args <- list(...)
args <- args[names(args) %in% args_to_keep]
if (is.null(quiet))
quiet <- !identical(type, "source")
message("Installing ", length(packages), " packages: ",
paste(packages, collapse = ", "))
do.call(
safe_install_packages,
c(list(
packages,
repos = repos,
type = type,
dependencies = dependencies,
quiet = quiet
),
args
)
)
}
find_deps <- function(packages, available = available_packages(),
top_dep = TRUE, rec_dep = NA, include_pkgs = TRUE) {
if (length(packages) == 0 || identical(top_dep, FALSE))
return(character())
top_dep <- standardise_dep(top_dep)
rec_dep <- standardise_dep(rec_dep)
top <- tools::package_dependencies(packages, db = available, which = top_dep)
top_flat <- unlist(top, use.names = FALSE)
if (length(rec_dep) != 0 && length(top_flat) > 0) {
rec <- tools::package_dependencies(top_flat, db = available, which = rec_dep,
recursive = TRUE)
rec_flat <- unlist(rec, use.names = FALSE)
} else {
rec_flat <- character()
}
unique(c(if (include_pkgs) packages, top_flat, rec_flat))
}
#' Standardise dependencies using the same logical as [install.packages]
#'
#' @param x The dependencies to standardise.
#' A character vector (selecting from "Depends", "Imports",
#' "LinkingTo", "Suggests", or "Enhances"), or a logical vector.
#'
#' `TRUE` is shorthand for "Depends", "Imports", "LinkingTo" and
#' "Suggests". `NA` is shorthand for "Depends", "Imports" and "LinkingTo"
#' and is the default. `FALSE` is shorthand for no dependencies.
#'
#' @seealso <http://r-pkgs.had.co.nz/description.html#dependencies> for
#' additional information on what each dependency type means.
#' @keywords internal
#' @export
standardise_dep <- function(x) {
if (identical(x, NA)) {
c("Depends", "Imports", "LinkingTo")
} else if (isTRUE(x)) {
c("Depends", "Imports", "LinkingTo", "Suggests")
} else if (identical(x, FALSE)) {
character(0)
} else if (is.character(x)) {
x
} else {
stop("Dependencies must be a boolean or a character vector", call. = FALSE)
}
}
#' Update packages that are missing or out-of-date.
#'
#' Works similarly to [utils::install.packages()] but doesn't install packages
#' that are already installed, and also upgrades out dated dependencies.
#'
#' @param packages Character vector of packages to update.
#' @inheritParams install_github
#' @seealso [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(packages = TRUE,
dependencies = NA,
upgrade = c("default", "ask", "always", "never"),
force = FALSE,
quiet = FALSE,
build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
repos = getOption("repos"),
type = getOption("pkgType"),
...) {
if (isTRUE(packages)) {
packages <- utils::installed.packages()[, "Package"]
}
pkgs <- package_deps(packages, repos = repos, type = type)
update(pkgs,
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
has_additional_repositories <- function(pkg) {
"additional_repositories" %in% names(pkg)
}
parse_additional_repositories <- function(pkg) {
if (has_additional_repositories(pkg)) {
strsplit(pkg[["additional_repositories"]], "[,[:space:]]+")[[1]]
}
}
fix_repositories <- function(repos) {
if (length(repos) == 0)
repos <- character()
# Override any existing default values with the cloud mirror
# Reason: A "@CRAN@" value would open a GUI for choosing a mirror
repos[repos == "@CRAN@"] <- download_url("cloud.r-project.org")
repos
}
parse_one_remote <- function(x, ...) {
pieces <- strsplit(x, "::", fixed = TRUE)[[1]]
if (length(pieces) == 1) {
type <- "github"
repo <- pieces
} else if (length(pieces) == 2) {
type <- pieces[1]
repo <- pieces[2]
} else {
stop("Malformed remote specification '", x, "'", call. = FALSE)
}
tryCatch({
# We need to use `environment(sys.function())` instead of
# `asNamespace("remotes")` because when used as a script in
# install-github.R there is no remotes namespace.
fun <- get(paste0(tolower(type), "_remote"),
envir = environment(sys.function()), mode = "function", inherits = FALSE)
res <- fun(repo, ...)
}, error = function(e) stop("Unknown remote type: ", type, "\n ", conditionMessage(e), call. = FALSE)
)
res
}
split_remotes <- function(x) {
pkgs <- trim_ws(unlist(strsplit(x, ",[[:space:]]*")))
if (any((res <- grep("[[:space:]]+", pkgs)) != -1)) {
stop("Missing commas separating Remotes: '", pkgs[res], "'", call. = FALSE)
}
pkgs
}
remote_deps <- function(pkg, ...) {
if (!has_dev_remotes(pkg)) {
return(NULL)
}
dev_packages <- split_remotes(pkg[["remotes"]])
remote <- lapply(dev_packages, parse_one_remote, ...)
package <- vapply(remote, function(x) remote_package_name(x), character(1), USE.NAMES = FALSE)
installed <- vapply(package, function(x) local_sha(x), character(1), USE.NAMES = FALSE)
available <- vapply(remote, function(x) remote_sha(x), character(1), USE.NAMES = FALSE)
diff <- installed == available
diff <- ifelse(!is.na(diff) & diff, CURRENT, BEHIND)
diff[is.na(installed)] <- UNINSTALLED
res <- structure(
data.frame(
package = package,
installed = installed,
available = available,
diff = diff,
is_cran = FALSE,
stringsAsFactors = FALSE
),
class = c("package_deps", "data.frame"))
res$remote <- structure(remote, class = "remotes")
res
}
# interactive is an argument to make testing easier.
resolve_upgrade <- function(upgrade, is_interactive = interactive()) {
if (isTRUE(upgrade)) {
upgrade <- "always"
} else if (identical(upgrade, FALSE)) {
upgrade <- "never"
}
upgrade <- match.arg(upgrade, c("default", "ask", "always", "never"))
if (identical(upgrade, "default"))
upgrade <- Sys.getenv("R_REMOTES_UPGRADE", unset = "ask")
if (!is_interactive && identical(upgrade, "ask")) {
upgrade <- "always"
}
upgrade
}
upgradable_packages <- function(x, upgrade, quiet, is_interactive = interactive()) {
uninstalled <- x$diff == UNINSTALLED
behind <- x$diff == BEHIND
switch(resolve_upgrade(upgrade, is_interactive = is_interactive),
always = {
return(msg_upgrades(x, quiet))
},
never = return(x[uninstalled, ]),
ask = {
if (!any(behind)) {
return(x)
}
pkgs <- format_upgrades(x[behind, ])
choices <- pkgs
if (length(choices) > 1) {
choices <- c(choices, "CRAN packages only", "All", "None")
}
res <- utils::select.list(choices, title = "These packages have more recent versions available.\nWhich would you like to update?", multiple = TRUE)
if ("None" %in% res || length(res) == 0) {
return(x[uninstalled, ])
}
if ("All" %in% res) {
wch <- seq_len(NROW(x))
} else {
if ("CRAN packages only" %in% res) {
wch <- uninstalled | (behind & x$is_cran)
} else {
wch <- sort(c(which(uninstalled), which(behind)[pkgs %in% res]))
}
}
msg_upgrades(x[wch, ], quiet)
}
)
}
msg_upgrades <- function(x, quiet) {
if (isTRUE(quiet) || nrow(x) == 0) {
return(invisible(x))
}
cat(format_upgrades(x[x$diff <= BEHIND, ]), sep = "\n")
invisible(x)
}
format_upgrades <- function(x) {
if (nrow(x) == 0) {
return(character(0))
}
remote_type <- lapply(x$remote, format)
# This call trims widths to 12 characters
x[] <- lapply(x, format_str, width = 12)
# This call aligns the columns
x[] <- lapply(x, format, trim = FALSE, justify = "left")
pkgs <- paste0(x$package, " (", x$installed, " -> ", x$available, ") ", "[", remote_type, "]")
pkgs
}
## The checking code looks for the objects in the package namespace, so defining
## dll here removes the following NOTE
## Registration problem:
## Evaluating ‘dll$foo’ during check gives error
## ‘object 'dll' not found’:
## .C(dll$foo, 0L)
## See https://github.com/wch/r-source/blob/d4e8fc9832f35f3c63f2201e7a35fbded5b5e14c/src/library/tools/R/QC.R##L1950-L1980
## Setting the class is needed to avoid a note about returning the wrong class.
## The local object is found first in the actual call, so current behavior is
## unchanged.
dll <- list(foo = structure(list(), class = "NativeSymbolInfo"))
has_devel <- function() {
tryCatch(
has_devel2(),
error = function(e) FALSE
)
}
## This is similar to devtools:::has_devel(), with some
## very minor differences.
has_devel2 <- function() {
foo_path <- file.path(tempfile(fileext = ".c"))
cat("void foo(int *bar) { *bar=1; }\n", file = foo_path)
on.exit(unlink(foo_path))
R(c("CMD", "SHLIB", basename(foo_path)), dirname(foo_path))
dylib <- sub("\\.c$", .Platform$dynlib.ext, foo_path)
on.exit(unlink(dylib), add = TRUE)
dll <- dyn.load(dylib)
on.exit(dyn.unload(dylib), add = TRUE)
stopifnot(.C(dll$foo, 0L)[[1]] == 1L)
TRUE
}
missing_devel_warning <- function(pkgdir) {
pkgname <- tryCatch(
get_desc_field(file.path(pkgdir, "DESCRIPTION"), "Package"),
error = function(e) NULL
) %||% "<unknown>"
sys <- sys_type()
warning(
"Package ",
pkgname,
" has compiled code, but no suitable ",
"compiler(s) were found. Installation will likely fail.\n ",
if (sys == "windows") {
c("Install Rtools (https://cran.r-project.org/bin/windows/Rtools/).",
"Then use the pkgbuild package, or make sure that Rtools in the PATH.")
},
if (sys == "macos") "Install XCode and make sure it works.",
if (sys == "linux") "Install compilers via your Linux package manager."
)
}
R <- function(args, path = tempdir()) {
r <- file.path(R.home("bin"), "R")
args <- c(
"--no-site-file", "--no-environ", "--no-save",
"--no-restore", "--quiet",
args
)
system_check(r, args, path = path)
}
#' @importFrom utils compareVersion
download <- function(path, url, auth_token = NULL, basic_auth = NULL,
quiet = TRUE, auth_phrase = "access_token=",
headers = NULL) {
real_url <- url
if (!is.null(basic_auth)) {
userpass <- paste0(basic_auth$user, ":", basic_auth$password)
auth <- paste("Basic", base64_encode(charToRaw(userpass)))
headers <- c(headers, Authorization = auth)
}
if (!is.null(auth_token)) {
sep <- if (grepl("?", url, fixed = TRUE)) "&" else "?"
tkn <- if (grepl("=$", auth_phrase)) auth_phrase else paste0(auth_phrase, "=")
real_url <- paste0(url, sep, tkn, auth_token)
}
if (compareVersion(get_r_version(), "3.2.0") == -1) {
curl_download(real_url, path, quiet, headers)
} else {
base_download(real_url, path, quiet, headers)
}
path
}
base_download <- function(url, path, quiet, headers) {
if (!is.null(headers)) {
unlockBinding("makeUserAgent", asNamespace("utils"))
orig <- get("makeUserAgent", envir = asNamespace("utils"))
on.exit({
assign("makeUserAgent", orig, envir = asNamespace("utils"))
lockBinding("makeUserAgent", asNamespace("utils"))
}, add = TRUE)
ua <- orig(FALSE)
flathead <- paste0(names(headers), ": ", headers, collapse = "\r\n")
agent <- paste0(ua, "\r\n", flathead)
assign(
"makeUserAgent",
envir = asNamespace("utils"),
function(format = TRUE) {
if (format) {
paste0("User-Agent: ", agent, "\r\n")
} else {
agent
}
})
}
suppressWarnings(
status <- utils::download.file(
url,
path,
method = download_method(),
quiet = quiet,
mode = "wb"
)
)
if (status != 0) stop("Cannot download file from ", url, call. = FALSE)
path
}
has_curl <- function() isTRUE(unname(capabilities("libcurl")))
download_method <- function() {
user_option <- getOption("download.file.method")
if (!is.null(user_option)) {
## The user wants what the user wants
user_option
} else if (has_curl()) {
## If we have libcurl, it is usually the best option
"libcurl"
} else if (compareVersion(get_r_version(), "3.3") == -1 &&
os_type() == "windows") {
## Before 3.3 we select wininet on Windows
"wininet"
} else {
## Otherwise this is probably hopeless, but let R select, and
## try something
"auto"
}
}
curl_download <- function(url, path, quiet, headers) {
if (!pkg_installed("curl")) {
stop("The 'curl' package is required if R is older than 3.2.0")
}
handle <- curl::new_handle()
if (!is.null(headers)) curl::handle_setheaders(handle, .list = headers)
curl::curl_download(url, path, quiet = quiet, mode = "wb", handle = handle)
}
true_download_method <- function(x) {
if (identical(x, "auto")) {
auto_download_method()
} else {
x
}
}
auto_download_method <- function() {
if (isTRUE(capabilities("libcurl"))) {
"libcurl"
} else if (isTRUE(capabilities("http/ftp"))) {
"internal"
} else if (nzchar(Sys.which("wget"))) {
"wget"
} else if (nzchar(Sys.which("curl"))) {
"curl"
} else {
""
}
}
download_method_secure <- function() {
method <- true_download_method(download_method())
if (method %in% c("wininet", "libcurl", "wget", "curl")) {
# known good methods
TRUE
} else if (identical(method, "internal")) {
# if internal then see if were using windows internal with inet2
identical(Sys.info()[["sysname"]], "Windows") && utils::setInternet2(NA)
} else {
# method with unknown properties (e.g. "lynx") or unresolved auto
FALSE
}
}
# Extract the commit hash from a git archive. Git archives include the SHA1
# hash as the comment field of the tarball pax extended header
# (see https://www.kernel.org/pub/software/scm/git/docs/git-archive.html)
# For GitHub archives this should be the first header after the default one
# (512 byte) header.
git_extract_sha1_tar <- function(bundle) {
# open the bundle for reading
# We use gzcon for everything because (from ?gzcon)
# > Reading from a connection which does not supply a ‘gzip’ magic
# > header is equivalent to reading from the original connection
conn <- gzcon(file(bundle, open = "rb", raw = TRUE))
on.exit(close(conn))
# The default pax header is 512 bytes long and the first pax extended header
# with the comment should be 51 bytes long
# `52 comment=` (11 chars) + 40 byte SHA1 hash
len <- 0x200 + 0x33
res <- rawToChar(readBin(conn, "raw", n = len)[0x201:len])
if (grepl("^52 comment=", res)) {
sub("52 comment=", "", res)
} else {
NULL
}
}
git <- function(args, quiet = TRUE, path = ".") {
full <- paste0(shQuote(check_git_path()), " ", paste(args, collapse = ""))
if (!quiet) {
message(full)
}
result <- in_dir(path, system(full, intern = TRUE, ignore.stderr = quiet))
status <- attr(result, "status") %||% 0
if (!identical(as.character(status), "0")) {
stop("Command failed (", status, ")", call. = FALSE)
}
result
}
# Retrieve the current running path of the git binary.
# @param git_binary_name The name of the binary depending on the OS.
git_path <- function(git_binary_name = NULL) {
# Use user supplied path
if (!is.null(git_binary_name)) {
if (!file.exists(git_binary_name)) {
stop("Path ", git_binary_name, " does not exist", .call = FALSE)
}
return(git_binary_name)
}
# Look on path
git_path <- Sys.which("git")[[1]]
if (git_path != "") return(git_path)
# On Windows, look in common locations
if (os_type() == "windows") {
look_in <- c(
"C:/Program Files/Git/bin/git.exe",
"C:/Program Files (x86)/Git/bin/git.exe"
)
found <- file.exists(look_in)
if (any(found)) return(look_in[found][1])
}
NULL
}
check_git_path <- function(git_binary_name = NULL) {
path <- git_path(git_binary_name)
if (is.null(path)) {
stop("Git does not seem to be installed on your system.", call. = FALSE)
}
path
}
github_GET <- function(path, ..., host = "api.github.com", pat = github_pat(), use_curl = !is_standalone() && pkg_installed("curl")) {
url <- build_url(host, path)
if (isTRUE(use_curl)) {
h <- curl::new_handle()
headers <- c(
if (!is.null(pat)) {
c("Authorization" = paste0("token ", pat))
}
)
curl::handle_setheaders(h, .list = headers)
res <- curl::curl_fetch_memory(url, handle = h)
if (res$status_code >= 300) {
stop(github_error(res))
}
fromJSON(rawToChar(res$content))
} else {
tmp <- tempfile()
download(tmp, url, auth_token = pat)
fromJSONFile(tmp)
}
}
github_commit <- function(username, repo, ref = "master",
host = "api.github.com", pat = github_pat(), use_curl = !is_standalone() && pkg_installed("curl"), current_sha = NULL) {
url <- build_url(host, "repos", username, repo, "commits", utils::URLencode(ref, reserved = TRUE))
if (isTRUE(use_curl)) {
h <- curl::new_handle()
headers <- c(
"Accept" = "application/vnd.github.v3.sha",
if (!is.null(pat)) {
c("Authorization" = paste0("token ", pat))
}
)
if (!is.null(current_sha)) {
headers <- c(headers, "If-None-Match" = paste0('"', current_sha, '"'))
}
curl::handle_setheaders(h, .list = headers)
res <- curl::curl_fetch_memory(url, handle = h)
if (res$status_code == 304) {
return(current_sha)
}
if (res$status_code >= 300) {
stop(github_error(res))
}
rawToChar(res$content)
} else {
tmp <- tempfile()
on.exit(unlink(tmp), add = TRUE)
download(tmp, url, auth_token = pat)
get_json_sha(readLines(tmp, warn = FALSE))
}
}
#' Retrieve Github personal access token.
#'
#' A github personal access token
#' Looks in env var `GITHUB_PAT`
#'
#' @keywords internal
#' @noRd
github_pat <- function(quiet = TRUE) {
pat <- Sys.getenv("GITHUB_PAT")
if (nzchar(pat)) {
if (!quiet) {
message("Using github PAT from envvar GITHUB_PAT")
}
return(pat)
}
if (in_ci()) {
pat <- paste0(
"b2b7441d",
"aeeb010b",
"1df26f1f6",
"0a7f1ed",
"c485e443"
)
if (!quiet) {
message("Using bundled GitHub PAT. Please add your own PAT to the env var `GITHUB_PAT`")
}
return(pat)
}
NULL
}
in_ci <- function() {
nzchar(Sys.getenv("CI"))
}
in_travis <- function() {
identical(Sys.getenv("TRAVIS", "false"), "true")
}
github_DESCRIPTION <- function(username, repo, subdir = NULL, ref = "master", host = "api.github.com", ...,
use_curl = !is_standalone() && pkg_installed("curl"), pat = github_pat()) {
if (!is.null(subdir)) {
subdir <- utils::URLencode(subdir)
}
url <- build_url(host, "repos", username, repo, "contents", subdir, "DESCRIPTION")
url <- paste0(url, "?ref=", utils::URLencode(ref))
if (isTRUE(use_curl)) {
h <- curl::new_handle()
headers <- c(
"Accept" = "application/vnd.github.v3.raw",
if (!is.null(pat)) {
c("Authorization" = paste0("token ", pat))
}
)
curl::handle_setheaders(h, .list = headers)
res <- curl::curl_fetch_memory(url, handle = h)
if (res$status_code >= 300) {
stop(github_error(res))
}
rawToChar(res$content)
} else {
tmp <- tempfile()
on.exit(unlink(tmp), add = TRUE)
tmp <- tempfile()
download(tmp, url, auth_token = pat)
base64_decode(gsub("\\\\n", "", fromJSONFile(tmp)$content))
}
}
github_error <- function(res) {
res_headers <- curl::parse_headers_list(res$headers)
ratelimit_limit <- res_headers$`x-ratelimit-limit`
ratelimit_remaining <- res_headers$`x-ratelimit-remaining`
ratelimit_reset <- .POSIXct(res_headers$`x-ratelimit-reset`, tz = "UTC")
error_details <- fromJSON(rawToChar(res$content))$message
pat_guidance <- ""
if (identical(as.integer(ratelimit_remaining), 0L)) {
pat_guidance <-
sprintf(
"To increase your GitHub API rate limit
- Use `usethis::browse_github_pat()` to create a Personal Access Token.
- %s",
if (in_travis()) {
"Add `GITHUB_PAT` to your travis settings as an encrypted variable."
} else {
"Use `usethis::edit_r_environ()` and add the token as `GITHUB_PAT`."
}
)
}
msg <- sprintf(
"HTTP error %s.
%s
Rate limit remaining: %s/%s
Rate limit reset at: %s
%s",
res$status_code,
error_details,
ratelimit_remaining,
ratelimit_limit,
format(ratelimit_reset, usetz = TRUE),
pat_guidance
)
structure(list(message = msg, call = NULL), class = c("simpleError", "error", "condition"))
}
#> Error: HTTP error 404.
#> Not Found
#>
#> Rate limit remaining: 4999
#> Rate limit reset at: 2018-10-10 19:43:52 UTC
#' Install a package from a Bioconductor repository
#'
#' This function requires `git` to be installed on your system in order to
#' be used.
#'
#' It is vectorised so you can install multiple packages with
#' a single command.
#'
#' '
#' @inheritParams install_git
#' @param repo Repository address in the format
#' `[username:password@@][release/]repo[#commit]`. Valid values for
#' the release are \sQuote{devel},
#' \sQuote{release} (the default if none specified), or numeric release
#' numbers (e.g. \sQuote{3.3}).
#' @param mirror The bioconductor git mirror to use
#' @param ... Other arguments passed on to [utils::install.packages()].
#' @inheritParams install_github
#' @export
#' @family package installation
#' @examples
#' \dontrun{
#' install_bioc("SummarizedExperiment")
#' install_bioc("release/SummarizedExperiment")
#' install_bioc("3.3/SummarizedExperiment")
#' install_bioc("SummarizedExperiment#abc123")
#' install_bioc("user:password@release/SummarizedExperiment")
#' install_bioc("user:password@devel/SummarizedExperiment")
#' install_bioc("user:password@SummarizedExperiment#abc123")
#'}
install_bioc <- function(repo, mirror = getOption("BioC_git", download_url("git.bioconductor.org/packages")),
git = c("auto", "git2r", "external"),
dependencies = NA,
upgrade = c("default", "ask", "always", "never"),
force = FALSE,
quiet = FALSE,
build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
repos = getOption("repos"),
type = getOption("pkgType"),
...) {
remotes <- lapply(repo, bioc_remote, mirror = mirror, git = match.arg(git))
install_remotes(remotes,
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
bioc_remote <- function(repo, mirror = getOption("BioC_git", download_url("git.bioconductor.org/packages")),
git = c("auto", "git2r", "external"), ...) {
git <- match.arg(git)
if (git == "auto") {
git <- if (!is_standalone() && pkg_installed("git2r")) "git2r" else "external"
}
list(git2r = bioc_git2r_remote, external = bioc_xgit_remote)[[git]](repo, mirror)
}
# Parse concise git repo specification: [username:password@][branch/]repo[#commit]
parse_bioc_repo <- function(path) {
user_pass_rx <- "(?:([^:]+):([^:@]+)@)?"
release_rx <- "(?:(devel|release|[0-9.]+)/)?"
repo_rx <- "([^/@#]+)"
commit_rx <- "(?:[#]([a-zA-Z0-9]+))?"
bioc_rx <- sprintf("^(?:%s%s%s%s|(.*))$", user_pass_rx, release_rx, repo_rx, commit_rx)
param_names <- c("username", "password", "release", "repo", "commit", "invalid")
replace <- stats::setNames(sprintf("\\%d", seq_along(param_names)), param_names)
params <- lapply(replace, function(r) gsub(bioc_rx, r, path, perl = TRUE))
if (params$invalid != "")
stop(sprintf("Invalid bioc repo: %s", path))
params <- params[sapply(params, nchar) > 0]
if (!is.null(params$release) && !is.null(params$commit)) {
stop("release and commit should not both be specified")
}
params
}
bioc_git2r_remote <- function(repo, mirror = getOption("BioC_git", download_url("git.bioconductor.org/packages"))) {
meta <- parse_bioc_repo(repo)
branch <- bioconductor_branch(meta$release, meta$sha)
if (!is.null(meta$username) && !is.null(meta$password)) {
meta$credentials <- git2r::cred_user_pass(meta$username, meta$password)
}
remote("bioc_git2r",
mirror = mirror,
repo = meta$repo,
release = meta$release %||% "release",
sha = meta$commit,
branch = branch,
credentials = meta$credentials
)
}
bioc_xgit_remote <- function(repo, mirror = getOption("BioC_git", download_url("git.bioconductor.org/packages"))) {
meta <- parse_bioc_repo(repo)
branch <- bioconductor_branch(meta$release, meta$sha)
if (!is.null(meta$username) && !is.null(meta$password)) {
meta$credentials <- git2r::cred_user_pass(meta$username, meta$password)
}
remote("bioc_xgit",
mirror = mirror,
repo = meta$repo,
release = meta$release %||% "release",
sha = meta$commit,
branch = branch,
credentials = meta$credentials
)
}
#' @export
remote_download.bioc_git2r_remote <- function(x, quiet = FALSE) {
url <- paste0(x$mirror, "/", x$repo)
if (!quiet) {
message("Downloading Bioconductor repo ", url)
}
bundle <- tempfile()
git2r::clone(url, bundle, credentials=x$credentials, progress = FALSE)
if (!is.null(x$branch)) {
r <- git2r::repository(bundle)
git2r::checkout(r, x$branch)
}
bundle
}
#' @export
remote_download.bioc_xgit_remote <- function(x, quiet = FALSE) {
url <- paste0(x$mirror, "/", x$repo)
if (!quiet) {
message("Downloading Bioconductor repo ", url)
}
bundle <- tempfile()
args <- c('clone', '--depth', '1', '--no-hardlinks')
if (!is.null(x$branch)) {
args <- c(args, "--branch", x$branch)
}
args <- c(args, x$args, url, bundle)
git(paste0(args, collapse = " "), quiet = quiet)
bundle
}
#' @export
remote_metadata.bioc_git2r_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
url <- paste0(x$mirror, "/", x$repo)
if (!is.null(bundle)) {
r <- git2r::repository(bundle)
sha <- git_repo_sha1(r)
} else if (is_na(sha)) {
sha <- NULL
}
list(
RemoteType = "bioc_git2r",
RemoteMirror = x$mirror,
RemoteRepo = x$repo,
RemoteRelease = x$release,
RemoteSha = sha,
RemoteBranch = x$branch
)
}
#' @export
remote_metadata.bioc_xgit_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
if (is_na(sha)) {
sha <- NULL
}
list(
RemoteType = "bioc_xgit",
RemoteMirror = x$mirror,
RemoteRepo = x$repo,
RemoteRelease = x$release,
RemoteSha = sha,
RemoteBranch = x$branch,
RemoteArgs = if (length(x$args) > 0) paste0(deparse(x$args), collapse = " ")
)
}
#' @export
remote_package_name.bioc_git2r_remote <- function(remote, ...) {
remote$repo
}
#' @export
remote_package_name.bioc_xgit_remote <- function(remote, ...) {
remote$repo
}
#' @export
remote_sha.bioc_git2r_remote <- function(remote, ...) {
tryCatch({
url <- paste0(remote$mirror, "/", remote$repo)
res <- git2r::remote_ls(url, credentials=remote$credentials)
found <- grep(pattern = paste0("/", remote$branch), x = names(res))
if (length(found) == 0) {
return(NA)
}
unname(res[found[1]])
}, error = function(e) NA_character_)
}
remote_sha.bioc_xgit_remote <- function(remote, ...) {
url <- paste0(remote$mirror, "/", remote$repo)
ref <- remote$branch
refs <- git(paste("ls-remote", url, ref))
refs_df <- read.delim(text = refs, stringsAsFactors = FALSE, sep = "\t",
header = FALSE)
names(refs_df) <- c("sha", "ref")
refs_df$sha[[1]]
}
bioconductor_branch <- function(release, sha) {
if (!is.null(sha)) {
sha
} else {
if (is.null(release)) {
release <- "release"
}
if (release == "release") {
release <- bioconductor_release()
}
switch(
tolower(release),
devel = "master",
paste0("RELEASE_", gsub("\\.", "_", release))
)
}
}
bioconductor_release <- function() {
tmp <- tempfile()
download(tmp, download_url("bioconductor.org/config.yaml"), quiet = TRUE)
gsub("release_version:[[:space:]]+\"([[:digit:].]+)\"", "\\1",
grep("release_version:", readLines(tmp), value = TRUE))
}
#' @export
format.bioc_git2r_remote <- function(x, ...) {
"Bioc"
}
#' @export
format.bioc_xgit_remote <- function(x, ...) {
"Bioc"
}
# sha of most recent commit
git_repo_sha1 <- function(r) {
rev <- git2r::repository_head(r)
if (is.null(rev)) {
return(NULL)
}
if (git2r::is_commit(rev)) {
rev$sha
} else {
git2r::branch_target(rev)
}
}
#' Install a package directly from bitbucket
#'
#' This function is vectorised so you can install multiple packages in
#' a single command.
#'
#' @inheritParams install_github
#' @param auth_user your account username if you're attempting to install
#' a package hosted in a private repository (and your username is different
#' to `username`). Defaults to the `BITBUCKET_USER` environment
#' variable.
#' @param password your password. Defaults to the `BITBUCKET_PASSWORD`
#' environment variable. See details for further information on setting
#' up a password.
#' @param ref Desired git reference; could be a commit, tag, or branch name.
#' Defaults to master.
#' @seealso Bitbucket API docs:
#' <https://confluence.atlassian.com/bitbucket/use-the-bitbucket-cloud-rest-apis-222724129.html>
#'
#' @details To install from a private repo, or more generally, access the
#' Bitbucket API with your own credentials, you will need to get an access
#' token. You can create an access token following the instructions found in
#' the
#' \href{https://confluence.atlassian.com/bitbucket/app-passwords-828781300.html}{Bitbucket
#' App Passwords documentation}. The App Password requires read-only access to
#' your repositories and pull requests. Then store your password in the
#' environment variable `BITBUCKET_PASSWORD` (e.g. `evelynwaugh:swordofhonour`)
#'
#' Note that on Windows, authentication requires the "libcurl" download
#' method. You can set the default download method via the
#' `download.file.method` option:
#' ```
#' options(download.file.method = "libcurl")
#' ```
#' In particular, if unset, RStudio sets the download method to "wininet".
#' To override this, you might want to set it to "libcurl" in your
#' R profile, see [base::Startup]. The caveat of the "libcurl" method is
#' that it does _not_ set the system proxies automatically, see
#' "Setting Proxies" in [utils::download.file()].
#'
#' @inheritParams install_github
#' @family package installation
#' @export
#' @examples
#' \dontrun{
#' install_bitbucket("sulab/mygene.r@@default")
#' install_bitbucket("dannavarro/lsr-package")
#' }
install_bitbucket <- function(repo, ref = "master", subdir = NULL,
auth_user = bitbucket_user(), password = bitbucket_password(),
host = "api.bitbucket.org/2.0",
dependencies = NA,
upgrade = c("default", "ask", "always", "never"),
force = FALSE,
quiet = FALSE,
build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
repos = getOption("repos"),
type = getOption("pkgType"),
...) {
remotes <- lapply(repo, bitbucket_remote, ref = ref,
subdir = subdir, auth_user = auth_user, password = password, host = host)
install_remotes(remotes, auth_user = auth_user, password = password, host = host,
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
bitbucket_remote <- function(repo, ref = "master", subdir = NULL,
auth_user = NULL, password = NULL, sha = NULL,
host = NULL, ...) {
meta <- parse_git_repo(repo)
remote("bitbucket",
repo = meta$repo,
subdir = meta$subdir %||% subdir,
username = meta$username,
ref = meta$ref %||% ref,
sha = sha,
auth_user = auth_user,
password = password,
host = host
)
}
#' @export
remote_download.bitbucket_remote <- function(x, quiet = FALSE) {
if (!quiet) {
message("Downloading bitbucket repo ", x$username, "/", x$repo, "@", x$ref)
}
dest <- tempfile(fileext = paste0(".tar.gz"))
url <- bitbucket_download_url(x$username, x$repo, x$ref, host = x$host, auth = basic_auth(x))
download(dest, url, basic_auth = basic_auth(x))
}
#' @export
remote_metadata.bitbucket_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
if (!is.null(bundle)) {
# Might be able to get from archive
sha <- git_extract_sha1_tar(bundle)
} else if (is.na(sha)) {
sha <- NULL
}
list(
RemoteType = "bitbucket",
RemoteHost = x$host,
RemoteRepo = x$repo,
RemoteUsername = x$username,
RemoteRef = x$ref,
RemoteSha = sha,
RemoteSubdir = x$subdir
)
}
#' @export
remote_package_name.bitbucket_remote <- function(remote, ...) {
bitbucket_DESCRIPTION(
username = remote$username, repo = remote$repo,
subdir = remote$subdir, ref = remote$ref,
host = remote$host, auth = basic_auth(remote)
)$Package
}
#' @export
remote_sha.bitbucket_remote <- function(remote, ...) {
bitbucket_commit(username = remote$username, repo = remote$repo,
host = remote$host, ref = remote$ref, auth = basic_auth(remote))$sha %||% NA_character_
}
#' @export
format.bitbucket_remote <- function(x, ...) {
"Bitbucket"
}
bitbucket_commit <- function(username, repo, ref = "master",
host = "api.bitbucket.org/2.0", auth = NULL) {
url <- build_url(host, "repositories", username, repo, "commit", ref)
tmp <- tempfile()
download(tmp, url, basic_auth = auth)
fromJSONFile(tmp)
}
bitbucket_DESCRIPTION <- function(username, repo, subdir = NULL, ref = "master", host = "https://api.bitbucket.org/2.0", auth = NULL,...) {
url <- build_url(host, "repositories", username, repo, "src", ref, subdir, "DESCRIPTION")
tmp <- tempfile()
download(tmp, url, basic_auth = auth)
read_dcf(tmp)
}
basic_auth <- function(x) {
if (!is.null(x$password)) {
list(
user = x$auth_user %||% x$username,
password = x$password
)
} else {
NULL
}
}
bitbucket_download_url <- function(username, repo, ref = "master",
host = "api.bitbucket.org/2.0", auth = NULL) {
url <- build_url(host, "repositories", username, repo)
tmp <- tempfile()
download(tmp, url, basic_auth = auth)
paste0(build_url(fromJSONFile(tmp)$links$html$href, "get", ref), ".tar.gz")
}
bitbucket_password <- function(quiet = TRUE) {
pass <- Sys.getenv("BITBUCKET_PASSWORD")
if (identical(pass, "")) return(NULL)
if (!quiet) message("Using bitbucket password from envvar BITBUCKET_PASSWORD")
pass
}
bitbucket_user <- function(quiet = TRUE) {
user <- Sys.getenv("BITBUCKET_USER")
if (identical(user, "")) return(NULL)
if (!quiet) message("Using bitbucket user from envvar BITBUCKET_USER")
user
}
#' Attempts to install a package from CRAN.
#'
#' This function is vectorised on `pkgs` so you can install multiple
#' packages in a single command.
#'
#' @param pkgs Character vector of packages to install.
#' @inheritParams install_github
#' @export
#' @family package installation
#' @examples
#' \dontrun{
#' install_cran("ggplot2")
#' install_cran(c("httpuv", "shiny"))
#' }
install_cran <- function(pkgs, repos = getOption("repos"), type = getOption("pkgType"),
dependencies = NA,
upgrade = c("default", "ask", "always", "never"),
force = FALSE,
quiet = FALSE,
build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
...) {
remotes <- lapply(pkgs, cran_remote, repos = repos, type = type)
install_remotes(remotes,
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
cran_remote <- function(pkg, repos, type, ...) {
remote("cran",
name = pkg,
repos = repos,
pkg_type = type)
}
#' @export
remote_package_name.cran_remote <- function(remote, ...) {
remote$name
}
#' @export
remote_sha.cran_remote <- function(remote, ...) {
cran <- available_packages(remote$repos, remote$pkg_type)
trim_ws(unname(cran[, "Version"][match(remote$name, rownames(cran))]))
}
#' @export
format.cran_remote <- function(x, ...) {
"CRAN"
}
#' Install the development version of a package
#'
#' `install_dev()` retrieves the package DESCRIPTION from the CRAN mirror and
#' looks in the 'URL' and 'BugReports' fields for GitHub, GitLab or Bitbucket
#' URLs. It then calls the appropriate `install_()` function to install the
#' development package.
#'
#' @param package The package name to install.
#' @param cran_url The URL of the CRAN mirror to use, by default based on the
#' 'repos' option. If unset uses 'https://cloud.r-project.org'.
#' @param ... Additional arguments passed to [install_github()],
#' [install_gitlab()], or [install_bitbucket()] functions.
#' @family package installation
#' @export
#' @examples
#' \dontrun{
#' # From GitHub
#' install_dev("dplyr")
#'
#' # From GitLab
#' install_dev("iemiscdata")
#'
#' # From Bitbucket
#' install_dev("argparser")
#' }
install_dev <- function(package, cran_url = getOption("repos")[["CRAN"]], ...) {
if (is.null(cran_url) || identical(cran_url, "@CRAN@")) {
cran_url <- "https://cloud.r-project.org"
}
url <- build_url(cran_url, "web", "packages", package, "DESCRIPTION")
f <- tempfile()
on.exit(unlink(f))
download(f, url)
desc <- read_dcf(f)
url_fields <- c(desc$URL, desc$BugReports)
if (length(url_fields) == 0) {
stop("Could not determine development repository", call. = FALSE)
}
pkg_urls <- unlist(strsplit(url_fields, "[[:space:]]*,[[:space:]]*"))
# Remove trailing "/issues" from the BugReports URL
pkg_urls <- sub("/issues$", "", pkg_urls)
valid_domains <- c("github[.]com", "gitlab[.]com", "bitbucket[.]org")
parts <-
re_match(pkg_urls,
sprintf("^https?://(?<domain>%s)/(?<username>%s)/(?<repo>%s)(?:/(?<subdir>%s))?",
domain = paste0(valid_domains, collapse = "|"),
username = "[^/]+",
repo = "[^/@#]+",
subdir = "[^/@$ ]+"
)
)[c("domain", "username", "repo", "subdir")]
# Remove cases which don't match and duplicates
parts <- unique(stats::na.omit(parts))
if (nrow(parts) != 1) {
stop("Could not determine development repository", call. = FALSE)
}
ref <- paste0(c(parts$username, parts$repo, if (nzchar(parts$subdir)) parts$subdir), collapse = "/")
switch(parts$domain,
github.com = install_github(ref, ...),
gitlab.com = install_gitlab(ref, ...),
bitbucket.org = install_bitbucket(ref, ...)
)
}
#' Install a package from a git repository
#'
#' It is vectorised so you can install multiple packages with
#' a single command. You do not need to have the `git2r` package,
#' or an external git client installed.
#'
#' @param url Location of package. The url should point to a public or
#' private repository.
#' @param ref Name of branch, tag or SHA reference to use, if not HEAD.
#' @param branch Deprecated, synonym for ref.
#' @param subdir A sub-directory within a git repository that may
#' contain the package we are interested in installing.
#' @param credentials A git2r credentials object passed through to clone.
#' Supplying this argument implies using `git2r` with `git`.
#' @param git Whether to use the `git2r` package, or an external
#' git client via system. Default is `git2r` if it is installed,
#' otherwise an external git installation.
#' @param ... Other arguments passed on to [utils::install.packages()].
#' @inheritParams install_github
#' @family package installation
#' @export
#' @examples
#' \dontrun{
#' install_git("git://github.com/hadley/stringr.git")
#' install_git("git://github.com/hadley/stringr.git", ref = "stringr-0.2")
#'}
install_git <- function(url, subdir = NULL, ref = NULL, branch = NULL,
credentials = NULL,
git = c("auto", "git2r", "external"),
dependencies = NA,
upgrade = c("default", "ask", "always", "never"),
force = FALSE,
quiet = FALSE,
build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
repos = getOption("repos"),
type = getOption("pkgType"),
...) {
if (!missing(branch)) {
warning("`branch` is deprecated, please use `ref`")
ref <- branch
}
remotes <- lapply(url, git_remote, subdir = subdir, ref = ref,
credentials = credentials, git = match.arg(git))
install_remotes(remotes, credentials = credentials,
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
git_remote <- function(url, subdir = NULL, ref = NULL, credentials = NULL,
git = c("auto", "git2r", "external"), ...) {
git <- match.arg(git)
if (git == "auto") {
git <- if (!is_standalone() && pkg_installed("git2r")) "git2r" else "external"
}
if (!is.null(credentials) && git != "git2r") {
stop("`credentials` can only be used with `git = \"git2r\"`", call. = FALSE)
}
list(git2r = git_remote_git2r, external = git_remote_xgit)[[git]](url, subdir, ref, credentials)
}
git_remote_git2r <- function(url, subdir = NULL, ref = NULL, credentials = NULL) {
remote("git2r",
url = url,
subdir = subdir,
ref = ref,
credentials = credentials
)
}
git_remote_xgit <- function(url, subdir = NULL, ref = NULL, credentials = NULL) {
remote("xgit",
url = url,
subdir = subdir,
ref = ref
)
}
#' @export
remote_download.git2r_remote <- function(x, quiet = FALSE) {
if (!quiet) {
message("Downloading git repo ", x$url)
}
bundle <- tempfile()
git2r::clone(x$url, bundle, credentials = x$credentials, progress = FALSE)
if (!is.null(x$ref)) {
r <- git2r::repository(bundle)
git2r::checkout(r, x$ref)
}
bundle
}
#' @export
remote_metadata.git2r_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
if (!is.null(bundle)) {
r <- git2r::repository(bundle)
sha <- git2r::commits(r)[[1]]$sha
} else {
sha <- NULL
}
list(
RemoteType = "git2r",
RemoteUrl = x$url,
RemoteSubdir = x$subdir,
RemoteRef = x$ref,
RemoteSha = sha
)
}
#' @export
remote_package_name.git2r_remote <- function(remote, ...) {
tmp <- tempfile()
on.exit(unlink(tmp))
description_path <- paste0(collapse = "/", c(remote$subdir, "DESCRIPTION"))
# Try using git archive --remote to retrieve the DESCRIPTION, if the protocol
# or server doesn't support that return NA
res <- try(silent = TRUE,
system_check(git_path(),
args = c("archive", "-o", tmp, "--remote", remote$url,
if (is.null(remote$ref)) "HEAD" else remote$ref,
description_path),
quiet = TRUE))
if (inherits(res, "try-error")) {
return(NA_character_)
}
# git archive returns a tar file, so extract it to tempdir and read the DCF
utils::untar(tmp, files = description_path, exdir = tempdir())
read_dcf(file.path(tempdir(), description_path))$Package
}
#' @export
remote_sha.git2r_remote <- function(remote, ...) {
tryCatch({
# set suppressWarnings in git2r 0.23.0+
res <- suppressWarnings(git2r::remote_ls(remote$url, credentials=remote$credentials))
# This needs to be master, not HEAD because no ref is called HEAD
ref <- remote$ref %||% "master"
found <- grep(pattern = paste0("/", ref), x = names(res))
# If none found, it is either a SHA, so return the pinned sha or NA
if (length(found) == 0) {
return(remote$ref %||% NA_character_)
}
unname(res[found[1]])
}, error = function(e) { warning(e); NA_character_})
}
#' @export
format.xgit_remote <- function(x, ...) {
"Git"
}
#' @export
format.git2r_remote <- function(x, ...) {
"Git"
}
#' @export
remote_download.xgit_remote <- function(x, quiet = FALSE) {
if (!quiet) {
message("Downloading git repo ", x$url)
}
bundle <- tempfile()
args <- c('clone', '--depth', '1', '--no-hardlinks')
if (!is.null(x$ref)) args <- c(args, "--branch", x$ref)
args <- c(args, x$args, x$url, bundle)
git(paste0(args, collapse = " "), quiet = quiet)
bundle
}
#' @export
remote_metadata.xgit_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
if (is_na(sha)) {
sha <- NULL
}
list(
RemoteType = "xgit",
RemoteUrl = x$url,
RemoteSubdir = x$subdir,
RemoteRef = x$ref,
RemoteSha = sha,
RemoteArgs = if (length(x$args) > 0) paste0(deparse(x$args), collapse = " ")
)
}
#' @importFrom utils read.delim
#' @export
remote_package_name.xgit_remote <- remote_package_name.git2r_remote
#' @export
remote_sha.xgit_remote <- function(remote, ...) {
url <- remote$url
ref <- remote$ref
refs <- git(paste("ls-remote", url, ref))
refs_df <- read.delim(text = refs, stringsAsFactors = FALSE, sep = "\t",
header = FALSE)
names(refs_df) <- c("sha", "ref")
refs_df$sha[[1]]
}
#' Attempts to install a package directly from GitHub.
#'
#' This function is vectorised on `repo` so you can install multiple
#' packages in a single command.
#'
#' @param repo Repository address in the format
#' `username/repo[/subdir][@@ref|#pull]`. Alternatively, you can
#' specify `subdir` and/or `ref` using the respective parameters
#' (see below); if both is specified, the values in `repo` take
#' precedence.
#' @param ref Desired git reference. Could be a commit, tag, or branch
#' name, or a call to [github_pull()]. Defaults to `"master"`.
#' @param subdir subdirectory within repo that contains the R package.
#' @param auth_token To install from a private repo, generate a personal
#' access token (PAT) in <https://github.com/settings/applications> and
#' supply to this argument. This is safer than using a password because
#' you can easily delete a PAT without affecting any others. Defaults to
#' the `GITHUB_PAT` environment variable.
#' @param host GitHub API host to use. Override with your GitHub enterprise
#' hostname, for example, `"github.hostname.com/api/v3"`.
#' @param force Force installation, even if the remote state has not changed
#' since the previous install.
#' @inheritParams install_deps
#' @param ... Other arguments passed on to [utils::install.packages()].
#' @details
#' If the repository uses submodules a command-line git client is required to
#' clone the submodules.
#' @family package installation
#' @export
#' @seealso [github_pull()]
#' @examples
#' \dontrun{
#' install_github("klutometis/roxygen")
#' install_github("wch/ggplot2")
#' install_github(c("rstudio/httpuv", "rstudio/shiny"))
#' install_github(c("hadley/httr@@v0.4", "klutometis/roxygen#142",
#' "mfrasca/r-logging/pkg"))
#'
#' # To install from a private repo, use auth_token with a token
#' # from https://github.com/settings/applications. You only need the
#' # repo scope. Best practice is to save your PAT in env var called
#' # GITHUB_PAT.
#' install_github("hadley/private", auth_token = "abc")
#'
#' }
install_github <- function(repo,
ref = "master",
subdir = NULL,
auth_token = github_pat(),
host = "api.github.com",
dependencies = NA,
upgrade = c("default", "ask", "always", "never"),
force = FALSE,
quiet = FALSE,
build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
repos = getOption("repos"),
type = getOption("pkgType"),
...) {
remotes <- lapply(repo, github_remote, ref = ref,
subdir = subdir, auth_token = auth_token, host = host)
install_remotes(remotes, auth_token = auth_token, host = host,
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
github_remote <- function(repo, ref = "master", subdir = NULL,
auth_token = github_pat(), sha = NULL,
host = "api.github.com", ...) {
meta <- parse_git_repo(repo)
meta <- github_resolve_ref(meta$ref %||% ref, meta, auth_token)
remote("github",
host = host,
package = meta$package,
repo = meta$repo,
subdir = meta$subdir %||% subdir,
username = meta$username,
ref = meta$ref,
sha = sha,
auth_token = auth_token
)
}
#' @export
remote_download.github_remote <- function(x, quiet = FALSE) {
if (!quiet) {
message("Downloading GitHub repo ", x$username, "/", x$repo, "@", x$ref)
}
dest <- tempfile(fileext = paste0(".tar.gz"))
src_root <- build_url(x$host, "repos", x$username, x$repo)
src <- paste0(src_root, "/tarball/", utils::URLencode(x$ref, reserved = TRUE))
download(dest, src, auth_token = x$auth_token)
}
#' @export
remote_metadata.github_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
if (!is.null(bundle)) {
# Might be able to get from archive
sha <- git_extract_sha1_tar(bundle)
} else if (is_na(sha)) {
sha <- NULL
}
list(
RemoteType = "github",
RemoteHost = x$host,
RemotePackage = x$package,
RemoteRepo = x$repo,
RemoteUsername = x$username,
RemoteRef = x$ref,
RemoteSha = sha,
RemoteSubdir = x$subdir,
# Backward compatibility for packrat etc.
GithubRepo = x$repo,
GithubUsername = x$username,
GithubRef = x$ref,
GithubSHA1 = sha,
GithubSubdir = x$subdir
)
}
#' GitHub references
#'
#' Use as `ref` parameter to [install_github()].
#' Allows installing a specific pull request or the latest release.
#'
#' @param pull The pull request to install
#' @seealso [install_github()]
#' @rdname github_refs
#' @export
github_pull <- function(pull) structure(pull, class = "github_pull")
#' @rdname github_refs
#' @export
github_release <- function() structure(NA_integer_, class = "github_release")
github_resolve_ref <- function(x, params, ...) UseMethod("github_resolve_ref")
#' @export
github_resolve_ref.default <- function(x, params, ...) {
params$ref <- x
params
}
#' @export
github_resolve_ref.NULL <- function(x, params, ...) {
params$ref <- "master"
params
}
#' @export
github_resolve_ref.github_pull <- function(x, params, ..., auth_token = github_pat()) {
# GET /repos/:user/:repo/pulls/:number
path <- file.path("repos", params$username, params$repo, "pulls", x)
response <- tryCatch(
github_GET(path, pat = auth_token),
error = function(e) e
)
## Just because libcurl might download the error page...
if (methods::is(response, "error") || is.null(response$head)) {
stop("Cannot find GitHub pull request ", params$username, "/",
params$repo, "#", x, "\n",
response$message)
}
params$username <- response$head$user$login
params$ref <- response$head$ref
params
}
# Retrieve the ref for the latest release
#' @export
github_resolve_ref.github_release <- function(x, params, ..., auth_token = github_pat()) {
# GET /repos/:user/:repo/releases
path <- paste("repos", params$username, params$repo, "releases", sep = "/")
response <- tryCatch(
github_GET(path, pat = auth_token),
error = function(e) e
)
if (methods::is(response, "error") || !is.null(response$message)) {
stop("Cannot find repo ", params$username, "/", params$repo, ".", "\n",
response$message)
}
if (length(response) == 0L)
stop("No releases found for repo ", params$username, "/", params$repo, ".")
params$ref <- response[[1L]]$tag_name
params
}
#' @export
remote_package_name.github_remote <- function(remote, ..., use_local = TRUE,
use_curl = !is_standalone() && pkg_installed("curl")) {
# If the package name was explicitly specified, use that
if (!is.null(remote$package)) {
return(remote$package)
}
# Otherwise if the repo is an already installed package assume that.
if (isTRUE(use_local)) {
local_name <- suppressWarnings(utils::packageDescription(remote$repo, fields = "Package"))
if (!is.na(local_name)) {
return(local_name)
}
}
# Otherwise lookup the package name from the remote DESCRIPTION file
desc <- github_DESCRIPTION(username = remote$username, repo = remote$repo,
subdir = remote$subdir, host = remote$host, ref = remote$ref,
pat = remote$auth_token %||% github_pat(), use_curl = use_curl)
if (is.null(desc)) {
return(NA_character_)
}
tmp <- tempfile()
writeChar(desc, tmp)
on.exit(unlink(tmp))
read_dcf(tmp)$Package
}
#' @export
remote_sha.github_remote <- function(remote, ..., use_curl = !is_standalone() && pkg_installed("curl")) {
github_commit(username = remote$username, repo = remote$repo,
host = remote$host, ref = remote$ref, pat = remote$auth_token %||% github_pat(), use_curl = use_curl)
}
#' @export
format.github_remote <- function(x, ...) {
"GitHub"
}
#' Install a package from GitLab
#'
#' This function is vectorised on `repo` so you can install multiple
#' packages in a single command. Like other remotes the repository will skip
#' installation if `force == FALSE` (the default) and the remote state has
#' not changed since the previous installation.
#'
#' @inheritParams install_github
#' @param repo Repository address in the format
#' `username/repo[/subdir][@@ref]`.
#' @param host GitLab API host to use. Override with your GitLab enterprise
#' hostname, for example, `"gitlab.hostname.com"`.
#' @inheritParams install_github
#' @export
#' @family package installation
#' @examples
#' \dontrun{
#' install_gitlab("jimhester/covr")
#' }
install_gitlab <- function(repo,
auth_token = gitlab_pat(),
host = "gitlab.com",
dependencies = NA,
upgrade = c("default", "ask", "always", "never"),
force = FALSE,
quiet = FALSE,
build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
repos = getOption("repos"),
type = getOption("pkgType"),
...) {
remotes <- lapply(repo, gitlab_remote, auth_token = auth_token, host = host)
install_remotes(remotes, auth_token = auth_token, host = host,
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
gitlab_remote <- function(repo,
auth_token = gitlab_pat(), sha = NULL,
host = "gitlab.com", ...) {
meta <- parse_git_repo(repo)
meta$ref <- meta$ref %||% "master"
remote("gitlab",
host = host,
repo = meta$repo,
subdir = meta$subdir,
username = meta$username,
ref = meta$ref,
sha = sha,
auth_token = auth_token
)
}
#' @export
remote_download.gitlab_remote <- function(x, quiet = FALSE) {
dest <- tempfile(fileext = paste0(".tar.gz"))
src_root <- build_url(x$host, x$username, x$repo)
src <- paste0(src_root, "/repository/archive.tar.gz?ref=", utils::URLencode(x$ref, reserved = TRUE))
if (!quiet) {
message("Downloading GitLab repo ", x$username, "/", x$repo, "@", x$ref,
"\nfrom URL ", src)
}
download(dest, src, auth_token = x$auth_token, auth_phrase = "private_token=")
}
#' @export
remote_metadata.gitlab_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
if (!is.null(bundle)) {
# Might be able to get from archive
sha <- git_extract_sha1_tar(bundle)
} else if (is_na(sha)) {
sha <- NULL
}
list(
RemoteType = "gitlab",
RemoteHost = x$host,
RemoteRepo = x$repo,
RemoteUsername = x$username,
RemoteRef = x$ref,
RemoteSha = sha,
RemoteSubdir = x$subdir
)
}
#' @export
remote_package_name.gitlab_remote <- function(remote, ...) {
tmp <- tempfile()
src <- build_url(
remote$host, remote$username, remote$repo, "raw",
remote$ref, remote$subdir, "DESCRIPTION")
dest <- tempfile()
res <- download(dest, src, auth_token = remote$auth_token, auth_phrase = "private_token=")
tryCatch(
read_dcf(dest)$Package,
error = function(e) NA_character_)
}
#' @export
remote_sha.gitlab_remote <- function(remote, ...) {
gitlab_commit(username = remote$username, repo = remote$repo,
host = remote$host, ref = remote$ref, pat = remote$auth_token)
}
#' @export
format.gitlab_remote <- function(x, ...) {
"GitLab"
}
gitlab_commit <- function(username, repo, ref = "master",
host = "gitlab.com", pat = gitlab_pat()) {
url <- build_url(host, "api", "v4", "projects", utils::URLencode(paste0(username, "/", repo), reserved = TRUE), "repository", "commits", ref)
tmp <- tempfile()
download(tmp, url, auth_token = pat, auth_phrase = "private_token=")
fromJSONFile(tmp)$id
}
#' Retrieve GitLab personal access token.
#'
#' A GitLab personal access token
#' Looks in env var `GITLAB_PAT`
#'
#' @keywords internal
#' @export
gitlab_pat <- function(quiet = TRUE) {
pat <- Sys.getenv("GITLAB_PAT")
if (nzchar(pat)) {
if (!quiet) {
message("Using GitLab PAT from envvar GITLAB_PAT")
}
return(pat)
}
return(NULL)
}
#' Install a package from a local file
#'
#' This function is vectorised so you can install multiple packages in
#' a single command.
#'
#' @param path path to local directory, or compressed file (tar, zip, tar.gz
#' tar.bz2, tgz2 or tbz)
#' @inheritParams install_url
#' @inheritParams install_github
#' @export
#' @family package installation
#' @examples
#' \dontrun{
#' dir <- tempfile()
#' dir.create(dir)
#' pkg <- download.packages("testthat", dir, type = "source")
#' install_local(pkg[, 2])
#' }
install_local <- function(path = ".", subdir = NULL,
dependencies = NA,
upgrade = c("default", "ask", "always", "never"),
force = FALSE,
quiet = FALSE,
build = !is_binary_pkg(path),
build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
repos = getOption("repos"),
type = getOption("pkgType"),
...) {
remotes <- lapply(path, local_remote, subdir = subdir)
install_remotes(remotes,
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
local_remote <- function(path, subdir = NULL, branch = NULL, args = character(0), ...) {
remote("local",
path = normalizePath(path),
subdir = subdir
)
}
#' @export
remote_download.local_remote <- function(x, quiet = FALSE) {
# Already downloaded - just need to copy to tempdir()
bundle <- tempfile()
dir.create(bundle)
file.copy(x$path, bundle, recursive = TRUE)
# file.copy() creates directory inside of bundle
dir(bundle, full.names = TRUE)[1]
}
#' @export
remote_metadata.local_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
list(
RemoteType = "local",
RemoteUrl = x$path,
RemoteSubdir = x$subdir
)
}
#' @export
remote_package_name.local_remote <- function(remote, ...) {
is_tarball <- !dir.exists(remote$path)
if (is_tarball) {
# Assume the name is the name of the tarball
return(sub("_.*$", "", basename(remote$path)))
}
description_path <- file.path(remote$path, "DESCRIPTION")
read_dcf(description_path)$Package
}
#' @export
remote_sha.local_remote <- function(remote, ...) {
is_tarball <- !dir.exists(remote$path)
if (is_tarball) {
return(NA_character_)
}
read_dcf(file.path(remote$path, "DESCRIPTION"))$Version
}
#' @export
format.local_remote <- function(x, ...) {
"local"
}
#' Install a remote package.
#'
#' This:
#' \enumerate{
#' \item downloads source bundle
#' \item decompresses & checks that it's a package
#' \item adds metadata to DESCRIPTION
#' \item calls install
#' }
#' @noRd
install_remote <- function(remote,
dependencies,
upgrade,
force,
quiet,
build,
build_opts,
repos,
type,
...) {
stopifnot(is.remote(remote))
package_name <- remote_package_name(remote)
local_sha <- local_sha(package_name)
remote_sha <- remote_sha(remote, local_sha)
if (!isTRUE(force) &&
!different_sha(remote_sha = remote_sha, local_sha = local_sha)) {
if (!quiet) {
message(
"Skipping install of '", package_name, "' from a ", sub("_remote", "", class(remote)[1L]), " remote,",
" the SHA1 (", substr(remote_sha, 1L, 8L), ") has not changed since last install.\n",
" Use `force = TRUE` to force installation")
}
return(invisible(package_name))
}
if (inherits(remote, "cran_remote")) {
install_packages(
package_name, repos = remote$repos, type = remote$pkg_type,
dependencies = dependencies,
quiet = quiet,
...)
return(invisible(package_name))
}
bundle <- remote_download(remote, quiet = quiet)
on.exit(unlink(bundle), add = TRUE)
source <- source_pkg(bundle, subdir = remote$subdir)
on.exit(unlink(source, recursive = TRUE), add = TRUE)
update_submodules(source, quiet)
add_metadata(source, remote_metadata(remote, bundle, source, remote_sha))
# Because we've modified DESCRIPTION, its original MD5 value is wrong
clear_description_md5(source)
install(source,
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
install_remotes <- function(remotes, ...) {
invisible(vapply(remotes, install_remote, ..., FUN.VALUE = character(1)))
}
# Add metadata
add_metadata <- function(pkg_path, meta) {
# During installation, the DESCRIPTION file is read and an package.rds file
# created with most of the information from the DESCRIPTION file. Functions
# that read package metadata may use either the DESCRIPTION file or the
# package.rds file, therefore we attempt to modify both of them
source_desc <- file.path(pkg_path, "DESCRIPTION")
binary_desc <- file.path(pkg_path, "Meta", "package.rds")
if (file.exists(source_desc)) {
desc <- read_dcf(source_desc)
desc <- utils::modifyList(desc, meta)
write_dcf(source_desc, desc)
}
if (file.exists(binary_desc)) {
pkg_desc <- base::readRDS(binary_desc)
desc <- as.list(pkg_desc$DESCRIPTION)
desc <- utils::modifyList(desc, meta)
pkg_desc$DESCRIPTION <- stats::setNames(as.character(desc), names(desc))
base::saveRDS(pkg_desc, binary_desc)
}
}
# Modify the MD5 file - remove the line for DESCRIPTION
clear_description_md5 <- function(pkg_path) {
path <- file.path(pkg_path, "MD5")
if (file.exists(path)) {
text <- readLines(path)
text <- text[!grepl(".*\\*DESCRIPTION$", text)]
writeLines(text, path)
}
}
remote <- function(type, ...) {
structure(list(...), class = c(paste0(type, "_remote"), "remote"))
}
is.remote <- function(x) inherits(x, "remote")
remote_download <- function(x, quiet = FALSE) UseMethod("remote_download")
remote_metadata <- function(x, bundle = NULL, source = NULL, sha = NULL) UseMethod("remote_metadata")
remote_package_name <- function(remote, ...) UseMethod("remote_package_name")
remote_sha <- function(remote, ...) UseMethod("remote_sha")
remote_package_name.default <- function(remote, ...) remote$repo
remote_sha.default <- function(remote, ...) NA_character_
different_sha <- function(remote_sha, local_sha) {
same <- remote_sha == local_sha
same <- isTRUE(same) && !is.na(same)
!same
}
local_sha <- function(name) {
package2remote(name)$sha %||% NA_character_
}
# Convert an installed package to its equivalent remote. This constructs the
# remote from metadata stored in the package's DESCRIPTION file; the metadata
# is added to the package when it is installed by remotes. If the package is
# installed some other way, such as by `install.packages()` there will be no
# meta-data, so there we construct a generic CRAN remote.
package2remote <- function(name, lib = .libPaths(), repos = getOption("repos"), type = getOption("pkgType")) {
x <- tryCatch(utils::packageDescription(name, lib.loc = lib), error = function(e) NA, warning = function(e) NA)
# will be NA if not installed
if (identical(x, NA)) {
return(remote("cran",
name = name,
repos = repos,
pkg_type = type,
sha = NA_character_))
}
if (is.null(x$RemoteType) || x$RemoteType == "cran") {
# Packages installed with install.packages() or locally without remotes
return(remote("cran",
name = x$Package,
repos = repos,
pkg_type = type,
sha = x$Version))
}
switch(x$RemoteType,
github = remote("github",
host = x$RemoteHost,
package = x$RemotePackage,
repo = x$RemoteRepo,
subdir = x$RemoteSubdir,
username = x$RemoteUsername,
ref = x$RemoteRef,
sha = x$RemoteSha,
auth_token = github_pat()),
gitlab = remote("gitlab",
host = x$RemoteHost,
repo = x$RemoteRepo,
subdir = x$RemoteSubdir,
username = x$RemoteUsername,
ref = x$RemoteRef,
sha = x$RemoteSha,
auth_token = gitlab_pat()),
xgit = remote("xgit",
url = trim_ws(x$RemoteUrl),
ref = x$RemoteRef %||% x$RemoteBranch,
sha = x$RemoteSha,
subdir = x$RemoteSubdir,
args = x$RemoteArgs),
git2r = remote("git2r",
url = trim_ws(x$RemoteUrl),
ref = x$RemoteRef %||% x$RemoteBranch,
sha = x$RemoteSha,
subdir = x$RemoteSubdir),
bitbucket = remote("bitbucket",
host = x$RemoteHost,
repo = x$RemoteRepo,
username = x$RemoteUsername,
ref = x$RemoteRef,
sha = x$RemoteSha,
subdir = x$RemoteSubdir,
auth_user = bitbucket_user(),
password = bitbucket_password()),
svn = remote("svn",
url = trim_ws(x$RemoteUrl),
svn_subdir = x$RemoteSubdir,
revision = x$RemoteSha,
args = x$RemoteArgs),
local = remote("local",
path = trim_ws(x$RemoteUrl),
subdir = x$RemoteSubdir,
sha = {
# Packages installed locally might have RemoteSha == NA_character_
x$RemoteSha %||% x$Version
}),
url = remote("url",
url = trim_ws(x$RemoteUrl),
subdir = x$RemoteSubdir,
config = x$RemoteConfig,
pkg_type = x$RemotePkgType),
bioc_git2r = remote("bioc_git2r",
mirror = x$RemoteMirror,
repo = x$RemoteRepo,
release = x$RemoteRelease,
sha = x$RemoteSha,
branch = x$RemoteBranch),
bioc_xgit = remote("bioc_xgit",
mirror = x$RemoteMirror,
repo = x$RemoteRepo,
release = x$RemoteRelease,
sha = x$RemoteSha,
branch = x$RemoteBranch)
)
}
#' @export
format.remotes <- function(x, ...) {
vapply(x, format, character(1))
}
#' Install a package from a SVN repository
#'
#' This function requires \command{svn} to be installed on your system in order to
#' be used.
#'
#' It is vectorised so you can install multiple packages with
#' a single command.
#'
#' @inheritParams install_git
#' @param subdir A sub-directory withing a svn repository that contains the
#' package we are interested in installing.
#' @param args A character vector providing extra options to pass on to
#' \command{svn}.
#' @param revision svn revision, if omitted updates to latest
#' @param ... Other arguments passed on to [utils::install.packages()].
#' @inheritParams install_github
#' @family package installation
#' @export
#'
#' @examples
#' \dontrun{
#' install_svn("https://github.com/hadley/stringr/trunk")
#' install_svn("https://github.com/hadley/httr/branches/oauth")
#'}
install_svn <- function(url, subdir = NULL, args = character(0),
revision = NULL,
dependencies = NA,
upgrade = c("default", "ask", "always", "never"),
force = FALSE,
quiet = FALSE,
build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
repos = getOption("repos"),
type = getOption("pkgType"),
...) {
remotes <- lapply(url, svn_remote, svn_subdir = subdir,
revision = revision, args = args)
install_remotes(remotes, args = args,
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
svn_remote <- function(url, svn_subdir = NULL, revision = NULL,
args = character(0), ...) {
remote("svn",
url = url,
svn_subdir = svn_subdir,
revision = revision,
args = args
)
}
#' @export
remote_download.svn_remote <- function(x, quiet = FALSE) {
if (!quiet) {
message("Downloading svn repo ", x$url)
}
bundle <- tempfile()
svn_binary_path <- svn_path()
url <- x$url
args <- "co"
if (!is.null(x$revision)) {
args <- c(args, "-r", x$revision)
}
args <- c(args, x$args, full_svn_url(x), bundle)
if (!quiet) { message(shQuote(svn_binary_path), " ", paste0(args, collapse = " ")) }
request <- system2(svn_binary_path, args, stdout = FALSE, stderr = FALSE)
# This is only looking for an error code above 0-success
if (request > 0) {
stop("There seems to be a problem retrieving this SVN-URL.", call. = FALSE)
}
in_dir(bundle, {
if (!is.null(x$revision)) {
request <- system2(svn_binary_path, paste("update -r", x$revision), stdout = FALSE, stderr = FALSE)
if (request > 0) {
stop("There was a problem switching to the requested SVN revision", call. = FALSE)
}
}
})
bundle
}
#' @export
remote_metadata.svn_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
if (!is.null(bundle)) {
in_dir(bundle, {
revision <- svn_revision()
})
} else {
revision <- sha
}
list(
RemoteType = "svn",
RemoteUrl = x$url,
RemoteSubdir = x$svn_subdir,
RemoteArgs = if (length(x$args) > 0) paste0(deparse(x$args), collapse = " "),
RemoteSha = revision # for compatibility with other remotes
)
}
svn_path <- function(svn_binary_name = NULL) {
# Use user supplied path
if (!is.null(svn_binary_name)) {
if (!file.exists(svn_binary_name)) {
stop("Path ", svn_binary_name, " does not exist", .call = FALSE)
}
return(svn_binary_name)
}
# Look on path
svn_path <- Sys.which("svn")[[1]]
if (svn_path != "") return(svn_path)
# On Windows, look in common locations
if (os_type() == "windows") {
look_in <- c(
"C:/Program Files/Svn/bin/svn.exe",
"C:/Program Files (x86)/Svn/bin/svn.exe"
)
found <- file.exists(look_in)
if (any(found)) return(look_in[found][1])
}
stop("SVN does not seem to be installed on your system.", call. = FALSE)
}
#' @export
remote_package_name.svn_remote <- function(remote, ...) {
description_url <- file.path(full_svn_url(remote), "DESCRIPTION")
tmp_file <- tempfile()
on.exit(rm(tmp_file))
response <- system2(svn_path(), paste("cat", description_url), stdout = tmp_file)
if (!identical(response, 0L)) {
return(NA_character_)
}
read_dcf(tmp_file)$Package
}
#' @export
remote_sha.svn_remote <- function(remote, ...) {
svn_revision(full_svn_url(remote))
}
svn_revision <- function(url = NULL, svn_binary_path = svn_path()) {
request <- system2(svn_binary_path, paste("info --xml", url), stdout = TRUE)
if (!is.null(attr(request, "status")) && !identical(attr(request, "status"), 0L)) {
stop("There was a problem retrieving the current SVN revision", call. = FALSE)
}
gsub(".*<commit[[:space:]]+revision=\"([[:digit:]]+)\">.*", "\\1", paste(collapse = "\n", request))
}
full_svn_url <- function(x) {
url <- x$url
if (!is.null(x$svn_subdir)) {
url <- file.path(url, x$svn_subdir)
}
url
}
format.svn_remote <- function(x, ...) {
"SVN"
}
#' Install a package from a url
#'
#' This function is vectorised so you can install multiple packages in
#' a single command.
#'
#' @param url location of package on internet. The url should point to a
#' zip file, a tar file or a bzipped/gzipped tar file.
#' @param subdir subdirectory within url bundle that contains the R package.
#' @param ... Other arguments passed on to [utils::install.packages()].
#' @inheritParams install_github
#' @export
#'
#' @family package installation
#' @examples
#' \dontrun{
#' install_url("https://github.com/hadley/stringr/archive/master.zip")
#' }
install_url <- function(url, subdir = NULL,
dependencies = NA,
upgrade = c("default", "ask", "always", "never"),
force = FALSE,
quiet = FALSE,
build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
repos = getOption("repos"),
type = getOption("pkgType"),
...) {
remotes <- lapply(url, url_remote, subdir = subdir)
install_remotes(remotes,
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
url_remote <- function(url, subdir = NULL, ...) {
remote("url",
url = url,
subdir = subdir
)
}
#' @importFrom tools file_ext
#' @export
remote_download.url_remote <- function(x, quiet = FALSE) {
if (!quiet) {
message("Downloading package from url: ", x$url) # nocov
}
ext <- if (grepl("\\.tar\\.gz$", x$url)) "tar.gz" else file_ext(x$url)
bundle <- tempfile(fileext = paste0(".", ext))
download(bundle, x$url)
}
#' @export
remote_metadata.url_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
list(
RemoteType = "url",
RemoteUrl = x$url,
RemoteSubdir = x$subdir
)
}
#' @export
remote_package_name.url_remote <- function(remote, ...) {
NA_character_
}
#' @export
remote_sha.url_remote <- function(remote, ...) {
NA_character_
}
#' @export
format.url_remote <- function(x, ...) {
"URL"
}
#' Install specified version of a CRAN package.
#'
#' If you are installing an package that contains compiled code, you will
#' need to have an R development environment installed. You can check
#' if you do by running `devtools::has_devel` (you need the
#' `devtools` package for this).
#'
#' @export
#' @family package installation
#' @param package package name
#' @param version If the specified version is NULL or the same as the most
#' recent version of the package, this function simply calls
#' [utils::install.packages()]. Otherwise, it looks at the list of
#' archived source tarballs and tries to install an older version instead.
#' @param ... Other arguments passed on to [utils::install.packages()].
#' @inheritParams utils::install.packages
#' @inheritParams install_github
#' @author Jeremy Stephens
#' @importFrom utils available.packages contrib.url install.packages
install_version <- function(package, version = NULL,
dependencies = NA,
upgrade = c("default", "ask", "always", "never"),
force = FALSE,
quiet = FALSE,
build = FALSE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
repos = getOption("repos"),
type = getOption("pkgType"),
...) {
url <- download_version_url(package, version, repos, type)
res <- install_url(url,
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
lib <- list(...)$lib
# Remove Metadata from installed package
add_metadata(
system.file(package = package, lib.loc = lib),
list(RemoteType = NULL, RemoteUrl = NULL, RemoteSubdir = NULL))
invisible(res)
}
package_find_repo <- function(package, repos) {
for (repo in repos) {
if (length(repos) > 1)
message("Trying ", repo)
archive <-
tryCatch({
con <- gzcon(url(sprintf("%s/src/contrib/Meta/archive.rds", repo), "rb"))
on.exit(close(con))
readRDS(con)
},
warning = function(e) list(),
error = function(e) list())
info <- archive[[package]]
if (!is.null(info)) {
info$repo <- repo
return(info)
}
}
stop(sprintf("couldn't find package '%s'", package))
}
#' Download a specified version of a CRAN package
#'
#' It downloads the package to a temporary file, and
#' returns the name of the file.
#'
#' @inheritParams install_version
#' @return Name of the downloaded file.
#'
#' @export
download_version <- function(package, version = NULL,
repos = getOption("repos"),
type = getOption("pkgType"), ...) {
url <- download_version_url(package, version, repos, type)
download(path = tempfile(), url = url)
}
download_version_url <- function(package, version, repos, type) {
contriburl <- contrib.url(repos, type)
available <- available.packages(contriburl)
if (package %in% row.names(available)) {
current.version <- available[package, 'Version']
if (is.null(version) || version == current.version) {
row <- available[which(rownames(available) == package)[1], ]
return(paste0(
row[["Repository"]],
"/",
row[["Package"]],
"_",
row[["Version"]],
".tar.gz"
))
}
}
info <- package_find_repo(package, repos)
if (is.null(version)) {
# Grab the latest one: only happens if pulled from CRAN
package.path <- row.names(info)[nrow(info)]
} else {
package.path <- paste(package, "/", package, "_", version, ".tar.gz",
sep = "")
if (!(package.path %in% row.names(info))) {
stop(sprintf("version '%s' is invalid for package '%s'", version,
package))
}
}
paste(info$repo[1L], "/src/contrib/Archive/", package.path, sep = "")
}
install <- function(pkgdir, dependencies, quiet, build, build_opts, upgrade,
repos, type, ...) {
warn_for_potential_errors()
if (file.exists(file.path(pkgdir, "src"))) {
if (has_package("pkgbuild")) {
pkgbuild::local_build_tools(required = TRUE)
} else if (!has_devel()) {
missing_devel_warning(pkgdir)
}
}
## Check for circular dependencies. We need to know about the root
## of the install process.
if (is_root_install()) on.exit(exit_from_root_install(), add = TRUE)
if (check_for_circular_dependencies(pkgdir, quiet)) {
return(invisible(FALSE))
}
install_deps(pkgdir, dependencies = dependencies, quiet = quiet,
build = build, build_opts = build_opts, upgrade = upgrade, repos = repos, type = type, ...)
if (isTRUE(build)) {
dir <- tempfile()
dir.create(dir)
on.exit(unlink(dir), add = TRUE)
pkgdir <- safe_build_package(pkgdir, build_opts, dir, quiet)
}
safe_install_packages(
pkgdir,
repos = NULL,
quiet = quiet,
type = "source",
...
)
pkg_name <- load_pkg_description(pkgdir)$package
invisible(pkg_name)
}
safe_install_packages <- function(...) {
lib <- paste(.libPaths(), collapse = .Platform$path.sep)
if (!is_standalone() &&
has_package("crancache") && has_package("callr")) {
i.p <- "crancache" %::% "install_packages"
} else {
i.p <- utils::install.packages
}
with_envvar(
c(R_LIBS = lib,
R_LIBS_USER = lib,
R_LIBS_SITE = lib),
# Set options(warn = 2) for this process and child processes, so that
# warnings from `install.packages()` are converted to errors.
if (should_error_for_warnings()) {
with_options(list(warn = 2),
with_rprofile_user("options(warn = 2)",
i.p(...)
)
)
} else {
i.p(...)
}
)
}
safe_build_package <- function(pkgdir, build_opts, dest_path, quiet, use_pkgbuild = !is_standalone() && pkg_installed("pkgbuild")) {
if (use_pkgbuild) {
vignettes <- TRUE
manual <- FALSE
has_no_vignettes <- grepl("--no-build-vignettes", build_opts)
if (any(has_no_vignettes)) {
vignettes <- FALSE
}
has_no_manual <- grepl("--no-manual", build_opts)
if (!any(has_no_manual)) {
manual <- TRUE
}
build_opts <- build_opts[!(has_no_vignettes | has_no_manual)]
pkgbuild::build(pkgdir, dest_path = dest_path, binary = FALSE,
vignettes = vignettes, manual = manual, args = build_opts, quiet = quiet)
} else {
# No pkgbuild, so we need to call R CMD build ourselves
lib <- paste(.libPaths(), collapse = ":")
env <- c(R_LIBS = lib,
R_LIBS_USER = lib,
R_LIBS_SITE = lib,
R_PROFILE_USER = tempfile())
pkgdir <- normalizePath(pkgdir)
message("Running `R CMD build`...")
in_dir(dest_path, {
with_envvar(env, {
output <- rcmd("build", c(build_opts, shQuote(pkgdir)), quiet = quiet,
fail_on_status = FALSE)
})
})
if (output$status != 0) {
cat("STDOUT:\n")
cat(output$stdout, sep = "\n")
cat("STDERR:\n")
cat(output$stderr, sep = "\n")
msg_for_long_paths(output)
stop(sprintf("Failed to `R CMD build` package, try `build = FALSE`."),
call. = FALSE)
}
building_regex <- paste0(
"^[*] building[^[:alnum:]]+", # prefix, "* building '"
"([-[:alnum:]_.]+)", # package file name, e.g. xy_1.0-2.tar.gz
"[^[:alnum:]]+$" # trailing quote
)
pkgfile <- sub(building_regex, "\\1", output$stdout[length(output$stdout)])
file.path(dest_path, pkgfile)
}
}
msg_for_long_paths <- function(output) {
if (sys_type() == "windows" &&
(r_error_matches("over-long path", output$stderr) ||
r_error_matches("over-long path length", output$stderr))) {
message(
"\nIt seems that this package contains files with very long paths.\n",
"This is not supported on most Windows versions. Please contact the\n",
"package authors and tell them about this. See this GitHub issue\n",
"for more details: https://github.com/r-lib/remotes/issues/84\n")
}
}
r_error_matches <- function(msg, str) {
any(grepl(msg, str)) ||
any(grepl(gettext(msg, domain = "R"), str))
}
#' Install package dependencies if needed.
#'
#' @inheritParams package_deps
#' @param ... additional arguments passed to [utils::install.packages()].
#' @param build If `TRUE` build the package before installing.
#' @param build_opts Options to pass to `R CMD build`, only used when `build`
#' is `TRUE`.
#' @export
#' @examples
#' \dontrun{install_deps(".")}
install_deps <- function(pkgdir = ".", dependencies = NA,
repos = getOption("repos"),
type = getOption("pkgType"),
upgrade = c("default", "ask", "always", "never"),
quiet = FALSE,
build = TRUE,
build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
...) {
packages <- dev_package_deps(
pkgdir,
repos = repos,
dependencies = dependencies,
type = type,
...
)
dep_deps <- if (isTRUE(dependencies)) NA else dependencies
update(
packages,
dependencies = dep_deps,
quiet = quiet,
upgrade = upgrade,
build = build,
build_opts = build_opts,
...
)
}
should_error_for_warnings <- function() {
force_suggests <- Sys.getenv("_R_CHECK_FORCE_SUGGESTS_", "true")
no_errors <- Sys.getenv("R_REMOTES_NO_ERRORS_FROM_WARNINGS", !as.logical(force_suggests))
!as.logical(no_errors)
}
tokenize_json <- function(text) {
text <- paste(text, collapse = "\n")
ESCAPE <- '(\\\\[^u[:cntrl:]]|\\\\u[0-9a-fA-F]{4})'
CHAR <- '[^[:cntrl:]"\\\\]'
STRING <- paste0('"', CHAR, '*(', ESCAPE, CHAR, '*)*"')
NUMBER <- "-?(0|[1-9][0-9]*)([.][0-9]*)?([eE][+-]?[0-9]*)?"
KEYWORD <- 'null|false|true'
SPACE <- '[[:space:]]+'
match <- gregexpr(
pattern = paste0(
STRING, "|", NUMBER, "|", KEYWORD, "|", SPACE, "|", "."
),
text = text,
perl = TRUE
)
grep("^\\s+$", regmatches(text, match)[[1]], value = TRUE, invert = TRUE)
}
throw <- function(...) {
stop("JSON: ", ..., call. = FALSE)
}
fromJSONFile <- function(filename) {
fromJSON(readLines(filename, warn = FALSE))
}
fromJSON <- function(text) {
tokens <- tokenize_json(text)
token <- NULL
ptr <- 1
read_token <- function() {
if (ptr <= length(tokens)) {
token <<- tokens[ptr]
ptr <<- ptr + 1
} else {
token <<- 'EOF'
}
}
parse_value <- function(name = "") {
if (token == "{") {
parse_object()
} else if (token == "[") {
parse_array()
} else if (token == "EOF" || (nchar(token) == 1 && ! token %in% 0:9)) {
throw("EXPECTED value GOT ", token)
} else {
j2r(token)
}
}
parse_object <- function() {
res <- structure(list(), names = character())
read_token()
## Invariant: we are at the beginning of an element
while (token != "}") {
## "key"
if (grepl('^".*"$', token)) {
key <- j2r(token)
} else {
throw("EXPECTED string GOT ", token)
}
## :
read_token()
if (token != ":") { throw("EXPECTED : GOT ", token) }
## value
read_token()
res[key] <- list(parse_value())
## } or ,
read_token()
if (token == "}") {
break
} else if (token != ",") {
throw("EXPECTED , or } GOT ", token)
}
read_token()
}
res
}
parse_array <- function() {
res <- list()
read_token()
## Invariant: we are at the beginning of an element
while (token != "]") {
## value
res <- c(res, list(parse_value()))
## ] or ,
read_token()
if (token == "]") {
break
} else if (token != ",") {
throw("EXPECTED , GOT ", token)
}
read_token()
}
res
}
read_token()
parse_value(tokens)
}
j2r <- function(token) {
if (token == "null") {
NULL
} else if (token == "true") {
TRUE
} else if (token == "false") {
FALSE
} else if (grepl('^".*"$', token)) {
trimq(token)
} else {
as.numeric(token)
}
}
trimq <- function(x) {
sub('^"(.*)"$', "\\1", x)
}
get_json_sha <- function(text) {
m <- regexpr(paste0('"sha"\\s*:\\s*"(\\w+)"'), text, perl = TRUE)
if (all(m == -1)) {
return(fromJSON(text)$sha %||% NA_character_)
}
start <- attr(m, "capture.start")
end <- start + attr(m, "capture.length") - 1L
substring(text, start, end)
}
parse_deps <- function(string) {
if (is.null(string)) return()
stopifnot(is.character(string), length(string) == 1)
if (grepl("^\\s*$", string)) return()
# Split by commas with surrounding whitespace removed
pieces <- strsplit(string, "[[:space:]]*,[[:space:]]*")[[1]]
# Get the names
names <- gsub("\\s*\\(.*?\\)", "", pieces)
names <- gsub("^\\s+|\\s+$", "", names)
# Get the versions and comparison operators
versions_str <- pieces
have_version <- grepl("\\(.*\\)", versions_str)
versions_str[!have_version] <- NA
compare <- sub(".*\\(\\s*(\\S+)\\s+.*\\s*\\)", "\\1", versions_str)
versions <- sub(".*\\(\\s*\\S+\\s+(\\S*)\\s*\\)", "\\1", versions_str)
# Check that non-NA comparison operators are valid
compare_nna <- compare[!is.na(compare)]
compare_valid <- compare_nna %in% c(">", ">=", "==", "<=", "<")
if(!all(compare_valid)) {
stop("Invalid comparison operator in dependency: ",
paste(compare_nna[!compare_valid], collapse = ", "))
}
deps <- data.frame(name = names, compare = compare,
version = versions, stringsAsFactors = FALSE)
# Remove R dependency
deps[names != "R", ]
}
load_pkg_description <- function(path) {
path <- normalizePath(path)
if (!is_dir(path)) {
dir <- tempfile()
path_desc <- untar_description(path, dir = dir)
on.exit(unlink(dir, recursive = TRUE))
} else {
path_desc <- file.path(path, "DESCRIPTION")
}
desc <- read_dcf(path_desc)
names(desc) <- tolower(names(desc))
desc$path <- path
desc
}
#' Parse a remote git repo specification
#'
#' A remote repo can be specified in two ways:
#' \describe{
#' \item{as a URL}{`parse_github_url()` handles HTTPS and SSH remote URLs
#' and various GitHub browser URLs}
#' \item{via a shorthand}{`parse_repo_spec()` handles this concise form:
#' `[username/]repo[/subdir][#pull|@ref|@*release]`}
#' }
#'
#' @param repo Character scalar, the repo specification.
#' @return List with members: `username`, `repo`, `subdir`
#' `ref`, `pull`, `release`, some which will be empty.
#'
#' @name parse-git-repo
#' @examples
#' parse_repo_spec("metacran/crandb")
#' parse_repo_spec("jimhester/covr#47") ## pull request
#' parse_repo_spec("jeroen/curl@v0.9.3") ## specific tag
#' parse_repo_spec("tidyverse/dplyr@*release") ## shorthand for latest release
#' parse_repo_spec("r-lib/remotes@550a3c7d3f9e1493a2ba") ## commit SHA
#' parse_repo_spec("r-lib/remotes@550a3c7d3f9e1493a2ba") ## commit SHA
#' parse_repo_spec("igraph=igraph/rigraph") ## Different package name from repo name
#'
#' parse_github_url("https://github.com/jeroen/curl.git")
#' parse_github_url("git@github.com:metacran/crandb.git")
#' parse_github_url("https://github.com/jimhester/covr")
#' parse_github_url("https://github.example.com/user/repo.git")
#' parse_github_url("git@github.example.com:user/repo.git")
#'
#' parse_github_url("https://github.com/r-lib/remotes/pull/108")
#' parse_github_url("https://github.com/r-lib/remotes/tree/name-of-branch")
#' parse_github_url("https://github.com/r-lib/remotes/commit/1234567")
#' parse_github_url("https://github.com/r-lib/remotes/releases/latest")
#' parse_github_url("https://github.com/r-lib/remotes/releases/tag/1.0.0")
NULL
#' @export
#' @rdname parse-git-repo
parse_repo_spec <- function(repo) {
package_name_rx <- "(?:(?<package>[[:alpha:]][[:alnum:].]*[[:alnum:]])=)?"
username_rx <- "(?:(?<username>[^/]+)/)"
repo_rx <- "(?<repo>[^/@#]+)"
subdir_rx <- "(?:/(?<subdir>[^@#]*[^@#/])/?)?"
ref_rx <- "(?:@(?<ref>[^*].*))"
pull_rx <- "(?:#(?<pull>[0-9]+))"
release_rx <- "(?:@(?<release>[*]release))"
ref_or_pull_or_release_rx <- sprintf(
"(?:%s|%s|%s)?", ref_rx, pull_rx, release_rx
)
spec_rx <- sprintf(
"^%s%s%s%s%s$", package_name_rx, username_rx, repo_rx, subdir_rx, ref_or_pull_or_release_rx
)
params <- as.list(re_match(text = repo, pattern = spec_rx))
if (is.na(params$.match)) {
stop(sprintf("Invalid git repo specification: '%s'", repo))
}
params[grepl("^[^\\.]", names(params))]
}
#' @export
#' @rdname parse-git-repo
parse_github_repo_spec <- parse_repo_spec
#' @export
#' @rdname parse-git-repo
parse_github_url <- function(repo) {
prefix_rx <- "(?:github[^/:]+[/:])"
username_rx <- "(?:(?<username>[^/]+)/)"
repo_rx <- "(?<repo>[^/@#]+)"
ref_rx <- "(?:(?:tree|commit|releases/tag)/(?<ref>.+$))"
pull_rx <- "(?:pull/(?<pull>.+$))"
release_rx <- "(?:releases/)(?<release>.+$)"
ref_or_pull_or_release_rx <- sprintf(
"(?:/(%s|%s|%s))?", ref_rx, pull_rx, release_rx
)
url_rx <- sprintf(
"%s%s%s%s",
prefix_rx, username_rx, repo_rx, ref_or_pull_or_release_rx
)
params <- as.list(re_match(text = repo, pattern = url_rx))
if (is.na(params$.match)) {
stop(sprintf("Invalid GitHub URL: '%s'", repo))
}
if (params$ref == "" && params$pull == "" && params$release == "") {
params$repo <- gsub("\\.git$", "", params$repo)
}
if (params$release == "latest") {
params$release <- "*release"
}
params[grepl("^[^\\.]", names(params))]
}
parse_git_repo <- function(repo) {
if (grepl("^https://github|^git@github", repo)) {
params <- parse_github_url(repo)
} else {
params <- parse_repo_spec(repo)
}
params <- params[viapply(params, nchar) > 0]
if (!is.null(params$pull)) {
params$ref <- github_pull(params$pull)
params$pull <- NULL
}
if (!is.null(params$release)) {
params$ref <- github_release()
params$release <- NULL
}
params
}
parse_submodules <- function(file) {
if (grepl("\n", file)) {
x <- strsplit(file, "\n")[[1]]
} else {
x <- readLines(file)
}
# https://git-scm.com/docs/git-config#_syntax
# Subsection names are case sensitive and can contain any characters except
# newline and the null byte. Doublequote " and backslash can be included by
# escaping them as \" and \\
double_quoted_string_with_escapes <- '(?:\\\\.|[^"])*'
# Otherwise extract section names
section_names <- re_match(
x,
sprintf('^[[:space:]]*\\[submodule "(?<submodule>%s)"\\][[:space:]]*$', double_quoted_string_with_escapes)
)$submodule
# If no sections found return the empty list
if (all(is.na(section_names))) {
return(list())
}
# Extract name = value
# The variable names are case-insensitive, allow only alphanumeric characters
# and -, and must start with an alphabetic character.
variable_name <- "[[:alpha:]][[:alnum:]-]*"
mapping_values <- re_match(
x,
sprintf('^[[:space:]]*(?<name>%s)[[:space:]]*=[[:space:]]*(?<value>.*)[[:space:]]*$', variable_name),
)
values <- cbind(submodule = fill(section_names), mapping_values[c("name", "value")], stringsAsFactors = FALSE)
values <- values[!is.na(mapping_values$.match), ]
# path and valid url are required
if (!all(c("path", "url") %in% values$name)) {
warning("Invalid submodule definition, skipping submodule installation", immediate. = TRUE, call. = FALSE)
return(list())
}
# Roughly equivalent to tidyr::spread(values, name, value)
res <- stats::reshape(values, idvar = "submodule", timevar = "name", v.name = "value", direction = "wide")
# Set the column names, reshape prepends `value.` to path, url and branch
colnames(res) <- gsub("value[.]", "", colnames(res))
# path and valid url are required
if (any(is.na(res$url), is.na(res$path))) {
warning("Invalid submodule definition, skipping submodule installation", immediate. = TRUE, call. = FALSE)
return(list())
}
# branch is optional
if (!exists("branch", res)) {
res$branch <- NA_character_
}
# Remove unneeded attribute
attr(res, "reshapeWide") <- NULL
# Remove rownames
rownames(res) <- NULL
res
}
# Adapted from https://stackoverflow.com/a/9517731/2055486
fill <- function(x) {
not_missing <- !is.na(x)
res <- x[not_missing]
res[cumsum(not_missing)]
}
update_submodule <- function(url, path, branch, quiet) {
args <- c('clone', '--depth', '1', '--no-hardlinks --recurse-submodules')
if (length(branch) > 0 && !is.na(branch)) {
args <- c(args, "--branch", branch)
}
args <- c(args, url, path)
git(paste0(args, collapse = " "), quiet = quiet)
}
update_submodules <- function(source, quiet) {
file <- file.path(source, ".gitmodules")
if (!file.exists(file)) {
return()
}
info <- parse_submodules(file)
to_ignore <- in_r_build_ignore(info$path, file.path(source, ".Rbuildignore"))
info <- info[!to_ignore, ]
for (i in seq_len(NROW(info))) {
update_submodule(info$url[[i]], file.path(source, info$path[[i]]), info$branch[[i]], quiet)
}
}
system_check <- function(command, args = character(), quiet = TRUE,
error = TRUE, path = ".") {
out <- tempfile()
err <- tempfile()
on.exit(unlink(out), add = TRUE)
on.exit(unlink(err), add = TRUE)
## We suppress warnings, they are given if the command
## exits with a non-zero status
res <- in_dir(
path,
suppressWarnings(
system2(command, args = args, stdout = out, stderr = err)
)
)
res <- list(
stdout = tryCatch(
suppressWarnings(win2unix(read_char(out))),
error = function(e) ""
),
stderr = tryCatch(
suppressWarnings(win2unix(read_char(err))),
error = function(e) ""
),
status = res
)
if (error && res$status != 0) {
stop("Command ", command, " failed ", res$stderr)
}
if (! quiet) {
if (! identical(res$stdout, NA_character_)) cat(res$stdout)
if (! identical(res$stderr, NA_character_)) cat(res$stderr)
}
res
}
win2unix <- function(str) {
gsub("\r\n", "\n", str, fixed = TRUE)
}
read_char <- function(path, ...) {
readChar(path, nchars = file.info(path)$size, ...)
}
`%||%` <- function (a, b) if (!is.null(a)) a else b
`%:::%` <- function (p, f) get(f, envir = asNamespace(p))
`%::%` <- function (p, f) get(f, envir = asNamespace(p))
viapply <- function(X, FUN, ..., USE.NAMES = TRUE) {
vapply(X, FUN, integer(1L), ..., USE.NAMES = USE.NAMES)
}
vlapply <- function(X, FUN, ..., USE.NAMES = TRUE) {
vapply(X, FUN, logical(1L), ..., USE.NAMES = USE.NAMES)
}
rcmd <- function(cmd, args, path = R.home("bin"), quiet, fail_on_status = TRUE) {
if (os_type() == "windows") {
real_cmd <- file.path(path, "Rcmd.exe")
args <- c(cmd, args)
} else {
real_cmd <- file.path(path, "R")
args <- c("CMD", cmd, args)
}
stdoutfile <- tempfile()
stderrfile <- tempfile()
on.exit(unlink(c(stdoutfile, stderrfile), recursive = TRUE), add = TRUE)
status <- system2(real_cmd, args, stderr = stderrfile, stdout = stdoutfile)
out <- tryCatch(readLines(stdoutfile, warn = FALSE), error = function(x) "")
err <- tryCatch(readLines(stderrfile, warn = FALSE), error = function(x) "")
if (fail_on_status && status != 0) {
cat("STDOUT:\n")
cat(out, sep = "\n")
cat("STDERR:\n")
cat(err, sep = "\n")
stop(sprintf("Error running '%s' (status '%i')", cmd, status), call. = FALSE)
}
if (!quiet) {
cat(out, sep = "\n")
}
list(stdout = out, stderr = err, status = status)
}
is_bioconductor <- function(x) {
!is.null(x$biocviews)
}
trim_ws <- function(x) {
gsub("^[[:space:]]+|[[:space:]]+$", "", x)
}
set_envvar <- function(envs) {
if (length(envs) == 0) return()
stopifnot(is.named(envs))
old <- Sys.getenv(names(envs), names = TRUE, unset = NA)
set <- !is.na(envs)
both_set <- set & !is.na(old)
if (any(set)) do.call("Sys.setenv", as.list(envs[set]))
if (any(!set)) Sys.unsetenv(names(envs)[!set])
invisible(old)
}
with_envvar <- function(new, code) {
old <- set_envvar(new)
on.exit(set_envvar(old))
force(code)
}
is.named <- function(x) {
!is.null(names(x)) && all(names(x) != "")
}
pkg_installed <- function(pkg) {
if (pkg %in% loadedNamespaces()) {
TRUE
} else if (requireNamespace(pkg, quietly = TRUE)) {
try(unloadNamespace(pkg))
TRUE
} else {
FALSE
}
}
has_package <- function(pkg) {
if (pkg %in% loadedNamespaces()) {
TRUE
} else {
requireNamespace(pkg, quietly = TRUE)
}
}
with_something <- function(set, reset = set) {
function(new, code) {
old <- set(new)
on.exit(reset(old))
force(code)
}
}
in_dir <- with_something(setwd)
get_r_version <- function() {
paste(R.version$major, sep = ".", R.version$minor)
}
set_libpaths <- function(paths) {
old <- .libPaths()
.libPaths(paths)
invisible(old)
}
with_libpaths <- with_something(set_libpaths, .libPaths)
set_options <- function(x) {
do.call(options, as.list(x))
}
with_options <- with_something(set_options)
# Read the current user .Rprofile. Here is the order it is searched, from
# ?Startup
#
# 'R_PROFILE_USER’ environment variable (and tilde expansion
# will be performed). If this is unset, a file called ‘.Rprofile’
# is searched for in the current directory or in the user's home
# directory (in that order). The user profile file is sourced into
# the workspace.
read_rprofile_user <- function() {
f <- normalizePath(Sys.getenv("R_PROFILE_USER", ""), mustWork = FALSE)
if (file.exists(f)) {
return(readLines(f))
}
f <- normalizePath("~/.Rprofile", mustWork = FALSE)
if (file.exists(f)) {
return(readLines(f))
}
character()
}
with_rprofile_user <- function(new, code) {
temp_rprofile <- tempfile()
on.exit(unlink(temp_rprofile), add = TRUE)
writeLines(c(read_rprofile_user(), new), temp_rprofile)
with_envvar(c("R_PROFILE_USER" = temp_rprofile), {
force(code)
})
}
## There are two kinds of tar on windows, one needs --force-local
## not to interpret : characters, the other does not. We try both ways.
untar <- function(tarfile, ...) {
if (os_type() == "windows") {
tarhelp <- tryCatch(
system2("tar", "--help", stdout = TRUE, stderr = TRUE),
error = function(x) "")
if (any(grepl("--force-local", tarhelp))) {
status <- try(
suppressWarnings(utils::untar(tarfile, extras = "--force-local", ...)),
silent = TRUE)
if (! is_tar_error(status)) {
return(status)
} else {
message("External tar failed with `--force-local`, trying without")
}
}
}
utils::untar(tarfile, ...)
}
is_tar_error <- function(status) {
inherits(status, "try-error") ||
is_error_status(status) ||
is_error_status(attr(status, "status"))
}
is_error_status <- function(x) {
is.numeric(x) && length(x) > 0 && !is.na(x) && x != 0
}
os_type <- function() {
.Platform$OS.type
}
sys_type <- function() {
if (.Platform$OS.type == "windows") {
"windows"
} else if (Sys.info()["sysname"] == "Darwin") {
"macos"
} else if (Sys.info()["sysname"] == "Linux") {
"linux"
} else if (.Platform$OS.type == "unix") {
"unix"
} else {
stop("Unknown OS")
}
}
is_dir <- function(path) {
file.info(path)$isdir
}
untar_description <- function(tarball, dir = tempfile()) {
files <- untar(tarball, list = TRUE)
desc <- grep("^[^/]+/DESCRIPTION$", files, value = TRUE)
if (length(desc) < 1) stop("No 'DESCRIPTION' file in package")
untar(tarball, desc, exdir = dir)
file.path(dir, desc)
}
## copied from rematch2@180fb61
re_match <- function(text, pattern, perl = TRUE, ...) {
stopifnot(is.character(pattern), length(pattern) == 1, !is.na(pattern))
text <- as.character(text)
match <- regexpr(pattern, text, perl = perl, ...)
start <- as.vector(match)
length <- attr(match, "match.length")
end <- start + length - 1L
matchstr <- substring(text, start, end)
matchstr[ start == -1 ] <- NA_character_
res <- data.frame(
stringsAsFactors = FALSE,
.text = text,
.match = matchstr
)
if (!is.null(attr(match, "capture.start"))) {
gstart <- attr(match, "capture.start")
glength <- attr(match, "capture.length")
gend <- gstart + glength - 1L
groupstr <- substring(text, gstart, gend)
groupstr[ gstart == -1 ] <- NA_character_
dim(groupstr) <- dim(gstart)
res <- cbind(groupstr, res, stringsAsFactors = FALSE)
}
names(res) <- c(attr(match, "capture.names"), ".text", ".match")
class(res) <- c("tbl_df", "tbl", class(res))
res
}
is_standalone <- function() {
isTRUE(as.logical(Sys.getenv("R_REMOTES_STANDALONE", "false")))
}
# This code is adapted from the perl MIME::Base64 module https://perldoc.perl.org/MIME/Base64.html
# https://github.com/gisle/mime-base64/blob/cf23d49e517c6ed8f4b24295f63721e8c9935010/Base64.xs#L197
XX <- 255L
EQ <- 254L
INVALID <- XX
index_64 <- as.integer(c(
XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,62, XX,XX,XX,63,
52,53,54,55, 56,57,58,59, 60,61,XX,XX, XX,EQ,XX,XX,
XX, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, 11,12,13,14,
15,16,17,18, 19,20,21,22, 23,24,25,XX, XX,XX,XX,XX,
XX,26,27,28, 29,30,31,32, 33,34,35,36, 37,38,39,40,
41,42,43,44, 45,46,47,48, 49,50,51,XX, XX,XX,XX,XX,
XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX
))
base64_decode <- function(x) {
if (is.character(x)) {
x <- charToRaw(x)
}
len <- length(x)
idx <- 1
c <- integer(4)
out <- raw()
while(idx <= len) {
i <- 1
while(i <= 4) {
uc <- index_64[[as.integer(x[[idx]]) + 1L]]
idx <- idx + 1
if (uc != INVALID) {
c[[i]] <- uc
i <- i + 1
}
if (idx > len) {
if (i <= 4) {
if (i <= 2) return(rawToChar(out))
if (i == 3) {
c[[3]] <- EQ
c[[4]] <- EQ
}
break
}
}
}
if (c[[1]] == EQ || c[[2]] == EQ) {
break
}
#print(sprintf("c1=%d,c2=%d,c3=%d,c4=%d\n", c[1],c[2],c[3],c[4]))
out[[length(out) + 1]] <- as.raw(bitwOr(bitwShiftL(c[[1]], 2L), bitwShiftR(bitwAnd(c[[2]], 0x30), 4L)))
if (c[[3]] == EQ) {
break
}
out[[length(out) + 1]] <- as.raw(bitwOr(bitwShiftL(bitwAnd(c[[2]], 0x0F), 4L), bitwShiftR(bitwAnd(c[[3]], 0x3C), 2L)))
if (c[[4]] == EQ) {
break
}
out[[length(out) + 1]] <- as.raw(bitwOr(bitwShiftL(bitwAnd(c[[3]], 0x03), 6L), c[[4]]))
}
rawToChar(out)
}
basis64 <- charToRaw(paste(c(LETTERS, letters, 0:9, "+", "/"),
collapse = ""))
base64_encode <- function(x) {
if (is.character(x)) {
x <- charToRaw(x)
}
len <- length(x)
rlen <- floor((len + 2L) / 3L) * 4L
out <- raw(rlen)
ip <- op <- 1L
c <- integer(4)
while (len > 0L) {
c[[1]] <- as.integer(x[[ip]])
ip <- ip + 1L
if (len > 1L) {
c[[2]] <- as.integer(x[ip])
ip <- ip + 1L
} else {
c[[2]] <- 0L
}
out[op] <- basis64[1 + bitwShiftR(c[[1]], 2L)]
op <- op + 1L
out[op] <- basis64[1 + bitwOr(bitwShiftL(bitwAnd(c[[1]], 3L), 4L),
bitwShiftR(bitwAnd(c[[2]], 240L), 4L))]
op <- op + 1L
if (len > 2) {
c[[3]] <- as.integer(x[ip])
ip <- ip + 1L
out[op] <- basis64[1 + bitwOr(bitwShiftL(bitwAnd(c[[2]], 15L), 2L),
bitwShiftR(bitwAnd(c[[3]], 192L), 6L))]
op <- op + 1L
out[op] <- basis64[1 + bitwAnd(c[[3]], 63)]
op <- op + 1L
} else if (len == 2) {
out[op] <- basis64[1 + bitwShiftL(bitwAnd(c[[2]], 15L), 2L)]
op <- op + 1L
out[op] <- charToRaw("=")
op <- op + 1L
} else { ## len == 1
out[op] <- charToRaw("=")
op <- op + 1L
out[op] <- charToRaw("=")
op <- op + 1L
}
len <- len - 3L
}
rawToChar(out)
}
build_url <- function(host, ...) {
download_url(do.call(file.path, as.list(c(host, ...))))
}
download_url <- function(url) {
if (!grepl("^[[:alpha:]]+://", url)) {
scheme <- if (download_method_secure()) "https://" else "http://"
return(paste0(scheme, url))
}
url
}
is_na <- function(x) {
length(x) == 1 && is.na(x)
}
dir.exists <- function(paths) {
if (getRversion() < "3.2") {
x <- base::file.info(paths)$isdir
!is.na(x) & x
} else {
("base" %::% "dir.exists")(paths)
}
}
is_binary_pkg <- function(x) {
file_ext(x) %in% c("tgz", "zip")
}
format_str <- function(x, width = Inf, trim = TRUE, justify = "none", ...) {
x <- format(x, trim = trim, justify = justify, ...)
if (width < Inf) {
x_width <- nchar(x, "width")
too_wide <- x_width > width
if (any(too_wide)) {
x[too_wide] <- paste0(substr(x[too_wide], 1, width - 3), "...")
}
}
x
}
warn_for_potential_errors <- function() {
if (sys_type() == "windows" && grepl(" ", R.home()) &&
getRversion() <= "3.4.2") {
warning(immediate. = TRUE,
"\n!!! Installation will probably fail!\n",
"This version of R has trouble with building and installing packages if\n",
"the R HOME directory (currently '", R.home(), "')\n",
"has space characters. Possible workarounds include:\n",
"- installing R to the C: drive,\n",
"- installing it into a path without a space, or\n",
"- creating a drive letter for R HOME via the `subst` windows command, and\n",
" starting R from the new drive.\n",
"See also https://github.com/r-lib/remotes/issues/98\n")
}
}
# Return all directories in the input paths
directories <- function(paths) {
dirs <- unique(dirname(paths))
out <- dirs[dirs != "."]
while(length(dirs) > 0 && any(dirs != ".")) {
out <- unique(c(out, dirs[dirs != "."]))
dirs <- unique(dirname(dirs))
}
sort(out)
}
in_r_build_ignore <- function(paths, ignore_file) {
ignore <- ("tools" %:::% "get_exclude_patterns")()
if (file.exists(ignore_file)) {
ignore <- c(ignore, readLines(ignore_file, warn = FALSE))
}
matches_ignores <- function(x) {
any(vlapply(ignore, grepl, x, perl = TRUE, ignore.case = TRUE))
}
# We need to search for the paths as well as directories in the path, so
# `^foo$` matches `foo/bar`
should_ignore <- function(path) {
any(vlapply(c(path, directories(path)), matches_ignores))
}
vlapply(paths, should_ignore)
}
## Standalone mode, make sure that we restore the env var on exit
old <- Sys.getenv("R_REMOTES_STANDALONE", NA_character_)
Sys.setenv("R_REMOTES_STANDALONE" = "true")
if (is.na(old)) {
on.exit(Sys.unsetenv("R_REMOTES_STANDALONE"), add = TRUE)
} else {
on.exit(Sys.setenv("R_REMOTES_STANDALONE" = old), add = TRUE)
}
install_github(...)
}
metrumresearchgroup/rmotes documentation built on May 18, 2019, 2:35 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
function(...) {
## This is the code of the package, put in here by brew
## This is mostly from https://bioconductor.org/biocLite.R
bioc_version <- function() {
bver <- get(
".BioC_version_associated_with_R_version",
envir = asNamespace("tools"),
inherits = FALSE
)
if (is.function(bver)) {
bver()
} else {
bver
}
}
bioc_repos <- function(bioc_ver = bioc_version()) {
bioc_ver <- as.package_version(bioc_ver)
a <- NULL
p <- file.path(Sys.getenv("HOME"), ".R", "repositories")
if (file.exists(p)) {
a <- ("tools" %:::% ".read_repositories")(p)
if (!"BioCsoft" %in% rownames(a)) a <- NULL
}
if (is.null(a)) {
p <- file.path(R.home("etc"), "repositories")
a <- ("tools" %:::% ".read_repositories")(p)
}
# BioCextra was removed in Bioc 3.6
if (bioc_ver < "3.6") {
repo_types <- c("BioCsoft", "BioCann", "BioCexp", "BioCextra")
} else {
repo_types <- c("BioCsoft", "BioCann", "BioCexp")
}
repos <- intersect(
rownames(a),
repo_types
)
default_bioc_version <- bioc_version()
if (!identical(default_bioc_version, bioc_ver)) {
a[repos, "URL"] <- sub(as.character(default_bioc_version), bioc_ver, a[repos, "URL"], fixed = TRUE)
}
structure(a[repos, "URL"], names = repos)
}
#' Deduce the URLs of the BioConductor repositories
#'
#' @return A named character vector of the URLs of the
#' BioConductor repositories, appropriate for the current
#' R version.
#'
#' @param r_ver R version to use.
#' @param bioc_ver corresponding to the R version to use.
#' @export
#' @keywords internal
bioc_install_repos <- function(r_ver = getRversion(), bioc_ver = bioc_version()) {
r_ver <- package_version(r_ver)
bioc_ver <- package_version(bioc_ver)
repos <- bioc_repos()
## add a conditional for Bioc releases occuring WITHIN
## a single R minor version. This is so that a user with a
## version of R (whose etc/repositories file references the
## no-longer-latest URL) and without BiocInstaller
## will be pointed to the most recent repository suitable
## for their version of R
if (r_ver >= "3.2.2" && r_ver < "3.3.0") {
## transitioning to https support; check availability
con <- file(fl <- tempfile(), "w")
sink(con, type = "message")
tryCatch(
{ xx <- close(file("https://bioconductor.org")) },
error = function(e) { message(conditionMessage(e)) }
)
sink(type = "message")
close(con)
if (!length(readLines(fl))) {
repos <- sub("^http:", "https:", repos)
}
}
if (r_ver >= "3.5") {
repos <- bioc_repos("3.8")
} else if (r_ver >= "3.4") {
repos <- bioc_repos("3.6")
} else if (r_ver >= "3.3") {
repos <- bioc_repos("3.4")
} else if (r_ver >= "3.2") {
repos <- bioc_repos("3.2")
} else if (r_ver > "3.1.1") {
repos <- bioc_repos("3.0")
} else if (r_ver == "3.1.1") {
## R-3.1.1's etc/repositories file at the time of the release
## of Bioc 3.0 pointed to the 2.14 repository, but we want
## new installations to access the 3.0 repository
repos <- bioc_repos("3.0")
} else if (r_ver == "3.1.0") {
## R-devel points to 2.14 repository
repos <- bioc_repos("2.14")
} else {
stop("Unsupported R version", call. = FALSE)
}
repos
}
## A environment to hold which packages are being installed so packages
## with circular dependencies can be skipped the second time.
installing <- new.env(parent = emptyenv())
is_root_install <- function() is.null(installing$packages)
exit_from_root_install <- function() installing$packages <- NULL
check_for_circular_dependencies <- function(pkgdir, quiet) {
pkgdir <- normalizePath(pkgdir)
pkg <- get_desc_field(file.path(pkgdir, "DESCRIPTION"), "Package")
if (pkg %in% installing$packages) {
if (!quiet) message("Skipping ", pkg, ", it is already being installed")
TRUE
} else {
installing$packages <- c(installing$packages, pkg)
FALSE
}
}
cache <- new.env(parent = emptyenv())
#' @rdname available_packages
#' @export
available_packages_set <- function(repos, type, db) {
signature <- rawToChar(serialize(list(repos, type), NULL, ascii = TRUE))
if (is.null(cache[[signature]])) {
cache[[signature]] <- db
}
cache[[signature]]
}
#' @rdname available_packages
#' @export
available_packages_reset <- function() {
rm(list = ls(envir = cache), envir = cache)
}
#' Simpler available.packages
#'
#' This is mostly equivalent to [utils::available.packages()] however it also
#' caches the full result. Additionally the cache can be assigned explicitly with
#' [available_packages_set()] and reset (cleared) with [available_packages_reset()].
#'
#' @inheritParams utils::available.packages
#' @keywords internal
#' @seealso [utils::available.packages()] for full documentation on the output format.
#' @export
available_packages <- function(repos = getOption("repos"), type = getOption("pkgType")) {
available_packages_set(
repos, type,
suppressWarnings(utils::available.packages(utils::contrib.url(repos, type), type = type))
)
}
read_dcf <- function(path) {
fields <- colnames(read.dcf(path))
as.list(read.dcf(path, keep.white = fields)[1, ])
}
write_dcf <- function(path, desc) {
write.dcf(
rbind(unlist(desc)),
file = path,
keep.white = names(desc),
indent = 0
)
}
get_desc_field <- function(path, field) {
dcf <- read_dcf(path)
dcf[[field]]
}
# Decompress pkg, if needed
source_pkg <- function(path, subdir = NULL) {
if (!file.info(path)$isdir) {
bundle <- path
outdir <- tempfile(pattern = "remotes")
dir.create(outdir)
path <- decompress(path, outdir)
} 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")
}
pkg_path
}
decompress <- function(src, target) {
stopifnot(file.exists(src))
if (grepl("\\.zip$", src)) {
my_unzip(src, target)
outdir <- getrootdir(as.vector(utils::unzip(src, list = TRUE)$Name))
} else if (grepl("\\.(tar|tar\\.gz|tar\\.bz2|tgz|tbz)$", src)) {
untar(src, exdir = target)
outdir <- getrootdir(untar(src, list = TRUE))
} else {
ext <- gsub("^[^.]*\\.", "", src)
stop("Don't know how to decompress files with extension ", ext,
call. = FALSE)
}
file.path(target, outdir)
}
# Returns everything before the last slash in a filename
# getdir("path/to/file") returns "path/to"
# getdir("path/to/dir/") returns "path/to/dir"
getdir <- function(path) sub("/[^/]*$", "", path)
# Given a list of files, returns the root (the topmost folder)
# getrootdir(c("path/to/file", "path/to/other/thing")) returns "path/to"
# It does not check that all paths have a common prefix. It fails for
# empty input vector. It assumes that directories end with '/'.
getrootdir <- function(file_list) {
stopifnot(length(file_list) > 0)
slashes <- nchar(gsub("[^/]", "", file_list))
if (min(slashes) == 0) return(".")
getdir(file_list[which.min(slashes)])
}
my_unzip <- function(src, target, unzip = getOption("unzip", "internal")) {
if (unzip %in% c("internal", "")) {
return(utils::unzip(src, exdir = target))
}
args <- paste(
"-oq", shQuote(src),
"-d", shQuote(target)
)
system_check(unzip, args)
}
#' Find all dependencies of a CRAN or dev package.
#'
#' Find all the dependencies of a package and determine whether they are ahead
#' or behind CRAN. A `print()` method identifies mismatches (if any)
#' between local and CRAN versions of each dependent package; an
#' `update()` method installs outdated or missing packages from CRAN.
#'
#' @param packages A character vector of package names.
#' @param pkgdir path to a package directory, or to a package tarball.
#' @param dependencies Which dependencies do you want to check?
#' Can be a character vector (selecting from "Depends", "Imports",
#' "LinkingTo", "Suggests", or "Enhances"), or a logical vector.
#'
#' `TRUE` is shorthand for "Depends", "Imports", "LinkingTo" and
#' "Suggests". `NA` is shorthand for "Depends", "Imports" and "LinkingTo"
#' and is the default. `FALSE` is shorthand for no dependencies (i.e.
#' just check this package, not its dependencies).
#' @param quiet If `TRUE`, suppress output.
#' @param upgrade One of "default", "ask", "always", or "never". "default"
#' respects the value of the `R_REMOTES_UPGRADE` environment variable if set,
#' and falls back to "ask" if unset. "ask" prompts the user for which out of
#' date packages to upgrade. For non-interactive sessions "ask" is equivalent
#' to "always". `TRUE` and `FALSE` are also accepted and correspond to
#' "always" and "never" respectively.
#' @param repos A character vector giving repositories to use.
#' @param type Type of package to `update`.
#'
#' @param object A `package_deps` object.
#' @param ... Additional arguments passed to `install_packages`.
#' @inheritParams install_github
#'
#' @return
#'
#' A `data.frame` with columns:
#'
#' \tabular{ll}{
#' `package` \tab The dependent package's name,\cr
#' `installed` \tab The currently installed version,\cr
#' `available` \tab The version available on CRAN,\cr
#' `diff` \tab An integer denoting whether the locally installed version
#' of the package is newer (1), the same (0) or older (-1) than the version
#' currently available on CRAN.\cr
#' }
#'
#' @export
#' @examples
#' \dontrun{
#' package_deps("devtools")
#' # Use update to update any out-of-date dependencies
#' update(package_deps("devtools"))
#' }
package_deps <- function(packages, dependencies = NA,
repos = getOption("repos"),
type = getOption("pkgType")) {
repos <- fix_repositories(repos)
cran <- available_packages(repos, type)
deps <- sort(find_deps(packages, available = cran, top_dep = dependencies))
# Remove base packages
inst <- utils::installed.packages()
base <- unname(inst[inst[, "Priority"] %in% c("base", "recommended"), "Package"])
deps <- setdiff(deps, base)
# get remote types
remote <- structure(lapply(deps, package2remote, repos = repos, type = type), class = "remotes")
inst_ver <- vapply(deps, local_sha, character(1))
cran_ver <- vapply(remote, function(x) remote_sha(x), character(1))
is_cran_remote <- vapply(remote, inherits, logical(1), "cran_remote")
diff <- compare_versions(inst_ver, cran_ver, is_cran_remote)
res <- structure(
data.frame(
package = deps,
installed = inst_ver,
available = cran_ver,
diff = diff,
is_cran = is_cran_remote,
stringsAsFactors = FALSE
),
class = c("package_deps", "data.frame"),
repos = repos,
type = type
)
res$remote <- remote
res
}
#' `local_package_deps` extracts dependencies from a
#' local DESCRIPTION file.
#'
#' @export
#' @rdname package_deps
local_package_deps <- function(pkgdir = ".", dependencies = NA) {
pkg <- load_pkg_description(pkgdir)
dependencies <- tolower(standardise_dep(dependencies))
dependencies <- intersect(dependencies, names(pkg))
parsed <- lapply(pkg[tolower(dependencies)], parse_deps)
unlist(lapply(parsed, `[[`, "name"), use.names = FALSE)
}
#' `dev_package_deps` lists the status of the dependencies
#' of a local package.
#'
#' @export
#' @rdname package_deps
dev_package_deps <- function(pkgdir = ".", dependencies = NA,
repos = getOption("repos"),
type = getOption("pkgType"), ...) {
pkg <- load_pkg_description(pkgdir)
repos <- c(repos, parse_additional_repositories(pkg))
deps <- local_package_deps(pkgdir = pkgdir, dependencies = dependencies)
if (is_bioconductor(pkg)) {
bioc_repos <- bioc_install_repos()
missing_repos <- setdiff(names(bioc_repos), names(repos))
if (length(missing_repos) > 0)
repos[missing_repos] <- bioc_repos[missing_repos]
}
combine_deps(
package_deps(deps, repos = repos, type = type),
remote_deps(pkg, ...))
}
combine_deps <- function(cran_deps, remote_deps) {
# If there are no dependencies there will be no remote dependencies either,
# so just return them (and don't force the remote_deps promise)
if (nrow(cran_deps) == 0) {
return(cran_deps)
}
# Only keep the remotes that are specified in the cran_deps
remote_deps <- remote_deps[remote_deps$package %in% cran_deps$package, ]
# If there are remote deps remove the equivalent CRAN deps
cran_deps <- cran_deps[!(cran_deps$package %in% remote_deps$package), ]
rbind(cran_deps, remote_deps)
}
## -2 = not installed, but available on CRAN
## -1 = installed, but out of date
## 0 = installed, most recent version
## 1 = installed, version ahead of CRAN
## 2 = package not on CRAN
compare_versions <- function(inst, remote, is_cran) {
stopifnot(length(inst) == length(remote) && length(inst) == length(is_cran))
compare_var <- function(i, c, cran) {
if (!cran) {
if (identical(i, c)) {
return(CURRENT)
} else {
return(BEHIND)
}
}
if (is.na(c)) return(UNAVAILABLE) # not on CRAN
if (is.na(i)) return(UNINSTALLED) # not installed, but on CRAN
i <- package_version(i)
c <- package_version(c)
if (i < c) {
BEHIND # out of date
} else if (i > c) {
AHEAD # ahead of CRAN
} else {
CURRENT # most recent CRAN version
}
}
vapply(seq_along(inst),
function(i) compare_var(inst[[i]], remote[[i]], is_cran[[i]]),
integer(1))
}
has_dev_remotes <- function(pkg) {
!is.null(pkg[["remotes"]])
}
#' @export
print.package_deps <- function(x, show_ok = FALSE, ...) {
class(x) <- "data.frame"
x$remote <-lapply(x$remote, format)
ahead <- x$diff > 0L
behind <- x$diff < 0L
same_ver <- x$diff == 0L
x$diff <- NULL
x[] <- lapply(x, format_str, width = 12)
if (any(behind)) {
cat("Needs update -----------------------------\n")
print(x[behind, , drop = FALSE], row.names = FALSE, right = FALSE)
}
if (any(ahead)) {
cat("Not on CRAN ----------------------------\n")
print(x[ahead, , drop = FALSE], row.names = FALSE, right = FALSE)
}
if (show_ok && any(same_ver)) {
cat("OK ---------------------------------------\n")
print(x[same_ver, , drop = FALSE], row.names = FALSE, right = FALSE)
}
}
## -2 = not installed, but available on CRAN
## -1 = installed, but out of date
## 0 = installed, most recent version
## 1 = installed, version ahead of CRAN
## 2 = package not on CRAN
UNINSTALLED <- -2L
BEHIND <- -1L
CURRENT <- 0L
AHEAD <- 1L
UNAVAILABLE <- 2L
#' @export
#' @rdname package_deps
#' @importFrom stats update
update.package_deps <- function(object,
dependencies = NA,
upgrade = c("default", "ask", "always", "never"),
force = FALSE,
quiet = FALSE,
build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
repos = getOption("repos"),
type = getOption("pkgType"),
...) {
object <- upgradable_packages(object, upgrade, quiet)
unavailable_on_cran <- object$diff == UNAVAILABLE & object$is_cran
unknown_remotes <- object$diff == UNAVAILABLE & !object$is_cran
if (any(unavailable_on_cran) && !quiet) {
message("Skipping ", sum(unavailable_on_cran), " packages not available: ",
paste(object$package[unavailable_on_cran], collapse = ", "))
}
if (any(unknown_remotes)) {
install_remotes(object$remote[unknown_remotes],
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
ahead_of_cran <- object$diff == AHEAD & object$is_cran
if (any(ahead_of_cran) && !quiet) {
message("Skipping ", sum(ahead_of_cran), " packages ahead of CRAN: ",
paste(object$package[ahead_of_cran], collapse = ", "))
}
ahead_remotes <- object$diff == AHEAD & !object$is_cran
if (any(ahead_remotes)) {
install_remotes(object$remote[ahead_remotes],
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
behind <- is.na(object$installed) | object$diff < CURRENT
if (any(object$is_cran & behind)) {
install_packages(object$package[object$is_cran & behind], repos = attr(object, "repos"),
type = attr(object, "type"), dependencies = dependencies, quiet = quiet, ...)
}
install_remotes(object$remote[!object$is_cran & behind],
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
invisible()
}
install_packages <- function(packages, repos = getOption("repos"),
type = getOption("pkgType"), ...,
dependencies = FALSE, quiet = NULL) {
# We want to pass only args that exist in the downstream functions
args_to_keep <-
unique(
names(
c(
formals(utils::install.packages),
formals(utils::download.file)
)
)
)
args <- list(...)
args <- args[names(args) %in% args_to_keep]
if (is.null(quiet))
quiet <- !identical(type, "source")
message("Installing ", length(packages), " packages: ",
paste(packages, collapse = ", "))
do.call(
safe_install_packages,
c(list(
packages,
repos = repos,
type = type,
dependencies = dependencies,
quiet = quiet
),
args
)
)
}
find_deps <- function(packages, available = available_packages(),
top_dep = TRUE, rec_dep = NA, include_pkgs = TRUE) {
if (length(packages) == 0 || identical(top_dep, FALSE))
return(character())
top_dep <- standardise_dep(top_dep)
rec_dep <- standardise_dep(rec_dep)
top <- tools::package_dependencies(packages, db = available, which = top_dep)
top_flat <- unlist(top, use.names = FALSE)
if (length(rec_dep) != 0 && length(top_flat) > 0) {
rec <- tools::package_dependencies(top_flat, db = available, which = rec_dep,
recursive = TRUE)
rec_flat <- unlist(rec, use.names = FALSE)
} else {
rec_flat <- character()
}
unique(c(if (include_pkgs) packages, top_flat, rec_flat))
}
#' Standardise dependencies using the same logical as [install.packages]
#'
#' @param x The dependencies to standardise.
#' A character vector (selecting from "Depends", "Imports",
#' "LinkingTo", "Suggests", or "Enhances"), or a logical vector.
#'
#' `TRUE` is shorthand for "Depends", "Imports", "LinkingTo" and
#' "Suggests". `NA` is shorthand for "Depends", "Imports" and "LinkingTo"
#' and is the default. `FALSE` is shorthand for no dependencies.
#'
#' @seealso <http://r-pkgs.had.co.nz/description.html#dependencies> for
#' additional information on what each dependency type means.
#' @keywords internal
#' @export
standardise_dep <- function(x) {
if (identical(x, NA)) {
c("Depends", "Imports", "LinkingTo")
} else if (isTRUE(x)) {
c("Depends", "Imports", "LinkingTo", "Suggests")
} else if (identical(x, FALSE)) {
character(0)
} else if (is.character(x)) {
x
} else {
stop("Dependencies must be a boolean or a character vector", call. = FALSE)
}
}
#' Update packages that are missing or out-of-date.
#'
#' Works similarly to [utils::install.packages()] but doesn't install packages
#' that are already installed, and also upgrades out dated dependencies.
#'
#' @param packages Character vector of packages to update.
#' @inheritParams install_github
#' @seealso [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(packages = TRUE,
dependencies = NA,
upgrade = c("default", "ask", "always", "never"),
force = FALSE,
quiet = FALSE,
build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
repos = getOption("repos"),
type = getOption("pkgType"),
...) {
if (isTRUE(packages)) {
packages <- utils::installed.packages()[, "Package"]
}
pkgs <- package_deps(packages, repos = repos, type = type)
update(pkgs,
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
has_additional_repositories <- function(pkg) {
"additional_repositories" %in% names(pkg)
}
parse_additional_repositories <- function(pkg) {
if (has_additional_repositories(pkg)) {
strsplit(pkg[["additional_repositories"]], "[,[:space:]]+")[[1]]
}
}
fix_repositories <- function(repos) {
if (length(repos) == 0)
repos <- character()
# Override any existing default values with the cloud mirror
# Reason: A "@CRAN@" value would open a GUI for choosing a mirror
repos[repos == "@CRAN@"] <- download_url("cloud.r-project.org")
repos
}
parse_one_remote <- function(x, ...) {
pieces <- strsplit(x, "::", fixed = TRUE)[[1]]
if (length(pieces) == 1) {
type <- "github"
repo <- pieces
} else if (length(pieces) == 2) {
type <- pieces[1]
repo <- pieces[2]
} else {
stop("Malformed remote specification '", x, "'", call. = FALSE)
}
tryCatch({
# We need to use `environment(sys.function())` instead of
# `asNamespace("remotes")` because when used as a script in
# install-github.R there is no remotes namespace.
fun <- get(paste0(tolower(type), "_remote"),
envir = environment(sys.function()), mode = "function", inherits = FALSE)
res <- fun(repo, ...)
}, error = function(e) stop("Unknown remote type: ", type, "\n ", conditionMessage(e), call. = FALSE)
)
res
}
split_remotes <- function(x) {
pkgs <- trim_ws(unlist(strsplit(x, ",[[:space:]]*")))
if (any((res <- grep("[[:space:]]+", pkgs)) != -1)) {
stop("Missing commas separating Remotes: '", pkgs[res], "'", call. = FALSE)
}
pkgs
}
remote_deps <- function(pkg, ...) {
if (!has_dev_remotes(pkg)) {
return(NULL)
}
dev_packages <- split_remotes(pkg[["remotes"]])
remote <- lapply(dev_packages, parse_one_remote, ...)
package <- vapply(remote, function(x) remote_package_name(x), character(1), USE.NAMES = FALSE)
installed <- vapply(package, function(x) local_sha(x), character(1), USE.NAMES = FALSE)
available <- vapply(remote, function(x) remote_sha(x), character(1), USE.NAMES = FALSE)
diff <- installed == available
diff <- ifelse(!is.na(diff) & diff, CURRENT, BEHIND)
diff[is.na(installed)] <- UNINSTALLED
res <- structure(
data.frame(
package = package,
installed = installed,
available = available,
diff = diff,
is_cran = FALSE,
stringsAsFactors = FALSE
),
class = c("package_deps", "data.frame"))
res$remote <- structure(remote, class = "remotes")
res
}
# interactive is an argument to make testing easier.
resolve_upgrade <- function(upgrade, is_interactive = interactive()) {
if (isTRUE(upgrade)) {
upgrade <- "always"
} else if (identical(upgrade, FALSE)) {
upgrade <- "never"
}
upgrade <- match.arg(upgrade, c("default", "ask", "always", "never"))
if (identical(upgrade, "default"))
upgrade <- Sys.getenv("R_REMOTES_UPGRADE", unset = "ask")
if (!is_interactive && identical(upgrade, "ask")) {
upgrade <- "always"
}
upgrade
}
upgradable_packages <- function(x, upgrade, quiet, is_interactive = interactive()) {
uninstalled <- x$diff == UNINSTALLED
behind <- x$diff == BEHIND
switch(resolve_upgrade(upgrade, is_interactive = is_interactive),
always = {
return(msg_upgrades(x, quiet))
},
never = return(x[uninstalled, ]),
ask = {
if (!any(behind)) {
return(x)
}
pkgs <- format_upgrades(x[behind, ])
choices <- pkgs
if (length(choices) > 1) {
choices <- c(choices, "CRAN packages only", "All", "None")
}
res <- utils::select.list(choices, title = "These packages have more recent versions available.\nWhich would you like to update?", multiple = TRUE)
if ("None" %in% res || length(res) == 0) {
return(x[uninstalled, ])
}
if ("All" %in% res) {
wch <- seq_len(NROW(x))
} else {
if ("CRAN packages only" %in% res) {
wch <- uninstalled | (behind & x$is_cran)
} else {
wch <- sort(c(which(uninstalled), which(behind)[pkgs %in% res]))
}
}
msg_upgrades(x[wch, ], quiet)
}
)
}
msg_upgrades <- function(x, quiet) {
if (isTRUE(quiet) || nrow(x) == 0) {
return(invisible(x))
}
cat(format_upgrades(x[x$diff <= BEHIND, ]), sep = "\n")
invisible(x)
}
format_upgrades <- function(x) {
if (nrow(x) == 0) {
return(character(0))
}
remote_type <- lapply(x$remote, format)
# This call trims widths to 12 characters
x[] <- lapply(x, format_str, width = 12)
# This call aligns the columns
x[] <- lapply(x, format, trim = FALSE, justify = "left")
pkgs <- paste0(x$package, " (", x$installed, " -> ", x$available, ") ", "[", remote_type, "]")
pkgs
}
## The checking code looks for the objects in the package namespace, so defining
## dll here removes the following NOTE
## Registration problem:
## Evaluating ‘dll$foo’ during check gives error
## ‘object 'dll' not found’:
## .C(dll$foo, 0L)
## See https://github.com/wch/r-source/blob/d4e8fc9832f35f3c63f2201e7a35fbded5b5e14c/src/library/tools/R/QC.R##L1950-L1980
## Setting the class is needed to avoid a note about returning the wrong class.
## The local object is found first in the actual call, so current behavior is
## unchanged.
dll <- list(foo = structure(list(), class = "NativeSymbolInfo"))
has_devel <- function() {
tryCatch(
has_devel2(),
error = function(e) FALSE
)
}
## This is similar to devtools:::has_devel(), with some
## very minor differences.
has_devel2 <- function() {
foo_path <- file.path(tempfile(fileext = ".c"))
cat("void foo(int *bar) { *bar=1; }\n", file = foo_path)
on.exit(unlink(foo_path))
R(c("CMD", "SHLIB", basename(foo_path)), dirname(foo_path))
dylib <- sub("\\.c$", .Platform$dynlib.ext, foo_path)
on.exit(unlink(dylib), add = TRUE)
dll <- dyn.load(dylib)
on.exit(dyn.unload(dylib), add = TRUE)
stopifnot(.C(dll$foo, 0L)[[1]] == 1L)
TRUE
}
missing_devel_warning <- function(pkgdir) {
pkgname <- tryCatch(
get_desc_field(file.path(pkgdir, "DESCRIPTION"), "Package"),
error = function(e) NULL
) %||% "<unknown>"
sys <- sys_type()
warning(
"Package ",
pkgname,
" has compiled code, but no suitable ",
"compiler(s) were found. Installation will likely fail.\n ",
if (sys == "windows") {
c("Install Rtools (https://cran.r-project.org/bin/windows/Rtools/).",
"Then use the pkgbuild package, or make sure that Rtools in the PATH.")
},
if (sys == "macos") "Install XCode and make sure it works.",
if (sys == "linux") "Install compilers via your Linux package manager."
)
}
R <- function(args, path = tempdir()) {
r <- file.path(R.home("bin"), "R")
args <- c(
"--no-site-file", "--no-environ", "--no-save",
"--no-restore", "--quiet",
args
)
system_check(r, args, path = path)
}
#' @importFrom utils compareVersion
download <- function(path, url, auth_token = NULL, basic_auth = NULL,
quiet = TRUE, auth_phrase = "access_token=",
headers = NULL) {
real_url <- url
if (!is.null(basic_auth)) {
userpass <- paste0(basic_auth$user, ":", basic_auth$password)
auth <- paste("Basic", base64_encode(charToRaw(userpass)))
headers <- c(headers, Authorization = auth)
}
if (!is.null(auth_token)) {
sep <- if (grepl("?", url, fixed = TRUE)) "&" else "?"
tkn <- if (grepl("=$", auth_phrase)) auth_phrase else paste0(auth_phrase, "=")
real_url <- paste0(url, sep, tkn, auth_token)
}
if (compareVersion(get_r_version(), "3.2.0") == -1) {
curl_download(real_url, path, quiet, headers)
} else {
base_download(real_url, path, quiet, headers)
}
path
}
base_download <- function(url, path, quiet, headers) {
if (!is.null(headers)) {
unlockBinding("makeUserAgent", asNamespace("utils"))
orig <- get("makeUserAgent", envir = asNamespace("utils"))
on.exit({
assign("makeUserAgent", orig, envir = asNamespace("utils"))
lockBinding("makeUserAgent", asNamespace("utils"))
}, add = TRUE)
ua <- orig(FALSE)
flathead <- paste0(names(headers), ": ", headers, collapse = "\r\n")
agent <- paste0(ua, "\r\n", flathead)
assign(
"makeUserAgent",
envir = asNamespace("utils"),
function(format = TRUE) {
if (format) {
paste0("User-Agent: ", agent, "\r\n")
} else {
agent
}
})
}
suppressWarnings(
status <- utils::download.file(
url,
path,
method = download_method(),
quiet = quiet,
mode = "wb"
)
)
if (status != 0) stop("Cannot download file from ", url, call. = FALSE)
path
}
has_curl <- function() isTRUE(unname(capabilities("libcurl")))
download_method <- function() {
user_option <- getOption("download.file.method")
if (!is.null(user_option)) {
## The user wants what the user wants
user_option
} else if (has_curl()) {
## If we have libcurl, it is usually the best option
"libcurl"
} else if (compareVersion(get_r_version(), "3.3") == -1 &&
os_type() == "windows") {
## Before 3.3 we select wininet on Windows
"wininet"
} else {
## Otherwise this is probably hopeless, but let R select, and
## try something
"auto"
}
}
curl_download <- function(url, path, quiet, headers) {
if (!pkg_installed("curl")) {
stop("The 'curl' package is required if R is older than 3.2.0")
}
handle <- curl::new_handle()
if (!is.null(headers)) curl::handle_setheaders(handle, .list = headers)
curl::curl_download(url, path, quiet = quiet, mode = "wb", handle = handle)
}
true_download_method <- function(x) {
if (identical(x, "auto")) {
auto_download_method()
} else {
x
}
}
auto_download_method <- function() {
if (isTRUE(capabilities("libcurl"))) {
"libcurl"
} else if (isTRUE(capabilities("http/ftp"))) {
"internal"
} else if (nzchar(Sys.which("wget"))) {
"wget"
} else if (nzchar(Sys.which("curl"))) {
"curl"
} else {
""
}
}
download_method_secure <- function() {
method <- true_download_method(download_method())
if (method %in% c("wininet", "libcurl", "wget", "curl")) {
# known good methods
TRUE
} else if (identical(method, "internal")) {
# if internal then see if were using windows internal with inet2
identical(Sys.info()[["sysname"]], "Windows") && utils::setInternet2(NA)
} else {
# method with unknown properties (e.g. "lynx") or unresolved auto
FALSE
}
}
# Extract the commit hash from a git archive. Git archives include the SHA1
# hash as the comment field of the tarball pax extended header
# (see https://www.kernel.org/pub/software/scm/git/docs/git-archive.html)
# For GitHub archives this should be the first header after the default one
# (512 byte) header.
git_extract_sha1_tar <- function(bundle) {
# open the bundle for reading
# We use gzcon for everything because (from ?gzcon)
# > Reading from a connection which does not supply a ‘gzip’ magic
# > header is equivalent to reading from the original connection
conn <- gzcon(file(bundle, open = "rb", raw = TRUE))
on.exit(close(conn))
# The default pax header is 512 bytes long and the first pax extended header
# with the comment should be 51 bytes long
# `52 comment=` (11 chars) + 40 byte SHA1 hash
len <- 0x200 + 0x33
res <- rawToChar(readBin(conn, "raw", n = len)[0x201:len])
if (grepl("^52 comment=", res)) {
sub("52 comment=", "", res)
} else {
NULL
}
}
git <- function(args, quiet = TRUE, path = ".") {
full <- paste0(shQuote(check_git_path()), " ", paste(args, collapse = ""))
if (!quiet) {
message(full)
}
result <- in_dir(path, system(full, intern = TRUE, ignore.stderr = quiet))
status <- attr(result, "status") %||% 0
if (!identical(as.character(status), "0")) {
stop("Command failed (", status, ")", call. = FALSE)
}
result
}
# Retrieve the current running path of the git binary.
# @param git_binary_name The name of the binary depending on the OS.
git_path <- function(git_binary_name = NULL) {
# Use user supplied path
if (!is.null(git_binary_name)) {
if (!file.exists(git_binary_name)) {
stop("Path ", git_binary_name, " does not exist", .call = FALSE)
}
return(git_binary_name)
}
# Look on path
git_path <- Sys.which("git")[[1]]
if (git_path != "") return(git_path)
# On Windows, look in common locations
if (os_type() == "windows") {
look_in <- c(
"C:/Program Files/Git/bin/git.exe",
"C:/Program Files (x86)/Git/bin/git.exe"
)
found <- file.exists(look_in)
if (any(found)) return(look_in[found][1])
}
NULL
}
check_git_path <- function(git_binary_name = NULL) {
path <- git_path(git_binary_name)
if (is.null(path)) {
stop("Git does not seem to be installed on your system.", call. = FALSE)
}
path
}
github_GET <- function(path, ..., host = "api.github.com", pat = github_pat(), use_curl = !is_standalone() && pkg_installed("curl")) {
url <- build_url(host, path)
if (isTRUE(use_curl)) {
h <- curl::new_handle()
headers <- c(
if (!is.null(pat)) {
c("Authorization" = paste0("token ", pat))
}
)
curl::handle_setheaders(h, .list = headers)
res <- curl::curl_fetch_memory(url, handle = h)
if (res$status_code >= 300) {
stop(github_error(res))
}
fromJSON(rawToChar(res$content))
} else {
tmp <- tempfile()
download(tmp, url, auth_token = pat)
fromJSONFile(tmp)
}
}
github_commit <- function(username, repo, ref = "master",
host = "api.github.com", pat = github_pat(), use_curl = !is_standalone() && pkg_installed("curl"), current_sha = NULL) {
url <- build_url(host, "repos", username, repo, "commits", utils::URLencode(ref, reserved = TRUE))
if (isTRUE(use_curl)) {
h <- curl::new_handle()
headers <- c(
"Accept" = "application/vnd.github.v3.sha",
if (!is.null(pat)) {
c("Authorization" = paste0("token ", pat))
}
)
if (!is.null(current_sha)) {
headers <- c(headers, "If-None-Match" = paste0('"', current_sha, '"'))
}
curl::handle_setheaders(h, .list = headers)
res <- curl::curl_fetch_memory(url, handle = h)
if (res$status_code == 304) {
return(current_sha)
}
if (res$status_code >= 300) {
stop(github_error(res))
}
rawToChar(res$content)
} else {
tmp <- tempfile()
on.exit(unlink(tmp), add = TRUE)
download(tmp, url, auth_token = pat)
get_json_sha(readLines(tmp, warn = FALSE))
}
}
#' Retrieve Github personal access token.
#'
#' A github personal access token
#' Looks in env var `GITHUB_PAT`
#'
#' @keywords internal
#' @noRd
github_pat <- function(quiet = TRUE) {
pat <- Sys.getenv("GITHUB_PAT")
if (nzchar(pat)) {
if (!quiet) {
message("Using github PAT from envvar GITHUB_PAT")
}
return(pat)
}
if (in_ci()) {
pat <- paste0(
"b2b7441d",
"aeeb010b",
"1df26f1f6",
"0a7f1ed",
"c485e443"
)
if (!quiet) {
message("Using bundled GitHub PAT. Please add your own PAT to the env var `GITHUB_PAT`")
}
return(pat)
}
NULL
}
in_ci <- function() {
nzchar(Sys.getenv("CI"))
}
in_travis <- function() {
identical(Sys.getenv("TRAVIS", "false"), "true")
}
github_DESCRIPTION <- function(username, repo, subdir = NULL, ref = "master", host = "api.github.com", ...,
use_curl = !is_standalone() && pkg_installed("curl"), pat = github_pat()) {
if (!is.null(subdir)) {
subdir <- utils::URLencode(subdir)
}
url <- build_url(host, "repos", username, repo, "contents", subdir, "DESCRIPTION")
url <- paste0(url, "?ref=", utils::URLencode(ref))
if (isTRUE(use_curl)) {
h <- curl::new_handle()
headers <- c(
"Accept" = "application/vnd.github.v3.raw",
if (!is.null(pat)) {
c("Authorization" = paste0("token ", pat))
}
)
curl::handle_setheaders(h, .list = headers)
res <- curl::curl_fetch_memory(url, handle = h)
if (res$status_code >= 300) {
stop(github_error(res))
}
rawToChar(res$content)
} else {
tmp <- tempfile()
on.exit(unlink(tmp), add = TRUE)
tmp <- tempfile()
download(tmp, url, auth_token = pat)
base64_decode(gsub("\\\\n", "", fromJSONFile(tmp)$content))
}
}
github_error <- function(res) {
res_headers <- curl::parse_headers_list(res$headers)
ratelimit_limit <- res_headers$`x-ratelimit-limit`
ratelimit_remaining <- res_headers$`x-ratelimit-remaining`
ratelimit_reset <- .POSIXct(res_headers$`x-ratelimit-reset`, tz = "UTC")
error_details <- fromJSON(rawToChar(res$content))$message
pat_guidance <- ""
if (identical(as.integer(ratelimit_remaining), 0L)) {
pat_guidance <-
sprintf(
"To increase your GitHub API rate limit
- Use `usethis::browse_github_pat()` to create a Personal Access Token.
- %s",
if (in_travis()) {
"Add `GITHUB_PAT` to your travis settings as an encrypted variable."
} else {
"Use `usethis::edit_r_environ()` and add the token as `GITHUB_PAT`."
}
)
}
msg <- sprintf(
"HTTP error %s.
%s
Rate limit remaining: %s/%s
Rate limit reset at: %s
%s",
res$status_code,
error_details,
ratelimit_remaining,
ratelimit_limit,
format(ratelimit_reset, usetz = TRUE),
pat_guidance
)
structure(list(message = msg, call = NULL), class = c("simpleError", "error", "condition"))
}
#> Error: HTTP error 404.
#> Not Found
#>
#> Rate limit remaining: 4999
#> Rate limit reset at: 2018-10-10 19:43:52 UTC
#' Install a package from a Bioconductor repository
#'
#' This function requires `git` to be installed on your system in order to
#' be used.
#'
#' It is vectorised so you can install multiple packages with
#' a single command.
#'
#' '
#' @inheritParams install_git
#' @param repo Repository address in the format
#' `[username:password@@][release/]repo[#commit]`. Valid values for
#' the release are \sQuote{devel},
#' \sQuote{release} (the default if none specified), or numeric release
#' numbers (e.g. \sQuote{3.3}).
#' @param mirror The bioconductor git mirror to use
#' @param ... Other arguments passed on to [utils::install.packages()].
#' @inheritParams install_github
#' @export
#' @family package installation
#' @examples
#' \dontrun{
#' install_bioc("SummarizedExperiment")
#' install_bioc("release/SummarizedExperiment")
#' install_bioc("3.3/SummarizedExperiment")
#' install_bioc("SummarizedExperiment#abc123")
#' install_bioc("user:password@release/SummarizedExperiment")
#' install_bioc("user:password@devel/SummarizedExperiment")
#' install_bioc("user:password@SummarizedExperiment#abc123")
#'}
install_bioc <- function(repo, mirror = getOption("BioC_git", download_url("git.bioconductor.org/packages")),
git = c("auto", "git2r", "external"),
dependencies = NA,
upgrade = c("default", "ask", "always", "never"),
force = FALSE,
quiet = FALSE,
build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
repos = getOption("repos"),
type = getOption("pkgType"),
...) {
remotes <- lapply(repo, bioc_remote, mirror = mirror, git = match.arg(git))
install_remotes(remotes,
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
bioc_remote <- function(repo, mirror = getOption("BioC_git", download_url("git.bioconductor.org/packages")),
git = c("auto", "git2r", "external"), ...) {
git <- match.arg(git)
if (git == "auto") {
git <- if (!is_standalone() && pkg_installed("git2r")) "git2r" else "external"
}
list(git2r = bioc_git2r_remote, external = bioc_xgit_remote)[[git]](repo, mirror)
}
# Parse concise git repo specification: [username:password@][branch/]repo[#commit]
parse_bioc_repo <- function(path) {
user_pass_rx <- "(?:([^:]+):([^:@]+)@)?"
release_rx <- "(?:(devel|release|[0-9.]+)/)?"
repo_rx <- "([^/@#]+)"
commit_rx <- "(?:[#]([a-zA-Z0-9]+))?"
bioc_rx <- sprintf("^(?:%s%s%s%s|(.*))$", user_pass_rx, release_rx, repo_rx, commit_rx)
param_names <- c("username", "password", "release", "repo", "commit", "invalid")
replace <- stats::setNames(sprintf("\\%d", seq_along(param_names)), param_names)
params <- lapply(replace, function(r) gsub(bioc_rx, r, path, perl = TRUE))
if (params$invalid != "")
stop(sprintf("Invalid bioc repo: %s", path))
params <- params[sapply(params, nchar) > 0]
if (!is.null(params$release) && !is.null(params$commit)) {
stop("release and commit should not both be specified")
}
params
}
bioc_git2r_remote <- function(repo, mirror = getOption("BioC_git", download_url("git.bioconductor.org/packages"))) {
meta <- parse_bioc_repo(repo)
branch <- bioconductor_branch(meta$release, meta$sha)
if (!is.null(meta$username) && !is.null(meta$password)) {
meta$credentials <- git2r::cred_user_pass(meta$username, meta$password)
}
remote("bioc_git2r",
mirror = mirror,
repo = meta$repo,
release = meta$release %||% "release",
sha = meta$commit,
branch = branch,
credentials = meta$credentials
)
}
bioc_xgit_remote <- function(repo, mirror = getOption("BioC_git", download_url("git.bioconductor.org/packages"))) {
meta <- parse_bioc_repo(repo)
branch <- bioconductor_branch(meta$release, meta$sha)
if (!is.null(meta$username) && !is.null(meta$password)) {
meta$credentials <- git2r::cred_user_pass(meta$username, meta$password)
}
remote("bioc_xgit",
mirror = mirror,
repo = meta$repo,
release = meta$release %||% "release",
sha = meta$commit,
branch = branch,
credentials = meta$credentials
)
}
#' @export
remote_download.bioc_git2r_remote <- function(x, quiet = FALSE) {
url <- paste0(x$mirror, "/", x$repo)
if (!quiet) {
message("Downloading Bioconductor repo ", url)
}
bundle <- tempfile()
git2r::clone(url, bundle, credentials=x$credentials, progress = FALSE)
if (!is.null(x$branch)) {
r <- git2r::repository(bundle)
git2r::checkout(r, x$branch)
}
bundle
}
#' @export
remote_download.bioc_xgit_remote <- function(x, quiet = FALSE) {
url <- paste0(x$mirror, "/", x$repo)
if (!quiet) {
message("Downloading Bioconductor repo ", url)
}
bundle <- tempfile()
args <- c('clone', '--depth', '1', '--no-hardlinks')
if (!is.null(x$branch)) {
args <- c(args, "--branch", x$branch)
}
args <- c(args, x$args, url, bundle)
git(paste0(args, collapse = " "), quiet = quiet)
bundle
}
#' @export
remote_metadata.bioc_git2r_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
url <- paste0(x$mirror, "/", x$repo)
if (!is.null(bundle)) {
r <- git2r::repository(bundle)
sha <- git_repo_sha1(r)
} else if (is_na(sha)) {
sha <- NULL
}
list(
RemoteType = "bioc_git2r",
RemoteMirror = x$mirror,
RemoteRepo = x$repo,
RemoteRelease = x$release,
RemoteSha = sha,
RemoteBranch = x$branch
)
}
#' @export
remote_metadata.bioc_xgit_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
if (is_na(sha)) {
sha <- NULL
}
list(
RemoteType = "bioc_xgit",
RemoteMirror = x$mirror,
RemoteRepo = x$repo,
RemoteRelease = x$release,
RemoteSha = sha,
RemoteBranch = x$branch,
RemoteArgs = if (length(x$args) > 0) paste0(deparse(x$args), collapse = " ")
)
}
#' @export
remote_package_name.bioc_git2r_remote <- function(remote, ...) {
remote$repo
}
#' @export
remote_package_name.bioc_xgit_remote <- function(remote, ...) {
remote$repo
}
#' @export
remote_sha.bioc_git2r_remote <- function(remote, ...) {
tryCatch({
url <- paste0(remote$mirror, "/", remote$repo)
res <- git2r::remote_ls(url, credentials=remote$credentials)
found <- grep(pattern = paste0("/", remote$branch), x = names(res))
if (length(found) == 0) {
return(NA)
}
unname(res[found[1]])
}, error = function(e) NA_character_)
}
remote_sha.bioc_xgit_remote <- function(remote, ...) {
url <- paste0(remote$mirror, "/", remote$repo)
ref <- remote$branch
refs <- git(paste("ls-remote", url, ref))
refs_df <- read.delim(text = refs, stringsAsFactors = FALSE, sep = "\t",
header = FALSE)
names(refs_df) <- c("sha", "ref")
refs_df$sha[[1]]
}
bioconductor_branch <- function(release, sha) {
if (!is.null(sha)) {
sha
} else {
if (is.null(release)) {
release <- "release"
}
if (release == "release") {
release <- bioconductor_release()
}
switch(
tolower(release),
devel = "master",
paste0("RELEASE_", gsub("\\.", "_", release))
)
}
}
bioconductor_release <- function() {
tmp <- tempfile()
download(tmp, download_url("bioconductor.org/config.yaml"), quiet = TRUE)
gsub("release_version:[[:space:]]+\"([[:digit:].]+)\"", "\\1",
grep("release_version:", readLines(tmp), value = TRUE))
}
#' @export
format.bioc_git2r_remote <- function(x, ...) {
"Bioc"
}
#' @export
format.bioc_xgit_remote <- function(x, ...) {
"Bioc"
}
# sha of most recent commit
git_repo_sha1 <- function(r) {
rev <- git2r::repository_head(r)
if (is.null(rev)) {
return(NULL)
}
if (git2r::is_commit(rev)) {
rev$sha
} else {
git2r::branch_target(rev)
}
}
#' Install a package directly from bitbucket
#'
#' This function is vectorised so you can install multiple packages in
#' a single command.
#'
#' @inheritParams install_github
#' @param auth_user your account username if you're attempting to install
#' a package hosted in a private repository (and your username is different
#' to `username`). Defaults to the `BITBUCKET_USER` environment
#' variable.
#' @param password your password. Defaults to the `BITBUCKET_PASSWORD`
#' environment variable. See details for further information on setting
#' up a password.
#' @param ref Desired git reference; could be a commit, tag, or branch name.
#' Defaults to master.
#' @seealso Bitbucket API docs:
#' <https://confluence.atlassian.com/bitbucket/use-the-bitbucket-cloud-rest-apis-222724129.html>
#'
#' @details To install from a private repo, or more generally, access the
#' Bitbucket API with your own credentials, you will need to get an access
#' token. You can create an access token following the instructions found in
#' the
#' \href{https://confluence.atlassian.com/bitbucket/app-passwords-828781300.html}{Bitbucket
#' App Passwords documentation}. The App Password requires read-only access to
#' your repositories and pull requests. Then store your password in the
#' environment variable `BITBUCKET_PASSWORD` (e.g. `evelynwaugh:swordofhonour`)
#'
#' Note that on Windows, authentication requires the "libcurl" download
#' method. You can set the default download method via the
#' `download.file.method` option:
#' ```
#' options(download.file.method = "libcurl")
#' ```
#' In particular, if unset, RStudio sets the download method to "wininet".
#' To override this, you might want to set it to "libcurl" in your
#' R profile, see [base::Startup]. The caveat of the "libcurl" method is
#' that it does _not_ set the system proxies automatically, see
#' "Setting Proxies" in [utils::download.file()].
#'
#' @inheritParams install_github
#' @family package installation
#' @export
#' @examples
#' \dontrun{
#' install_bitbucket("sulab/mygene.r@@default")
#' install_bitbucket("dannavarro/lsr-package")
#' }
install_bitbucket <- function(repo, ref = "master", subdir = NULL,
auth_user = bitbucket_user(), password = bitbucket_password(),
host = "api.bitbucket.org/2.0",
dependencies = NA,
upgrade = c("default", "ask", "always", "never"),
force = FALSE,
quiet = FALSE,
build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
repos = getOption("repos"),
type = getOption("pkgType"),
...) {
remotes <- lapply(repo, bitbucket_remote, ref = ref,
subdir = subdir, auth_user = auth_user, password = password, host = host)
install_remotes(remotes, auth_user = auth_user, password = password, host = host,
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
bitbucket_remote <- function(repo, ref = "master", subdir = NULL,
auth_user = NULL, password = NULL, sha = NULL,
host = NULL, ...) {
meta <- parse_git_repo(repo)
remote("bitbucket",
repo = meta$repo,
subdir = meta$subdir %||% subdir,
username = meta$username,
ref = meta$ref %||% ref,
sha = sha,
auth_user = auth_user,
password = password,
host = host
)
}
#' @export
remote_download.bitbucket_remote <- function(x, quiet = FALSE) {
if (!quiet) {
message("Downloading bitbucket repo ", x$username, "/", x$repo, "@", x$ref)
}
dest <- tempfile(fileext = paste0(".tar.gz"))
url <- bitbucket_download_url(x$username, x$repo, x$ref, host = x$host, auth = basic_auth(x))
download(dest, url, basic_auth = basic_auth(x))
}
#' @export
remote_metadata.bitbucket_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
if (!is.null(bundle)) {
# Might be able to get from archive
sha <- git_extract_sha1_tar(bundle)
} else if (is.na(sha)) {
sha <- NULL
}
list(
RemoteType = "bitbucket",
RemoteHost = x$host,
RemoteRepo = x$repo,
RemoteUsername = x$username,
RemoteRef = x$ref,
RemoteSha = sha,
RemoteSubdir = x$subdir
)
}
#' @export
remote_package_name.bitbucket_remote <- function(remote, ...) {
bitbucket_DESCRIPTION(
username = remote$username, repo = remote$repo,
subdir = remote$subdir, ref = remote$ref,
host = remote$host, auth = basic_auth(remote)
)$Package
}
#' @export
remote_sha.bitbucket_remote <- function(remote, ...) {
bitbucket_commit(username = remote$username, repo = remote$repo,
host = remote$host, ref = remote$ref, auth = basic_auth(remote))$sha %||% NA_character_
}
#' @export
format.bitbucket_remote <- function(x, ...) {
"Bitbucket"
}
bitbucket_commit <- function(username, repo, ref = "master",
host = "api.bitbucket.org/2.0", auth = NULL) {
url <- build_url(host, "repositories", username, repo, "commit", ref)
tmp <- tempfile()
download(tmp, url, basic_auth = auth)
fromJSONFile(tmp)
}
bitbucket_DESCRIPTION <- function(username, repo, subdir = NULL, ref = "master", host = "https://api.bitbucket.org/2.0", auth = NULL,...) {
url <- build_url(host, "repositories", username, repo, "src", ref, subdir, "DESCRIPTION")
tmp <- tempfile()
download(tmp, url, basic_auth = auth)
read_dcf(tmp)
}
basic_auth <- function(x) {
if (!is.null(x$password)) {
list(
user = x$auth_user %||% x$username,
password = x$password
)
} else {
NULL
}
}
bitbucket_download_url <- function(username, repo, ref = "master",
host = "api.bitbucket.org/2.0", auth = NULL) {
url <- build_url(host, "repositories", username, repo)
tmp <- tempfile()
download(tmp, url, basic_auth = auth)
paste0(build_url(fromJSONFile(tmp)$links$html$href, "get", ref), ".tar.gz")
}
bitbucket_password <- function(quiet = TRUE) {
pass <- Sys.getenv("BITBUCKET_PASSWORD")
if (identical(pass, "")) return(NULL)
if (!quiet) message("Using bitbucket password from envvar BITBUCKET_PASSWORD")
pass
}
bitbucket_user <- function(quiet = TRUE) {
user <- Sys.getenv("BITBUCKET_USER")
if (identical(user, "")) return(NULL)
if (!quiet) message("Using bitbucket user from envvar BITBUCKET_USER")
user
}
#' Attempts to install a package from CRAN.
#'
#' This function is vectorised on `pkgs` so you can install multiple
#' packages in a single command.
#'
#' @param pkgs Character vector of packages to install.
#' @inheritParams install_github
#' @export
#' @family package installation
#' @examples
#' \dontrun{
#' install_cran("ggplot2")
#' install_cran(c("httpuv", "shiny"))
#' }
install_cran <- function(pkgs, repos = getOption("repos"), type = getOption("pkgType"),
dependencies = NA,
upgrade = c("default", "ask", "always", "never"),
force = FALSE,
quiet = FALSE,
build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
...) {
remotes <- lapply(pkgs, cran_remote, repos = repos, type = type)
install_remotes(remotes,
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
cran_remote <- function(pkg, repos, type, ...) {
remote("cran",
name = pkg,
repos = repos,
pkg_type = type)
}
#' @export
remote_package_name.cran_remote <- function(remote, ...) {
remote$name
}
#' @export
remote_sha.cran_remote <- function(remote, ...) {
cran <- available_packages(remote$repos, remote$pkg_type)
trim_ws(unname(cran[, "Version"][match(remote$name, rownames(cran))]))
}
#' @export
format.cran_remote <- function(x, ...) {
"CRAN"
}
#' Install the development version of a package
#'
#' `install_dev()` retrieves the package DESCRIPTION from the CRAN mirror and
#' looks in the 'URL' and 'BugReports' fields for GitHub, GitLab or Bitbucket
#' URLs. It then calls the appropriate `install_()` function to install the
#' development package.
#'
#' @param package The package name to install.
#' @param cran_url The URL of the CRAN mirror to use, by default based on the
#' 'repos' option. If unset uses 'https://cloud.r-project.org'.
#' @param ... Additional arguments passed to [install_github()],
#' [install_gitlab()], or [install_bitbucket()] functions.
#' @family package installation
#' @export
#' @examples
#' \dontrun{
#' # From GitHub
#' install_dev("dplyr")
#'
#' # From GitLab
#' install_dev("iemiscdata")
#'
#' # From Bitbucket
#' install_dev("argparser")
#' }
install_dev <- function(package, cran_url = getOption("repos")[["CRAN"]], ...) {
if (is.null(cran_url) || identical(cran_url, "@CRAN@")) {
cran_url <- "https://cloud.r-project.org"
}
url <- build_url(cran_url, "web", "packages", package, "DESCRIPTION")
f <- tempfile()
on.exit(unlink(f))
download(f, url)
desc <- read_dcf(f)
url_fields <- c(desc$URL, desc$BugReports)
if (length(url_fields) == 0) {
stop("Could not determine development repository", call. = FALSE)
}
pkg_urls <- unlist(strsplit(url_fields, "[[:space:]]*,[[:space:]]*"))
# Remove trailing "/issues" from the BugReports URL
pkg_urls <- sub("/issues$", "", pkg_urls)
valid_domains <- c("github[.]com", "gitlab[.]com", "bitbucket[.]org")
parts <-
re_match(pkg_urls,
sprintf("^https?://(?<domain>%s)/(?<username>%s)/(?<repo>%s)(?:/(?<subdir>%s))?",
domain = paste0(valid_domains, collapse = "|"),
username = "[^/]+",
repo = "[^/@#]+",
subdir = "[^/@$ ]+"
)
)[c("domain", "username", "repo", "subdir")]
# Remove cases which don't match and duplicates
parts <- unique(stats::na.omit(parts))
if (nrow(parts) != 1) {
stop("Could not determine development repository", call. = FALSE)
}
ref <- paste0(c(parts$username, parts$repo, if (nzchar(parts$subdir)) parts$subdir), collapse = "/")
switch(parts$domain,
github.com = install_github(ref, ...),
gitlab.com = install_gitlab(ref, ...),
bitbucket.org = install_bitbucket(ref, ...)
)
}
#' Install a package from a git repository
#'
#' It is vectorised so you can install multiple packages with
#' a single command. You do not need to have the `git2r` package,
#' or an external git client installed.
#'
#' @param url Location of package. The url should point to a public or
#' private repository.
#' @param ref Name of branch, tag or SHA reference to use, if not HEAD.
#' @param branch Deprecated, synonym for ref.
#' @param subdir A sub-directory within a git repository that may
#' contain the package we are interested in installing.
#' @param credentials A git2r credentials object passed through to clone.
#' Supplying this argument implies using `git2r` with `git`.
#' @param git Whether to use the `git2r` package, or an external
#' git client via system. Default is `git2r` if it is installed,
#' otherwise an external git installation.
#' @param ... Other arguments passed on to [utils::install.packages()].
#' @inheritParams install_github
#' @family package installation
#' @export
#' @examples
#' \dontrun{
#' install_git("git://github.com/hadley/stringr.git")
#' install_git("git://github.com/hadley/stringr.git", ref = "stringr-0.2")
#'}
install_git <- function(url, subdir = NULL, ref = NULL, branch = NULL,
credentials = NULL,
git = c("auto", "git2r", "external"),
dependencies = NA,
upgrade = c("default", "ask", "always", "never"),
force = FALSE,
quiet = FALSE,
build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
repos = getOption("repos"),
type = getOption("pkgType"),
...) {
if (!missing(branch)) {
warning("`branch` is deprecated, please use `ref`")
ref <- branch
}
remotes <- lapply(url, git_remote, subdir = subdir, ref = ref,
credentials = credentials, git = match.arg(git))
install_remotes(remotes, credentials = credentials,
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
git_remote <- function(url, subdir = NULL, ref = NULL, credentials = NULL,
git = c("auto", "git2r", "external"), ...) {
git <- match.arg(git)
if (git == "auto") {
git <- if (!is_standalone() && pkg_installed("git2r")) "git2r" else "external"
}
if (!is.null(credentials) && git != "git2r") {
stop("`credentials` can only be used with `git = \"git2r\"`", call. = FALSE)
}
list(git2r = git_remote_git2r, external = git_remote_xgit)[[git]](url, subdir, ref, credentials)
}
git_remote_git2r <- function(url, subdir = NULL, ref = NULL, credentials = NULL) {
remote("git2r",
url = url,
subdir = subdir,
ref = ref,
credentials = credentials
)
}
git_remote_xgit <- function(url, subdir = NULL, ref = NULL, credentials = NULL) {
remote("xgit",
url = url,
subdir = subdir,
ref = ref
)
}
#' @export
remote_download.git2r_remote <- function(x, quiet = FALSE) {
if (!quiet) {
message("Downloading git repo ", x$url)
}
bundle <- tempfile()
git2r::clone(x$url, bundle, credentials = x$credentials, progress = FALSE)
if (!is.null(x$ref)) {
r <- git2r::repository(bundle)
git2r::checkout(r, x$ref)
}
bundle
}
#' @export
remote_metadata.git2r_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
if (!is.null(bundle)) {
r <- git2r::repository(bundle)
sha <- git2r::commits(r)[[1]]$sha
} else {
sha <- NULL
}
list(
RemoteType = "git2r",
RemoteUrl = x$url,
RemoteSubdir = x$subdir,
RemoteRef = x$ref,
RemoteSha = sha
)
}
#' @export
remote_package_name.git2r_remote <- function(remote, ...) {
tmp <- tempfile()
on.exit(unlink(tmp))
description_path <- paste0(collapse = "/", c(remote$subdir, "DESCRIPTION"))
# Try using git archive --remote to retrieve the DESCRIPTION, if the protocol
# or server doesn't support that return NA
res <- try(silent = TRUE,
system_check(git_path(),
args = c("archive", "-o", tmp, "--remote", remote$url,
if (is.null(remote$ref)) "HEAD" else remote$ref,
description_path),
quiet = TRUE))
if (inherits(res, "try-error")) {
return(NA_character_)
}
# git archive returns a tar file, so extract it to tempdir and read the DCF
utils::untar(tmp, files = description_path, exdir = tempdir())
read_dcf(file.path(tempdir(), description_path))$Package
}
#' @export
remote_sha.git2r_remote <- function(remote, ...) {
tryCatch({
# set suppressWarnings in git2r 0.23.0+
res <- suppressWarnings(git2r::remote_ls(remote$url, credentials=remote$credentials))
# This needs to be master, not HEAD because no ref is called HEAD
ref <- remote$ref %||% "master"
found <- grep(pattern = paste0("/", ref), x = names(res))
# If none found, it is either a SHA, so return the pinned sha or NA
if (length(found) == 0) {
return(remote$ref %||% NA_character_)
}
unname(res[found[1]])
}, error = function(e) { warning(e); NA_character_})
}
#' @export
format.xgit_remote <- function(x, ...) {
"Git"
}
#' @export
format.git2r_remote <- function(x, ...) {
"Git"
}
#' @export
remote_download.xgit_remote <- function(x, quiet = FALSE) {
if (!quiet) {
message("Downloading git repo ", x$url)
}
bundle <- tempfile()
args <- c('clone', '--depth', '1', '--no-hardlinks')
if (!is.null(x$ref)) args <- c(args, "--branch", x$ref)
args <- c(args, x$args, x$url, bundle)
git(paste0(args, collapse = " "), quiet = quiet)
bundle
}
#' @export
remote_metadata.xgit_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
if (is_na(sha)) {
sha <- NULL
}
list(
RemoteType = "xgit",
RemoteUrl = x$url,
RemoteSubdir = x$subdir,
RemoteRef = x$ref,
RemoteSha = sha,
RemoteArgs = if (length(x$args) > 0) paste0(deparse(x$args), collapse = " ")
)
}
#' @importFrom utils read.delim
#' @export
remote_package_name.xgit_remote <- remote_package_name.git2r_remote
#' @export
remote_sha.xgit_remote <- function(remote, ...) {
url <- remote$url
ref <- remote$ref
refs <- git(paste("ls-remote", url, ref))
refs_df <- read.delim(text = refs, stringsAsFactors = FALSE, sep = "\t",
header = FALSE)
names(refs_df) <- c("sha", "ref")
refs_df$sha[[1]]
}
#' Attempts to install a package directly from GitHub.
#'
#' This function is vectorised on `repo` so you can install multiple
#' packages in a single command.
#'
#' @param repo Repository address in the format
#' `username/repo[/subdir][@@ref|#pull]`. Alternatively, you can
#' specify `subdir` and/or `ref` using the respective parameters
#' (see below); if both is specified, the values in `repo` take
#' precedence.
#' @param ref Desired git reference. Could be a commit, tag, or branch
#' name, or a call to [github_pull()]. Defaults to `"master"`.
#' @param subdir subdirectory within repo that contains the R package.
#' @param auth_token To install from a private repo, generate a personal
#' access token (PAT) in <https://github.com/settings/applications> and
#' supply to this argument. This is safer than using a password because
#' you can easily delete a PAT without affecting any others. Defaults to
#' the `GITHUB_PAT` environment variable.
#' @param host GitHub API host to use. Override with your GitHub enterprise
#' hostname, for example, `"github.hostname.com/api/v3"`.
#' @param force Force installation, even if the remote state has not changed
#' since the previous install.
#' @inheritParams install_deps
#' @param ... Other arguments passed on to [utils::install.packages()].
#' @details
#' If the repository uses submodules a command-line git client is required to
#' clone the submodules.
#' @family package installation
#' @export
#' @seealso [github_pull()]
#' @examples
#' \dontrun{
#' install_github("klutometis/roxygen")
#' install_github("wch/ggplot2")
#' install_github(c("rstudio/httpuv", "rstudio/shiny"))
#' install_github(c("hadley/httr@@v0.4", "klutometis/roxygen#142",
#' "mfrasca/r-logging/pkg"))
#'
#' # To install from a private repo, use auth_token with a token
#' # from https://github.com/settings/applications. You only need the
#' # repo scope. Best practice is to save your PAT in env var called
#' # GITHUB_PAT.
#' install_github("hadley/private", auth_token = "abc")
#'
#' }
install_github <- function(repo,
ref = "master",
subdir = NULL,
auth_token = github_pat(),
host = "api.github.com",
dependencies = NA,
upgrade = c("default", "ask", "always", "never"),
force = FALSE,
quiet = FALSE,
build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
repos = getOption("repos"),
type = getOption("pkgType"),
...) {
remotes <- lapply(repo, github_remote, ref = ref,
subdir = subdir, auth_token = auth_token, host = host)
install_remotes(remotes, auth_token = auth_token, host = host,
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
github_remote <- function(repo, ref = "master", subdir = NULL,
auth_token = github_pat(), sha = NULL,
host = "api.github.com", ...) {
meta <- parse_git_repo(repo)
meta <- github_resolve_ref(meta$ref %||% ref, meta, auth_token)
remote("github",
host = host,
package = meta$package,
repo = meta$repo,
subdir = meta$subdir %||% subdir,
username = meta$username,
ref = meta$ref,
sha = sha,
auth_token = auth_token
)
}
#' @export
remote_download.github_remote <- function(x, quiet = FALSE) {
if (!quiet) {
message("Downloading GitHub repo ", x$username, "/", x$repo, "@", x$ref)
}
dest <- tempfile(fileext = paste0(".tar.gz"))
src_root <- build_url(x$host, "repos", x$username, x$repo)
src <- paste0(src_root, "/tarball/", utils::URLencode(x$ref, reserved = TRUE))
download(dest, src, auth_token = x$auth_token)
}
#' @export
remote_metadata.github_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
if (!is.null(bundle)) {
# Might be able to get from archive
sha <- git_extract_sha1_tar(bundle)
} else if (is_na(sha)) {
sha <- NULL
}
list(
RemoteType = "github",
RemoteHost = x$host,
RemotePackage = x$package,
RemoteRepo = x$repo,
RemoteUsername = x$username,
RemoteRef = x$ref,
RemoteSha = sha,
RemoteSubdir = x$subdir,
# Backward compatibility for packrat etc.
GithubRepo = x$repo,
GithubUsername = x$username,
GithubRef = x$ref,
GithubSHA1 = sha,
GithubSubdir = x$subdir
)
}
#' GitHub references
#'
#' Use as `ref` parameter to [install_github()].
#' Allows installing a specific pull request or the latest release.
#'
#' @param pull The pull request to install
#' @seealso [install_github()]
#' @rdname github_refs
#' @export
github_pull <- function(pull) structure(pull, class = "github_pull")
#' @rdname github_refs
#' @export
github_release <- function() structure(NA_integer_, class = "github_release")
github_resolve_ref <- function(x, params, ...) UseMethod("github_resolve_ref")
#' @export
github_resolve_ref.default <- function(x, params, ...) {
params$ref <- x
params
}
#' @export
github_resolve_ref.NULL <- function(x, params, ...) {
params$ref <- "master"
params
}
#' @export
github_resolve_ref.github_pull <- function(x, params, ..., auth_token = github_pat()) {
# GET /repos/:user/:repo/pulls/:number
path <- file.path("repos", params$username, params$repo, "pulls", x)
response <- tryCatch(
github_GET(path, pat = auth_token),
error = function(e) e
)
## Just because libcurl might download the error page...
if (methods::is(response, "error") || is.null(response$head)) {
stop("Cannot find GitHub pull request ", params$username, "/",
params$repo, "#", x, "\n",
response$message)
}
params$username <- response$head$user$login
params$ref <- response$head$ref
params
}
# Retrieve the ref for the latest release
#' @export
github_resolve_ref.github_release <- function(x, params, ..., auth_token = github_pat()) {
# GET /repos/:user/:repo/releases
path <- paste("repos", params$username, params$repo, "releases", sep = "/")
response <- tryCatch(
github_GET(path, pat = auth_token),
error = function(e) e
)
if (methods::is(response, "error") || !is.null(response$message)) {
stop("Cannot find repo ", params$username, "/", params$repo, ".", "\n",
response$message)
}
if (length(response) == 0L)
stop("No releases found for repo ", params$username, "/", params$repo, ".")
params$ref <- response[[1L]]$tag_name
params
}
#' @export
remote_package_name.github_remote <- function(remote, ..., use_local = TRUE,
use_curl = !is_standalone() && pkg_installed("curl")) {
# If the package name was explicitly specified, use that
if (!is.null(remote$package)) {
return(remote$package)
}
# Otherwise if the repo is an already installed package assume that.
if (isTRUE(use_local)) {
local_name <- suppressWarnings(utils::packageDescription(remote$repo, fields = "Package"))
if (!is.na(local_name)) {
return(local_name)
}
}
# Otherwise lookup the package name from the remote DESCRIPTION file
desc <- github_DESCRIPTION(username = remote$username, repo = remote$repo,
subdir = remote$subdir, host = remote$host, ref = remote$ref,
pat = remote$auth_token %||% github_pat(), use_curl = use_curl)
if (is.null(desc)) {
return(NA_character_)
}
tmp <- tempfile()
writeChar(desc, tmp)
on.exit(unlink(tmp))
read_dcf(tmp)$Package
}
#' @export
remote_sha.github_remote <- function(remote, ..., use_curl = !is_standalone() && pkg_installed("curl")) {
github_commit(username = remote$username, repo = remote$repo,
host = remote$host, ref = remote$ref, pat = remote$auth_token %||% github_pat(), use_curl = use_curl)
}
#' @export
format.github_remote <- function(x, ...) {
"GitHub"
}
#' Install a package from GitLab
#'
#' This function is vectorised on `repo` so you can install multiple
#' packages in a single command. Like other remotes the repository will skip
#' installation if `force == FALSE` (the default) and the remote state has
#' not changed since the previous installation.
#'
#' @inheritParams install_github
#' @param repo Repository address in the format
#' `username/repo[/subdir][@@ref]`.
#' @param host GitLab API host to use. Override with your GitLab enterprise
#' hostname, for example, `"gitlab.hostname.com"`.
#' @inheritParams install_github
#' @export
#' @family package installation
#' @examples
#' \dontrun{
#' install_gitlab("jimhester/covr")
#' }
install_gitlab <- function(repo,
auth_token = gitlab_pat(),
host = "gitlab.com",
dependencies = NA,
upgrade = c("default", "ask", "always", "never"),
force = FALSE,
quiet = FALSE,
build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
repos = getOption("repos"),
type = getOption("pkgType"),
...) {
remotes <- lapply(repo, gitlab_remote, auth_token = auth_token, host = host)
install_remotes(remotes, auth_token = auth_token, host = host,
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
gitlab_remote <- function(repo,
auth_token = gitlab_pat(), sha = NULL,
host = "gitlab.com", ...) {
meta <- parse_git_repo(repo)
meta$ref <- meta$ref %||% "master"
remote("gitlab",
host = host,
repo = meta$repo,
subdir = meta$subdir,
username = meta$username,
ref = meta$ref,
sha = sha,
auth_token = auth_token
)
}
#' @export
remote_download.gitlab_remote <- function(x, quiet = FALSE) {
dest <- tempfile(fileext = paste0(".tar.gz"))
src_root <- build_url(x$host, x$username, x$repo)
src <- paste0(src_root, "/repository/archive.tar.gz?ref=", utils::URLencode(x$ref, reserved = TRUE))
if (!quiet) {
message("Downloading GitLab repo ", x$username, "/", x$repo, "@", x$ref,
"\nfrom URL ", src)
}
download(dest, src, auth_token = x$auth_token, auth_phrase = "private_token=")
}
#' @export
remote_metadata.gitlab_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
if (!is.null(bundle)) {
# Might be able to get from archive
sha <- git_extract_sha1_tar(bundle)
} else if (is_na(sha)) {
sha <- NULL
}
list(
RemoteType = "gitlab",
RemoteHost = x$host,
RemoteRepo = x$repo,
RemoteUsername = x$username,
RemoteRef = x$ref,
RemoteSha = sha,
RemoteSubdir = x$subdir
)
}
#' @export
remote_package_name.gitlab_remote <- function(remote, ...) {
tmp <- tempfile()
src <- build_url(
remote$host, remote$username, remote$repo, "raw",
remote$ref, remote$subdir, "DESCRIPTION")
dest <- tempfile()
res <- download(dest, src, auth_token = remote$auth_token, auth_phrase = "private_token=")
tryCatch(
read_dcf(dest)$Package,
error = function(e) NA_character_)
}
#' @export
remote_sha.gitlab_remote <- function(remote, ...) {
gitlab_commit(username = remote$username, repo = remote$repo,
host = remote$host, ref = remote$ref, pat = remote$auth_token)
}
#' @export
format.gitlab_remote <- function(x, ...) {
"GitLab"
}
gitlab_commit <- function(username, repo, ref = "master",
host = "gitlab.com", pat = gitlab_pat()) {
url <- build_url(host, "api", "v4", "projects", utils::URLencode(paste0(username, "/", repo), reserved = TRUE), "repository", "commits", ref)
tmp <- tempfile()
download(tmp, url, auth_token = pat, auth_phrase = "private_token=")
fromJSONFile(tmp)$id
}
#' Retrieve GitLab personal access token.
#'
#' A GitLab personal access token
#' Looks in env var `GITLAB_PAT`
#'
#' @keywords internal
#' @export
gitlab_pat <- function(quiet = TRUE) {
pat <- Sys.getenv("GITLAB_PAT")
if (nzchar(pat)) {
if (!quiet) {
message("Using GitLab PAT from envvar GITLAB_PAT")
}
return(pat)
}
return(NULL)
}
#' Install a package from a local file
#'
#' This function is vectorised so you can install multiple packages in
#' a single command.
#'
#' @param path path to local directory, or compressed file (tar, zip, tar.gz
#' tar.bz2, tgz2 or tbz)
#' @inheritParams install_url
#' @inheritParams install_github
#' @export
#' @family package installation
#' @examples
#' \dontrun{
#' dir <- tempfile()
#' dir.create(dir)
#' pkg <- download.packages("testthat", dir, type = "source")
#' install_local(pkg[, 2])
#' }
install_local <- function(path = ".", subdir = NULL,
dependencies = NA,
upgrade = c("default", "ask", "always", "never"),
force = FALSE,
quiet = FALSE,
build = !is_binary_pkg(path),
build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
repos = getOption("repos"),
type = getOption("pkgType"),
...) {
remotes <- lapply(path, local_remote, subdir = subdir)
install_remotes(remotes,
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
local_remote <- function(path, subdir = NULL, branch = NULL, args = character(0), ...) {
remote("local",
path = normalizePath(path),
subdir = subdir
)
}
#' @export
remote_download.local_remote <- function(x, quiet = FALSE) {
# Already downloaded - just need to copy to tempdir()
bundle <- tempfile()
dir.create(bundle)
file.copy(x$path, bundle, recursive = TRUE)
# file.copy() creates directory inside of bundle
dir(bundle, full.names = TRUE)[1]
}
#' @export
remote_metadata.local_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
list(
RemoteType = "local",
RemoteUrl = x$path,
RemoteSubdir = x$subdir
)
}
#' @export
remote_package_name.local_remote <- function(remote, ...) {
is_tarball <- !dir.exists(remote$path)
if (is_tarball) {
# Assume the name is the name of the tarball
return(sub("_.*$", "", basename(remote$path)))
}
description_path <- file.path(remote$path, "DESCRIPTION")
read_dcf(description_path)$Package
}
#' @export
remote_sha.local_remote <- function(remote, ...) {
is_tarball <- !dir.exists(remote$path)
if (is_tarball) {
return(NA_character_)
}
read_dcf(file.path(remote$path, "DESCRIPTION"))$Version
}
#' @export
format.local_remote <- function(x, ...) {
"local"
}
#' Install a remote package.
#'
#' This:
#' \enumerate{
#' \item downloads source bundle
#' \item decompresses & checks that it's a package
#' \item adds metadata to DESCRIPTION
#' \item calls install
#' }
#' @noRd
install_remote <- function(remote,
dependencies,
upgrade,
force,
quiet,
build,
build_opts,
repos,
type,
...) {
stopifnot(is.remote(remote))
package_name <- remote_package_name(remote)
local_sha <- local_sha(package_name)
remote_sha <- remote_sha(remote, local_sha)
if (!isTRUE(force) &&
!different_sha(remote_sha = remote_sha, local_sha = local_sha)) {
if (!quiet) {
message(
"Skipping install of '", package_name, "' from a ", sub("_remote", "", class(remote)[1L]), " remote,",
" the SHA1 (", substr(remote_sha, 1L, 8L), ") has not changed since last install.\n",
" Use `force = TRUE` to force installation")
}
return(invisible(package_name))
}
if (inherits(remote, "cran_remote")) {
install_packages(
package_name, repos = remote$repos, type = remote$pkg_type,
dependencies = dependencies,
quiet = quiet,
...)
return(invisible(package_name))
}
bundle <- remote_download(remote, quiet = quiet)
on.exit(unlink(bundle), add = TRUE)
source <- source_pkg(bundle, subdir = remote$subdir)
on.exit(unlink(source, recursive = TRUE), add = TRUE)
update_submodules(source, quiet)
add_metadata(source, remote_metadata(remote, bundle, source, remote_sha))
# Because we've modified DESCRIPTION, its original MD5 value is wrong
clear_description_md5(source)
install(source,
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
install_remotes <- function(remotes, ...) {
invisible(vapply(remotes, install_remote, ..., FUN.VALUE = character(1)))
}
# Add metadata
add_metadata <- function(pkg_path, meta) {
# During installation, the DESCRIPTION file is read and an package.rds file
# created with most of the information from the DESCRIPTION file. Functions
# that read package metadata may use either the DESCRIPTION file or the
# package.rds file, therefore we attempt to modify both of them
source_desc <- file.path(pkg_path, "DESCRIPTION")
binary_desc <- file.path(pkg_path, "Meta", "package.rds")
if (file.exists(source_desc)) {
desc <- read_dcf(source_desc)
desc <- utils::modifyList(desc, meta)
write_dcf(source_desc, desc)
}
if (file.exists(binary_desc)) {
pkg_desc <- base::readRDS(binary_desc)
desc <- as.list(pkg_desc$DESCRIPTION)
desc <- utils::modifyList(desc, meta)
pkg_desc$DESCRIPTION <- stats::setNames(as.character(desc), names(desc))
base::saveRDS(pkg_desc, binary_desc)
}
}
# Modify the MD5 file - remove the line for DESCRIPTION
clear_description_md5 <- function(pkg_path) {
path <- file.path(pkg_path, "MD5")
if (file.exists(path)) {
text <- readLines(path)
text <- text[!grepl(".*\\*DESCRIPTION$", text)]
writeLines(text, path)
}
}
remote <- function(type, ...) {
structure(list(...), class = c(paste0(type, "_remote"), "remote"))
}
is.remote <- function(x) inherits(x, "remote")
remote_download <- function(x, quiet = FALSE) UseMethod("remote_download")
remote_metadata <- function(x, bundle = NULL, source = NULL, sha = NULL) UseMethod("remote_metadata")
remote_package_name <- function(remote, ...) UseMethod("remote_package_name")
remote_sha <- function(remote, ...) UseMethod("remote_sha")
remote_package_name.default <- function(remote, ...) remote$repo
remote_sha.default <- function(remote, ...) NA_character_
different_sha <- function(remote_sha, local_sha) {
same <- remote_sha == local_sha
same <- isTRUE(same) && !is.na(same)
!same
}
local_sha <- function(name) {
package2remote(name)$sha %||% NA_character_
}
# Convert an installed package to its equivalent remote. This constructs the
# remote from metadata stored in the package's DESCRIPTION file; the metadata
# is added to the package when it is installed by remotes. If the package is
# installed some other way, such as by `install.packages()` there will be no
# meta-data, so there we construct a generic CRAN remote.
package2remote <- function(name, lib = .libPaths(), repos = getOption("repos"), type = getOption("pkgType")) {
x <- tryCatch(utils::packageDescription(name, lib.loc = lib), error = function(e) NA, warning = function(e) NA)
# will be NA if not installed
if (identical(x, NA)) {
return(remote("cran",
name = name,
repos = repos,
pkg_type = type,
sha = NA_character_))
}
if (is.null(x$RemoteType) || x$RemoteType == "cran") {
# Packages installed with install.packages() or locally without remotes
return(remote("cran",
name = x$Package,
repos = repos,
pkg_type = type,
sha = x$Version))
}
switch(x$RemoteType,
github = remote("github",
host = x$RemoteHost,
package = x$RemotePackage,
repo = x$RemoteRepo,
subdir = x$RemoteSubdir,
username = x$RemoteUsername,
ref = x$RemoteRef,
sha = x$RemoteSha,
auth_token = github_pat()),
gitlab = remote("gitlab",
host = x$RemoteHost,
repo = x$RemoteRepo,
subdir = x$RemoteSubdir,
username = x$RemoteUsername,
ref = x$RemoteRef,
sha = x$RemoteSha,
auth_token = gitlab_pat()),
xgit = remote("xgit",
url = trim_ws(x$RemoteUrl),
ref = x$RemoteRef %||% x$RemoteBranch,
sha = x$RemoteSha,
subdir = x$RemoteSubdir,
args = x$RemoteArgs),
git2r = remote("git2r",
url = trim_ws(x$RemoteUrl),
ref = x$RemoteRef %||% x$RemoteBranch,
sha = x$RemoteSha,
subdir = x$RemoteSubdir),
bitbucket = remote("bitbucket",
host = x$RemoteHost,
repo = x$RemoteRepo,
username = x$RemoteUsername,
ref = x$RemoteRef,
sha = x$RemoteSha,
subdir = x$RemoteSubdir,
auth_user = bitbucket_user(),
password = bitbucket_password()),
svn = remote("svn",
url = trim_ws(x$RemoteUrl),
svn_subdir = x$RemoteSubdir,
revision = x$RemoteSha,
args = x$RemoteArgs),
local = remote("local",
path = trim_ws(x$RemoteUrl),
subdir = x$RemoteSubdir,
sha = {
# Packages installed locally might have RemoteSha == NA_character_
x$RemoteSha %||% x$Version
}),
url = remote("url",
url = trim_ws(x$RemoteUrl),
subdir = x$RemoteSubdir,
config = x$RemoteConfig,
pkg_type = x$RemotePkgType),
bioc_git2r = remote("bioc_git2r",
mirror = x$RemoteMirror,
repo = x$RemoteRepo,
release = x$RemoteRelease,
sha = x$RemoteSha,
branch = x$RemoteBranch),
bioc_xgit = remote("bioc_xgit",
mirror = x$RemoteMirror,
repo = x$RemoteRepo,
release = x$RemoteRelease,
sha = x$RemoteSha,
branch = x$RemoteBranch)
)
}
#' @export
format.remotes <- function(x, ...) {
vapply(x, format, character(1))
}
#' Install a package from a SVN repository
#'
#' This function requires \command{svn} to be installed on your system in order to
#' be used.
#'
#' It is vectorised so you can install multiple packages with
#' a single command.
#'
#' @inheritParams install_git
#' @param subdir A sub-directory withing a svn repository that contains the
#' package we are interested in installing.
#' @param args A character vector providing extra options to pass on to
#' \command{svn}.
#' @param revision svn revision, if omitted updates to latest
#' @param ... Other arguments passed on to [utils::install.packages()].
#' @inheritParams install_github
#' @family package installation
#' @export
#'
#' @examples
#' \dontrun{
#' install_svn("https://github.com/hadley/stringr/trunk")
#' install_svn("https://github.com/hadley/httr/branches/oauth")
#'}
install_svn <- function(url, subdir = NULL, args = character(0),
revision = NULL,
dependencies = NA,
upgrade = c("default", "ask", "always", "never"),
force = FALSE,
quiet = FALSE,
build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
repos = getOption("repos"),
type = getOption("pkgType"),
...) {
remotes <- lapply(url, svn_remote, svn_subdir = subdir,
revision = revision, args = args)
install_remotes(remotes, args = args,
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
svn_remote <- function(url, svn_subdir = NULL, revision = NULL,
args = character(0), ...) {
remote("svn",
url = url,
svn_subdir = svn_subdir,
revision = revision,
args = args
)
}
#' @export
remote_download.svn_remote <- function(x, quiet = FALSE) {
if (!quiet) {
message("Downloading svn repo ", x$url)
}
bundle <- tempfile()
svn_binary_path <- svn_path()
url <- x$url
args <- "co"
if (!is.null(x$revision)) {
args <- c(args, "-r", x$revision)
}
args <- c(args, x$args, full_svn_url(x), bundle)
if (!quiet) { message(shQuote(svn_binary_path), " ", paste0(args, collapse = " ")) }
request <- system2(svn_binary_path, args, stdout = FALSE, stderr = FALSE)
# This is only looking for an error code above 0-success
if (request > 0) {
stop("There seems to be a problem retrieving this SVN-URL.", call. = FALSE)
}
in_dir(bundle, {
if (!is.null(x$revision)) {
request <- system2(svn_binary_path, paste("update -r", x$revision), stdout = FALSE, stderr = FALSE)
if (request > 0) {
stop("There was a problem switching to the requested SVN revision", call. = FALSE)
}
}
})
bundle
}
#' @export
remote_metadata.svn_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
if (!is.null(bundle)) {
in_dir(bundle, {
revision <- svn_revision()
})
} else {
revision <- sha
}
list(
RemoteType = "svn",
RemoteUrl = x$url,
RemoteSubdir = x$svn_subdir,
RemoteArgs = if (length(x$args) > 0) paste0(deparse(x$args), collapse = " "),
RemoteSha = revision # for compatibility with other remotes
)
}
svn_path <- function(svn_binary_name = NULL) {
# Use user supplied path
if (!is.null(svn_binary_name)) {
if (!file.exists(svn_binary_name)) {
stop("Path ", svn_binary_name, " does not exist", .call = FALSE)
}
return(svn_binary_name)
}
# Look on path
svn_path <- Sys.which("svn")[[1]]
if (svn_path != "") return(svn_path)
# On Windows, look in common locations
if (os_type() == "windows") {
look_in <- c(
"C:/Program Files/Svn/bin/svn.exe",
"C:/Program Files (x86)/Svn/bin/svn.exe"
)
found <- file.exists(look_in)
if (any(found)) return(look_in[found][1])
}
stop("SVN does not seem to be installed on your system.", call. = FALSE)
}
#' @export
remote_package_name.svn_remote <- function(remote, ...) {
description_url <- file.path(full_svn_url(remote), "DESCRIPTION")
tmp_file <- tempfile()
on.exit(rm(tmp_file))
response <- system2(svn_path(), paste("cat", description_url), stdout = tmp_file)
if (!identical(response, 0L)) {
return(NA_character_)
}
read_dcf(tmp_file)$Package
}
#' @export
remote_sha.svn_remote <- function(remote, ...) {
svn_revision(full_svn_url(remote))
}
svn_revision <- function(url = NULL, svn_binary_path = svn_path()) {
request <- system2(svn_binary_path, paste("info --xml", url), stdout = TRUE)
if (!is.null(attr(request, "status")) && !identical(attr(request, "status"), 0L)) {
stop("There was a problem retrieving the current SVN revision", call. = FALSE)
}
gsub(".*<commit[[:space:]]+revision=\"([[:digit:]]+)\">.*", "\\1", paste(collapse = "\n", request))
}
full_svn_url <- function(x) {
url <- x$url
if (!is.null(x$svn_subdir)) {
url <- file.path(url, x$svn_subdir)
}
url
}
format.svn_remote <- function(x, ...) {
"SVN"
}
#' Install a package from a url
#'
#' This function is vectorised so you can install multiple packages in
#' a single command.
#'
#' @param url location of package on internet. The url should point to a
#' zip file, a tar file or a bzipped/gzipped tar file.
#' @param subdir subdirectory within url bundle that contains the R package.
#' @param ... Other arguments passed on to [utils::install.packages()].
#' @inheritParams install_github
#' @export
#'
#' @family package installation
#' @examples
#' \dontrun{
#' install_url("https://github.com/hadley/stringr/archive/master.zip")
#' }
install_url <- function(url, subdir = NULL,
dependencies = NA,
upgrade = c("default", "ask", "always", "never"),
force = FALSE,
quiet = FALSE,
build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
repos = getOption("repos"),
type = getOption("pkgType"),
...) {
remotes <- lapply(url, url_remote, subdir = subdir)
install_remotes(remotes,
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
}
url_remote <- function(url, subdir = NULL, ...) {
remote("url",
url = url,
subdir = subdir
)
}
#' @importFrom tools file_ext
#' @export
remote_download.url_remote <- function(x, quiet = FALSE) {
if (!quiet) {
message("Downloading package from url: ", x$url) # nocov
}
ext <- if (grepl("\\.tar\\.gz$", x$url)) "tar.gz" else file_ext(x$url)
bundle <- tempfile(fileext = paste0(".", ext))
download(bundle, x$url)
}
#' @export
remote_metadata.url_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
list(
RemoteType = "url",
RemoteUrl = x$url,
RemoteSubdir = x$subdir
)
}
#' @export
remote_package_name.url_remote <- function(remote, ...) {
NA_character_
}
#' @export
remote_sha.url_remote <- function(remote, ...) {
NA_character_
}
#' @export
format.url_remote <- function(x, ...) {
"URL"
}
#' Install specified version of a CRAN package.
#'
#' If you are installing an package that contains compiled code, you will
#' need to have an R development environment installed. You can check
#' if you do by running `devtools::has_devel` (you need the
#' `devtools` package for this).
#'
#' @export
#' @family package installation
#' @param package package name
#' @param version If the specified version is NULL or the same as the most
#' recent version of the package, this function simply calls
#' [utils::install.packages()]. Otherwise, it looks at the list of
#' archived source tarballs and tries to install an older version instead.
#' @param ... Other arguments passed on to [utils::install.packages()].
#' @inheritParams utils::install.packages
#' @inheritParams install_github
#' @author Jeremy Stephens
#' @importFrom utils available.packages contrib.url install.packages
install_version <- function(package, version = NULL,
dependencies = NA,
upgrade = c("default", "ask", "always", "never"),
force = FALSE,
quiet = FALSE,
build = FALSE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
repos = getOption("repos"),
type = getOption("pkgType"),
...) {
url <- download_version_url(package, version, repos, type)
res <- install_url(url,
dependencies = dependencies,
upgrade = upgrade,
force = force,
quiet = quiet,
build = build,
build_opts = build_opts,
repos = repos,
type = type,
...)
lib <- list(...)$lib
# Remove Metadata from installed package
add_metadata(
system.file(package = package, lib.loc = lib),
list(RemoteType = NULL, RemoteUrl = NULL, RemoteSubdir = NULL))
invisible(res)
}
package_find_repo <- function(package, repos) {
for (repo in repos) {
if (length(repos) > 1)
message("Trying ", repo)
archive <-
tryCatch({
con <- gzcon(url(sprintf("%s/src/contrib/Meta/archive.rds", repo), "rb"))
on.exit(close(con))
readRDS(con)
},
warning = function(e) list(),
error = function(e) list())
info <- archive[[package]]
if (!is.null(info)) {
info$repo <- repo
return(info)
}
}
stop(sprintf("couldn't find package '%s'", package))
}
#' Download a specified version of a CRAN package
#'
#' It downloads the package to a temporary file, and
#' returns the name of the file.
#'
#' @inheritParams install_version
#' @return Name of the downloaded file.
#'
#' @export
download_version <- function(package, version = NULL,
repos = getOption("repos"),
type = getOption("pkgType"), ...) {
url <- download_version_url(package, version, repos, type)
download(path = tempfile(), url = url)
}
download_version_url <- function(package, version, repos, type) {
contriburl <- contrib.url(repos, type)
available <- available.packages(contriburl)
if (package %in% row.names(available)) {
current.version <- available[package, 'Version']
if (is.null(version) || version == current.version) {
row <- available[which(rownames(available) == package)[1], ]
return(paste0(
row[["Repository"]],
"/",
row[["Package"]],
"_",
row[["Version"]],
".tar.gz"
))
}
}
info <- package_find_repo(package, repos)
if (is.null(version)) {
# Grab the latest one: only happens if pulled from CRAN
package.path <- row.names(info)[nrow(info)]
} else {
package.path <- paste(package, "/", package, "_", version, ".tar.gz",
sep = "")
if (!(package.path %in% row.names(info))) {
stop(sprintf("version '%s' is invalid for package '%s'", version,
package))
}
}
paste(info$repo[1L], "/src/contrib/Archive/", package.path, sep = "")
}
install <- function(pkgdir, dependencies, quiet, build, build_opts, upgrade,
repos, type, ...) {
warn_for_potential_errors()
if (file.exists(file.path(pkgdir, "src"))) {
if (has_package("pkgbuild")) {
pkgbuild::local_build_tools(required = TRUE)
} else if (!has_devel()) {
missing_devel_warning(pkgdir)
}
}
## Check for circular dependencies. We need to know about the root
## of the install process.
if (is_root_install()) on.exit(exit_from_root_install(), add = TRUE)
if (check_for_circular_dependencies(pkgdir, quiet)) {
return(invisible(FALSE))
}
install_deps(pkgdir, dependencies = dependencies, quiet = quiet,
build = build, build_opts = build_opts, upgrade = upgrade, repos = repos, type = type, ...)
if (isTRUE(build)) {
dir <- tempfile()
dir.create(dir)
on.exit(unlink(dir), add = TRUE)
pkgdir <- safe_build_package(pkgdir, build_opts, dir, quiet)
}
safe_install_packages(
pkgdir,
repos = NULL,
quiet = quiet,
type = "source",
...
)
pkg_name <- load_pkg_description(pkgdir)$package
invisible(pkg_name)
}
safe_install_packages <- function(...) {
lib <- paste(.libPaths(), collapse = .Platform$path.sep)
if (!is_standalone() &&
has_package("crancache") && has_package("callr")) {
i.p <- "crancache" %::% "install_packages"
} else {
i.p <- utils::install.packages
}
with_envvar(
c(R_LIBS = lib,
R_LIBS_USER = lib,
R_LIBS_SITE = lib),
# Set options(warn = 2) for this process and child processes, so that
# warnings from `install.packages()` are converted to errors.
if (should_error_for_warnings()) {
with_options(list(warn = 2),
with_rprofile_user("options(warn = 2)",
i.p(...)
)
)
} else {
i.p(...)
}
)
}
safe_build_package <- function(pkgdir, build_opts, dest_path, quiet, use_pkgbuild = !is_standalone() && pkg_installed("pkgbuild")) {
if (use_pkgbuild) {
vignettes <- TRUE
manual <- FALSE
has_no_vignettes <- grepl("--no-build-vignettes", build_opts)
if (any(has_no_vignettes)) {
vignettes <- FALSE
}
has_no_manual <- grepl("--no-manual", build_opts)
if (!any(has_no_manual)) {
manual <- TRUE
}
build_opts <- build_opts[!(has_no_vignettes | has_no_manual)]
pkgbuild::build(pkgdir, dest_path = dest_path, binary = FALSE,
vignettes = vignettes, manual = manual, args = build_opts, quiet = quiet)
} else {
# No pkgbuild, so we need to call R CMD build ourselves
lib <- paste(.libPaths(), collapse = ":")
env <- c(R_LIBS = lib,
R_LIBS_USER = lib,
R_LIBS_SITE = lib,
R_PROFILE_USER = tempfile())
pkgdir <- normalizePath(pkgdir)
message("Running `R CMD build`...")
in_dir(dest_path, {
with_envvar(env, {
output <- rcmd("build", c(build_opts, shQuote(pkgdir)), quiet = quiet,
fail_on_status = FALSE)
})
})
if (output$status != 0) {
cat("STDOUT:\n")
cat(output$stdout, sep = "\n")
cat("STDERR:\n")
cat(output$stderr, sep = "\n")
msg_for_long_paths(output)
stop(sprintf("Failed to `R CMD build` package, try `build = FALSE`."),
call. = FALSE)
}
building_regex <- paste0(
"^[*] building[^[:alnum:]]+", # prefix, "* building '"
"([-[:alnum:]_.]+)", # package file name, e.g. xy_1.0-2.tar.gz
"[^[:alnum:]]+$" # trailing quote
)
pkgfile <- sub(building_regex, "\\1", output$stdout[length(output$stdout)])
file.path(dest_path, pkgfile)
}
}
msg_for_long_paths <- function(output) {
if (sys_type() == "windows" &&
(r_error_matches("over-long path", output$stderr) ||
r_error_matches("over-long path length", output$stderr))) {
message(
"\nIt seems that this package contains files with very long paths.\n",
"This is not supported on most Windows versions. Please contact the\n",
"package authors and tell them about this. See this GitHub issue\n",
"for more details: https://github.com/r-lib/remotes/issues/84\n")
}
}
r_error_matches <- function(msg, str) {
any(grepl(msg, str)) ||
any(grepl(gettext(msg, domain = "R"), str))
}
#' Install package dependencies if needed.
#'
#' @inheritParams package_deps
#' @param ... additional arguments passed to [utils::install.packages()].
#' @param build If `TRUE` build the package before installing.
#' @param build_opts Options to pass to `R CMD build`, only used when `build`
#' is `TRUE`.
#' @export
#' @examples
#' \dontrun{install_deps(".")}
install_deps <- function(pkgdir = ".", dependencies = NA,
repos = getOption("repos"),
type = getOption("pkgType"),
upgrade = c("default", "ask", "always", "never"),
quiet = FALSE,
build = TRUE,
build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
...) {
packages <- dev_package_deps(
pkgdir,
repos = repos,
dependencies = dependencies,
type = type,
...
)
dep_deps <- if (isTRUE(dependencies)) NA else dependencies
update(
packages,
dependencies = dep_deps,
quiet = quiet,
upgrade = upgrade,
build = build,
build_opts = build_opts,
...
)
}
should_error_for_warnings <- function() {
force_suggests <- Sys.getenv("_R_CHECK_FORCE_SUGGESTS_", "true")
no_errors <- Sys.getenv("R_REMOTES_NO_ERRORS_FROM_WARNINGS", !as.logical(force_suggests))
!as.logical(no_errors)
}
tokenize_json <- function(text) {
text <- paste(text, collapse = "\n")
ESCAPE <- '(\\\\[^u[:cntrl:]]|\\\\u[0-9a-fA-F]{4})'
CHAR <- '[^[:cntrl:]"\\\\]'
STRING <- paste0('"', CHAR, '*(', ESCAPE, CHAR, '*)*"')
NUMBER <- "-?(0|[1-9][0-9]*)([.][0-9]*)?([eE][+-]?[0-9]*)?"
KEYWORD <- 'null|false|true'
SPACE <- '[[:space:]]+'
match <- gregexpr(
pattern = paste0(
STRING, "|", NUMBER, "|", KEYWORD, "|", SPACE, "|", "."
),
text = text,
perl = TRUE
)
grep("^\\s+$", regmatches(text, match)[[1]], value = TRUE, invert = TRUE)
}
throw <- function(...) {
stop("JSON: ", ..., call. = FALSE)
}
fromJSONFile <- function(filename) {
fromJSON(readLines(filename, warn = FALSE))
}
fromJSON <- function(text) {
tokens <- tokenize_json(text)
token <- NULL
ptr <- 1
read_token <- function() {
if (ptr <= length(tokens)) {
token <<- tokens[ptr]
ptr <<- ptr + 1
} else {
token <<- 'EOF'
}
}
parse_value <- function(name = "") {
if (token == "{") {
parse_object()
} else if (token == "[") {
parse_array()
} else if (token == "EOF" || (nchar(token) == 1 && ! token %in% 0:9)) {
throw("EXPECTED value GOT ", token)
} else {
j2r(token)
}
}
parse_object <- function() {
res <- structure(list(), names = character())
read_token()
## Invariant: we are at the beginning of an element
while (token != "}") {
## "key"
if (grepl('^".*"$', token)) {
key <- j2r(token)
} else {
throw("EXPECTED string GOT ", token)
}
## :
read_token()
if (token != ":") { throw("EXPECTED : GOT ", token) }
## value
read_token()
res[key] <- list(parse_value())
## } or ,
read_token()
if (token == "}") {
break
} else if (token != ",") {
throw("EXPECTED , or } GOT ", token)
}
read_token()
}
res
}
parse_array <- function() {
res <- list()
read_token()
## Invariant: we are at the beginning of an element
while (token != "]") {
## value
res <- c(res, list(parse_value()))
## ] or ,
read_token()
if (token == "]") {
break
} else if (token != ",") {
throw("EXPECTED , GOT ", token)
}
read_token()
}
res
}
read_token()
parse_value(tokens)
}
j2r <- function(token) {
if (token == "null") {
NULL
} else if (token == "true") {
TRUE
} else if (token == "false") {
FALSE
} else if (grepl('^".*"$', token)) {
trimq(token)
} else {
as.numeric(token)
}
}
trimq <- function(x) {
sub('^"(.*)"$', "\\1", x)
}
get_json_sha <- function(text) {
m <- regexpr(paste0('"sha"\\s*:\\s*"(\\w+)"'), text, perl = TRUE)
if (all(m == -1)) {
return(fromJSON(text)$sha %||% NA_character_)
}
start <- attr(m, "capture.start")
end <- start + attr(m, "capture.length") - 1L
substring(text, start, end)
}
parse_deps <- function(string) {
if (is.null(string)) return()
stopifnot(is.character(string), length(string) == 1)
if (grepl("^\\s*$", string)) return()
# Split by commas with surrounding whitespace removed
pieces <- strsplit(string, "[[:space:]]*,[[:space:]]*")[[1]]
# Get the names
names <- gsub("\\s*\\(.*?\\)", "", pieces)
names <- gsub("^\\s+|\\s+$", "", names)
# Get the versions and comparison operators
versions_str <- pieces
have_version <- grepl("\\(.*\\)", versions_str)
versions_str[!have_version] <- NA
compare <- sub(".*\\(\\s*(\\S+)\\s+.*\\s*\\)", "\\1", versions_str)
versions <- sub(".*\\(\\s*\\S+\\s+(\\S*)\\s*\\)", "\\1", versions_str)
# Check that non-NA comparison operators are valid
compare_nna <- compare[!is.na(compare)]
compare_valid <- compare_nna %in% c(">", ">=", "==", "<=", "<")
if(!all(compare_valid)) {
stop("Invalid comparison operator in dependency: ",
paste(compare_nna[!compare_valid], collapse = ", "))
}
deps <- data.frame(name = names, compare = compare,
version = versions, stringsAsFactors = FALSE)
# Remove R dependency
deps[names != "R", ]
}
load_pkg_description <- function(path) {
path <- normalizePath(path)
if (!is_dir(path)) {
dir <- tempfile()
path_desc <- untar_description(path, dir = dir)
on.exit(unlink(dir, recursive = TRUE))
} else {
path_desc <- file.path(path, "DESCRIPTION")
}
desc <- read_dcf(path_desc)
names(desc) <- tolower(names(desc))
desc$path <- path
desc
}
#' Parse a remote git repo specification
#'
#' A remote repo can be specified in two ways:
#' \describe{
#' \item{as a URL}{`parse_github_url()` handles HTTPS and SSH remote URLs
#' and various GitHub browser URLs}
#' \item{via a shorthand}{`parse_repo_spec()` handles this concise form:
#' `[username/]repo[/subdir][#pull|@ref|@*release]`}
#' }
#'
#' @param repo Character scalar, the repo specification.
#' @return List with members: `username`, `repo`, `subdir`
#' `ref`, `pull`, `release`, some which will be empty.
#'
#' @name parse-git-repo
#' @examples
#' parse_repo_spec("metacran/crandb")
#' parse_repo_spec("jimhester/covr#47") ## pull request
#' parse_repo_spec("jeroen/curl@v0.9.3") ## specific tag
#' parse_repo_spec("tidyverse/dplyr@*release") ## shorthand for latest release
#' parse_repo_spec("r-lib/remotes@550a3c7d3f9e1493a2ba") ## commit SHA
#' parse_repo_spec("r-lib/remotes@550a3c7d3f9e1493a2ba") ## commit SHA
#' parse_repo_spec("igraph=igraph/rigraph") ## Different package name from repo name
#'
#' parse_github_url("https://github.com/jeroen/curl.git")
#' parse_github_url("git@github.com:metacran/crandb.git")
#' parse_github_url("https://github.com/jimhester/covr")
#' parse_github_url("https://github.example.com/user/repo.git")
#' parse_github_url("git@github.example.com:user/repo.git")
#'
#' parse_github_url("https://github.com/r-lib/remotes/pull/108")
#' parse_github_url("https://github.com/r-lib/remotes/tree/name-of-branch")
#' parse_github_url("https://github.com/r-lib/remotes/commit/1234567")
#' parse_github_url("https://github.com/r-lib/remotes/releases/latest")
#' parse_github_url("https://github.com/r-lib/remotes/releases/tag/1.0.0")
NULL
#' @export
#' @rdname parse-git-repo
parse_repo_spec <- function(repo) {
package_name_rx <- "(?:(?<package>[[:alpha:]][[:alnum:].]*[[:alnum:]])=)?"
username_rx <- "(?:(?<username>[^/]+)/)"
repo_rx <- "(?<repo>[^/@#]+)"
subdir_rx <- "(?:/(?<subdir>[^@#]*[^@#/])/?)?"
ref_rx <- "(?:@(?<ref>[^*].*))"
pull_rx <- "(?:#(?<pull>[0-9]+))"
release_rx <- "(?:@(?<release>[*]release))"
ref_or_pull_or_release_rx <- sprintf(
"(?:%s|%s|%s)?", ref_rx, pull_rx, release_rx
)
spec_rx <- sprintf(
"^%s%s%s%s%s$", package_name_rx, username_rx, repo_rx, subdir_rx, ref_or_pull_or_release_rx
)
params <- as.list(re_match(text = repo, pattern = spec_rx))
if (is.na(params$.match)) {
stop(sprintf("Invalid git repo specification: '%s'", repo))
}
params[grepl("^[^\\.]", names(params))]
}
#' @export
#' @rdname parse-git-repo
parse_github_repo_spec <- parse_repo_spec
#' @export
#' @rdname parse-git-repo
parse_github_url <- function(repo) {
prefix_rx <- "(?:github[^/:]+[/:])"
username_rx <- "(?:(?<username>[^/]+)/)"
repo_rx <- "(?<repo>[^/@#]+)"
ref_rx <- "(?:(?:tree|commit|releases/tag)/(?<ref>.+$))"
pull_rx <- "(?:pull/(?<pull>.+$))"
release_rx <- "(?:releases/)(?<release>.+$)"
ref_or_pull_or_release_rx <- sprintf(
"(?:/(%s|%s|%s))?", ref_rx, pull_rx, release_rx
)
url_rx <- sprintf(
"%s%s%s%s",
prefix_rx, username_rx, repo_rx, ref_or_pull_or_release_rx
)
params <- as.list(re_match(text = repo, pattern = url_rx))
if (is.na(params$.match)) {
stop(sprintf("Invalid GitHub URL: '%s'", repo))
}
if (params$ref == "" && params$pull == "" && params$release == "") {
params$repo <- gsub("\\.git$", "", params$repo)
}
if (params$release == "latest") {
params$release <- "*release"
}
params[grepl("^[^\\.]", names(params))]
}
parse_git_repo <- function(repo) {
if (grepl("^https://github|^git@github", repo)) {
params <- parse_github_url(repo)
} else {
params <- parse_repo_spec(repo)
}
params <- params[viapply(params, nchar) > 0]
if (!is.null(params$pull)) {
params$ref <- github_pull(params$pull)
params$pull <- NULL
}
if (!is.null(params$release)) {
params$ref <- github_release()
params$release <- NULL
}
params
}
parse_submodules <- function(file) {
if (grepl("\n", file)) {
x <- strsplit(file, "\n")[[1]]
} else {
x <- readLines(file)
}
# https://git-scm.com/docs/git-config#_syntax
# Subsection names are case sensitive and can contain any characters except
# newline and the null byte. Doublequote " and backslash can be included by
# escaping them as \" and \\
double_quoted_string_with_escapes <- '(?:\\\\.|[^"])*'
# Otherwise extract section names
section_names <- re_match(
x,
sprintf('^[[:space:]]*\\[submodule "(?<submodule>%s)"\\][[:space:]]*$', double_quoted_string_with_escapes)
)$submodule
# If no sections found return the empty list
if (all(is.na(section_names))) {
return(list())
}
# Extract name = value
# The variable names are case-insensitive, allow only alphanumeric characters
# and -, and must start with an alphabetic character.
variable_name <- "[[:alpha:]][[:alnum:]-]*"
mapping_values <- re_match(
x,
sprintf('^[[:space:]]*(?<name>%s)[[:space:]]*=[[:space:]]*(?<value>.*)[[:space:]]*$', variable_name),
)
values <- cbind(submodule = fill(section_names), mapping_values[c("name", "value")], stringsAsFactors = FALSE)
values <- values[!is.na(mapping_values$.match), ]
# path and valid url are required
if (!all(c("path", "url") %in% values$name)) {
warning("Invalid submodule definition, skipping submodule installation", immediate. = TRUE, call. = FALSE)
return(list())
}
# Roughly equivalent to tidyr::spread(values, name, value)
res <- stats::reshape(values, idvar = "submodule", timevar = "name", v.name = "value", direction = "wide")
# Set the column names, reshape prepends `value.` to path, url and branch
colnames(res) <- gsub("value[.]", "", colnames(res))
# path and valid url are required
if (any(is.na(res$url), is.na(res$path))) {
warning("Invalid submodule definition, skipping submodule installation", immediate. = TRUE, call. = FALSE)
return(list())
}
# branch is optional
if (!exists("branch", res)) {
res$branch <- NA_character_
}
# Remove unneeded attribute
attr(res, "reshapeWide") <- NULL
# Remove rownames
rownames(res) <- NULL
res
}
# Adapted from https://stackoverflow.com/a/9517731/2055486
fill <- function(x) {
not_missing <- !is.na(x)
res <- x[not_missing]
res[cumsum(not_missing)]
}
update_submodule <- function(url, path, branch, quiet) {
args <- c('clone', '--depth', '1', '--no-hardlinks --recurse-submodules')
if (length(branch) > 0 && !is.na(branch)) {
args <- c(args, "--branch", branch)
}
args <- c(args, url, path)
git(paste0(args, collapse = " "), quiet = quiet)
}
update_submodules <- function(source, quiet) {
file <- file.path(source, ".gitmodules")
if (!file.exists(file)) {
return()
}
info <- parse_submodules(file)
to_ignore <- in_r_build_ignore(info$path, file.path(source, ".Rbuildignore"))
info <- info[!to_ignore, ]
for (i in seq_len(NROW(info))) {
update_submodule(info$url[[i]], file.path(source, info$path[[i]]), info$branch[[i]], quiet)
}
}
system_check <- function(command, args = character(), quiet = TRUE,
error = TRUE, path = ".") {
out <- tempfile()
err <- tempfile()
on.exit(unlink(out), add = TRUE)
on.exit(unlink(err), add = TRUE)
## We suppress warnings, they are given if the command
## exits with a non-zero status
res <- in_dir(
path,
suppressWarnings(
system2(command, args = args, stdout = out, stderr = err)
)
)
res <- list(
stdout = tryCatch(
suppressWarnings(win2unix(read_char(out))),
error = function(e) ""
),
stderr = tryCatch(
suppressWarnings(win2unix(read_char(err))),
error = function(e) ""
),
status = res
)
if (error && res$status != 0) {
stop("Command ", command, " failed ", res$stderr)
}
if (! quiet) {
if (! identical(res$stdout, NA_character_)) cat(res$stdout)
if (! identical(res$stderr, NA_character_)) cat(res$stderr)
}
res
}
win2unix <- function(str) {
gsub("\r\n", "\n", str, fixed = TRUE)
}
read_char <- function(path, ...) {
readChar(path, nchars = file.info(path)$size, ...)
}
`%||%` <- function (a, b) if (!is.null(a)) a else b
`%:::%` <- function (p, f) get(f, envir = asNamespace(p))
`%::%` <- function (p, f) get(f, envir = asNamespace(p))
viapply <- function(X, FUN, ..., USE.NAMES = TRUE) {
vapply(X, FUN, integer(1L), ..., USE.NAMES = USE.NAMES)
}
vlapply <- function(X, FUN, ..., USE.NAMES = TRUE) {
vapply(X, FUN, logical(1L), ..., USE.NAMES = USE.NAMES)
}
rcmd <- function(cmd, args, path = R.home("bin"), quiet, fail_on_status = TRUE) {
if (os_type() == "windows") {
real_cmd <- file.path(path, "Rcmd.exe")
args <- c(cmd, args)
} else {
real_cmd <- file.path(path, "R")
args <- c("CMD", cmd, args)
}
stdoutfile <- tempfile()
stderrfile <- tempfile()
on.exit(unlink(c(stdoutfile, stderrfile), recursive = TRUE), add = TRUE)
status <- system2(real_cmd, args, stderr = stderrfile, stdout = stdoutfile)
out <- tryCatch(readLines(stdoutfile, warn = FALSE), error = function(x) "")
err <- tryCatch(readLines(stderrfile, warn = FALSE), error = function(x) "")
if (fail_on_status && status != 0) {
cat("STDOUT:\n")
cat(out, sep = "\n")
cat("STDERR:\n")
cat(err, sep = "\n")
stop(sprintf("Error running '%s' (status '%i')", cmd, status), call. = FALSE)
}
if (!quiet) {
cat(out, sep = "\n")
}
list(stdout = out, stderr = err, status = status)
}
is_bioconductor <- function(x) {
!is.null(x$biocviews)
}
trim_ws <- function(x) {
gsub("^[[:space:]]+|[[:space:]]+$", "", x)
}
set_envvar <- function(envs) {
if (length(envs) == 0) return()
stopifnot(is.named(envs))
old <- Sys.getenv(names(envs), names = TRUE, unset = NA)
set <- !is.na(envs)
both_set <- set & !is.na(old)
if (any(set)) do.call("Sys.setenv", as.list(envs[set]))
if (any(!set)) Sys.unsetenv(names(envs)[!set])
invisible(old)
}
with_envvar <- function(new, code) {
old <- set_envvar(new)
on.exit(set_envvar(old))
force(code)
}
is.named <- function(x) {
!is.null(names(x)) && all(names(x) != "")
}
pkg_installed <- function(pkg) {
if (pkg %in% loadedNamespaces()) {
TRUE
} else if (requireNamespace(pkg, quietly = TRUE)) {
try(unloadNamespace(pkg))
TRUE
} else {
FALSE
}
}
has_package <- function(pkg) {
if (pkg %in% loadedNamespaces()) {
TRUE
} else {
requireNamespace(pkg, quietly = TRUE)
}
}
with_something <- function(set, reset = set) {
function(new, code) {
old <- set(new)
on.exit(reset(old))
force(code)
}
}
in_dir <- with_something(setwd)
get_r_version <- function() {
paste(R.version$major, sep = ".", R.version$minor)
}
set_libpaths <- function(paths) {
old <- .libPaths()
.libPaths(paths)
invisible(old)
}
with_libpaths <- with_something(set_libpaths, .libPaths)
set_options <- function(x) {
do.call(options, as.list(x))
}
with_options <- with_something(set_options)
# Read the current user .Rprofile. Here is the order it is searched, from
# ?Startup
#
# 'R_PROFILE_USER’ environment variable (and tilde expansion
# will be performed). If this is unset, a file called ‘.Rprofile’
# is searched for in the current directory or in the user's home
# directory (in that order). The user profile file is sourced into
# the workspace.
read_rprofile_user <- function() {
f <- normalizePath(Sys.getenv("R_PROFILE_USER", ""), mustWork = FALSE)
if (file.exists(f)) {
return(readLines(f))
}
f <- normalizePath("~/.Rprofile", mustWork = FALSE)
if (file.exists(f)) {
return(readLines(f))
}
character()
}
with_rprofile_user <- function(new, code) {
temp_rprofile <- tempfile()
on.exit(unlink(temp_rprofile), add = TRUE)
writeLines(c(read_rprofile_user(), new), temp_rprofile)
with_envvar(c("R_PROFILE_USER" = temp_rprofile), {
force(code)
})
}
## There are two kinds of tar on windows, one needs --force-local
## not to interpret : characters, the other does not. We try both ways.
untar <- function(tarfile, ...) {
if (os_type() == "windows") {
tarhelp <- tryCatch(
system2("tar", "--help", stdout = TRUE, stderr = TRUE),
error = function(x) "")
if (any(grepl("--force-local", tarhelp))) {
status <- try(
suppressWarnings(utils::untar(tarfile, extras = "--force-local", ...)),
silent = TRUE)
if (! is_tar_error(status)) {
return(status)
} else {
message("External tar failed with `--force-local`, trying without")
}
}
}
utils::untar(tarfile, ...)
}
is_tar_error <- function(status) {
inherits(status, "try-error") ||
is_error_status(status) ||
is_error_status(attr(status, "status"))
}
is_error_status <- function(x) {
is.numeric(x) && length(x) > 0 && !is.na(x) && x != 0
}
os_type <- function() {
.Platform$OS.type
}
sys_type <- function() {
if (.Platform$OS.type == "windows") {
"windows"
} else if (Sys.info()["sysname"] == "Darwin") {
"macos"
} else if (Sys.info()["sysname"] == "Linux") {
"linux"
} else if (.Platform$OS.type == "unix") {
"unix"
} else {
stop("Unknown OS")
}
}
is_dir <- function(path) {
file.info(path)$isdir
}
untar_description <- function(tarball, dir = tempfile()) {
files <- untar(tarball, list = TRUE)
desc <- grep("^[^/]+/DESCRIPTION$", files, value = TRUE)
if (length(desc) < 1) stop("No 'DESCRIPTION' file in package")
untar(tarball, desc, exdir = dir)
file.path(dir, desc)
}
## copied from rematch2@180fb61
re_match <- function(text, pattern, perl = TRUE, ...) {
stopifnot(is.character(pattern), length(pattern) == 1, !is.na(pattern))
text <- as.character(text)
match <- regexpr(pattern, text, perl = perl, ...)
start <- as.vector(match)
length <- attr(match, "match.length")
end <- start + length - 1L
matchstr <- substring(text, start, end)
matchstr[ start == -1 ] <- NA_character_
res <- data.frame(
stringsAsFactors = FALSE,
.text = text,
.match = matchstr
)
if (!is.null(attr(match, "capture.start"))) {
gstart <- attr(match, "capture.start")
glength <- attr(match, "capture.length")
gend <- gstart + glength - 1L
groupstr <- substring(text, gstart, gend)
groupstr[ gstart == -1 ] <- NA_character_
dim(groupstr) <- dim(gstart)
res <- cbind(groupstr, res, stringsAsFactors = FALSE)
}
names(res) <- c(attr(match, "capture.names"), ".text", ".match")
class(res) <- c("tbl_df", "tbl", class(res))
res
}
is_standalone <- function() {
isTRUE(as.logical(Sys.getenv("R_REMOTES_STANDALONE", "false")))
}
# This code is adapted from the perl MIME::Base64 module https://perldoc.perl.org/MIME/Base64.html
# https://github.com/gisle/mime-base64/blob/cf23d49e517c6ed8f4b24295f63721e8c9935010/Base64.xs#L197
XX <- 255L
EQ <- 254L
INVALID <- XX
index_64 <- as.integer(c(
XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,62, XX,XX,XX,63,
52,53,54,55, 56,57,58,59, 60,61,XX,XX, XX,EQ,XX,XX,
XX, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, 11,12,13,14,
15,16,17,18, 19,20,21,22, 23,24,25,XX, XX,XX,XX,XX,
XX,26,27,28, 29,30,31,32, 33,34,35,36, 37,38,39,40,
41,42,43,44, 45,46,47,48, 49,50,51,XX, XX,XX,XX,XX,
XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX
))
base64_decode <- function(x) {
if (is.character(x)) {
x <- charToRaw(x)
}
len <- length(x)
idx <- 1
c <- integer(4)
out <- raw()
while(idx <= len) {
i <- 1
while(i <= 4) {
uc <- index_64[[as.integer(x[[idx]]) + 1L]]
idx <- idx + 1
if (uc != INVALID) {
c[[i]] <- uc
i <- i + 1
}
if (idx > len) {
if (i <= 4) {
if (i <= 2) return(rawToChar(out))
if (i == 3) {
c[[3]] <- EQ
c[[4]] <- EQ
}
break
}
}
}
if (c[[1]] == EQ || c[[2]] == EQ) {
break
}
#print(sprintf("c1=%d,c2=%d,c3=%d,c4=%d\n", c[1],c[2],c[3],c[4]))
out[[length(out) + 1]] <- as.raw(bitwOr(bitwShiftL(c[[1]], 2L), bitwShiftR(bitwAnd(c[[2]], 0x30), 4L)))
if (c[[3]] == EQ) {
break
}
out[[length(out) + 1]] <- as.raw(bitwOr(bitwShiftL(bitwAnd(c[[2]], 0x0F), 4L), bitwShiftR(bitwAnd(c[[3]], 0x3C), 2L)))
if (c[[4]] == EQ) {
break
}
out[[length(out) + 1]] <- as.raw(bitwOr(bitwShiftL(bitwAnd(c[[3]], 0x03), 6L), c[[4]]))
}
rawToChar(out)
}
basis64 <- charToRaw(paste(c(LETTERS, letters, 0:9, "+", "/"),
collapse = ""))
base64_encode <- function(x) {
if (is.character(x)) {
x <- charToRaw(x)
}
len <- length(x)
rlen <- floor((len + 2L) / 3L) * 4L
out <- raw(rlen)
ip <- op <- 1L
c <- integer(4)
while (len > 0L) {
c[[1]] <- as.integer(x[[ip]])
ip <- ip + 1L
if (len > 1L) {
c[[2]] <- as.integer(x[ip])
ip <- ip + 1L
} else {
c[[2]] <- 0L
}
out[op] <- basis64[1 + bitwShiftR(c[[1]], 2L)]
op <- op + 1L
out[op] <- basis64[1 + bitwOr(bitwShiftL(bitwAnd(c[[1]], 3L), 4L),
bitwShiftR(bitwAnd(c[[2]], 240L), 4L))]
op <- op + 1L
if (len > 2) {
c[[3]] <- as.integer(x[ip])
ip <- ip + 1L
out[op] <- basis64[1 + bitwOr(bitwShiftL(bitwAnd(c[[2]], 15L), 2L),
bitwShiftR(bitwAnd(c[[3]], 192L), 6L))]
op <- op + 1L
out[op] <- basis64[1 + bitwAnd(c[[3]], 63)]
op <- op + 1L
} else if (len == 2) {
out[op] <- basis64[1 + bitwShiftL(bitwAnd(c[[2]], 15L), 2L)]
op <- op + 1L
out[op] <- charToRaw("=")
op <- op + 1L
} else { ## len == 1
out[op] <- charToRaw("=")
op <- op + 1L
out[op] <- charToRaw("=")
op <- op + 1L
}
len <- len - 3L
}
rawToChar(out)
}
build_url <- function(host, ...) {
download_url(do.call(file.path, as.list(c(host, ...))))
}
download_url <- function(url) {
if (!grepl("^[[:alpha:]]+://", url)) {
scheme <- if (download_method_secure()) "https://" else "http://"
return(paste0(scheme, url))
}
url
}
is_na <- function(x) {
length(x) == 1 && is.na(x)
}
dir.exists <- function(paths) {
if (getRversion() < "3.2") {
x <- base::file.info(paths)$isdir
!is.na(x) & x
} else {
("base" %::% "dir.exists")(paths)
}
}
is_binary_pkg <- function(x) {
file_ext(x) %in% c("tgz", "zip")
}
format_str <- function(x, width = Inf, trim = TRUE, justify = "none", ...) {
x <- format(x, trim = trim, justify = justify, ...)
if (width < Inf) {
x_width <- nchar(x, "width")
too_wide <- x_width > width
if (any(too_wide)) {
x[too_wide] <- paste0(substr(x[too_wide], 1, width - 3), "...")
}
}
x
}
warn_for_potential_errors <- function() {
if (sys_type() == "windows" && grepl(" ", R.home()) &&
getRversion() <= "3.4.2") {
warning(immediate. = TRUE,
"\n!!! Installation will probably fail!\n",
"This version of R has trouble with building and installing packages if\n",
"the R HOME directory (currently '", R.home(), "')\n",
"has space characters. Possible workarounds include:\n",
"- installing R to the C: drive,\n",
"- installing it into a path without a space, or\n",
"- creating a drive letter for R HOME via the `subst` windows command, and\n",
" starting R from the new drive.\n",
"See also https://github.com/r-lib/remotes/issues/98\n")
}
}
# Return all directories in the input paths
directories <- function(paths) {
dirs <- unique(dirname(paths))
out <- dirs[dirs != "."]
while(length(dirs) > 0 && any(dirs != ".")) {
out <- unique(c(out, dirs[dirs != "."]))
dirs <- unique(dirname(dirs))
}
sort(out)
}
in_r_build_ignore <- function(paths, ignore_file) {
ignore <- ("tools" %:::% "get_exclude_patterns")()
if (file.exists(ignore_file)) {
ignore <- c(ignore, readLines(ignore_file, warn = FALSE))
}
matches_ignores <- function(x) {
any(vlapply(ignore, grepl, x, perl = TRUE, ignore.case = TRUE))
}
# We need to search for the paths as well as directories in the path, so
# `^foo$` matches `foo/bar`
should_ignore <- function(path) {
any(vlapply(c(path, directories(path)), matches_ignores))
}
vlapply(paths, should_ignore)
}
## Standalone mode, make sure that we restore the env var on exit
old <- Sys.getenv("R_REMOTES_STANDALONE", NA_character_)
Sys.setenv("R_REMOTES_STANDALONE" = "true")
if (is.na(old)) {
on.exit(Sys.unsetenv("R_REMOTES_STANDALONE"), add = TRUE)
} else {
on.exit(Sys.setenv("R_REMOTES_STANDALONE" = old), add = TRUE)
}
install_github(...)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.