The R Project SVN
R
(root)/trunk/src/library/utils/R/packages.R – Rev 90005
Rev 89912 | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed
# File src/library/utils/R/packages.R# Part of the R package, https://www.R-project.org## Copyright (C) 1995-2026 The R Core Team## This program is free software; you can redistribute it and/or modify# it under the terms of the GNU General Public License as published by# the Free Software Foundation; either version 2 of the License, or# (at your option) any later version.## This program is distributed in the hope that it will be useful,# but WITHOUT ANY WARRANTY; without even the implied warranty of# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the# GNU General Public License for more details.## A copy of the GNU General Public License is available at# https://www.R-project.org/Licenses/available.packages <-function(contriburl = contrib.url(repos, type), method,fields = getOption("available_packages_fields"),type = getOption("pkgType"), filters = NULL,repos = getOption("repos"),ignore_repo_cache = FALSE, max_repo_cache_age,cache_user_dir = str2logical(Sys.getenv("R_PACKAGES_CACHE_USER_DIR", FALSE)),quiet = TRUE, verbose = FALSE, ...){if (!is.character(type))stop(gettextf("'%s' must be a character string", "type"), domain = NA)## We need Built if any of the URLs are binaries. At this point we don't enforce that url/type## match, partially because we don't actually use that information, but in case we are## on a system with binaries the default pkgType will contain "binary" or "both" so we take it## as a hint that one of them may be binary and thus we need "Built"requiredFields <-c(tools:::.get_standard_repository_db_fields(), "File", "Published",if(any(grepl("(binary|both)", type))) "Built")if (is.null(fields))fields <- requiredFieldselse {stopifnot(is.character(fields))fields <- unique(c(requiredFields, fields))}if(missing(max_repo_cache_age))max_repo_cache_age <- as.numeric(Sys.getenv("R_AVAILABLE_PACKAGES_CACHE_CONTROL_MAX_AGE", "3600"))timestamp <- Sys.time()res <- matrix(NA_character_, 0L, length(fields) + 1L,dimnames = list(NULL, c(fields, "Repository")))url_to_cache_name <- function(url){# from rfc 3986re <- "^(([^:/?#]+):)?(//([^/?#]*))?([^?#]*)(\\?([^#]*))?(#(.*))?"p <- unlist(regmatches(url, regexec(re, url)))[c(2,4,6,7,9)]names(p) <- c("scheme", "authority", "path", "query", "fragment")if (grepl("@", p["authority"], fixed=TRUE)) {rea <- "//([^@]*)@(.*)"pa <- unlist(regmatches(p["authority"],regexec(rea, p["authority"])))[c(2,3)]names(pa) <- c("userinfo", "hostport")if (nzchar(pa["userinfo"])) {# replace user info by a hashsha <- tools::sha256sum(bytes=charToRaw(pa["userinfo"]))url <- paste0(p["scheme"], "//",substr(sha, 49, 64), "@", pa["hostport"],p["path"], p["query"], p["fragment"])}}URLencode(url, TRUE)}for(repos in unique(contriburl)) {localcran <- startsWith(repos, "file:")if(localcran) {## see note in download.packagesif(startsWith(repos, "file:///")) {tmpf <- paste0(substring(repos, 8L), "/PACKAGES")if(.Platform$OS.type == "windows") {if(length(grep("^/[A-Za-z]:", tmpf)))tmpf <- substring(tmpf, 2L)}} else {tmpf <- paste0(substring(repos, 6L), "/PACKAGES")}res0 <- if(file.exists(dest <- paste0(tmpf, ".rds")))readRDS(dest)elseread.dcf(file = tmpf)if(length(res0))rownames(res0) <- res0[, "Package"]} else {used_dest <- FALSEif(ignore_repo_cache) {dest <- tempfile()} else {dest <- file.path(if(cache_user_dir) tools::R_user_dir("base", "cache")else tempdir(),paste0("repos_", url_to_cache_name(repos),".rds"))if(file.exists(dest)) {age <- difftime(timestamp, file.mtime(dest), units = "secs")if(isTRUE(age < max_repo_cache_age)) {res0 <- readRDS(dest)used_dest <- TRUE## Be defensive :if(length(res0))rownames(res0) <- res0[, "Package"]}elseunlink(dest) # Cache too old.}}if(!used_dest) {## Try .rds and readRDS(), and then .gz or plain DCF and## read.dcf(), catching problems from both missing or## invalid files.need_dest <- FALSEop <- options(warn = -1L)z <- tryCatch({z <- download.file(url = paste0(repos, "/PACKAGES.rds"),destfile = dest, method = method,cacheOK = FALSE, quiet = quiet,mode = "wb", ...)if(z != 0L)stop(gettextf("'download.file()' error code '%d'", z))}, error = identity)options(op)if(!inherits(z, "error")) {z <- res0 <- tryCatch(readRDS(dest), error = identity)if(ignore_repo_cache) unlink(dest)}if(inherits(z, "error")) {## Downloading or reading .rds failed, so try the## DCF variants.if(!ignore_repo_cache) need_dest <- TRUEtmpf <- tempfile()on.exit(unlink(tmpf))op <- options(warn = -1L)## FIXME: this should check the return value == 0Lz <- tryCatch({## This is a binary filez <- download.file(url = paste0(repos, "/PACKAGES.gz"),destfile = tmpf, method = method,cacheOK = FALSE, quiet = quiet,mode = "wb", ...)if(z != 0L)stop(gettextf("'download.file()' error code '%d'", z))}, error = identity)if(inherits(z, "error"))z <- tryCatch({## read.dcf is going to interpret CRLF as## LF, so use binary mode to avoid CRLF.z <- download.file(url = paste0(repos, "/PACKAGES"),destfile = tmpf, method = method,cacheOK = FALSE, quiet = quiet,mode = "wb", ...)if(z != 0L)stop(gettextf("'download.file()' error code '%d'", z))}, error = identity)options(op)if (!inherits(z, "error"))z <- res0 <- tryCatch(read.dcf(file = tmpf),error = identity)unlink(tmpf)on.exit()}if(inherits(z, "error")) {warning(gettextf("unable to access index for repository %s",repos),":\n ", conditionMessage(z),call. = FALSE, immediate. = TRUE, domain = NA)## Do not cache incorrect results. It can be a page## from a web proxy about inaccessible network.unlink(dest)next}if(length(res0)) {rownames(res0) <- res0[, "Package"]if(need_dest)saveRDS(res0, dest, compress = TRUE)} else if(!need_dest) {## download.file() gave an empty .rds## Do not cache empty results.unlink(dest)}} # end of download vs cached} # end of localcran vs onlineif (length(res0)) {missingFields <- fields[!(fields %in% colnames(res0))]if (length(missingFields)) {toadd <- matrix(NA_character_, nrow = nrow(res0),ncol = length(missingFields),dimnames = list(NULL, missingFields))res0 <- cbind(res0, toadd)}if ("Path" %in% colnames(res0)) {rp <- rep.int(repos, nrow(res0))path <- res0[, "Path"]rp[!is.na(path)] <- paste(repos, path[!is.na(path)], sep = "/")} else rp <- reposres0 <- cbind(res0[, fields, drop = FALSE], Repository = rp)res <- rbind(res, res0, deparse.level = 0L)}if(verbose) cat("added", NROW(res0), "packages, from repos", sQuote(repos),"to a total of", NROW(res), "\n")} ## end for(repos in *)if(!length(res)) return(res)if(is.null(filters)) {filters <- getOption("available_packages_filters")if(is.null(filters))filters <- available_packages_filters_default}if(is.list(filters)) {## If filters is a list with an add = TRUE element, add the## given filters to the default ones.if(isTRUE(filters$add)) {filters$add <- NULLfilters <- c(available_packages_filters_default, filters)}}for(f in filters) {if(!length(res)) breakif(is.character(f)) {## Look up the filters db.## Could be nice and allow abbrevs or ignore case.f <- available_packages_filters_db[[f[1L]]]}if(!is.function(f))stop("invalid 'filters' argument.")res <- f(res)}res}available_packages_filters_default <-c("R_version", "OS_type", "subarch", "duplicates")available_packages_filters_db <- new.env(hash = FALSE) # smallavailable_packages_filters_db$R_version <-function(db){## Ignore packages which don't fit our version of R.## Compare current R version to given R version dependency which may## also be an SVN revision.cmp <- function(o, v) {y <- logical(length(v))i <- startsWith(v, "r")if(length(p <- which(i)))y[p] <- do.call(o, list(as.numeric(R.version[["svn rev"]]),as.numeric(substring(v[p], 2L))))if(length(p <- which(!i)))y[p] <- do.call(o, list(getRversion(), v[p]))y}depends <- db[, "Depends"]depends[is.na(depends)] <- ""## Collect the (versioned) R depends entries.x <- lapply(strsplit(gsub("[[:space:]]", "", depends), ",",fixed = TRUE),function(s) s[startsWith(s, "R(")])lens <- lengths(x)pos <- which(lens > 0L)if(!length(pos)) return(db)lens <- lens[pos]## Unlist.x <- unlist(x)end <- 3L + (substring(x, 4L, 4L) == "=")## Extract ops.ops <- substring(x, 3L, end)## Split target versions according to ops.ver <- split(substring(x, end + 1L, nchar(x) - 1L), ops)## Compare current to target grouped by op.res <- logical(length(x))for(op in names(ver))res[ops == op] <- cmp(op, ver[[op]])## And assemble test results according to the rows of db.pos <- pos[!vapply(split(res, rep.int(seq_along(lens), lens)), all,NA)]if(length(pos))db <- db[-pos, , drop = FALSE]db}available_packages_filters_db$OS_type <-function(db){## Ignore packages that do not fit our OS.OS_type <- db[, "OS_type"]db[is.na(OS_type) | (OS_type == .Platform$OS.type), , drop = FALSE]}available_packages_filters_db$subarch <-function(db){## Ignore packages that do not fit our sub-architecture.## Applies only to Mac and Windows binary repositories.current <- .Platform$r_archif(!nzchar(current)) return(db)archs <- db[, "Archs"]if(all(is.na(archs))) return(db)OK <- unlist(lapply(archs, function(x) {if(is.na(x)) return(TRUE)this <- strsplit(x, "[[:space:]]*,[[:space:]]*")[[1L]]current %in% this}))db[OK, , drop = FALSE]}available_packages_filters_db$duplicates <-function(db)tools:::.remove_stale_dups(db)filter_packages_by_depends_predicates <-function(db, predicate, recursive = TRUE){## Could also add a 'which' argument to specify which dependencies## are taken.## Drop all packages for which any (recursive) dependency does not## satisfy the given predicate (implemented as a function computing## TRUE or FALSE for each rows of the package db).## Somewhat tricky because there may be depends missing from the db,## which are taken not to satisfy the predicate unless they are## standard packages.## Determine all depends missing from the db.db1 <- data.frame(Package = db[, "Package"],stringsAsFactors = FALSE)fields <- c("Depends", "Imports", "LinkingTo")for(f in fields)db1[[f]] <-lapply(db[, f], tools:::.extract_dependency_package_names)all_packages <- unique(unlist(db1[fields], use.names = FALSE))bad_packages <-all_packages[is.na(match(all_packages, db1$Package))]## Drop the standard packages from these.bad_packages <-setdiff(bad_packages,unlist(tools:::.get_standard_package_names()))## Packages in the db which do not satisfy the predicate.ind <- !predicate(db)## Now find the recursive reverse dependencies of these and the## non-standard packages missing from the db.rdepends <-tools::package_dependencies(db1$Package[ind], db = db1,reverse = TRUE,recursive = recursive)rdepends <- unique(unlist(rdepends))ind[match(rdepends, db1$Package, nomatch = 0L)] <- TRUE## And drop these from the db.db[!ind, , drop = FALSE]}available_packages_filters_db$`license/FOSS` <-function(db) {predicate <- function(db)tools:::analyze_licenses(db[, "License"], db)$is_verifiedfilter_packages_by_depends_predicates(db, predicate)}available_packages_filters_db$`license/restricts_use` <-function(db) {predicate <- function(db) {ru <- tools:::analyze_licenses(db[, "License"], db)$restricts_use!is.na(ru) & !ru}filter_packages_by_depends_predicates(db, predicate)}available_packages_filters_db$CRAN <-function(db){packages <- db[, "Package"]dups <- packages[duplicated(packages)]drop <- integer()CRAN <- getOption("repos")["CRAN"]## do nothing if there is no CRAN repos on the listif(is.na(CRAN)) return(db)for(d in dups) {pos <- which(packages == d)ind <- !startsWith(db[pos, "Repository"], CRAN)if(!all(ind)) drop <- c(drop, pos[ind])}if(length(drop)) db[-drop, , drop = FALSE] else db}## unexported helper functionsimplifyRepos <- function(repos, type){tail <- substring(contrib.url("---", type), 4L)ind <- regexpr(tail, repos, fixed=TRUE)ind <- ifelse(ind > 0L, ind-1L, nchar(repos, type="c"))substr(repos, 1L, ind)}update.packages <- function(lib.loc = NULL, repos = getOption("repos"),contriburl = contrib.url(repos, type),method, instlib = NULL, ask = TRUE,available = NULL, oldPkgs = NULL, ...,checkBuilt = FALSE, type = getOption("pkgType")){if (!is.character(type))stop(gettextf("'%s' must be a character string", "type"), domain = NA)force(ask) # just a check that it is valid before we start worktext.select <- function(old){update <- NULLfor(k in seq_len(nrow(old))) {cat(old[k, "Package"], ":\n","Version", old[k, "Installed"],"installed in", old[k, "LibPath"],if(checkBuilt) paste("built under R", .builtRver(old[k, "Built"])),"\n","Version", old[k, "ReposVer"], "available at",simplifyRepos(old[k, "Repository"], type))cat("\n")answer <- askYesNo("Update?")if(is.na(answer)) {cat("cancelled by user\n")return(invisible())}if(isTRUE(answer))update <- rbind(update, old[k,])}update}if(is.null(lib.loc))lib.loc <- .libPaths()if(type == "both" && (!missing(contriburl) || !is.null(available))) {stop("specifying 'contriburl' or 'available' requires a single type, not type = \"both\"")}if(is.null(available)) {available <- if (type == "both" && .Platform$pkgType != "source").available.both(repos, method, ...)elseavailable.packages(contriburl = contriburl, method = method, ...)if (missing(repos)) repos <- getOption("repos") # May have changed}if(!is.matrix(oldPkgs) && is.character(oldPkgs)) {subset <- oldPkgsoldPkgs <- NULL} elsesubset <- NULLif(is.null(oldPkgs)) {## since 'available' is supplied, 'contriburl' and 'method' are unusedoldPkgs <- old.packages(lib.loc = lib.loc,contriburl = contriburl, method = method,available = available, checkBuilt = checkBuilt)if (missing(repos)) repos <- getOption("repos") # May have changed## prune package versions which are invisible to require()if(!is.null(oldPkgs)) {pkg <- 0Lwhile(pkg < nrow(oldPkgs)) {pkg <- pkg + 1Lif(find.package(oldPkgs[pkg], lib.loc = lib.loc) !=find.package(oldPkgs[pkg], lib.loc = oldPkgs[pkg,2])) {warning(sprintf("package '%s' in library '%s' will not be updated",oldPkgs[pkg], oldPkgs[pkg, 2]),call. = FALSE, immediate. = TRUE)oldPkgs <- oldPkgs[-pkg, , drop = FALSE]pkg <- pkg - 1L}}}if(is.null(oldPkgs))return(invisible())} else if (!(is.matrix(oldPkgs) && is.character(oldPkgs)))stop("invalid 'oldPkgs'; must be a character vector or a result from old.packages()")if(!is.null(subset)) {oldPkgs <- oldPkgs[ rownames(oldPkgs) %in% subset, ,drop=FALSE]if (nrow(oldPkgs) == 0)return(invisible())}update <- if(is.character(ask) && ask == "graphics") {if(.Platform$OS.type == "windows" || .Platform$GUI == "AQUA"|| (capabilities("tcltk") && capabilities("X11"))) {k <- select.list(oldPkgs[,1L], oldPkgs[,1L], multiple = TRUE,title = "Packages to be updated", graphics = TRUE)oldPkgs[match(k, oldPkgs[,1L]), , drop=FALSE]} else text.select(oldPkgs)} else if(isTRUE(ask)) text.select(oldPkgs)else oldPkgsif(length(update)) {if(is.null(instlib)) instlib <- update[, "LibPath"]## do this a library at a time, to handle dependencies correctly.libs <- unique(instlib)for(l in libs)if (type == 'both')install.packages(update[instlib == l , "Package"], l,repos = repos, method = method,..., type = type)elseinstall.packages(update[instlib == l , "Package"], l,contriburl = contriburl, method = method,available = available, ..., type = type)}}## (see also indices.R but it strips the time, sadly).builtDate <- function(built) { ## see also tools::.split_description, but return NA if something went wrong## also allow structure from package.rds (just in case)bc <- if (is.list(built) && is.character(built$Date))built$Dateelsestrsplit(built, "; ", fixed=TRUE)[[1]]## Note that the timestamp should be always in UTC## Some systems overwrite this field with invalid timestaps so ignore thoseif (length(bc) >= 3L)tryCatch(as.POSIXct(bc[3], "UTC"), error=function(e) NA)elseNA}.builtRver <- function(built) ## convert full "Built" string to just R version (unless it is already)gsub("^R ([0-9.]+).*", "\\1", built)## this is a wrapper of available.packages that handles the special case of type="both"## by calling available.packages twice: once with "source" and once with "binary",## combing the result. Given that the combination step is subject to specific choices,## the logic in this wrapper is tailored for internal use in update.packages and old.packages..available.both <- function(repos, method, ...) {## "both" gets complicated as we have to use available.packages twicefields <- c(tools:::.get_standard_repository_db_fields(), "File", "Built")av.src <- available.packages(contriburl = contrib.url(repos, "source"), method = method, fields = fields, ...)av.bin <- available.packages(contriburl = contrib.url(repos, "binary"), method = method, fields = fields, ...)## we keep things simple in that we use source unless there is the same binary version## so that we can get at the Built field. This is more simple than in install.packages## since we only care about determining whether a package is new, but not which type is## preferred - install.packages will sort that out.pkg.src <- row.names(av.src)pkg.bin <- row.names(av.bin)bin.ver <- av.bin[pkg.bin, "Version"]src.ver <- av.src[pkg.bin, "Version"]use.bin <- pkg.bin[as.numeric_version(bin.ver) >= as.numeric_version(src.ver)]use.bin <- use.bin[!is.na(use.bin)]use.src <- pkg.src[pkg.src %notin% use.bin]rbind(av.src[use.src,], av.bin[use.bin, ])}old.packages <- function(lib.loc = NULL, repos = getOption("repos"),contriburl = contrib.url(repos, type),instPkgs = installed.packages(lib.loc = lib.loc, ...),method, available = NULL, checkBuilt = FALSE,..., type = getOption("pkgType")){if (!is.character(type))stop(gettextf("'%s' must be a character string", "type"), domain = NA)if(is.null(lib.loc))lib.loc <- .libPaths()if(!missing(instPkgs)) {## actually we need rather more than thisif(!is.matrix(instPkgs) || !is.character(instPkgs[, "Package"]))stop("ill-formed 'instPkgs' matrix")}if(NROW(instPkgs) == 0L) return(NULL)## NB: type is ignored if either available or contriburl is specified.## update.packages() raises an error in that case, but we can't really do that,## becuase we get called with available internallyavailable <- if(is.null(available)) {if (type == "both" && .Platform$pkgType != "source").available.both(repos, method, ...)elseavailable.packages(contriburl = contriburl, method = method, ...)} else tools:::.remove_stale_dups(available)update <- NULL## safely attempt to parse a (possibly incomplete) timestamp in UTC.ts <- function(x) if (isTRUE(!is.na(x))) as.POSIXlt(x, optional=TRUE, tz="UTC") else NAneeds.install <- function(repo, inst)## if the repo version is higher, then it's obvious((package_version(repo["Version"]) > package_version(inst["Version"])) ||## otherwise it depends - on equal versions we still need to install if published/built is higher(package_version(repo["Version"]) == package_version(inst["Version"]) &&(isTRUE(.builtDate(repo["Built"]) > .builtDate(inst["Built"])) || ## new re-built binaryisTRUE(.ts(repo["Published"]) > .ts(inst["Published"])) ## new "invalidated" due to dependency)))currentR <- minorR <- getRversion()minorR[[c(1L, 3L)]] <- 0L # set patchlevel to 0for(k in 1L:nrow(instPkgs)) {if (instPkgs[k, "Priority"] %in% "base") nextz <- match(instPkgs[k, "Package"], rownames(available))if(is.na(z)) nextonRepos <- available[z, ]## works OK if Built: is missing (which it should not be)if((!checkBuilt || package_version(.builtRver(instPkgs[k, "Built"])) >= minorR) &&!needs.install(onRepos, instPkgs[k,])) nextdeps <- onRepos["Depends"]if(!is.na(deps)) {Rdeps <- tools:::.split_dependencies(deps)[["R", exact=TRUE]]if(length(Rdeps) > 1L && !do.call(Rdeps$op, list(currentR, Rdeps$version)))next}update <- rbind(update,c(instPkgs[k, c("Package", "LibPath", "Version", "Built")],onRepos["Version"], onRepos["Repository"]))}if(!is.null(update))colnames(update) <- c("Package", "LibPath", "Installed", "Built","ReposVer", "Repository")rownames(update) <- update[, "Package"]## finally, remove any duplicate rowsupdate[!duplicated(update), , drop = FALSE]}new.packages <- function(lib.loc = NULL, repos = getOption("repos"),contriburl = contrib.url(repos, type),instPkgs = installed.packages(lib.loc = lib.loc, ...),method, available = NULL, ask = FALSE,..., type = getOption("pkgType")){if (!is.character(type))stop(gettextf("'%s' must be a character string", "type"), domain = NA)ask # just a check that it is valid before we start workif(type == "both" && (!missing(contriburl) || !is.null(available))) {stop("specifying 'contriburl' or 'available' requires a single type, not type = \"both\"")}if(is.null(lib.loc)) lib.loc <- .libPaths()if(!is.matrix(instPkgs))stop(gettextf("no installed packages for (invalid?) 'lib.loc=%s'",lib.loc), domain = NA)## NB: this implicitly uses type="source" even if type="both" - c.f. contrib.url()## but that's ok here as there should not be binary packages without sourcesif(is.null(available))available <- available.packages(contriburl = contriburl,method = method, ...)installed <- unique(instPkgs[, "Package"])poss <- sort(unique(available[ ,"Package"])) # sort in local localeres <- setdiff(poss, installed)update <- character()graphics <- FALSEif(is.character(ask) && ask == "graphics") {ask <- TRUEif(.Platform$OS.type == "windows" || .Platform$GUI == "AQUA"|| (capabilities("tcltk") && capabilities("X11")))graphics <- TRUE}if(isTRUE(ask)) {if(length(res))update <- res[match(select.list(res, multiple = TRUE,title = "New packages to be installed",graphics = graphics), res)]else message("no new packages are available")}if(length(update)) {if(type == "both")install.packages(update, lib = lib.loc[1L], method = method,type = type, ...)elseinstall.packages(update, lib = lib.loc[1L], contriburl = contriburl,method = method, available = available,type = type, ...)# Now check if they were installed and update 'res'dirs <- list.files(lib.loc[1L])updated <- update[update %in% dirs]res <- res[!res %in% updated]}res}.instPkgFields <- function(fields) {## to be used in installed.packages() and similarrequiredFields <-c(tools:::.get_standard_repository_db_fields(), "Built", "Published")if (is.null(fields))fields <- requiredFieldselse {stopifnot(is.character(fields))fields <- unique(c(requiredFields, fields))}## Don't retain 'Package' and 'LibPath' fields as these are used to## record name and path of installed packages.fields[! fields %in% c("Package", "LibPath")]}## Read packages' Description and aggregate 'fields' into a character matrix## NB: this does not handle encodings, so only suitable for ASCII-only fields..readPkgDesc <- function(lib, fields, pkgs = list.files(lib)){## to be used in installed.packages() and similar## As from 2.13.0 only look at metadata.ret <- matrix(NA_character_, length(pkgs), 2L+length(fields))for(i in seq_along(pkgs)) {pkgpath <- file.path(lib, pkgs[i])if(file.access(pkgpath, 5L)) nextif (file.exists(file <- file.path(pkgpath, "Meta", "package.rds"))) {## this is vulnerable to installs going on in parallelmd <- try(readRDS(file))if(inherits(md, "try-error")) nextdesc <- md$DESCRIPTION[fields]if (!length(desc)) {warning(gettextf("metadata of %s is corrupt", sQuote(pkgpath)),domain = NA)next}ret[i, ] <- c(pkgs[i], lib, desc)}}ret[!is.na(ret[, 1L]), , drop = FALSE]}installed.packages <-function(lib.loc = NULL, priority = NULL, noCache = FALSE,cache_user_dir = str2logical(Sys.getenv("R_PACKAGES_CACHE_USER_DIR", FALSE)),fields = NULL, subarch = .Platform$r_arch, ...){if(is.null(lib.loc))lib.loc <- .libPaths()if(!is.null(priority)) {if(!is.character(priority))stop("'priority' must be character or NULL")if(any(b <- priority %in% "high"))priority <- c(priority[!b], "recommended","base")}fields <- .instPkgFields(fields)retval <- matrix(character(), 0L, 2L + length(fields))for(lib in lib.loc) {if(noCache) {ret0 <- .readPkgDesc(lib, fields)if(length(ret0)) retval <- rbind(retval, ret0, deparse.level = 0L)} else {## Previously used URLencode for e.g. Windows paths with drives## This version works for very long file names.base <- paste(c(lib, fields), collapse = ",")## add length and 64-bit CRC in hex (in theory, seems## it is actually 32-bit on some systems)enc <- sprintf("%d_%s", nchar(base), .Call(C_crc64, base))dest <- file.path(if(cache_user_dir) tools::R_user_dir("base", "cache")else tempdir(),paste0("libloc_", enc, ".rds"))test <- file.exists(dest) &&file.mtime(dest) > file.mtime(lib) &&(val <- readRDS(dest))$base == baseif(isTRUE(as.vector(test)))## use the cache fileretval <- rbind(retval, val$value)else {ret0 <- .readPkgDesc(lib, fields)if(length(ret0)) {retval <- rbind(retval, ret0, deparse.level = 0L)## save the cache filedir.create(dirname(dest), recursive = TRUE,showWarnings = FALSE)saveRDS(list(base = base, value = ret0), dest)} else unlink(dest)}}}.fixupPkgMat(retval, fields, priority, subarch)}.fixupPkgMat <- function(mat, fields, priority, subarch=NULL){## to be used in installed.packages() and similarcolnames(mat) <- c("Package", "LibPath", fields)if (length(mat) && !is.null(priority)) {keep <- !is.na(pmatch(mat[,"Priority"], priority,duplicates.ok = TRUE))mat <- mat[keep, , drop = FALSE]}if (length(mat) && !is.null(subarch) && nzchar(subarch)) {archs <- strsplit(mat[, "Archs"], ", ", fixed = TRUE)keep <- unlist(lapply(archs,function(x) is.na(x[1L]) || subarch %in% x))mat <- mat[keep, , drop = FALSE]}if (length(mat)) mat <- mat[, colnames(mat) != "Archs", drop = FALSE]if (length(mat)) rownames(mat) <- mat[, "Package"]mat}remove.packages <- function(pkgs, lib){if(!length(pkgs)) return(invisible())base <- vapply(pkgs, isBasePkg, FALSE)if(any(base)) {(if(all(base)) stop else warning)(sprintf(ngettext(sum(base),"package %s is a base package, and cannot be removed","packages %s are base packages, and cannot be removed"),paste(sQuote(pkgs[base]), collapse = ", ")),domain = NA)pkgs <- pkgs[!base]}updateIndices <- function(lib) {## This matches what install.packages() doesif(lib == .Library && .Platform$OS.type == "unix") {message("Updating HTML index of packages in '.Library'")make.packages.html(.Library)}}if(missing(lib) || is.null(lib)) {lib <- .libPaths()[1L]message(sprintf(ngettext(length(pkgs),"Removing package from %s\n(as %s is unspecified)","Removing packages from %s\n(as %s is unspecified)"),sQuote(lib), sQuote("lib")), domain = NA)}paths <- find.package(pkgs, lib)if(length(paths)) {unlink(paths, TRUE)for(lib in unique(dirname(paths))) updateIndices(lib)}invisible()}.download.file.method <- function(method){if (missing(method))method <- getOption("download.file.method", default = "auto")match.arg(method, c("auto", "internal", "wininet","libcurl", "wget", "curl", "lynx"))}download.packages <- function(pkgs, destdir, available = NULL,repos = getOption("repos"),contriburl = contrib.url(repos, type),method, type = getOption("pkgType"),local = FALSE, ...){if (!is.character(type))stop(gettextf("'%s' must be a character string", "type"), domain = NA)nonlocalcran <- !all(startsWith(contriburl, "file:")) || localif(nonlocalcran && !dir.exists(destdir))stop("'destdir' is not a directory")type <- resolvePkgType(type)if(is.null(available))available <-available.packages(contriburl = contriburl, method = method, ...)if (.download.file.method(method) %in% c("auto", "libcurl"))bulkdown <- matrix(character(), 0L, 3L)elsebulkdown <- NULLretval <- matrix(character(), 0L, 2L)for(p in unique(pkgs)){ok <- (available[,"Package"] == p)ok <- ok & !is.na(ok)if(!any(ok))warning(gettextf("no package %s at the repositories", sQuote(p)),domain = NA, immediate. = TRUE)else {if(sum(ok) > 1L) { # have multiple copiesvers <- package_version(available[ok, "Version"])keep <- vers == max(vers)keep[duplicated(keep)] <- FALSEok[ok][!keep] <- FALSE}## in Oct 2009 we introduced file names in PACKAGES filesFile <- available[ok, "File"]## strip build name for ext detectiontype <- gsub("^([[:lower:]]+[.]binary)[.].*", "\\1", type)## this is just a fall-back if there is no File: so hopefully## no longer usedfn <- paste0(p, "_", available[ok, "Version"],switch(type,"source" = ".tar.gz","mac.binary" = ".tgz","win.binary" = ".zip",".tar.xz")) ## for any other binaries, but they should use File:have_fn <- !is.na(File)fn[have_fn] <- File[have_fn]repos <- available[ok, "Repository"]if(startsWith(repos, "file:")) { # local repository## This could be file: + file path or a file:/// URL.if(startsWith(repos, "file:///")) {## We need to derive the file name from the URL## This is tricky as so many forms have been allowed,## and indeed external methods may do even more.fn <- paste(substring(repos, 8L), fn, sep = "/")## This leaves a path beginning with /if(.Platform$OS.type == "windows") {if(length(grep("^/[A-Za-z]:", fn)))fn <- substring(fn, 2L)}} else {fn <- paste(substring(repos, 6L), fn, sep = "/")}if(file.exists(fn)) {if(local) file.copy(fn, destdir)retval <- rbind(retval, c(p, fn))}elsewarning(gettextf("package %s does not exist on the local repository", sQuote(p)),domain = NA, immediate. = TRUE)} else {url <- paste(repos, fn, sep = "/")destfile <- file.path(destdir, fn)if (is.null(bulkdown)) {# serial downloadres <- try(download.file(url, destfile, method, mode = "wb",...))if(!inherits(res, "try-error") && res == 0L)retval <- rbind(retval, c(p, destfile))elsewarning(gettextf("download of package %s failed", sQuote(p)),domain = NA, immediate. = TRUE)} elsebulkdown <- rbind(bulkdown, c(p, destfile, url))}}}if (!is.null(bulkdown) && nrow(bulkdown) > 0) {# bulk download using libcurlurls <- bulkdown[,3]destfiles <- bulkdown[,2]ps <- bulkdown[,1]res <- try(download.file(urls, destfiles, "libcurl", mode = "wb", ...))if(!inherits(res, "try-error") && res == 0L) {if (length(urls) > 1) {retvals <- attr(res, "retvals")for(i in seq_along(retvals)) {if (retvals[i] == 0L)retval <- rbind(retval, c(ps[i], destfiles[i]))elsewarning(gettextf("download of package %s failed",sQuote(ps[i])), domain = NA, immediate. = TRUE)}} elseretval <- rbind(retval, c(ps, destfiles))} elsefor(p in ps)warning(gettextf("download of package %s failed", sQuote(p)),domain = NA, immediate. = TRUE)}retval}resolvePkgType <- function(type) {## Not entirely clear this is optimal## This was built on the assumption that binaries are always a subset, so## using sources covers everything necssary. Not only is that not guaranteed,## but binaries now may have additional information such as build timestamps.if(type == "both") type <- "source"else if(type == "binary") type <- .Platform$pkgTypetype}contrib.url <- function(repos, type = getOption("pkgType")){if (!is.character(type))stop(gettextf("'%s' must be a character string", "type"), domain = NA)type <- resolvePkgType(type)if(is.null(repos)) return(NULL)if(!length(repos)) return(character())if("@CRAN@" %in% repos && interactive()) {cat(gettext("--- Please select a CRAN mirror for use in this session ---"),"\n", sep = "")flush.console()chooseCRANmirror()m <- match("@CRAN@", repos)nm <- names(repos)repos[m] <- getOption("repos")["CRAN"]if(is.null(nm)) nm <- rep.int("", length(repos))nm[m] <- "CRAN"names(repos) <- nm}if("@CRAN@" %in% repos) stop("trying to use CRAN without setting a mirror")ver <- paste(R.version$major,strsplit(R.version$minor, ".", fixed=TRUE)[[1L]][1L], sep = ".").contrib.path <- function(type, ver) {## <os>.binary[.<build>] where build has to match [[:alnum:]_-]+m <- regexec("^([[:lower:]]+)[.]binary(|[.]([[:alnum:]_-]+))$", type)if (length(m) && length(m[[1]]) == 4) { ## binary spec?m <- m[[1]]l <- attr(m, "match.length")os <- substr(type, m[2], m[2] + l[2] - 1L)## for historical reasons mac/win have different directory namesos <- switch(os, mac = "macosx", win = "windows", os)if (l[3] > 0) ## have build name ?paste("bin", os, substr(type, m[4], m[4] + l[4] - 1L), "contrib", ver, sep = "/")elsepaste("bin", os, "contrib", ver, sep = "/")} else if (isTRUE(type == "source"))"src/contrib"elsestop("invalid 'type'")}paste(gsub("/$", "", repos), .contrib.path(type, ver), sep = "/")}.getMirrors <- function(url, local.file, all, local.only){m <- NULLif(!local.only) {## Try to handle explicitly failure to connect to CRAN.f <- tempfile()on.exit(unlink(f))m <- tryCatch({m <- download.file(url, destfile = f, quiet = TRUE)if(m != 0L)stop(gettextf("'download.file()' error code '%d'", m))read.csv(f, as.is = TRUE, encoding = "UTF-8")}, error=function(err) {warning(gettextf("failed to download mirrors file (%s); using local file '%s'",conditionMessage(err), local.file),call.=FALSE, immediate.=TRUE)NULL})}if(is.null(m))m <- read.csv(local.file, as.is = TRUE, encoding = "UTF-8")if(!all) m <- m[as.logical(m$OK), ]m}getCRANmirrors <- function(all = FALSE, local.only = FALSE){.getMirrors("https://cran.r-project.org/CRAN_mirrors.csv",file.path(R.home("doc"), "CRAN_mirrors.csv"),all = all, local.only = local.only)}.chooseMirror <- function(m, label, graphics, ind){if(is.null(ind) && !interactive())stop("cannot choose a ", label, " mirror non-interactively")if (length(ind))res <- as.integer(ind)[1L]else {isHTTPS <- (startsWith(m[, "URL"], "https") &grepl("secure_mirror_from_master",m[, "Comment"],fixed = TRUE))mHTTPS <- m[isHTTPS,]mHTTP <- m[!isHTTPS,]httpsLabel <- paste("Secure", label, "mirrors")httpLabel <- paste("Other", label, "mirrors")m <- mHTTPSres <- menu(c(m[, 1L], "(other mirrors)"), graphics, httpsLabel)if (res > nrow(m)) {m <- mHTTPres <- menu(m[, 1L], graphics, httpLabel)}}if (res > 0L) {URL <- m[res, "URL"]names(URL) <- m[res, "Name"]sub("/$", "", URL[1L])} else character()}chooseCRANmirror <- function(graphics = getOption("menu.graphics"), ind = NULL,local.only = FALSE){m <- getCRANmirrors(all = FALSE, local.only = local.only)url <- .chooseMirror(m, "CRAN", graphics, ind)if (length(url)) {repos <- getOption("repos")repos["CRAN"] <- urloptions(repos = repos)}invisible()}chooseBioCmirror <- function(graphics = getOption("menu.graphics"), ind = NULL,local.only = FALSE){m <- .getMirrors("https://bioconductor.org/BioC_mirrors.csv",file.path(R.home("doc"), "BioC_mirrors.csv"),all = FALSE, local.only = local.only)url <- .chooseMirror(m, "BioC", graphics, ind)if (length(url))options(BioC_mirror = url)invisible()}setRepositories <-function(graphics = getOption("menu.graphics"), ind = NULL,addURLs = character(), name = NULL){if(is.null(name) && is.null(ind) && !interactive())stop("cannot set repositories non-interactively")a <- .get_repositories()pkgType <- getOption("pkgType")if (!is.character(pkgType))stop("invalid options(\"pkgType\"); must be a character string")if (pkgType == "both") pkgType <- "source" #.Platform$pkgTypeif (pkgType == "binary") pkgType <- .Platform$pkgType## strip build names (until we need them and start recording them)pkgType <- gsub("^([[:lower:]]+[.]binary)[.].*", "\\1", pkgType)thisType <- a[[pkgType]]a <- a[thisType, 1L:3L]repos <- getOption("repos")## Now look for CRAN and any others in getOptions("repos")if("CRAN" %in% row.names(a) && !is.na(CRAN <- repos["CRAN"]))a["CRAN", "URL"] <- CRAN## Set as default any already in the option.a[(a[["URL"]] %in% repos), "default"] <- TRUEnew <- !(repos %in% a[["URL"]])if(any(new)) {aa <- names(repos[new])if(is.null(aa)) aa <- rep.int("", length(repos[new]))aa[aa == ""] <- repos[new][aa == ""]newa <- data.frame(menu_name=aa, URL=repos[new], default=TRUE)row.names(newa) <- aaa <- rbind(a, newa, deparse.level = 0L)}default <- a[["default"]]res <- if (length(name)) {m <- match(tolower(name), tolower(row.names(a)))if (any(is.na(m)))stop("No matching repositories found for ",paste(name[is.na(m)], collapse=', '))m} else if(length(ind)) as.integer(ind)else {title <- if(graphics) "Repositories" else gettext("--- Please select repositories for use in this session ---\n")match(select.list(a[, 1L], a[default, 1L], multiple = TRUE, title,graphics = graphics), a[, 1L])}if(length(res) || length(addURLs)) {repos <- a[["URL"]]names(repos) <- row.names(a)repos <- c(repos[res], addURLs)options(repos = repos)}}findCRANmirror <- function(type = c("src", "web")){e <- paste0("R_CRAN_", toupper(type))Sys.getenv(e, tools:::.get_CRAN_repository_URL())}## used in some BioC packages and their support in tools.compareVersion <- function(a, b){if(is.na(a)) return(-1L)if(is.na(b)) return(1L)## The nest two could be skipped if(inherits(x), "numeric_version")## but the saving would be small.a <- as.integer(strsplit(a, "[.-]")[[1L]])b <- as.integer(strsplit(b, "[.-]")[[1L]])## This does not handle malformed inputs which will give an error.for(k in seq_along(a))if(k <= length(b)) {if(a[k] > b[k]) return(1) else if(a[k] < b[k]) return(-1L)} else return(1L)if(length(b) > length(a)) return(-1L) else return(0L)}## ------------- private functions --------------------## .clean_up_dependencies <- function(x, available = NULL)## {## ## x is a character vector of Depends / Suggests / Imports entries## ## returns a character vector of all the package dependencies mentioned## x <- x[!is.na(x)]## if(!length(x)) return(x)## x <- unlist(strsplit(x, ",", fixed = TRUE), use.names = FALSE)## unique(sub("^[[:space:]]*([[:alnum:].]+).*$", "\\1" , x))## }.clean_up_dependencies <- function(x)unique.default(tools:::.extract_dependency_package_names(x)).clean_up_dependencies2 <- function(x, installed, available){## x is a character vector of Depends / Suggests / Imports entries.## Returns a list of length 2, a character vector of the names of## all the package dependencies mentioned that are not already## satisfied and one of those which cannot be satisfied (possibly## of the form "pkg (>= ver)').split_dependencies <- function(x) {.split2 <- function(x) {## some have had space before ,x <- sub('[[:space:]]+$', '', x)x <- unique(sub("^[[:space:]]*(.*)", "\\1" , x))names(x) <- sub("^([[:alnum:].]+).*$", "\\1" , x)x <- x[names(x) != "R"]x <- x[nzchar(x)]## FIXME: a better way to handle duplicates.## However, there should not be any, and if there are## Depends: should be the first.x <- x[!duplicated(names(x))]lapply(x, tools:::.split_op_version)}## given one of more concatenations of Depends/Imports/Suggests fields,## return a named list of list(name, [op, version])if(!any(nzchar(x))) return(list())unlist(lapply(strsplit(x, ","), .split2), FALSE, FALSE)}x <- x[!is.na(x)]if(!length(x)) return(list(character(), character()))xx <- .split_dependencies(x)if(!length(xx)) return(list(character(), character()))## Then check for those we already have installedpkgs <- installed[, "Package"]have <- vapply(xx, function(x) {if(length(x) == 3L) {if (! x[[1L]] %in% pkgs ) return(FALSE)if(x[[2L]] != ">=") return(TRUE)## We may have the package installed more than once## which we get will depend on the .libPaths() order,## so for now just see if any installed version will do.current <- as.package_version(installed[pkgs == x[[1L]], "Version"])target <- as.package_version(x[[3L]])any(do.call(x$op, list(current, target)))} else x[[1L]] %in% pkgs}, NA)xx <- xx[!have]if(!length(xx)) return(list(character(), character()))## now check if we can satisfy the missing dependenciespkgs <- row.names(available)canget <- miss <- character()for (i in seq_along(xx)) {x <- xx[[i]]if(length(x) == 3L) {if (! x[[1L]] %in% pkgs ) { miss <- c(miss, x[[1L]]); next }if(x[[2L]] != ">=") { canget <- c(canget, x[[1L]]); next }## we may have the package available more than once## install.packages() will find the highest version.current <- as.package_version(available[pkgs == x[[1L]], "Version"])target <- as.package_version(x[[3L]])res <- any(do.call(x$op, list(current, target)))if(res) canget <- c(canget, x[[1L]])else miss <- c(miss, paste0(x[[1L]], " (>= ", x[[3L]], ")"))} else if(x[[1L]] %in% pkgs) canget <- c(canget, x[[1L]])else miss <- c(miss, x[[1L]])}list(canget, miss)}.make_dependency_list <-function(pkgs, available,dependencies = c("Depends", "Imports", "LinkingTo"),recursive = FALSE){## given a character vector of packages,## return a named list of character vectors of their dependencies.## If recursive = TRUE, do this recursively.if(!length(pkgs)) return(NULL)if(is.null(available))stop(gettextf("%s must be supplied", sQuote("available")), domain = NA)info <- available[pkgs, dependencies, drop = FALSE]x <- vector("list", length(pkgs)); names(x) <- pkgsif(recursive) {known <- row.names(available)xx <- vector("list", length(known)); names(xx) <- knowninfo2 <- available[, dependencies, drop = FALSE]for (i in seq_along(known))xx[[i]] <- .clean_up_dependencies(info2[i, ])for (i in pkgs) {p <- xx[[i]]p <- p[p %in% known]; p1 <- prepeat {extra <- unlist(xx[p1])extra <- extra[extra != i]extra <- extra[extra %in% known]deps <- unique(c(p, extra))if (length(deps) <= length(p)) breakp1 <- deps[!deps %in% p]p <- deps}x[[i]] <- p}} else {for (i in seq_along(pkgs)) x[[i]] <- .clean_up_dependencies(info[i, ])}x}.find_install_order <- function(pkgs, dependencyList){## given a character vector of packages, find an install order## which reflects their dependencies.DL <- dependencyList[pkgs]## some of the packages may be already installed, but the## dependencies apply to those being got from CRAN.DL <- lapply(DL, function(x) x[x %in% pkgs])lens <- lengths(DL)if(all(lens > 0L)) {warning("every package depends on at least one other")return(pkgs)}done <- names(DL[lens == 0L]); DL <- DL[lens > 0L]while(length(DL)) {OK <- vapply(DL, function(x) all(x %in% done), NA)if(!any(OK)) {warning(gettextf("packages %s are mutually dependent",paste(sQuote(names(DL)), collapse = ", ")),domain = NA)return(c(done, names(DL)))}done <- c(done, names(DL[OK]))DL <- DL[!OK]}done}## moved from tools/R/utils.R as this is now called in utils::.onLoad.get_repositories <- function(){rfile <- Sys.getenv("R_REPOSITORIES", unset = NA_character_)## "NULL" has a special meaning during .onLoad()if(is.na(rfile) || rfile == "NULL" || !file_test("-f", rfile)) {rfile <- file.path(Sys.getenv("HOME"), ".R", "repositories")if(!file_test("-f", rfile))rfile <- file.path(R.home("etc"), "repositories")}.read_repositories(rfile)}.read_repositories <- function(file){db <- read.delim(file, header = TRUE, comment.char = "#",colClasses = c(rep.int("character", 3L),rep.int("logical", 4L))) # allow for win64.binarydb[, "URL"] <- .expand_BioC_repository_URLs(db[, "URL"])db}.write_repositories <-function(repos, file = stdout(), ...){## Use .write_repositories(getOption("repos")) to write the current## option to a file which can be re-used by other R processes.x <- list(...)n <- length(repos)h <- "menu_name\tURL\tdefault\tsource\twin.binary\tmac.binary"s <- sprintf(paste(rep.int("%s", 7L), collapse = "\t"),names(repos),names(repos),repos,rep_len(x$default %||% "TRUE", n),rep_len(x$source %||% "NA", n),rep_len(x$win.binary %||% "NA", n),rep_len(x$mac.binary %||% "NA", n))writeLines(c(h, s), file)}### default changed to https: for R 3.3.0.expand_BioC_repository_URLs <- function(x){x <- sub("%bm",as.character(getOption("BioC_mirror","https://bioconductor.org")),x, fixed = TRUE)sub("%v",as.character(.BioC_version_associated_with_R_version()),x, fixed = TRUE)}## default is included in setRepositories.Rd (via \Sexpr).BioC_version_associated_with_R_version_default <- "3.23".BioC_version_associated_with_R_version <- function ()numeric_version(Sys.getenv("R_BIOC_VERSION",.BioC_version_associated_with_R_version_default))## Helper for getting the dependencies of the given installed packages## without reading the DESCRIPTION metadata of all installed packages..installed_package_dependencies <- function(pkgs, fields) {mat <- do.call(rbind,lapply(.libPaths(), .readPkgDesc, fields, pkgs))lst <- apply(mat[, - c(1L, 2L), drop = FALSE], 1L,.clean_up_dependencies, simplify = FALSE)names(lst) <- mat[, 1L]lst}