From adcaaf19debb8cefbb026154f6b32024a43aa481 Mon Sep 17 00:00:00 2001 From: vincent guyader Date: Sun, 5 Nov 2023 21:32:59 +0100 Subject: [PATCH] use internalised renv version. * fix issue #56 and #64 . - feat: use of {memoise} to cache call to `pak::pkg_system_requirements` - fix : dont depend anymore to {renv} use an internalised {renv} version (1.0.3) - fix : remove `renv:::lockfile` and use `lockfile_read` instead - feat: Added `renv_version` parameter to `dock_from_renv` to be able to fix the renv version to use during `renv::restore()` --- DESCRIPTION | 7 +- NAMESPACE | 2 + NEWS.md | 17 +- R/dock_from_renv.R | 52 +- R/renv.R | 91 + dev/config_fusen.yaml | 2 +- dev/flat_dock_from_renv.Rmd | 188 +- inst/renv_with_1.0.0.lock | 709 + inst/vendor/renv.R | 33442 ++++++++++++++++++++++ man/dock_from_renv.Rd | 7 +- man/renv.Rd | 16 + tests/testthat/test-dock_from_renv.R | 99 +- vignettes/dockerfile-from-renv-lock.Rmd | 30 - 13 files changed, 34451 insertions(+), 211 deletions(-) create mode 100644 R/renv.R create mode 100644 inst/renv_with_1.0.0.lock create mode 100644 inst/vendor/renv.R create mode 100644 man/renv.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 0e00572..c506f55 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: dockerfiler Title: Easy Dockerfile Creation from R -Version: 0.2.1.9003 +Version: 0.2.1.9004 Authors@R: c( person("Colin", "Fay", , "contact@colinfay.me", role = c("cre", "aut"), comment = c(ORCID = "0000-0001-7343-1846")), @@ -24,11 +24,11 @@ Imports: fs (>= 1.5.0), glue (>= 1.4.2), jsonlite (>= 1.7.2), + memoise, pak (>= 0.2.0), pkgbuild (>= 1.2.0), R6 (>= 2.5.0), remotes (>= 2.2.0), - renv (>= 0.12.0), usethis (>= 2.0.1), utils Suggests: @@ -36,8 +36,7 @@ Suggests: rmarkdown (>= 2.6), testthat (>= 3.0.0), withr -VignetteBuilder: - knitr +VignetteBuilder: knitr Config/fusen/version: 0.5.2.9000 Config/testthat/edition: 3 Encoding: UTF-8 diff --git a/NAMESPACE b/NAMESPACE index a724b58..d3144b3 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -8,6 +8,7 @@ export(docker_ignore_add) export(get_sysreqs) export(parse_dockerfile) export(r) +export(renv) importFrom(R6,R6Class) importFrom(attempt,map_try_catch) importFrom(attempt,warn_if_not) @@ -21,6 +22,7 @@ importFrom(fs,file_temp) importFrom(fs,path) importFrom(glue,glue) importFrom(jsonlite,fromJSON) +importFrom(memoise,memoise) importFrom(pak,pkg_system_requirements) importFrom(pkgbuild,build) importFrom(remotes,dev_package_deps) diff --git a/NEWS.md b/NEWS.md index 9a6605c..ab76af4 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,12 +1,21 @@ -# dockerfile 0.2.0 to 0.3.0 +# dockerfile 0.2.x to 0.3.0 -- fix: graceful failing in case no internet +- feat: use of {memoise} to cache call to `pak::pkg_system_requirements` + +- fix : dont depend anymore to {renv} use an internalised {renv} version (1.0.3) + +- fix : remove `renv:::lockfile` and use `lockfile_read` instead - feat: Added `dock_from_renv()`, to create a Dockerfile from a renv.lock file (@JosiahParry, @statnmap) -- feat: Added `parse_dockerfile()`, to Create a Dockerfile object from a Dockerfile (@JosiahParry) +- feat: Added `parse_dockerfile()`, to Create a Dockerfile object from a Dockerfile file (@JosiahParry) + +- feat: Added `renv_version` parameter to `dock_from_renv` to be able to fix the renv version to use during `renv::restore()` (@campbead) -- feat: Added `fix_renv_version` boolean parameter to `dock_from_renv` to be able to fix the renv version to use during `renv::restore()` + +# dockerfile 0.2.0 + +- fix: graceful failing in case no internet - fix: the dedicated `compact_sysreqs` function allow to deal with 'complex' sysreqs, such as chromimum installation diff --git a/R/dock_from_renv.R b/R/dock_from_renv.R index 006a164..62a7ef9 100644 --- a/R/dock_from_renv.R +++ b/R/dock_from_renv.R @@ -9,6 +9,12 @@ available_distros <- c( "centos8" ) +#' @importFrom memoise memoise +pkg_system_requirements_mem <- memoise::memoise( + pak::pkg_system_requirements +) + + #' Create a Dockerfile from an `renv.lock` file #' #' @param lockfile Path to an `renv.lock` file to use as an input.. @@ -24,8 +30,9 @@ available_distros <- c( #' @param repos character. The URL(s) of the repositories to use for `options("repos")`. #' @param extra_sysreqs character vector. Extra debian system requirements. #' Will be installed with apt-get install. -#' @param fix_renv_version boolean. If `TRUE` the version of renv in the lockfile -#' will be used for the `renv::restore()` command +#' @param renv_version character. The {renv} version to use in the generated Dockerfile. +#' By default, it is set to the version specified in the `renv.lock` file. +#' If the `renv.lock` file does not specify a {renv} version, the version of {renv} bundled with {dockerfiler}, specifically `dockerfiler::renv$the$metadata$version`, will be used. If you set it to NULL, the latest available version of {renv} will be used. #' @importFrom utils getFromNamespace #' @return A R6 object of class `Dockerfile`. #' @details @@ -58,17 +65,15 @@ dock_from_renv <- function( repos = c(CRAN = "https://cran.rstudio.com/"), expand = FALSE, extra_sysreqs = NULL, - fix_renv_version = FALSE + renv_version ) { distro <- match.arg(distro, available_distros) - - lock <- getFromNamespace("lockfile", "renv")(lockfile) - - # lock$repos(CRAN = repos) - lockfile <- basename(lockfile) + try(dockerfiler::renv$initialize(),silent=TRUE) + lock <- dockerfiler::renv$lockfile_read(file = lockfile) # using vendored renv + # https://rstudio.github.io/renv/reference/vendor.html?q=vendor#null # start the dockerfile - R_major_minor <- lock$data()$R$Version + R_major_minor <- lock$R$Version dock <- Dockerfile$new( FROM = gen_base_image( distro = distro, @@ -79,7 +84,18 @@ dock_from_renv <- function( ) # get renv version - renv_version <- lock$data()$Packages$renv$Version + + if (missing(renv_version)) { + if (!is.null(lock$Packages$renv$Version)) { + renv_version <- lock$Packages$renv$Version + } else { + renv_version <- dockerfiler::renv$the$metadata$version + } + } + + message("renv version = ", + ifelse(!is.null(renv_version),renv_version,"the must up to date in the repos") + ) distro_args <- switch( distro, @@ -139,7 +155,7 @@ dock_from_renv <- function( jammy = "rm -rf /var/lib/apt/lists/*" ) - pkgs <- names(lock$data()$Packages) + pkgs <- names(lock$Packages) if (sysreqs) { @@ -167,11 +183,12 @@ dock_from_renv <- function( } ) + pkg_sysreqs <- attempt::map_try_catch( pkg_os, function(x) { do.call( - pak::pkg_system_requirements, + pkg_system_requirements_mem, x ) }, @@ -244,13 +261,13 @@ dock_from_renv <- function( ) ) - # check if fix_renv_version is true - if (fix_renv_version){ + + if (!is.null(renv_version)){ dock$RUN("R -e 'install.packages(\"remotes\")'") install_renv_string <- paste0( - "R -e 'remotes::install_version(\"renv\", version = ", + "R -e 'remotes::install_version(\"renv\", version = \"", renv_version, - ")'" + "\")'" ) dock$RUN(install_renv_string) @@ -259,8 +276,9 @@ dock_from_renv <- function( } dock$COPY(basename(lockfile), "renv.lock") - dock$RUN(r(renv::restore())) + dock$RUN("R -e 'renv::restore()'") dock } + diff --git a/R/renv.R b/R/renv.R new file mode 100644 index 0000000..0b4c92c --- /dev/null +++ b/R/renv.R @@ -0,0 +1,91 @@ + +# +# renv 1.0.3 [rstudio/renv#e49d9be]: A dependency management toolkit for R. +# Generated using `renv:::vendor()` at 2023-11-05 11:48:15. +# + + +#' Internalised {renv} +#' +#' https://rstudio.github.io/renv/reference/vendor.html?q=vendor +#' +#' @export +#' @name renv +#' @alias renv +#' @docType data +renv <- new.env(parent = new.env()) + +renv$initialize <- function() { + + # set up renv + imports environments + attr(renv, "name") <- "embedded:renv" + attr(parent.env(renv), "name") <- "imports:renv" + + # get imports + imports <- list( + tools = c( + "file_ext", + "pskill", + "psnice", + "write_PACKAGES" + ), + utils = c( + "Rprof", + "URLencode", + "adist", + "available.packages", + "browseURL", + "citation", + "contrib.url", + "download.file", + "download.packages", + "file.edit", + "getCRANmirrors", + "head", + "help", + "install.packages", + "installed.packages", + "modifyList", + "old.packages", + "packageDescription", + "packageVersion", + "read.table", + "remove.packages", + "sessionInfo", + "str", + "summaryRprof", + "tail", + "tar", + "toBibtex", + "untar", + "unzip", + "update.packages", + "zip" + ) + ) + + # load the imports required by renv + for (package in names(imports)) { + namespace <- asNamespace(package) + functions <- imports[[package]] + list2env(mget(functions, envir = namespace), envir = parent.env(renv)) + } + + # source renv into the aforementioned environment + script <- system.file("vendor/renv.R", package = .packageName) + sys.source(script, envir = renv) + + # initialize metadata + renv$the$metadata <- list( + embedded = TRUE, + version = structure("1.0.3", sha = "e49d9be9528e0ff73b673f97382731c140013474") + ) + + # run our load / attach hooks so internal state is initialized + renv$renv_zzz_load() + + # remove our initialize method when we're done + rm(list = "initialize", envir = renv) + +} +# renv$initialize() diff --git a/dev/config_fusen.yaml b/dev/config_fusen.yaml index 24c7ffc..49c242a 100644 --- a/dev/config_fusen.yaml +++ b/dev/config_fusen.yaml @@ -11,5 +11,5 @@ flat_dock_from_renv.Rmd: vignette_name: Dockerfile from renv.lock open_vignette: false check: false - document: true + document: false overwrite: 'yes' diff --git a/dev/flat_dock_from_renv.Rmd b/dev/flat_dock_from_renv.Rmd index 5bc3aa6..5b7e196 100644 --- a/dev/flat_dock_from_renv.Rmd +++ b/dev/flat_dock_from_renv.Rmd @@ -52,6 +52,12 @@ available_distros <- c( "centos8" ) +#' @importFrom memoise memoise +pkg_system_requirements_mem <- memoise::memoise( + pak::pkg_system_requirements +) + + #' Create a Dockerfile from an `renv.lock` file #' #' @param lockfile Path to an `renv.lock` file to use as an input.. @@ -67,8 +73,9 @@ available_distros <- c( #' @param repos character. The URL(s) of the repositories to use for `options("repos")`. #' @param extra_sysreqs character vector. Extra debian system requirements. #' Will be installed with apt-get install. -#' @param fix_renv_version boolean. If `TRUE` the version of renv in the lockfile -#' will be used for the `renv::restore()` command +#' @param renv_version character. The {renv} version to use in the generated Dockerfile. +#' By default, it is set to the version specified in the `renv.lock` file. +#' If the `renv.lock` file does not specify a {renv} version, the version of {renv} bundled with {dockerfiler}, specifically `dockerfiler::renv$the$metadata$version`, will be used. If you set it to NULL, the latest available version of {renv} will be used. #' @importFrom utils getFromNamespace #' @return A R6 object of class `Dockerfile`. #' @details @@ -96,17 +103,15 @@ dock_from_renv <- function( repos = c(CRAN = "https://cran.rstudio.com/"), expand = FALSE, extra_sysreqs = NULL, - fix_renv_version = FALSE + renv_version ) { distro <- match.arg(distro, available_distros) - - lock <- getFromNamespace("lockfile", "renv")(lockfile) - - # lock$repos(CRAN = repos) - lockfile <- basename(lockfile) + try(dockerfiler::renv$initialize(),silent=TRUE) + lock <- dockerfiler::renv$lockfile_read(file = lockfile) # using vendored renv + # https://rstudio.github.io/renv/reference/vendor.html?q=vendor#null # start the dockerfile - R_major_minor <- lock$data()$R$Version + R_major_minor <- lock$R$Version dock <- Dockerfile$new( FROM = gen_base_image( distro = distro, @@ -117,7 +122,18 @@ dock_from_renv <- function( ) # get renv version - renv_version <- lock$data()$Packages$renv$Version + + if (missing(renv_version)) { + if (!is.null(lock$Packages$renv$Version)) { + renv_version <- lock$Packages$renv$Version + } else { + renv_version <- dockerfiler::renv$the$metadata$version + } + } + + message("renv version = ", + ifelse(!is.null(renv_version),renv_version,"the must up to date in the repos") + ) distro_args <- switch( distro, @@ -177,7 +193,7 @@ dock_from_renv <- function( jammy = "rm -rf /var/lib/apt/lists/*" ) - pkgs <- names(lock$data()$Packages) + pkgs <- names(lock$Packages) if (sysreqs) { @@ -205,11 +221,12 @@ dock_from_renv <- function( } ) + pkg_sysreqs <- attempt::map_try_catch( pkg_os, function(x) { do.call( - pak::pkg_system_requirements, + pkg_system_requirements_mem, x ) }, @@ -282,13 +299,13 @@ dock_from_renv <- function( ) ) - # check if fix_renv_version is true - if (fix_renv_version){ + + if (!is.null(renv_version)){ dock$RUN("R -e 'install.packages(\"remotes\")'") install_renv_string <- paste0( - "R -e 'remotes::install_version(\"renv\", version = ", + "R -e 'remotes::install_version(\"renv\", version = \"", renv_version, - ")'" + "\")'" ) dock$RUN(install_renv_string) @@ -297,11 +314,12 @@ dock_from_renv <- function( } dock$COPY(basename(lockfile), "renv.lock") - dock$RUN(r(renv::restore())) + dock$RUN("R -e 'renv::restore()'") dock } + ``` ```{r example-dock_from_renv} @@ -312,46 +330,16 @@ dock_from_renv <- function( ``` -```{r dock_from_renv, eval=FALSE} +```{r test-dock_from_renv, eval=FALSE} # A temporary directory dir_build <- tempfile(pattern = "renv") dir.create(dir_build) -# Create a lockfile -the_lockfile <- file.path(dir_build, "renv.lock") -custom_packages <- c( - # attachment::att_from_description(), # build from a DESCRIPTION file - "renv", - "cli", "glue", "golem", "shiny", "stats", "utils", - "testthat", - "knitr" -) -renv::snapshot( - packages = custom_packages, - lockfile = the_lockfile, - prompt = FALSE) - -# Create Dockerfile -dock_from_renv(lockfile = the_lockfile, - distro = "focal", - FROM = "rstudio/verse", - out_dir = dir_build - ) - -# rstudioapi::navigateToFile(file.path(dir_build, "Dockerfile")) -unlink(dir_build) -``` - -```{r tests-dock_from_renv, filename="dock_from_renv"} -dir_build <- tempfile(pattern = "renv") -dir.create(dir_build) - # Create a lockfile the_lockfile <- file.path(dir_build, "renv.lock") custom_packages <- c( # attachment::att_from_description(), - "renv", "cli", "glue", # "golem", "shiny", @@ -360,7 +348,8 @@ custom_packages <- c( "testthat", "knitr" ) -renv::snapshot( +try(dockerfiler::renv$initialize(),silent=TRUE) +dockerfiler::renv$snapshot( packages = custom_packages, lockfile = the_lockfile, prompt = FALSE @@ -410,16 +399,13 @@ test_that("dock_from_renv works", { "FROM rocker/verse:4.1.2" ) - expect_length( - grep("install.packages\\(c\\(\"renv\",\"remotes\"", dock_created), - 1 - ) expect_length( grep("RUN R -e 'renv::restore\\(\\)'", dock_created), 1 ) # System dependencies are different when build in interactive environment? + # yes. strange. skip_if_not(interactive()) dir.create( file.path( @@ -485,64 +471,66 @@ test_that("gen_base_image works", { -test_that("dock_from_renv works with old renv", { - out_true <- dock_from_renv( - lockfile = the_lockfile, - distro = "focal", - FROM = "rocker/verse", - fix_renv_version = TRUE - ) - - out_true$write( - file.path( - dir_build, - "Dockerfile_keep_true" - ) - ) - - dock_created_true <- readLines( - file.path( - dir_build, - "Dockerfile_keep_true" +test_that("dock_from_renv works with specific renv", { + +the_lockfile1.0.0 <- system.file("renv_with_1.0.0.lock",package = "dockerfiler") + +for (lf in list(the_lockfile,the_lockfile1.0.0)){ +for (renv_version in list(NULL,"banana","missing")){ + + + if (!is.null(renv_version) && renv_version == "missing") { + out <- dock_from_renv(lockfile = lf, + distro = "focal", + FROM = "rocker/verse") + } else{ + out <- dock_from_renv( + lockfile = lf, + distro = "focal", + FROM = "rocker/verse", + renv_version = renv_version ) - ) - out_false <- dock_from_renv( - lockfile = the_lockfile, - distro = "focal", - FROM = "rocker/verse", - fix_renv_version = FALSE - ) - out_false$write( - file.path( - dir_build, - "Dockerfile_keep_false" - ) - ) + } +socle_install_version <- "remotes::install_version\\(\"renv\", version = \"" + if (lf == the_lockfile & is.null(renv_version)) { + test_string <- 'install.packages\\(c\\(\"renv\",\"remotes\"))' + } else if (lf == the_lockfile1.0.0 & is.null(renv_version)) { + test_string <- 'install.packages\\(c\\(\"renv\",\"remotes\"))' + } else if (lf == the_lockfile & renv_version == "banana") { + test_string <- paste0(socle_install_version,"banana" ,"\"\\)") + } else if (lf == the_lockfile1.0.0 & renv_version == "banana") { + test_string <- paste0(socle_install_version,"banana","\"\\)") + } else if (lf == the_lockfile & renv_version == "missing") { + test_string <- + paste0( + socle_install_version,dockerfiler::renv$the$metadata$version,"\"\\)" + ) + } else if (lf == the_lockfile1.0.0 & renv_version == "missing") { + test_string <-paste0(socle_install_version,"1.0.0","\"\\)") + } - dock_created_false <- readLines( - file.path( - dir_build, - "Dockerfile_keep_false" - ) - ) - dock_created_false - dock_created_true + expect_true( any( grepl(test_string , out$Dockerfile) ), + info = paste(lf," & ",renv_version)) - packageVersion("renv") - test_string <- paste0("remotes::install_version\\(\"renv\", version = ", packageVersion("renv") ,"\\)") - expect_true( any( grepl(test_string , dock_created_true) )) - dock_created_false - test_string <- 'install.packages\\(c\\(\"renv\",\"remotes\"))' - expect_true( any( grepl(test_string , dock_created_false) )) +}} + + + }) + ``` + + ```{r development-inflate, eval=FALSE} # Run but keep eval=FALSE to avoid infinite loop # Execute in the console directly -fusen::inflate(flat_file = "dev/flat_dock_from_renv.Rmd", vignette_name = "Dockerfile from renv.lock",check=FALSE,open_vignette = FALSE,overwrite = TRUE) +fusen::inflate(flat_file = "dev/flat_dock_from_renv.Rmd", vignette_name = "Dockerfile from renv.lock",check=FALSE,open_vignette = FALSE,overwrite = TRUE, + document = FALSE + # ,pkg_ignore = "renv" + ) ``` diff --git a/inst/renv_with_1.0.0.lock b/inst/renv_with_1.0.0.lock new file mode 100644 index 0000000..b459d23 --- /dev/null +++ b/inst/renv_with_1.0.0.lock @@ -0,0 +1,709 @@ +{ + "R": { + "Version": "4.1.2", + "Repositories": [ + { + "Name": "CRAN", + "URL": "https://cran.rstudio.com" + } + ] + }, + "Packages": { + "R6": { + "Package": "R6", + "Version": "2.5.1", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "470851b6d5d0ac559e9d01bb352b4021" + }, + "Rcpp": { + "Package": "Rcpp", + "Version": "1.0.10", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "methods", + "utils" + ], + "Hash": "e749cae40fa9ef469b6050959517453c" + }, + "base64enc": { + "Package": "base64enc", + "Version": "0.1-3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "543776ae6848fde2f48ff3816d0628bc" + }, + "brio": { + "Package": "brio", + "Version": "1.1.3", + "Source": "Repository", + "Repository": "CRAN", + "Hash": "976cf154dfb043c012d87cddd8bca363" + }, + "bslib": { + "Package": "bslib", + "Version": "0.4.2", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "base64enc", + "cachem", + "grDevices", + "htmltools", + "jquerylib", + "jsonlite", + "memoise", + "mime", + "rlang", + "sass" + ], + "Hash": "a7fbf03946ad741129dc81098722fca1" + }, + "cachem": { + "Package": "cachem", + "Version": "1.0.7", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "fastmap", + "rlang" + ], + "Hash": "cda74447c42f529de601fe4d4050daef" + }, + "callr": { + "Package": "callr", + "Version": "3.7.3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "R6", + "processx", + "utils" + ], + "Hash": "9b2191ede20fa29828139b9900922e51" + }, + "cli": { + "Package": "cli", + "Version": "3.6.1", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "utils" + ], + "Hash": "89e6d8219950eac806ae0c489052048a" + }, + "commonmark": { + "Package": "commonmark", + "Version": "1.9.0", + "Source": "Repository", + "Repository": "CRAN", + "Hash": "d691c61bff84bd63c383874d2d0c3307" + }, + "crayon": { + "Package": "crayon", + "Version": "1.5.2", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "grDevices", + "methods", + "utils" + ], + "Hash": "e8a1e41acf02548751f45c718d55aa6a" + }, + "desc": { + "Package": "desc", + "Version": "1.4.2", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "R6", + "cli", + "rprojroot", + "utils" + ], + "Hash": "6b9602c7ebbe87101a9c8edb6e8b6d21" + }, + "diffobj": { + "Package": "diffobj", + "Version": "0.3.5", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "crayon", + "methods", + "stats", + "tools", + "utils" + ], + "Hash": "bcaa8b95f8d7d01a5dedfd959ce88ab8" + }, + "digest": { + "Package": "digest", + "Version": "0.6.31", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "utils" + ], + "Hash": "8b708f296afd9ae69f450f9640be8990" + }, + "ellipsis": { + "Package": "ellipsis", + "Version": "0.3.2", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "rlang" + ], + "Hash": "bb0eec2fe32e88d9e2836c2f73ea2077" + }, + "evaluate": { + "Package": "evaluate", + "Version": "0.20", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "methods" + ], + "Hash": "4b68aa51edd89a0e044a66e75ae3cc6c" + }, + "fansi": { + "Package": "fansi", + "Version": "1.0.4", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "grDevices", + "utils" + ], + "Hash": "1d9e7ad3c8312a192dea7d3db0274fde" + }, + "fastmap": { + "Package": "fastmap", + "Version": "1.1.1", + "Source": "Repository", + "Repository": "CRAN", + "Hash": "f7736a18de97dea803bde0a2daaafb27" + }, + "fontawesome": { + "Package": "fontawesome", + "Version": "0.5.1", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "htmltools", + "rlang" + ], + "Hash": "1e22b8cabbad1eae951a75e9f8b52378" + }, + "fs": { + "Package": "fs", + "Version": "1.5.2", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "methods" + ], + "Hash": "7c89603d81793f0d5486d91ab1fc6f1d" + }, + "glue": { + "Package": "glue", + "Version": "1.6.2", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "methods" + ], + "Hash": "4f2596dfb05dac67b9dc558e5c6fba2e" + }, + "highr": { + "Package": "highr", + "Version": "0.10", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "xfun" + ], + "Hash": "06230136b2d2b9ba5805e1963fa6e890" + }, + "htmltools": { + "Package": "htmltools", + "Version": "0.5.5", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "base64enc", + "digest", + "ellipsis", + "fastmap", + "grDevices", + "rlang", + "utils" + ], + "Hash": "ba0240784ad50a62165058a27459304a" + }, + "httpuv": { + "Package": "httpuv", + "Version": "1.6.9", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "R6", + "Rcpp", + "later", + "promises", + "utils" + ], + "Hash": "1046aa31a57eae8b357267a56a0b6d8b" + }, + "jquerylib": { + "Package": "jquerylib", + "Version": "0.1.4", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "htmltools" + ], + "Hash": "5aab57a3bd297eee1c1d862735972182" + }, + "jsonlite": { + "Package": "jsonlite", + "Version": "1.8.4", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "methods" + ], + "Hash": "a4269a09a9b865579b2635c77e572374" + }, + "knitr": { + "Package": "knitr", + "Version": "1.42", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "evaluate", + "highr", + "methods", + "tools", + "xfun", + "yaml" + ], + "Hash": "8329a9bcc82943c8069104d4be3ee22d" + }, + "later": { + "Package": "later", + "Version": "1.3.0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "Rcpp", + "rlang" + ], + "Hash": "7e7b457d7766bc47f2a5f21cc2984f8e" + }, + "lifecycle": { + "Package": "lifecycle", + "Version": "1.0.3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "cli", + "glue", + "rlang" + ], + "Hash": "001cecbeac1cff9301bdc3775ee46a86" + }, + "magrittr": { + "Package": "magrittr", + "Version": "2.0.3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "7ce2733a9826b3aeb1775d56fd305472" + }, + "memoise": { + "Package": "memoise", + "Version": "2.0.1", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "cachem", + "rlang" + ], + "Hash": "e2817ccf4a065c5d9d7f2cfbe7c1d78c" + }, + "mime": { + "Package": "mime", + "Version": "0.12", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "tools" + ], + "Hash": "18e9c28c1d3ca1560ce30658b22ce104" + }, + "pillar": { + "Package": "pillar", + "Version": "1.9.0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "cli", + "fansi", + "glue", + "lifecycle", + "rlang", + "utf8", + "utils", + "vctrs" + ], + "Hash": "15da5a8412f317beeee6175fbc76f4bb" + }, + "pkgconfig": { + "Package": "pkgconfig", + "Version": "2.0.3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "utils" + ], + "Hash": "01f28d4278f15c76cddbea05899c5d6f" + }, + "pkgload": { + "Package": "pkgload", + "Version": "1.3.2", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "cli", + "crayon", + "desc", + "fs", + "glue", + "methods", + "rlang", + "rprojroot", + "utils", + "withr" + ], + "Hash": "6b0c222c5071efe0f3baf3dae9aa40e2" + }, + "praise": { + "Package": "praise", + "Version": "1.0.0", + "Source": "Repository", + "Repository": "CRAN", + "Hash": "a555924add98c99d2f411e37e7d25e9f" + }, + "processx": { + "Package": "processx", + "Version": "3.8.1", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "R6", + "ps", + "utils" + ], + "Hash": "d75b4059d781336efba24021915902b4" + }, + "promises": { + "Package": "promises", + "Version": "1.2.0.1", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R6", + "Rcpp", + "later", + "magrittr", + "rlang", + "stats" + ], + "Hash": "4ab2c43adb4d4699cf3690acd378d75d" + }, + "ps": { + "Package": "ps", + "Version": "1.7.5", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "utils" + ], + "Hash": "709d852d33178db54b17c722e5b1e594" + }, + "rappdirs": { + "Package": "rappdirs", + "Version": "0.3.3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "5e3c5dc0b071b21fa128676560dbe94d" + }, + "rematch2": { + "Package": "rematch2", + "Version": "2.1.2", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "tibble" + ], + "Hash": "76c9e04c712a05848ae7a23d2f170a40" + }, + "renv": { + "Package": "renv", + "Version": "1.0.0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "utils" + ], + "Hash": "c321cd99d56443dbffd1c9e673c0c1a2" + }, + "rlang": { + "Package": "rlang", + "Version": "1.1.0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "utils" + ], + "Hash": "dc079ccd156cde8647360f473c1fa718" + }, + "rprojroot": { + "Package": "rprojroot", + "Version": "2.0.3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "1de7ab598047a87bba48434ba35d497d" + }, + "sass": { + "Package": "sass", + "Version": "0.4.5", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R6", + "fs", + "htmltools", + "rappdirs", + "rlang" + ], + "Hash": "2bb4371a4c80115518261866eab6ab11" + }, + "shiny": { + "Package": "shiny", + "Version": "1.7.4", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "R6", + "bslib", + "cachem", + "commonmark", + "crayon", + "ellipsis", + "fastmap", + "fontawesome", + "glue", + "grDevices", + "htmltools", + "httpuv", + "jsonlite", + "later", + "lifecycle", + "methods", + "mime", + "promises", + "rlang", + "sourcetools", + "tools", + "utils", + "withr", + "xtable" + ], + "Hash": "c2eae3d8c670fa9dfa35a12066f4a1d5" + }, + "sourcetools": { + "Package": "sourcetools", + "Version": "0.1.7-1", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "5f5a7629f956619d519205ec475fe647" + }, + "testthat": { + "Package": "testthat", + "Version": "3.1.7", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "R6", + "brio", + "callr", + "cli", + "desc", + "digest", + "ellipsis", + "evaluate", + "jsonlite", + "lifecycle", + "magrittr", + "methods", + "pkgload", + "praise", + "processx", + "ps", + "rlang", + "utils", + "waldo", + "withr" + ], + "Hash": "7eb5fd202a61d2fb78af5869b6c08998" + }, + "tibble": { + "Package": "tibble", + "Version": "3.2.1", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "fansi", + "lifecycle", + "magrittr", + "methods", + "pillar", + "pkgconfig", + "rlang", + "utils", + "vctrs" + ], + "Hash": "a84e2cc86d07289b3b6f5069df7a004c" + }, + "utf8": { + "Package": "utf8", + "Version": "1.2.3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "1fe17157424bb09c48a8b3b550c753bc" + }, + "vctrs": { + "Package": "vctrs", + "Version": "0.6.1", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "cli", + "glue", + "lifecycle", + "rlang" + ], + "Hash": "06eceb3a5d716fd0654cc23ca3d71a99" + }, + "waldo": { + "Package": "waldo", + "Version": "0.4.0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "cli", + "diffobj", + "fansi", + "glue", + "methods", + "rematch2", + "rlang", + "tibble" + ], + "Hash": "035fba89d0c86e2113120f93301b98ad" + }, + "withr": { + "Package": "withr", + "Version": "2.5.0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "grDevices", + "graphics", + "stats" + ], + "Hash": "c0e49a9760983e81e55cdd9be92e7182" + }, + "xfun": { + "Package": "xfun", + "Version": "0.39", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "stats", + "tools" + ], + "Hash": "8f56e9acb54fb525e66464d57ab58bcb" + }, + "xtable": { + "Package": "xtable", + "Version": "1.8-4", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "stats", + "utils" + ], + "Hash": "b8acdf8af494d9ec19ccb2481a9b11c2" + }, + "yaml": { + "Package": "yaml", + "Version": "2.3.7", + "Source": "Repository", + "Repository": "CRAN", + "Hash": "0d0056cc5383fbc240ccd0cb584bf436" + } + } +} diff --git a/inst/vendor/renv.R b/inst/vendor/renv.R new file mode 100644 index 0000000..adf1826 --- /dev/null +++ b/inst/vendor/renv.R @@ -0,0 +1,33442 @@ +# +# renv 1.0.3 [rstudio/renv#e49d9be]: A dependency management toolkit for R. +# Generated using `renv:::vendor()` at 2023-11-05 11:48:15. +# + +# aaa.R ---------------------------------------------------------------------- + + +# global variables +the <- new.env(parent = emptyenv()) + +# detect if we're running on CI +ci <- function() { + !is.na(Sys.getenv("CI", unset = NA)) +} + +# detect if we're running within R CMD build +building <- function() { + nzchar(Sys.getenv("R_CMD")) && + grepl("Rbuild", basename(dirname(getwd())), fixed = TRUE) +} + +# are we running code within R CMD check? +checking <- function() { + "CheckExEnv" %in% search() || + renv_envvar_exists("_R_CHECK_PACKAGE_NAME_") || + renv_envvar_exists("_R_CHECK_SIZE_OF_TARBALL_") +} + +# NOTE: Prefer using 'testing()' to 'renv_tests_running()' for behavior +# that should apply regardless of the package currently being tested. +# +# 'renv_tests_running()' is appropriate when running renv's own tests. +testing <- function() { + identical(Sys.getenv("TESTTHAT"), "true") +} + + +# abi.R ---------------------------------------------------------------------- + + +renv_abi_check <- function(packages = NULL, + ..., + libpaths = NULL, + project = NULL) +{ + if (renv_platform_windows()) { + writef("- ABI conflict checks are not yet implemented on Windows.") + return() + } + + # disable via option if necessary + enabled <- getOption("renv.abi.check", default = TRUE) + if (identical(enabled, FALSE)) + return() + + # resolve arguments + project <- renv_project_resolve(project) + libpaths <- libpaths %||% renv_libpaths_all() + + # read installed packages + packages <- packages %||% renv_abi_packages(project, libpaths) + + # analyze each package + problems <- stack() + map(packages, function(package) { + tryCatch( + renv_abi_check_impl(package, problems), + error = warnify + ) + }) + + # report problmes + data <- problems$data() + if (empty(data)) { + fmt <- "- No ABI conflicts were detected in the set of installed packages." + writef(fmt) + return(invisible(data)) + } + + # combine everything together + tbl <- bind(data) + + # make reports for each different type + reasons <- unique(tbl$reason) + if ("Rcpp_precious_list" %in% reasons) { + packages <- sort(unique(tbl$package[tbl$reason == "Rcpp_precious_list"])) + caution_bullets( + "The following packages were built against a newer version of Rcpp than is currently available:", + packages, + c( + paste( + "These packages depend on Rcpp (>= 1.0.7);", + "however, Rcpp", renv_package_version("Rcpp"), "is currently installed." + ), + "Consider installing a new version of Rcpp with 'install.packages(\"Rcpp\")'." + ) + ) + } + + invisible(tbl) + +} + +renv_abi_check_impl <- function(package, problems) { + + # find path to package + pkgpath <- renv_package_find(package) + + # look for an associated shared object + shlib <- renv_package_shlib(pkgpath) + if (!file.exists(shlib)) + return() + + # read symbols from LinkingTo dependency packages + pkgdesc <- renv_description_read(path = pkgpath) + if (is.null(pkgdesc$LinkingTo)) + return() + + # read symbols from the library + symbols <- renv_abi_symbols(shlib) + + # handle Rcpp + linkdeps <- renv_description_parse_field(pkgdesc$LinkingTo) + if ("Rcpp" %in% linkdeps$Package) + renv_abi_check_impl_rcpp(package, symbols, problems) + + # TODO: other checks? more direct symbol checks for other packages? + +} + +renv_abi_check_impl_rcpp <- function(package, symbols, problems) { + + # read Rcpp symbols + rcpplib <- renv_package_shlib("Rcpp") + rcppsyms <- renv_abi_symbols(rcpplib) + + # perform checks for different versions of Rcpp + renv_abi_check_impl_rcpp_preciouslist(package, symbols, rcppsyms, problems) + +} + +renv_abi_check_impl_rcpp_preciouslist <- function(package, symbols, rcppsyms, problems) { + + # check for dependency on Rcpp_precious APIs + required <- grep("Rcpp_precious", symbols$symbol, value = TRUE) + if (empty(required)) + return() + + # check for Rcpp_precious APIs being available + available <- grep("Rcpp_precious", rcppsyms$symbol, value = TRUE) + if (length(available)) + return() + + problem <- renv_abi_problem( + package = paste(package, renv_package_version(package)), + dependency = paste("Rcpp", renv_package_version("Rcpp")), + reason = "Rcpp_precious_list" + ) + + problems$push(problem) + +} + +renv_abi_symbols <- function(path, args = NULL) { + + # invoke nm to read symbols + output <- renv_system_exec( + command = "nm", + args = c(args, renv_shell_path(path)), + action = "reading symbols" + ) + + # parse output + parts <- strsplit(output, "\\s+") + data <- .mapply(c, parts, NULL) + names(data) <- c("offset", "type", "symbol") + + # join into data.frame + as_data_frame(data) + +} + +renv_abi_problem <- function(package, dependency, reason) { + + list( + package = package, + dependency = dependency, + reason = reason + ) + +} + +renv_abi_packages <- function(project, libpaths) { + + # create a lockfile + lockfile <- snapshot( + library = libpaths, + lockfile = NULL, + type = "all", + project = project + ) + + # return package names + names(lockfile$Packages) + +} + + +# abort.R -------------------------------------------------------------------- + + +abort <- function(message, ..., body = NULL, class = NULL) { + + # create condition object + cnd <- if (is.character(message)) { + structure(class = c(class, "error", "condition"), list( + message = paste(c(message, body), collapse = "\n"), + meta = list(message = message, body = body), + ... + )) + } else if (inherits(message, "condition")) { + message + } else { + stop("internal error: abort called with unexpected message") + } + + # if we were called with a custom condition object not having our meta, + # just throw it as-is + if (is.null(cnd$meta)) + stop(cnd) + + # signal the condition, giving calling handlers a chance to run first + signalCondition(cnd) + + # if we got here, then there wasn't any tryCatch() handler on the stack. + # handle printing of the error ourselves, and then stop with fallback. + all <- c( + cnd$meta$body, if (length(cnd$meta$body)) "", + paste("Error:", paste(cnd$meta$message, collapse = "\n")) + ) + + # write error message to stderr, as errors might normally do + writeLines(all, con = stderr()) + + # create the fallback, but 'dodge' the existing error handlers + fallback <- cnd + fallback$message <- "" + class(fallback) <- "condition" + + # disable error printing for the empty error + renv_scope_options(show.error.messages = FALSE) + + # now throw the error + stop(fallback) + +} + + +# acls.R --------------------------------------------------------------------- + + +renv_acls_reset <- function(source, target = dirname(source)) { + + # only run on Linux for now + if (!renv_platform_linux()) + return(FALSE) + + # skip if we don't have 'getfacl', 'setfacl' + getfacl <- Sys.which("getfacl"); setfacl <- Sys.which("setfacl") + if (!nzchar(getfacl) || !nzchar(setfacl)) + return(FALSE) + + # build command + fmt <- "getfacl %s 2> /dev/null | setfacl -R --set-file=- %s 2> /dev/null" + cmd <- sprintf(fmt, renv_shell_path(target), renv_shell_path(source)) + + # execute it + # TODO: Should we report errors? If so, how? + catch( + renv_system_exec( + command = cmd, + action = "resetting ACLs", + quiet = TRUE + ) + ) + +} + + +# actions.R ------------------------------------------------------------------ + + +actions <- function(action = c("snapshot", "restore"), + ..., + project = NULL, + library = NULL, + lockfile = NULL, + type = settings$snapshot.type(project = project), + clean = FALSE) +{ + action <- match.arg(action) + project <- renv_project_resolve(project) + lockfile <- lockfile %||% renv_lockfile_path(project = project) + + renv_project_lock(project = project) + + switch( + action, + snapshot = renv_actions_snapshot(project, library, lockfile, type), + restore = renv_actions_restore(project, library, lockfile, clean) + ) +} + +renv_actions_merge <- function(snap, lock, diff) { + + fields <- c("Package", "Version", "Source") + defaults <- data.frame( + "Package" = character(), + "Library Version" = character(), + "Library Source" = character(), + "Lockfile Version" = character(), + "Lockfile Source" = character(), + check.names = FALSE, + stringsAsFactors = FALSE + ) + + lhs <- bapply(unname(renv_lockfile_records(snap)), `[`, fields) + if (length(lhs)) + names(lhs) <- c("Package", paste("Library", names(lhs)[-1L])) + + rhs <- bapply(unname(renv_lockfile_records(lock)), `[`, fields) + if (length(rhs)) + names(rhs) <- c("Package", paste("Lockfile", names(rhs)[-1L])) + + merged <- if (length(lhs) && length(rhs)) + merge(lhs, rhs, by = "Package", all = TRUE) + else if (length(lhs)) + lhs + else if (length(rhs)) + rhs + else + defaults + + actions <- data.frame(Package = names(diff), + Action = as.character(diff), + check.names = FALSE, + stringsAsFactors = FALSE) + + all <- merge(merged, actions, by = "Package") + + missing <- setdiff(names(defaults), names(all)) + all[missing] <- NA_character_ + + all + +} + +renv_actions_snapshot <- function(project, library, lockfile, type) { + + lock <- renv_lockfile_load(project = project) + snap <- snapshot(project = project, + library = library, + lockfile = NULL, + type = type) + + diff <- renv_lockfile_diff_packages(lock, snap) + renv_actions_merge(snap, lock, diff) + +} + +renv_actions_restore <- function(project, library, lockfile, clean) { + + # NOTE: we use a simple snapshot here as we just want to know the + # difference in library state before and after applying the lockfile; + # that is, we want to know what the library looks like without any + # filtering of what records would be reported from the library + lock <- renv_lockfile_load(project = project) + snap <- snapshot(project = project, + library = library, + lockfile = NULL, + type = "all") + + diff <- renv_lockfile_diff_packages(snap, lock) + actions <- renv_actions_merge(snap, lock, diff) + renv_actions_restore_clean(actions, clean, project) + +} + +renv_actions_restore_clean <- function(actions, clean, project) { + + # if not cleaning, then we don't do any removals + if (!clean) { + filtered <- actions[actions$Action != "remove", ] + return(filtered) + } + + # otherwise, only process removals in the project library + projlib <- renv_paths_library(project = project) + locations <- renv_package_find(actions$Package) + + keep <- actions$Action != "remove" | dirname(locations) == projlib + actions[keep, ] + +} + + +# activate.R ----------------------------------------------------------------- + + +#' Activate or deactivate a project +#' +#' @description +#' `activate()` enables renv for a project in both the current session and +#' in all future sessions. You should not generally need to call `activate()` +#' yourself as it's called automatically by [renv::init()], which is the best +#' way to start using renv in a new project. +#' +#' `activate()` first calls [renv::scaffold()] to set up the project +#' infrastructure. Most importantly, this creates a project library and adds a +#' an auto-loader to `.Rprofile` to ensure that the project library is +#' automatically used for all future instances of the project. It then restarts +#' the session to use that auto-loader. +#' +#' `deactivate()` removes the infrastructure added by `activate()`, and +#' restarts the session. By default it will remove the auto-loader from the +#' `.Rprofile`; use `clean = TRUE` to also delete the lockfile and the project +#' library. +#' +#' # Temporary deactivation +#' +#' If you need to temporarily disable autoload activation you can set +#' the `RENV_CONFIG_AUTOLOADER_ENABLED` envvar, e.g. +#' `Sys.setenv(RENV_CONFIG_AUTOLOADER_ENABLED = "false")`. +#' +#' @inherit renv-params +#' +#' @export +#' +#' @examples +#' \dontrun{ +#' +#' # activate the current project +#' renv::activate() +#' +#' # activate a separate project +#' renv::activate("~/projects/analysis") +#' +#' # deactivate the currently-activated project +#' renv::deactivate() +#' +#' } +activate <- function(project = NULL, profile = NULL) { + + renv_consent_check() + renv_scope_error_handler() + + project <- renv_project_resolve(project) + renv_project_lock(project = project) + + renv_profile_set(profile) + + renv_activate_impl( + project = project, + profile = profile, + version = NULL + ) + + invisible(project) + +} + +renv_activate_impl <- function(project, + profile, + version = NULL, + load = TRUE, + restart = TRUE) +{ + # prepare renv infrastructure + renv_infrastructure_write( + project = project, + profile = profile, + version = version + ) + + # ensure renv is imbued into the new library path if necessary + if (!renv_tests_running()) + renv_imbue_self(project) + + # restart session if requested + if (restart && !renv_tests_running()) + return(renv_restart_request(project, reason = "renv activated")) + + if (renv_rstudio_available()) + renv_rstudio_initialize(project) + + # try to load the project + if (load) { + setwd(project) + load(project) + } + + invisible(project) + +} + +renv_activate_version <- function(project) { + + # try to get version from activate.R + methods <- list( + renv_activate_version_lockfile, + renv_activate_version_activate, + renv_activate_version_metadata + ) + + for (method in methods) { + version <- catch(method(project)) + if (is.character(version)) + return(version) + } + + fmt <- "failed to determine renv version for project %s" + stopf(fmt, renv_path_pretty(project)) + +} + +renv_activate_version_activate <- function(project) { + + # get path to the activate script + activate <- renv_paths_activate(project = project) + if (!file.exists(activate)) + return(NULL) + + # check for version + contents <- readLines(activate, warn = FALSE) + line <- grep("version <-", contents, fixed = TRUE, value = TRUE)[[1L]] + version <- parse(text = line)[[1L]][[3L]] + + # check for sha as well + line <- grep("attr(version, \"sha\")", contents, fixed = TRUE, value = TRUE) + if (length(line)) { + sha <- parse(text = line)[[1L]][[3L]] + attr(version, "sha") <- sha + } + + version + +} + +renv_activate_version_lockfile <- function(project) { + + path <- renv_lockfile_path(project) + if (!file.exists(path)) + return(NULL) + + # read the renv record + lockfile <- renv_lockfile_read(path) + records <- renv_lockfile_records(lockfile) + renv_metadata_version_create(records[["renv"]]) + +} + +renv_activate_version_metadata <- function(project) { + the$metadata$version +} + +renv_activate_prompt <- function(action, library, prompt, project) { + + # check whether we should ask user to activate + ask <- + config$activate.prompt() && + prompt && + interactive() && + is.null(library) && + !renv_project_loaded(project) && + !testing() + + # for snapshot, since users might want to snapshot their system library + # in an renv-lite configuration, only prompt if it looks like they're + # working within an renv project that hasn't been loaded + if ("snapshot" %in% action) { + libpath <- renv_paths_library(project = project) + ask <- ask && file.exists(libpath) + } + + if (!ask) + return(FALSE) + + renv_activate_prompt_impl(action, project) + + +} + +renv_activate_prompt_impl <- function(action, project = NULL) { + title <- c( + sprintf( + "It looks like you've called renv::%s() in a project that hasn't been activated yet.", + action + ), + "How would you like to proceed?" + ) + choices <- c( + activate = "Activate the project and use the project library.", + continue = "Do not activate the project and use the current library paths.", + cancel = "Cancel and resolve the situation another way." + ) + + choice <- menu(choices, title, default = "continue") + switch(choice, + activate = { activate(project = project); TRUE }, + continue = FALSE, + cancel = cancel(), + ) +} + + +# addins.R ------------------------------------------------------------------- + + +renv_addins_embed_ui <- function() { + + miniUI::miniPage( + miniUI::gadgetTitleBar("Embed a Lockfile"), + miniUI::miniContentPanel( + shiny::verticalLayout( + shiny::fileInput( + inputId = "lockfile", + label = "Lockfile path:", + placeholder = "(Use default)" + ) + ) + ) + ) + +} + +renv_addins_embed_server <- function(input, output, session) { + + shiny::observeEvent(input$done, { + + # notify the user that we're working now + progress <- shiny::Progress$new( + session = shiny::getDefaultReactiveDomain(), + style = "notification" + ) + + progress$set(message = "Embedding lockfile...") + + # get editor context + context <- rstudioapi::getSourceEditorContext() + + # validate we have a path + path <- context$path + if (!nzchar(path)) + stop("cannot embed lockfile into an unsaved file", call. = FALSE) + + # get project path + project <- rstudioapi::getActiveProject() + + # read lockfile + lockfile <- input$lockfile + if (!is.null(lockfile)) + lockfile <- renv_lockfile_read(file = lockfile$datapath) + + # save document and run embed + rstudioapi::documentSave(id = context$id) + embed(path = path, lockfile = lockfile, project = project) + + # stop app + invisible(shiny::stopApp()) + + }) + +} + +renv_addins_embed <- function() { + + # first, check that shiny and miniUI are available + for (package in c("miniUI", "rstudioapi", "shiny")) { + if (!requireNamespace(package, quietly = TRUE)) { + fmt <- "required package '%s' is not available" + stopf(fmt, package) + } + } + + # ask the user to save the document first if necessary + context <- rstudioapi::getSourceEditorContext() + if (!nzchar(context$path)) + stop("this addin cannot be run with an unsaved document") + + # okay, we can run the addin + shiny::runGadget( + app = renv_addins_embed_ui(), + server = renv_addins_embed_server, + viewer = shiny::dialogViewer( + dialogName = "Embed Lockfile", + width = 400, + height = 200 + ) + ) +} + + + +# aliases.R ------------------------------------------------------------------ + + +# aliases used primarily for nicer / normalized text output +the$aliases <- list( + bioc = "Bioconductor", + bioconductor = "Bioconductor", + bitbucket = "Bitbucket", + cellar = "Cellar", + cran = "CRAN", + git2r = "Git", + github = "GitHub", + gitlab = "GitLab", + local = "Local", + repository = "Repository", + standard = "Repository", + url = "URL", + xgit = "Git" +) + +alias <- function(text) { + the$aliases[[text]] %||% text +} + + +# archive.R ------------------------------------------------------------------ + + +renv_archive_type <- function(archive) { + + ext <- fileext(archive) + + if (ext %in% c(".tgz", ".tar", ".tar.gz")) + return("tar") + else if (ext %in% c(".zip")) + return("zip") + else + return("unknown") + +} + +renv_archive_list <- function(archive) { + suppressWarnings(renv_archive_list_impl(archive)) +} + +renv_archive_list_impl <- function(archive) { + + switch( + renv_archive_type(archive), + tar = untar(archive, list = TRUE), + zip = unzip(archive, list = TRUE)[["Name"]], + stopf("don't know how to list files in archive '%s'", basename(archive)) + ) + +} + +renv_archive_decompress <- function(archive, files = NULL, exdir = ".", ...) { + + switch( + renv_archive_type(archive), + tar = renv_archive_decompress_tar(archive, files = files, exdir = exdir, ...), + zip = renv_archive_decompress_zip(archive, files = files, exdir = exdir, ...), + stopf("don't know how to decompress archive '%s'", basename(archive)) + ) + +} + +renv_archive_decompress_tar <- function(archive, files = NULL, exdir = ".", ...) { + + # if an appropriate system tar is available, use it + tar <- renv_tar_exe() + if (nzchar(tar)) + return(renv_tar_decompress(tar, archive = archive, files = files, exdir = exdir, ...)) + + # when using internal TAR, we want to suppress warnings + # (otherwise we get noise about global PAX headers) + suppressWarnings(untar(archive, files = files, exdir = exdir, tar = "internal", ...)) + return(TRUE) + +} + +renv_archive_decompress_zip <- function(archive, files = NULL, exdir = ".", ...) { + + # the default unzip tool will give warnings rather than + # errors if R was unable to extract from a zip archive + status <- tryCatch( + unzip(archive, files = files, exdir = exdir, ...), + condition = identity + ) + + if (inherits(status, "condition")) { + fmt <- "failed to decompress '%s' [%s]" + stopf(fmt, basename(archive), conditionMessage(status)) + } + + TRUE + +} + +renv_archive_find <- function(archive, pattern) { + files <- renv_archive_list(archive) + grep(pattern, files, value = TRUE) +} + +renv_archive_read <- function(archive, file) { + + type <- renv_archive_type(archive) + case( + type == "tar" ~ renv_archive_read_tar(archive, file), + type == "zip" ~ renv_archive_read_zip(archive, file), + ~ stopf("don't know how to read file from archive %s", renv_path_pretty(archive)) + ) + +} + +renv_archive_read_tar <- function(archive, file) { + + # if an appropriate tar is available, use it + tar <- renv_tar_exe() + if (nzchar(tar)) { + args <- c("xf", renv_shell_path(archive), "-O", renv_shell_path(file)) + return(renv_system_exec(tar, args, action = "reading file from archive")) + } + + # create extraction directory + exdir <- renv_scope_tempfile("renv-archive-") + ensure_directory(exdir) + + # unpack the requested file + suppressWarnings(untar(archive, files = file, exdir = exdir, tar = "internal")) + + # and read it + archive <- file.path(exdir, file) + readLines(archive, warn = FALSE) + +} + +renv_archive_read_zip <- function(archive, file) { + renv_scope_tempdir() + conn <- unz(archive, file, encoding = "native.enc") + defer(close(conn)) + readLines(conn, warn = FALSE) +} + + +# autoload.R ----------------------------------------------------------------- + + +#' Auto-load the active project +#' +#' Automatically load the renv project associated with a particular directory. +#' renv will search parent directories for the renv project root; if found, +#' that project will be loaded via [renv::load()]. +#' +#' To enable the renv auto-loader, you can place: +#' +#' ``` +#' renv::autoload() +#' ```` +#' +#' into your site-wide or user `.Rprofile` to ensure that renv projects are +#' automatically loaded for any newly-launched \R sessions, even if those \R +#' sessions are launched within the sub-directory of an renv project. +#' +#' If you'd like to launch \R within the sub-directory of an renv project +#' without auto-loading renv, you can set the environment variable: +#' +#' ``` +#' RENV_AUTOLOAD_ENABLED = FALSE +#' ``` +#' +#' before starting \R. +#' +#' Note that `renv::autoload()` is only compatible with projects using +#' `renv 0.15.3` or newer, as it relies on features within the `renv/activate.R` +#' script that are only generated with newer versions of renv. +#' +#' @export +autoload <- function() { + invisible(renv_autoload_impl()) +} + +renv_autoload_impl <- function() { + + # check if we're disabled + enabled <- Sys.getenv("RENV_AUTOLOAD_ENABLED", unset = "TRUE") + if (!truthy(enabled)) + return(FALSE) + + # bail if load is already being called + if (the$load_running) + return(FALSE) + + # avoid recursion + running <- getOption("renv.autoload.running") + if (identical(running, TRUE)) + return(FALSE) + + # set our flag + renv_scope_options(renv.autoload.running = TRUE) + + # try to find a project + project <- catch(renv_project_find()) + if (inherits(project, "error")) + return(FALSE) + + # move to project directory + renv_scope_wd(project) + + # if we have a project profile, source it + profile <- file.path(project, ".Rprofile") + if (file.exists(profile)) { + sys.source(profile, envir = globalenv()) + return(TRUE) + } + + # if we have an activate script, run it + activate <- file.path(project, "renv/activate.R") + if (file.exists(activate)) { + sys.source(activate, envir = globalenv()) + return(TRUE) + } + + # otherwise, just try to load the project + load(project) + TRUE + +} + + +# available-packages.R ------------------------------------------------------- + + +# tools for querying information about packages available on CRAN. +# note that this does _not_ merge package entries from multiple repositories; +# rather, a list of databases is returned (one for each repository) +available_packages <- function(type, + repos = NULL, + limit = NULL, + quiet = FALSE, + cellar = FALSE) +{ + dynamic( + + key = list( + type = type, + repos = repos %||% getOption("repos"), + cellar = cellar + ), + + value = renv_available_packages_impl( + type = type, + repos = repos, + limit = limit, + quiet = quiet, + cellar = cellar + ) + + ) +} + +renv_available_packages_impl <- function(type, + repos = NULL, + limit = NULL, + quiet = FALSE, + cellar = FALSE) +{ + limit <- limit %||% Sys.getenv("R_AVAILABLE_PACKAGES_CACHE_CONTROL_MAX_AGE", "3600") + repos <- renv_repos_normalize(repos %||% getOption("repos")) + + # invalidate cache if http_proxy or https_proxy environment variables change, + # since those could effect (or even re-direct?) repository URLs + envkeys <- c("http_proxy", "https_proxy", "HTTP_PROXY", "HTTPS_PROXY") + envvals <- Sys.getenv(envkeys, unset = NA) + + # invalidate the cache if 'renv.download.headers' changes as well + headers <- getOption("renv.download.headers") + key <- list(repos = repos, type = type, headers = headers, envvals) + + # retrieve available packages + dbs <- if (length(repos)) index( + scope = "available-packages", + key = key, + value = renv_available_packages_query(type, repos, quiet), + limit = as.integer(limit) + ) + + # include cellar if requested + dbs[["__renv_cellar__"]] <- if (cellar) + renv_available_packages_cellar(type = type) + + dbs + +} + +renv_available_packages_query <- function(type, repos, quiet = FALSE) { + + if (quiet) + renv_scope_options(renv.verbose = FALSE) + + fmt <- "- Querying repositories for available %s packages ... " + printf(fmt, type) + + # exclude repositories which are known to not have packages available + if (type == "binary") { + ignored <- setdiff(grep("^BioC", names(repos), value = TRUE), "BioCsoft") + repos <- repos[setdiff(names(repos), ignored)] + } + + # request repositories + urls <- contrib.url(repos, type) + errors <- new.env(parent = emptyenv()) + dbs <- map(urls, renv_available_packages_query_impl, type = type, errors = errors) + names(dbs) <- names(repos) + + # notify finished + writef("Done!") + + # propagate errors + errors <- as.list(errors) + if (empty(errors)) + return(dbs) + + header <- "renv was unable to query available packages from the following repositories:" + msgs <- enum_chr(errors, function(url, cnds) { + msgs <- map_chr(cnds, conditionMessage) + paste(c(header(url), msgs, ""), collapse = "\n") + }) + + caution_bullets(header, msgs) + filter(dbs, Negate(is.null)) + +} + +renv_available_packages_query_impl_packages_rds <- function(url) { + path <- file.path(url, "PACKAGES.rds") + destfile <- renv_scope_tempfile("renv-packages-", fileext = ".rds") + + download(url = path, destfile = destfile, quiet = TRUE) + suppressWarnings(readRDS(destfile)) +} + +renv_available_packages_query_impl_packages_gz <- function(url) { + path <- file.path(url, "PACKAGES.gz") + destfile <- renv_scope_tempfile("renv-packages-", fileext = ".gz") + + download(url = path, destfile = destfile, quiet = TRUE) + suppressWarnings(read.dcf(destfile)) +} + +renv_available_packages_query_impl_packages <- function(url) { + path <- file.path(url, "PACKAGES") + destfile <- renv_scope_tempfile("renv-packages-") + + download(url = path, destfile = destfile, quiet = TRUE) + suppressWarnings(read.dcf(destfile)) +} + +renv_available_packages_query_impl <- function(url, type, errors) { + + # define query_impl methods for the different PACKAGES + methods <- list( + renv_available_packages_query_impl_packages_rds, + renv_available_packages_query_impl_packages_gz, + renv_available_packages_query_impl_packages + ) + + stack <- stack() + seize <- function(restart) { + function(condition) { + stack$push(condition) + invokeRestart(restart) + } + } + + for (method in methods) { + + db <- withCallingHandlers( + catch(method(url)), + warning = seize(restart = "muffleWarning"), + message = seize(restart = "muffleMessage") + ) + + if (inherits(db, "error")) { + stack$push(db) + next + } + + return(renv_available_packages_success(db, url, type)) + + } + + assign(url, stack$data(), envir = errors) + NULL + +} + +renv_available_packages_success <- function(db, url, type) { + + # convert to data.frame + db <- as_data_frame(db) + if (nrow(db) == 0L) + return(db) + + # build repository url + repository <- rep.int(url, nrow(db)) + + # update with path + path <- db$Path + if (length(path)) { + set <- !is.na(path) + repository[set] <- paste(url, path[set], sep = "/") + } + + # set it + db$Repository <- repository + + # add in necessary missing columns + required <- c( + "Package", "Version", "Priority", + "Depends", "Imports", "LinkingTo", "Suggests", "Enhances", + "License", "License_is_FOSS", "License_restricts_use", + "OS_type", "Archs", "MD5sum", + if (type %in% "source") "NeedsCompilation", + "File", "Repository" + ) + + missing <- setdiff(required, names(db)) + db[missing] <- NA_character_ + db <- db[required] + + # filter as appropriate + db <- renv_available_packages_filter(db) + + # remove row names + row.names(db) <- NULL + + # ok + db + +} + +renv_available_packages_entry <- function(package, + type = "source", + repos = NULL, + filter = NULL, + quiet = FALSE, + prefer = NULL) +{ + + # if filter is a string, treat it as an explicit version requirement + version <- NULL + if (is.character(filter)) { + version <- filter + filter <- function(entries) { + matches <- which(entries$Version == version) + candidate <- head(matches, n = 1L) + entries[candidate, ] + } + } + + # by default, provide a filter that selects the newest-available package + filter <- filter %||% function(entries) { + version <- numeric_version(entries$Version) + ordered <- order(version, decreasing = TRUE) + entries[ordered[[1]], ] + } + + # read available packages + dbs <- available_packages( + type = type, + repos = repos, + quiet = quiet + ) + + # if a preferred repository is marked and available, prefer using that + if (length(prefer) == 1L && prefer %in% names(dbs)) { + idx <- match(prefer, names(dbs)) + ord <- c(idx, setdiff(seq_along(dbs), idx)) + dbs <- dbs[ord] + } + + # iterate through repositories, and find first matching + for (i in seq_along(dbs)) { + + db <- dbs[[i]] + matches <- which(db$Package == package) + if (empty(matches)) + next + + entries <- db[matches, ] + entry <- filter(entries) + if (nrow(entry) == 0) + next + + entry[["Type"]] <- type + entry[["Name"]] <- names(dbs)[[i]] %||% "" + return(entry) + + } + + # report package + version if both available + pkgver <- if (length(version)) + paste(package, version) + else + package + + fmt <- "failed to find %s for '%s' in package repositories" + stopf(fmt, type, pkgver) + +} + +renv_available_packages_record <- function(entry, type) { + + # check to see if this is already a proper record + attrs <- attributes(entry) + keys <- c("type", "url") + if (all(keys %in% names(attrs))) + return(entry) + + # otherwise, construct it + record <- entry + + if (identical(record$Name, "__renv_cellar__")) { + record$Source <- "Cellar" + record$Repository <- NULL + record$Name <- NULL + } else { + record$Source <- "Repository" + record$Repository <- entry$Name + record$Name <- NULL + } + + # form url + url <- entry$Repository + path <- entry$Path + if (length(path) && !is.na(path)) + url <- paste(url, path, sep = "/") + + attr(record, "type") <- type + attr(record, "url") <- url + + record + +} + +renv_available_packages_latest_repos_impl <- function(package, type, repos) { + + # get available packages + dbs <- available_packages( + type = type, + repos = repos, + quiet = TRUE, + cellar = TRUE + ) + + fields <- c( + "Package", "Version", + "OS_type", "NeedsCompilation", + "Repository", "Path", "File" + ) + + entries <- bapply(dbs, function(db) { + + # extract entries for this package + entries <- rows(db, db$Package == package) + if (nrow(entries) == 0L) + return(entries) + + # keep only compatible rows + the required fields + cols(entries, intersect(fields, names(db))) + + }, index = "Name") + + if (is.null(entries)) + return(NULL) + + # sort based on version + version <- numeric_version(entries$Version) + ordered <- order(version, decreasing = TRUE) + + # extract newest entry + entry <- as.list(entries[ordered[[1L]], ]) + + # remove an NA file entry if necessary + # https://github.com/rstudio/renv/issues/1045 + if (length(entry$File) && is.na(entry$File)) + entry$File <- NULL + + # return newest-available version + renv_available_packages_record(entry, type) + +} + +renv_available_packages_latest <- function(package, + type = NULL, + repos = NULL) +{ + methods <- list( + renv_available_packages_latest_repos, + if (renv_mran_enabled()) + renv_available_packages_latest_mran + ) + + errors <- stack() + + entries <- lapply(methods, function(method) { + + if (is.null(method)) + return(NULL) + + entry <- catch(method(package, type, repos)) + if (inherits(entry, "error")) { + errors$push(entry) + return(NULL) + } + + entry + + }) + + # if both entries are null, error + if (all(map_lgl(entries, is.null))) { + map(errors$data(), warning) + stopf("package '%s' is not available", package) + } else if (is.null(entries[[2L]])) { + return(entries[[1L]]) + } else if (is.null(entries[[1L]])) { + return(entries[[2L]]) + } + + # extract both entries + lhs <- entries[[1L]] + rhs <- entries[[2L]] + + # extract versions + lhsv <- package_version(lhs$Version %||% "0.0") + rhsv <- package_version(rhs$Version %||% "0.0") + + # if the versions don't match, take the newest one + if (lhsv > rhsv) + return(lhs) + else if (rhsv > lhsv) + return(rhs) + + # otherwise, if we have a binary from the active package repositories, + # use those; otherwise, use the mran binary + if (identical(lhsv, rhsv)) { + if (identical(attr(lhs, "type", exact = TRUE), "binary")) + return(lhs) + else + return(rhs) + } + + # otherwise, return the regular repository entry + lhs + +} + +renv_available_packages_latest_mran <- function(package, + type = NULL, + repos = NULL) +{ + if (!config$mran.enabled()) + stop("MRAN is not enabled") + + type <- type %||% getOption("pkgType") + if (identical(type, "source")) + stop("MRAN database requires binary packages to be available") + + # ensure local MRAN database is up-to-date + renv_mran_database_refresh(explicit = FALSE) + + # attempt to read it + database <- catch(renv_mran_database_load()) + if (inherits(database, "error")) + return(database) + + # get entry for this version of R + platform + suffix <- contrib.url("", type = "binary") + entry <- database[[suffix]] + if (is.null(entry)) + stopf("no MRAN records available from repository URL '%s'", suffix) + + # find all available packages + keys <- attr(entry, "keys") + pattern <- paste0("^", package, " ") + matching <- grep(pattern, keys, perl = TRUE, value = TRUE) + if (empty(matching)) + stopf("package '%s' is not available from MRAN", package) + + # take the latest-available package + entries <- unlist(mget(matching, envir = entry)) + sorted <- sort(entries, decreasing = TRUE) + key <- names(sorted)[[1L]] + idate <- sorted[[1L]] + + # split into package, version + index <- regexpr(" ", key, fixed = TRUE) + version <- substring(key, index + 1) + + # return an appropriate record + record <- list( + Package = package, + Version = version, + Source = "Repository", + Repository = "MRAN" + ) + + # convert from integer to date + date <- as.Date(idate, origin = "1970-01-01") + + # form url to binary package + base <- renv_mran_url(date, suffix) + name <- renv_retrieve_name(record, type = "binary") + url <- file.path(base, name) + + # tag record with url + type + attr(record, "url") <- dirname(url) + attr(record, "type") <- "binary" + + record +} + +renv_available_packages_latest_repos <- function(package, + type = NULL, + repos = NULL) +{ + type <- type %||% getOption("pkgType") + repos <- repos %||% getOption("repos") + + # detect requests for only source packages + if (identical(type, "source")) + return(renv_available_packages_latest_repos_impl(package, "source", repos)) + + # detect requests for only binary packages + if (grepl("\\bbinary\\b", type)) + return(renv_available_packages_latest_repos_impl(package, "binary", repos)) + + # otherwise, check both source and binary repositories + src <- renv_available_packages_latest_repos_impl(package, "source", repos) + bin <- renv_available_packages_latest_repos_impl(package, "binary", repos) + + # choose an appropriate record + if (is.null(src) && is.null(bin)) + stopf("package '%s' is not available", package) + else if (is.null(src)) + renv_available_packages_record(bin, "binary") + else if (is.null(bin)) + renv_available_packages_record(src, "source") + else + renv_available_packages_latest_select(src, bin) +} + +renv_available_packages_latest_select <- function(src, bin) { + + # if the binary is at least as old as the source version, + # then use the binary version + if (renv_version_compare(bin$Version, src$Version) >= 0) + return(renv_available_packages_record(bin, "binary")) + + # if the user has requested we skip source repositories, + # use the binary anyway + ipcs <- getOption("install.packages.check.source", default = "yes") + if (!identical(ipcs, "yes")) + return(renv_available_packages_record(bin, "binary")) + + # if the package requires compilation, check to see whether + # the user has opted in to compiling packages from source + nc <- identical(src$NeedsCompilation, "yes") + if (nc) { + + # check user preference re: compilation from source + ipcfs <- getOption( + "install.packages.compile.from.source", + default = Sys.getenv("R_COMPILE_AND_INSTALL_PACKAGES") + ) + + # if make is not available, then we can't build from source + make <- Sys.getenv("MAKE", unset = "make") + if (!nzchar(Sys.which(make))) + ipcfs <- "never" + + # if we're on macOS and command line tools are not available, + # then we can't build from sources + if (renv_platform_macos() && !renv_xcode_available()) + ipcfs <- "never" + + if (identical(ipcfs, "never")) + return(renv_available_packages_record(bin, "binary")) + + } + + # take the source version + renv_available_packages_record(src, "source") + +} + +renv_available_packages_cellar <- function(type, project = NULL) { + + # look in the cellar + project <- renv_project_resolve(project) + roots <- renv_cellar_roots(project = project) + + # look for packages + all <- list.files( + path = roots, + all.files = TRUE, + full.names = TRUE, + recursive = TRUE, + include.dirs = FALSE + ) + + # keep only files with matching extensions + ext <- renv_package_ext(type = type) + keep <- all[fileext(all) %in% ext] + + # construct records for each cellar entry + records <- lapply(keep, function(path) { + + # infer package name, version from tarball name + base <- basename(keep) + idx <- regexpr("_", base, fixed = TRUE) + package <- substring(base, 1L, idx - 1L) + version <- substring(base, idx + 1L, nchar(base) - nchar(ext)) + + # set the Repository field + prefix <- if (renv_platform_windows()) "file:///" else "file://" + repository <- paste0(prefix, dirname(path)) + + # build record + list( + Package = package, + Version = version, + Repository = repository + ) + + }) + + bind(records) + +} + +renv_available_packages_filter <- function(db) { + + # sanity check + if (is.null(db) || nrow(db) == 0L) + return(db) + + # TODO: subarch? duplicates? + # remove packages which won't work on this OS + db <- renv_available_packages_filter_ostype(db) + db <- renv_available_packages_filter_version(db) + + # return filtered database + db + +} + +renv_available_packages_filter_ostype <- function(db) { + ostype <- db$OS_type + ok <- is.na(ostype) | ostype %in% .Platform$OS.type + rows(db, ok) +} + +renv_available_packages_filter_version <- function(db) { + + depends <- db$Depends + + # find the packages which express an R dependency + splat <- strsplit(depends, "\\s*,\\s*", perl = TRUE) + + # remove the non-R dependencies + table <- c("R ", "R\n", "R(") + splat <- map(splat, function(requirements) { + requirements[match(substr(requirements, 1L, 2L), table, 0L) != 0L] + }) + + # collect the unique R dependencies + dependencies <- unique(unlist(splat)) + + # convert this to a simpler form + pattern <- "^R\\s*\\(([^\\d\\s+]+)\\s*([^\\)]+)\\)$" + matches <- gsub(pattern, "\\1 \\2", dependencies, perl = TRUE) + + # split into operator and version + idx <- regexpr(" ", matches, fixed = TRUE) + ops <- substring(matches, 1L, idx - 1L) + version <- numeric_version(substring(matches, idx + 1L)) + + # bundle the calls for efficiency + ok <- rep.int(NA, length(ops)) + names(ok) <- dependencies + + # iterate over the operations, and update our vector + rversion <- getRversion() + for (op in unique(ops)) { + idx <- ops == op + ok[idx] <- do.call(op, list(rversion, version[idx])) + } + + # now, map the names back to their computed values, and check whether + # all requirements were satisfied + ok <- map_lgl(splat, function(requirements) { + all(ok[requirements]) + }) + + rows(db, ok) + +} + +# flattens available packages, keeping only the newest version +renv_available_packages_flatten <- function(dbs) { + + # stack the databases together + stacked <- bind(dbs) + + # order by package + version + # TODO: 'order()' is kind of slow for numeric versions; can we do better? + index <- with(stacked, order(Package, numeric_version(Version), decreasing = TRUE)) + ordered <- rows(stacked, index) + + # remove duplicates + dupes <- duplicated(ordered$Package) + filtered <- rows(ordered, !dupes) + + # ready to return + filtered + +} + + +# backports.R ---------------------------------------------------------------- + + +if (is.null(.BaseNamespaceEnv$lengths)) { + + lengths <- function(x, use.names = TRUE) { + vapply(x, length, numeric(1), USE.NAMES = use.names) + } + +} + + +# base64.R ------------------------------------------------------------------- + + +the$base64_table <- as.integer(charToRaw("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=")) + +renv_base64_encode_main <- function(input) { + + ni <- as.integer(length(input)) + if (ni < 3L) + return(integer()) + + no <- ni %/% 3L * 4L + output <- integer(no) + + i0 <- seq.int(1L, ni - 2L, by = 3L) + i1 <- seq.int(2L, ni - 1L, by = 3L) + i2 <- seq.int(3L, ni - 0L, by = 3L) + + o0 <- seq.int(1L, no - 3L, by = 4L) + o1 <- seq.int(2L, no - 2L, by = 4L) + o2 <- seq.int(3L, no - 1L, by = 4L) + o3 <- seq.int(4L, no - 0L, by = 4L) + + output[o0] <- the$base64_table[1L + bitwShiftR(input[i0], 2L)] + + output[o1] <- the$base64_table[1L + bitwOr( + bitwShiftL(bitwAnd(input[i0], 0x03L), 4L), + bitwShiftR(bitwAnd(input[i1], 0xF0L), 4L) + )] + + output[o2] <- the$base64_table[1L + bitwOr( + bitwShiftL(bitwAnd(input[i1], 0x0FL), 2L), + bitwShiftR(bitwAnd(input[i2], 0xC0L), 6L) + )] + + output[o3] <- the$base64_table[1L + bitwAnd(input[i2], 0x3FL)] + + output + +} + +renv_base64_encode_rest <- function(input) { + + ni <- as.integer(length(input)) + remaining <- ni %% 3L + if (remaining == 0L) + return(integer()) + + output <- rep.int(61L, 4L) + i <- ni - remaining + 1 + + output[1L] <- the$base64_table[1L + bitwShiftR(input[i + 0L], 2L)] + + if (remaining == 1L) { + + output[2L] <- the$base64_table[1L + bitwShiftL(bitwAnd(input[i + 0L], 0x03L), 4L)] + + } else if (remaining == 2L) { + + output[2L] <- the$base64_table[1L + bitwOr( + bitwShiftL(bitwAnd(input[i + 0L], 0x03L), 4L), + bitwShiftR(bitwAnd(input[i + 1L], 0xF0L), 4L) + )] + + output[3L] <- the$base64_table[1L + bitwShiftL(bitwAnd(input[i + 1L], 0x0FL), 2L)] + + } + + output + +} + +renv_base64_encode <- function(text) { + + # convert to raw vector + input <- case( + is.character(text) ~ as.integer(charToRaw(text)), + is.raw(text) ~ as.integer(text), + ~ stopf("unexpected input type '%s'", typeof(text)) + ) + + encoded <- c( + renv_base64_encode_main(input), + renv_base64_encode_rest(input) + ) + + rawToChar(as.raw(encoded)) + +} + +the$base64_decode_table <- NULL +renv_base64_decode_table <- function() { + the$base64_decode_table <- the$base64_decode_table %||% { + table <- integer(255) + text <- "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=" + table[utf8ToInt(text)] <- seq_len(nchar(text)) - 1L + table + } +} + +renv_base64_decode_main <- function(input) { + + ni <- length(input) + no <- (ni * 3L) %/% 4L + + output <- integer(no) + + i0 <- seq(from = 1L, to = ni - 3L, by = 4L) + i1 <- seq(from = 2L, to = ni - 2L, by = 4L) + i2 <- seq(from = 3L, to = ni - 1L, by = 4L) + i3 <- seq(from = 4L, to = ni - 0L, by = 4L) + + o0 <- seq.int(1L, no - 2L, by = 3L) + o1 <- seq.int(2L, no - 1L, by = 3L) + o2 <- seq.int(3L, no - 0L, by = 3L) + + t <- renv_base64_decode_table() + + output[o0] <- bitwOr( + bitwAnd(bitwShiftL(t[input[i0]], 2L), 255L), + bitwAnd(bitwShiftR(t[input[i1]], 4L), 255L) + ) + + output[o1] <- bitwOr( + bitwAnd(bitwShiftL(t[input[i1]], 4L), 255L), + bitwAnd(bitwShiftR(t[input[i2]], 2L), 255L) + ) + + output[o2] <- bitwOr( + bitwAnd(bitwShiftL(t[input[i2]], 6L), 255L), + bitwAnd(bitwShiftR(t[input[i3]], 0L), 255L) + ) + + output + +} + +renv_base64_decode <- function(encoded) { + + # remove newlines + if (c(regexpr("\n", encoded, fixed = TRUE)) != -1L) + encoded <- gsub("\n", "", encoded, fixed = TRUE) + + # convert to raw vector + input <- case( + is.character(encoded) ~ as.integer(charToRaw(encoded)), + is.raw(encoded) ~ as.integer(encoded), + ~ stopf("unexpected input type '%s'", typeof(encoded)) + ) + + # decode vector + output <- renv_base64_decode_main(input) + + # trim off padded bits + n <- length(input) + if (input[n - 1L] == 61L) + output <- head(output, n = -2L) + else if (input[n] == 61L) + output <- head(output, n = -1L) + + # convert back to string + rawToChar(as.raw(output)) + +} + + +# bind.R --------------------------------------------------------------------- + + +bind <- function(data, names = NULL, index = "Index") { + + # keep only non-empty data + data <- Filter(NROW, data) + if (!length(data)) + return(NULL) + + # check for quick exit + if (length(data) == 1L) { + + # no-name case + if (is.null(names(data))) { + rhs <- data[[1L]] + names(rhs) <- names(rhs) %||% names + return(as_data_frame(rhs)) + } + + # named case + lhs <- list(rep.int(names(data), times = NROW(data[[1L]]))) + names(lhs) <- index + rhs <- as.list(data[[1L]]) + return(as_data_frame(c(lhs, rhs))) + + } + + # ensure all datasets have the same column names + # try to preserve the ordering of names if possible + # (try to find one dataset which has all column relevant column names) + nms <- character() + for (i in seq_along(data)) { + names(data[[i]]) <- names(data[[i]]) %||% names + nmsi <- names(data[[i]]) + if (length(nmsi) > length(nms)) + nms <- nmsi + } + + # check now if we've caught all relevant names; if we didn't, + # just fall back to a "dumb" union + allnms <- unique.default(unlist(lapply(data, names), use.names = FALSE)) + if (!setequal(nms, allnms)) + nms <- allnms + + # we've collected all names; now fill with NAs as necessary + filled <- map(data, function(datum) { + datum[setdiff(nms, names(datum))] <- NA + datum[nms] + }) + + # we've collected and ordered each data.frame, now merge them + rhs <- .mapply(c, filled, list(use.names = FALSE)) + names(rhs) <- names(filled[[1L]]) + + if (is.null(names(data))) { + names(rhs) <- names(rhs) %||% names + return(as_data_frame(rhs)) + } + + if (index %in% names(rhs)) { + fmt <- "name collision: bound list already contains column called '%s'" + stopf(fmt, index) + } + + lhs <- list() + rows <- function(item) nrow(item) %||% length(item[[1L]]) + lhs[[index]] <- rep.int(names(filled), times = map_dbl(filled, rows)) + + as_data_frame(c(lhs, rhs)) + +} + + + + + + + +# binding.R ------------------------------------------------------------------ + + +renv_binding_lock <- function(envir, symbol) { + .BaseNamespaceEnv$lockBinding(symbol, envir) +} + +renv_binding_locked <- function(envir, symbol) { + .BaseNamespaceEnv$bindingIsLocked(symbol, envir) +} + +renv_binding_unlock <- function(envir, symbol) { + .BaseNamespaceEnv$unlockBinding(symbol, envir) +} + +renv_binding_replace <- function(envir, symbol, replacement) { + + # get the original definition + original <- envir[[symbol]] + + # if the binding is locked, temporarily unlock it + if (renv_binding_locked(envir, symbol)) { + defer(renv_binding_lock(envir, symbol)) + renv_binding_unlock(envir, symbol) + } + + # update the binding + assign(symbol, replacement, envir = envir) + + # return old definition + original + +} + + +# bioconductor.R ------------------------------------------------------------- + + +renv_bioconductor_manager <- function() { + if (getRversion() >= "3.5.0") + "BiocManager" + else + "BiocInstaller" +} + +renv_bioconductor_init <- function(library = NULL) { + renv_scope_options(renv.verbose = FALSE) + + if (identical(renv_bioconductor_manager(), "BiocManager")) + renv_bioconductor_init_biocmanager(library) + else + renv_bioconductor_init_biocinstaller(library) +} + +renv_bioconductor_init_biocmanager <- function(library = NULL) { + + library <- library %||% renv_libpaths_active() + if (renv_package_installed("BiocManager", lib.loc = library)) + return(TRUE) + + ensure_directory(library) + install("BiocManager", library = library) + TRUE + +} + +renv_bioconductor_init_biocinstaller <- function(library = NULL) { + + library <- library %||% renv_libpaths_active() + if (renv_package_installed("BiocInstaller", lib.loc = library)) + return(TRUE) + + url <- "https://bioconductor.org/biocLite.R" + destfile <- renv_scope_tempfile("renv-bioclite-", fileext = ".R") + download(url, destfile = destfile, quiet = TRUE) + + ensure_directory(library) + renv_scope_libpaths(library) + source(destfile) + TRUE + +} + +renv_bioconductor_version <- function(project, refresh = FALSE) { + + # check and see if we have an override via option + version <- getOption("renv.bioconductor.version") + if (!is.null(version)) + return(version) + + # check and see if the project has been configured to use a specific + # Bioconductor release + if (!refresh) { + version <- settings$bioconductor.version(project = project) + if (length(version)) + return(version) + } + + # if BiocVersion is installed, use it + if (renv_package_available("BiocVersion")) + return(format(packageVersion("BiocVersion")[1, 1:2])) + + # make sure the required bioc package is available + renv_bioconductor_init() + + # otherwise, infer the Bioconductor version from installed packages + case( + + renv_package_available("BiocManager") ~ { + BiocManager <- renv_scope_biocmanager() + format(BiocManager$version()) + }, + + renv_package_available("BiocVersion") ~ { + BiocInstaller <- renv_namespace_load("BiocInstaller") + format(BiocInstaller$biocVersion()) + } + + ) + +} + +# Returns the union of the inferred Bioconductor repositories, together with the +# current value of the 'repos' R option. The Bioconductor repositories are +# placed first in the repository list. +renv_bioconductor_repos <- function(project = NULL, version = NULL) { + + # allow bioconductor repos override + repos <- getOption("renv.bioconductor.repos") + if (!is.null(repos)) + return(repos) + + # make sure the required bioc package is available + renv_bioconductor_init() + + # read Bioconductor version (normally set during restore) + version <- version %||% renv_bioconductor_version(project = project) + + # read Bioconductor repositories (prefer BiocInstaller for older R) + if (identical(renv_bioconductor_manager(), "BiocManager")) + renv_bioconductor_repos_biocmanager(version) + else + renv_bioconductor_repos_biocinstaller(version) + +} + +renv_bioconductor_repos_biocmanager <- function(version) { + + BiocManager <- renv_scope_biocmanager() + version <- version %||% BiocManager$version() + + tryCatch( + BiocManager$.repositories(site_repository = character(), version = version), + error = function(e) { + BiocManager$repositories(version = version) + } + ) + +} + +renv_bioconductor_repos_biocinstaller <- function(version) { + BiocInstaller <- asNamespace("BiocInstaller") + version <- version %||% BiocInstaller$biocVersion() + BiocInstaller$biocinstallRepos(version = version) +} + +renv_bioconductor_required <- function(records) { + + for (record in records) + if (identical(record$Source, "Bioconductor")) + return(TRUE) + + FALSE + +} + + +# bootstrap.R ---------------------------------------------------------------- + + +`%||%` <- function(x, y) { + if (is.null(x)) y else x +} + +catf <- function(fmt, ..., appendLF = TRUE) { + + quiet <- getOption("renv.bootstrap.quiet", default = FALSE) + if (quiet) + return(invisible()) + + msg <- sprintf(fmt, ...) + cat(msg, file = stdout(), sep = if (appendLF) "\n" else "") + + invisible(msg) + +} + +header <- function(label, + ..., + prefix = "#", + suffix = "-", + n = min(getOption("width"), 78)) +{ + label <- sprintf(label, ...) + n <- max(n - nchar(label) - nchar(prefix) - 2L, 8L) + if (n <= 0) + return(paste(prefix, label)) + + tail <- paste(rep.int(suffix, n), collapse = "") + paste0(prefix, " ", label, " ", tail) + +} + +startswith <- function(string, prefix) { + substring(string, 1, nchar(prefix)) == prefix +} + +bootstrap <- function(version, library) { + + friendly <- renv_bootstrap_version_friendly(version) + section <- header(sprintf("Bootstrapping renv %s", friendly)) + catf(section) + + # attempt to download renv + catf("- Downloading renv ... ", appendLF = FALSE) + withCallingHandlers( + tarball <- renv_bootstrap_download(version), + error = function(err) { + catf("FAILED") + stop("failed to download:\n", conditionMessage(err)) + } + ) + catf("OK") + on.exit(unlink(tarball), add = TRUE) + + # now attempt to install + catf("- Installing renv ... ", appendLF = FALSE) + withCallingHandlers( + status <- renv_bootstrap_install(version, tarball, library), + error = function(err) { + catf("FAILED") + stop("failed to install:\n", conditionMessage(err)) + } + ) + catf("OK") + + # add empty line to break up bootstrapping from normal output + catf("") + + return(invisible()) +} + +renv_bootstrap_tests_running <- function() { + getOption("renv.tests.running", default = FALSE) +} + +renv_bootstrap_repos <- function() { + + # get CRAN repository + cran <- getOption("renv.repos.cran", "https://cloud.r-project.org") + + # check for repos override + repos <- Sys.getenv("RENV_CONFIG_REPOS_OVERRIDE", unset = NA) + if (!is.na(repos)) { + + # check for RSPM; if set, use a fallback repository for renv + rspm <- Sys.getenv("RSPM", unset = NA) + if (identical(rspm, repos)) + repos <- c(RSPM = rspm, CRAN = cran) + + return(repos) + + } + + # check for lockfile repositories + repos <- tryCatch(renv_bootstrap_repos_lockfile(), error = identity) + if (!inherits(repos, "error") && length(repos)) + return(repos) + + # retrieve current repos + repos <- getOption("repos") + + # ensure @CRAN@ entries are resolved + repos[repos == "@CRAN@"] <- cran + + # add in renv.bootstrap.repos if set + default <- c(FALLBACK = "https://cloud.r-project.org") + extra <- getOption("renv.bootstrap.repos", default = default) + repos <- c(repos, extra) + + # remove duplicates that might've snuck in + dupes <- duplicated(repos) | duplicated(names(repos)) + repos[!dupes] + +} + +renv_bootstrap_repos_lockfile <- function() { + + lockpath <- Sys.getenv("RENV_PATHS_LOCKFILE", unset = "renv.lock") + if (!file.exists(lockpath)) + return(NULL) + + lockfile <- tryCatch(renv_json_read(lockpath), error = identity) + if (inherits(lockfile, "error")) { + warning(lockfile) + return(NULL) + } + + repos <- lockfile$R$Repositories + if (length(repos) == 0) + return(NULL) + + keys <- vapply(repos, `[[`, "Name", FUN.VALUE = character(1)) + vals <- vapply(repos, `[[`, "URL", FUN.VALUE = character(1)) + names(vals) <- keys + + return(vals) + +} + +renv_bootstrap_download <- function(version) { + + sha <- attr(version, "sha", exact = TRUE) + + methods <- if (!is.null(sha)) { + + # attempting to bootstrap a development version of renv + c( + function() renv_bootstrap_download_tarball(sha), + function() renv_bootstrap_download_github(sha) + ) + + } else { + + # attempting to bootstrap a release version of renv + c( + function() renv_bootstrap_download_tarball(version), + function() renv_bootstrap_download_cran_latest(version), + function() renv_bootstrap_download_cran_archive(version) + ) + + } + + for (method in methods) { + path <- tryCatch(method(), error = identity) + if (is.character(path) && file.exists(path)) + return(path) + } + + stop("All download methods failed") + +} + +renv_bootstrap_download_impl <- function(url, destfile) { + + mode <- "wb" + + # https://bugs.r-project.org/bugzilla/show_bug.cgi?id=17715 + fixup <- + Sys.info()[["sysname"]] == "Windows" && + substring(url, 1L, 5L) == "file:" + + if (fixup) + mode <- "w+b" + + args <- list( + url = url, + destfile = destfile, + mode = mode, + quiet = TRUE + ) + + if ("headers" %in% names(formals(utils::download.file))) + args$headers <- renv_bootstrap_download_custom_headers(url) + + do.call(utils::download.file, args) + +} + +renv_bootstrap_download_custom_headers <- function(url) { + + headers <- getOption("renv.download.headers") + if (is.null(headers)) + return(character()) + + if (!is.function(headers)) + stopf("'renv.download.headers' is not a function") + + headers <- headers(url) + if (length(headers) == 0L) + return(character()) + + if (is.list(headers)) + headers <- unlist(headers, recursive = FALSE, use.names = TRUE) + + ok <- + is.character(headers) && + is.character(names(headers)) && + all(nzchar(names(headers))) + + if (!ok) + stop("invocation of 'renv.download.headers' did not return a named character vector") + + headers + +} + +renv_bootstrap_download_cran_latest <- function(version) { + + spec <- renv_bootstrap_download_cran_latest_find(version) + type <- spec$type + repos <- spec$repos + + baseurl <- utils::contrib.url(repos = repos, type = type) + ext <- if (identical(type, "source")) + ".tar.gz" + else if (Sys.info()[["sysname"]] == "Windows") + ".zip" + else + ".tgz" + name <- sprintf("renv_%s%s", version, ext) + url <- paste(baseurl, name, sep = "/") + + destfile <- file.path(tempdir(), name) + status <- tryCatch( + renv_bootstrap_download_impl(url, destfile), + condition = identity + ) + + if (inherits(status, "condition")) + return(FALSE) + + # report success and return + destfile + +} + +renv_bootstrap_download_cran_latest_find <- function(version) { + + # check whether binaries are supported on this system + binary <- + getOption("renv.bootstrap.binary", default = TRUE) && + !identical(.Platform$pkgType, "source") && + !identical(getOption("pkgType"), "source") && + Sys.info()[["sysname"]] %in% c("Darwin", "Windows") + + types <- c(if (binary) "binary", "source") + + # iterate over types + repositories + for (type in types) { + for (repos in renv_bootstrap_repos()) { + + # retrieve package database + db <- tryCatch( + as.data.frame( + utils::available.packages(type = type, repos = repos), + stringsAsFactors = FALSE + ), + error = identity + ) + + if (inherits(db, "error")) + next + + # check for compatible entry + entry <- db[db$Package %in% "renv" & db$Version %in% version, ] + if (nrow(entry) == 0) + next + + # found it; return spec to caller + spec <- list(entry = entry, type = type, repos = repos) + return(spec) + + } + } + + # if we got here, we failed to find renv + fmt <- "renv %s is not available from your declared package repositories" + stop(sprintf(fmt, version)) + +} + +renv_bootstrap_download_cran_archive <- function(version) { + + name <- sprintf("renv_%s.tar.gz", version) + repos <- renv_bootstrap_repos() + urls <- file.path(repos, "src/contrib/Archive/renv", name) + destfile <- file.path(tempdir(), name) + + for (url in urls) { + + status <- tryCatch( + renv_bootstrap_download_impl(url, destfile), + condition = identity + ) + + if (identical(status, 0L)) + return(destfile) + + } + + return(FALSE) + +} + +renv_bootstrap_download_tarball <- function(version) { + + # if the user has provided the path to a tarball via + # an environment variable, then use it + tarball <- Sys.getenv("RENV_BOOTSTRAP_TARBALL", unset = NA) + if (is.na(tarball)) + return() + + # allow directories + if (dir.exists(tarball)) { + name <- sprintf("renv_%s.tar.gz", version) + tarball <- file.path(tarball, name) + } + + # bail if it doesn't exist + if (!file.exists(tarball)) { + + # let the user know we weren't able to honour their request + fmt <- "- RENV_BOOTSTRAP_TARBALL is set (%s) but does not exist." + msg <- sprintf(fmt, tarball) + warning(msg) + + # bail + return() + + } + + catf("- Using local tarball '%s'.", tarball) + tarball + +} + +renv_bootstrap_download_github <- function(version) { + + enabled <- Sys.getenv("RENV_BOOTSTRAP_FROM_GITHUB", unset = "TRUE") + if (!identical(enabled, "TRUE")) + return(FALSE) + + # prepare download options + pat <- Sys.getenv("GITHUB_PAT") + if (nzchar(Sys.which("curl")) && nzchar(pat)) { + fmt <- "--location --fail --header \"Authorization: token %s\"" + extra <- sprintf(fmt, pat) + saved <- options("download.file.method", "download.file.extra") + options(download.file.method = "curl", download.file.extra = extra) + on.exit(do.call(base::options, saved), add = TRUE) + } else if (nzchar(Sys.which("wget")) && nzchar(pat)) { + fmt <- "--header=\"Authorization: token %s\"" + extra <- sprintf(fmt, pat) + saved <- options("download.file.method", "download.file.extra") + options(download.file.method = "wget", download.file.extra = extra) + on.exit(do.call(base::options, saved), add = TRUE) + } + + url <- file.path("https://api.github.com/repos/rstudio/renv/tarball", version) + name <- sprintf("renv_%s.tar.gz", version) + destfile <- file.path(tempdir(), name) + + status <- tryCatch( + renv_bootstrap_download_impl(url, destfile), + condition = identity + ) + + if (!identical(status, 0L)) + return(FALSE) + + renv_bootstrap_download_augment(destfile) + + return(destfile) + +} + +# Add Sha to DESCRIPTION. This is stop gap until #890, after which we +# can use renv::install() to fully capture metadata. +renv_bootstrap_download_augment <- function(destfile) { + sha <- renv_bootstrap_git_extract_sha1_tar(destfile) + if (is.null(sha)) { + return() + } + + # Untar + tempdir <- tempfile("renv-github-") + on.exit(unlink(tempdir, recursive = TRUE), add = TRUE) + untar(destfile, exdir = tempdir) + pkgdir <- dir(tempdir, full.names = TRUE)[[1]] + + # Modify description + desc_path <- file.path(pkgdir, "DESCRIPTION") + desc_lines <- readLines(desc_path) + remotes_fields <- c( + "RemoteType: github", + "RemoteHost: api.github.com", + "RemoteRepo: renv", + "RemoteUsername: rstudio", + "RemotePkgRef: rstudio/renv", + paste("RemoteRef: ", sha), + paste("RemoteSha: ", sha) + ) + writeLines(c(desc_lines[desc_lines != ""], remotes_fields), con = desc_path) + + # Re-tar + local({ + old <- setwd(tempdir) + on.exit(setwd(old), add = TRUE) + + tar(destfile, compression = "gzip") + }) + invisible() +} + +# 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. +renv_bootstrap_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 + } +} + +renv_bootstrap_install <- function(version, tarball, library) { + + # attempt to install it into project library + dir.create(library, showWarnings = FALSE, recursive = TRUE) + output <- renv_bootstrap_install_impl(library, tarball) + + # check for successful install + status <- attr(output, "status") + if (is.null(status) || identical(status, 0L)) + return(status) + + # an error occurred; report it + header <- "installation of renv failed" + lines <- paste(rep.int("=", nchar(header)), collapse = "") + text <- paste(c(header, lines, output), collapse = "\n") + stop(text) + +} + +renv_bootstrap_install_impl <- function(library, tarball) { + + # invoke using system2 so we can capture and report output + bin <- R.home("bin") + exe <- if (Sys.info()[["sysname"]] == "Windows") "R.exe" else "R" + R <- file.path(bin, exe) + + args <- c( + "--vanilla", "CMD", "INSTALL", "--no-multiarch", + "-l", shQuote(path.expand(library)), + shQuote(path.expand(tarball)) + ) + + system2(R, args, stdout = TRUE, stderr = TRUE) + +} + +renv_bootstrap_platform_prefix <- function() { + + # construct version prefix + version <- paste(R.version$major, R.version$minor, sep = ".") + prefix <- paste("R", numeric_version(version)[1, 1:2], sep = "-") + + # include SVN revision for development versions of R + # (to avoid sharing platform-specific artefacts with released versions of R) + devel <- + identical(R.version[["status"]], "Under development (unstable)") || + identical(R.version[["nickname"]], "Unsuffered Consequences") + + if (devel) + prefix <- paste(prefix, R.version[["svn rev"]], sep = "-r") + + # build list of path components + components <- c(prefix, R.version$platform) + + # include prefix if provided by user + prefix <- renv_bootstrap_platform_prefix_impl() + if (!is.na(prefix) && nzchar(prefix)) + components <- c(prefix, components) + + # build prefix + paste(components, collapse = "/") + +} + +renv_bootstrap_platform_prefix_impl <- function() { + + # if an explicit prefix has been supplied, use it + prefix <- Sys.getenv("RENV_PATHS_PREFIX", unset = NA) + if (!is.na(prefix)) + return(prefix) + + # if the user has requested an automatic prefix, generate it + auto <- Sys.getenv("RENV_PATHS_PREFIX_AUTO", unset = NA) + if (auto %in% c("TRUE", "True", "true", "1")) + return(renv_bootstrap_platform_prefix_auto()) + + # empty string on failure + "" + +} + +renv_bootstrap_platform_prefix_auto <- function() { + + prefix <- tryCatch(renv_bootstrap_platform_os(), error = identity) + if (inherits(prefix, "error") || prefix %in% "unknown") { + + msg <- paste( + "failed to infer current operating system", + "please file a bug report at https://github.com/rstudio/renv/issues", + sep = "; " + ) + + warning(msg) + + } + + prefix + +} + +renv_bootstrap_platform_os <- function() { + + sysinfo <- Sys.info() + sysname <- sysinfo[["sysname"]] + + # handle Windows + macOS up front + if (sysname == "Windows") + return("windows") + else if (sysname == "Darwin") + return("macos") + + # check for os-release files + for (file in c("/etc/os-release", "/usr/lib/os-release")) + if (file.exists(file)) + return(renv_bootstrap_platform_os_via_os_release(file, sysinfo)) + + # check for redhat-release files + if (file.exists("/etc/redhat-release")) + return(renv_bootstrap_platform_os_via_redhat_release()) + + "unknown" + +} + +renv_bootstrap_platform_os_via_os_release <- function(file, sysinfo) { + + # read /etc/os-release + release <- utils::read.table( + file = file, + sep = "=", + quote = c("\"", "'"), + col.names = c("Key", "Value"), + comment.char = "#", + stringsAsFactors = FALSE + ) + + vars <- as.list(release$Value) + names(vars) <- release$Key + + # get os name + os <- tolower(sysinfo[["sysname"]]) + + # read id + id <- "unknown" + for (field in c("ID", "ID_LIKE")) { + if (field %in% names(vars) && nzchar(vars[[field]])) { + id <- vars[[field]] + break + } + } + + # read version + version <- "unknown" + for (field in c("UBUNTU_CODENAME", "VERSION_CODENAME", "VERSION_ID", "BUILD_ID")) { + if (field %in% names(vars) && nzchar(vars[[field]])) { + version <- vars[[field]] + break + } + } + + # join together + paste(c(os, id, version), collapse = "-") + +} + +renv_bootstrap_platform_os_via_redhat_release <- function() { + + # read /etc/redhat-release + contents <- readLines("/etc/redhat-release", warn = FALSE) + + # infer id + id <- if (grepl("centos", contents, ignore.case = TRUE)) + "centos" + else if (grepl("redhat", contents, ignore.case = TRUE)) + "redhat" + else + "unknown" + + # try to find a version component (very hacky) + version <- "unknown" + + parts <- strsplit(contents, "[[:space:]]")[[1L]] + for (part in parts) { + + nv <- tryCatch(numeric_version(part), error = identity) + if (inherits(nv, "error")) + next + + version <- nv[1, 1] + break + + } + + paste(c("linux", id, version), collapse = "-") + +} + +renv_bootstrap_library_root_name <- function(project) { + + # use project name as-is if requested + asis <- Sys.getenv("RENV_PATHS_LIBRARY_ROOT_ASIS", unset = "FALSE") + if (asis) + return(basename(project)) + + # otherwise, disambiguate based on project's path + id <- substring(renv_bootstrap_hash_text(project), 1L, 8L) + paste(basename(project), id, sep = "-") + +} + +renv_bootstrap_library_root <- function(project) { + + prefix <- renv_bootstrap_profile_prefix() + + path <- Sys.getenv("RENV_PATHS_LIBRARY", unset = NA) + if (!is.na(path)) + return(paste(c(path, prefix), collapse = "/")) + + path <- renv_bootstrap_library_root_impl(project) + if (!is.null(path)) { + name <- renv_bootstrap_library_root_name(project) + return(paste(c(path, prefix, name), collapse = "/")) + } + + renv_bootstrap_paths_renv("library", project = project) + +} + +renv_bootstrap_library_root_impl <- function(project) { + + root <- Sys.getenv("RENV_PATHS_LIBRARY_ROOT", unset = NA) + if (!is.na(root)) + return(root) + + type <- renv_bootstrap_project_type(project) + if (identical(type, "package")) { + userdir <- renv_bootstrap_user_dir() + return(file.path(userdir, "library")) + } + +} + +renv_bootstrap_validate_version <- function(version, description = NULL) { + + # resolve description file + # + # avoid passing lib.loc to `packageDescription()` below, since R will + # use the loaded version of the package by default anyhow. note that + # this function should only be called after 'renv' is loaded + # https://github.com/rstudio/renv/issues/1625 + description <- description %||% packageDescription("renv") + + # check whether requested version 'version' matches loaded version of renv + sha <- attr(version, "sha", exact = TRUE) + valid <- if (!is.null(sha)) + renv_bootstrap_validate_version_dev(sha, description) + else + renv_bootstrap_validate_version_release(version, description) + + if (valid) + return(TRUE) + + # the loaded version of renv doesn't match the requested version; + # give the user instructions on how to proceed + remote <- if (!is.null(description[["RemoteSha"]])) { + paste("rstudio/renv", description[["RemoteSha"]], sep = "@") + } else { + paste("renv", description[["Version"]], sep = "@") + } + + # display both loaded version + sha if available + friendly <- renv_bootstrap_version_friendly( + version = description[["Version"]], + sha = description[["RemoteSha"]] + ) + + fmt <- paste( + "renv %1$s was loaded from project library, but this project is configured to use renv %2$s.", + "- Use `renv::record(\"%3$s\")` to record renv %1$s in the lockfile.", + "- Use `renv::restore(packages = \"renv\")` to install renv %2$s into the project library.", + sep = "\n" + ) + catf(fmt, friendly, renv_bootstrap_version_friendly(version), remote) + + FALSE + +} + +renv_bootstrap_validate_version_dev <- function(version, description) { + expected <- description[["RemoteSha"]] + is.character(expected) && startswith(expected, version) +} + +renv_bootstrap_validate_version_release <- function(version, description) { + expected <- description[["Version"]] + is.character(expected) && identical(expected, version) +} + +renv_bootstrap_hash_text <- function(text) { + + hashfile <- tempfile("renv-hash-") + on.exit(unlink(hashfile), add = TRUE) + + writeLines(text, con = hashfile) + tools::md5sum(hashfile) + +} + +renv_bootstrap_load <- function(project, libpath, version) { + + # try to load renv from the project library + if (!requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) + return(FALSE) + + # warn if the version of renv loaded does not match + renv_bootstrap_validate_version(version) + + # execute renv load hooks, if any + hooks <- getHook("renv::autoload") + for (hook in hooks) + if (is.function(hook)) + tryCatch(hook(), error = warnify) + + # load the project + renv::load(project) + + TRUE + +} + +renv_bootstrap_profile_load <- function(project) { + + # if RENV_PROFILE is already set, just use that + profile <- Sys.getenv("RENV_PROFILE", unset = NA) + if (!is.na(profile) && nzchar(profile)) + return(profile) + + # check for a profile file (nothing to do if it doesn't exist) + path <- renv_bootstrap_paths_renv("profile", profile = FALSE, project = project) + if (!file.exists(path)) + return(NULL) + + # read the profile, and set it if it exists + contents <- readLines(path, warn = FALSE) + if (length(contents) == 0L) + return(NULL) + + # set RENV_PROFILE + profile <- contents[[1L]] + if (!profile %in% c("", "default")) + Sys.setenv(RENV_PROFILE = profile) + + profile + +} + +renv_bootstrap_profile_prefix <- function() { + profile <- renv_bootstrap_profile_get() + if (!is.null(profile)) + return(file.path("profiles", profile, "renv")) +} + +renv_bootstrap_profile_get <- function() { + profile <- Sys.getenv("RENV_PROFILE", unset = "") + renv_bootstrap_profile_normalize(profile) +} + +renv_bootstrap_profile_set <- function(profile) { + profile <- renv_bootstrap_profile_normalize(profile) + if (is.null(profile)) + Sys.unsetenv("RENV_PROFILE") + else + Sys.setenv(RENV_PROFILE = profile) +} + +renv_bootstrap_profile_normalize <- function(profile) { + + if (is.null(profile) || profile %in% c("", "default")) + return(NULL) + + profile + +} + +renv_bootstrap_path_absolute <- function(path) { + + substr(path, 1L, 1L) %in% c("~", "/", "\\") || ( + substr(path, 1L, 1L) %in% c(letters, LETTERS) && + substr(path, 2L, 3L) %in% c(":/", ":\\") + ) + +} + +renv_bootstrap_paths_renv <- function(..., profile = TRUE, project = NULL) { + renv <- Sys.getenv("RENV_PATHS_RENV", unset = "renv") + root <- if (renv_bootstrap_path_absolute(renv)) NULL else project + prefix <- if (profile) renv_bootstrap_profile_prefix() + components <- c(root, renv, prefix, ...) + paste(components, collapse = "/") +} + +renv_bootstrap_project_type <- function(path) { + + descpath <- file.path(path, "DESCRIPTION") + if (!file.exists(descpath)) + return("unknown") + + desc <- tryCatch( + read.dcf(descpath, all = TRUE), + error = identity + ) + + if (inherits(desc, "error")) + return("unknown") + + type <- desc$Type + if (!is.null(type)) + return(tolower(type)) + + package <- desc$Package + if (!is.null(package)) + return("package") + + "unknown" + +} + +renv_bootstrap_user_dir <- function() { + dir <- renv_bootstrap_user_dir_impl() + path.expand(chartr("\\", "/", dir)) +} + +renv_bootstrap_user_dir_impl <- function() { + + # use local override if set + override <- getOption("renv.userdir.override") + if (!is.null(override)) + return(override) + + # use R_user_dir if available + tools <- asNamespace("tools") + if (is.function(tools$R_user_dir)) + return(tools$R_user_dir("renv", "cache")) + + # try using our own backfill for older versions of R + envvars <- c("R_USER_CACHE_DIR", "XDG_CACHE_HOME") + for (envvar in envvars) { + root <- Sys.getenv(envvar, unset = NA) + if (!is.na(root)) + return(file.path(root, "R/renv")) + } + + # use platform-specific default fallbacks + if (Sys.info()[["sysname"]] == "Windows") + file.path(Sys.getenv("LOCALAPPDATA"), "R/cache/R/renv") + else if (Sys.info()[["sysname"]] == "Darwin") + "~/Library/Caches/org.R-project.R/R/renv" + else + "~/.cache/R/renv" + +} + +renv_bootstrap_version_friendly <- function(version, shafmt = NULL, sha = NULL) { + sha <- sha %||% attr(version, "sha", exact = TRUE) + parts <- c(version, sprintf(shafmt %||% " [sha: %s]", substring(sha, 1L, 7L))) + paste(parts, collapse = "") +} + +renv_bootstrap_exec <- function(project, libpath, version) { + if (!renv_bootstrap_load(project, libpath, version)) + renv_bootstrap_run(version, libpath) +} + +renv_bootstrap_run <- function(version, libpath) { + + # perform bootstrap + bootstrap(version, libpath) + + # exit early if we're just testing bootstrap + if (!is.na(Sys.getenv("RENV_BOOTSTRAP_INSTALL_ONLY", unset = NA))) + return(TRUE) + + # try again to load + if (requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) { + return(renv::load(project = getwd())) + } + + # failed to download or load renv; warn the user + msg <- c( + "Failed to find an renv installation: the project will not be loaded.", + "Use `renv::activate()` to re-initialize the project." + ) + + warning(paste(msg, collapse = "\n"), call. = FALSE) + +} + + +# cache.R -------------------------------------------------------------------- + + +# tools for interacting with the renv global package cache +renv_cache_version <- function() { + # NOTE: users should normally not override the cache version; + # this is provided just to make testing easier + Sys.getenv("RENV_CACHE_VERSION", unset = "v5") +} + +renv_cache_version_previous <- function() { + version <- renv_cache_version() + number <- as.integer(substring(version, 2L)) + paste("v", number - 1L, sep = "") +} + +# given a record, find a compatible version of that package in the cache, +# using a computed hash if available; if no hash is available, then try +# to match based on the package name + version +renv_cache_find <- function(record) { + + # validate required fields -- if any are missing, we can't use the cache + required <- c("Package", "Version") + missing <- renv_vector_diff(required, names(record)) + if (length(missing)) + return("") + + # if we have a hash, use it directly + if (!is.null(record$Hash)) { + + # generate path to package installations in cache + paths <- with(record, renv_paths_cache(Package, Version, Hash, Package)) + + # if there are multiple cache entries, return the first existing one + # if no entries exist, return path into first cache entry + for (path in paths) + if (file.exists(path)) + return(path) + + return(paths[[1L]]) + + } + + # if the record doesn't have a hash, check to see if we can still locate a + # compatible package version within the cache + root <- with(record, renv_paths_cache(Package, Version)) + hashes <- list.files(root, full.names = TRUE) + packages <- list.files(hashes, full.names = TRUE) + + # iterate over package paths, read DESCRIPTION, and look + # for something compatible with the requested record + for (package in packages) { + + # try to read the DESCRIPTION file + dcf <- catch(as.list(renv_description_read(package))) + if (inherits(dcf, "error")) + next + + # if we're requesting an install from an R package repository, + # and the cached package has a "Repository" field, then use it + source <- renv_record_source(record) + hasrepo <- + source %in% c("cran", "repository") && + "Repository" %in% names(dcf) + + if (hasrepo) + return(package) + + # check for compatible fields + fields <- unique(c( + renv_record_names(record, c("Package", "Version")), + renv_record_names(dcf, c("Package", "Version")) + )) + + # drop unnamed fields + record <- record[nzchar(record)] + dcf <- dcf[nzchar(dcf)] + + # check identical + lhs <- keep(record, fields) + rhs <- keep(dcf, fields) + if (identical(lhs, rhs)) + return(package) + + } + + # failed; return "" as proxy for missing file + "" + +} + +# given the path to a package's description file, +# compute the location it would be assigned if it +# were moved to the renv cache +renv_cache_path <- function(path) { + record <- renv_description_read(path) + record$Hash <- renv_hash_description(path) + renv_cache_find(record) +} + +renv_cache_path_components <- function(path) { + + data_frame( + Package = renv_path_component(path, 1L), + Hash = renv_path_component(path, 2L), + Version = renv_path_component(path, 3L) + ) + +} + +renv_cache_synchronize <- function(record, linkable = FALSE) { + + # construct path to package in library + library <- renv_libpaths_active() + path <- file.path(library, record$Package) + if (!file.exists(path)) + return(FALSE) + + # bail if the package source is unknown + # (packages with an unknown source are not cacheable) + desc <- renv_description_read(path) + source <- renv_snapshot_description_source(desc) + if (identical(source, list(Source = "unknown"))) + return(FALSE) + + # bail if record not cacheable + if (!renv_record_cacheable(record)) + return(FALSE) + + # if we don't have a hash, compute it now + record$Hash <- record$Hash %||% renv_hash_description(path) + + # construct cache entry + caches <- renv_cache_find(record) + + # try to synchronize + copied <- FALSE + for (cache in caches) { + copied <- renv_cache_synchronize_impl(cache, record, linkable, path) + if (copied) + return(TRUE) + } + + return(FALSE) + +} + +renv_cache_synchronize_impl <- function(cache, record, linkable, path) { + + # double-check we have a valid cache path + if (!nzchar(cache)) + return(FALSE) + + # if our cache -> path link is already up to date, then nothing to do + if (renv_file_same(cache, path)) + return(TRUE) + + # try to create the cache directory target + # (catch errors due to permissions, etc) + parent <- dirname(cache) + status <- catchall(ensure_directory(parent)) + if (inherits(status, "error")) + return(FALSE) + + # double-check that the cache is writable + writable <- local({ + file <- renv_scope_tempfile("renv-tempfile-", tmpdir = parent) + status <- catchall(file.create(file)) + file.exists(file) + }) + + if (!writable) + return(FALSE) + + # obtain lock on the cache + lockpath <- file.path(parent, ".cache.lock") + renv_scope_lock(lockpath) + + # if we already have a cache entry, back it up + restore <- renv_file_backup(cache) + defer(restore()) + + # copy package from source location into the cache + if (linkable) { + renv_cache_move(path, cache, overwrite = TRUE) + renv_file_link(cache, path, overwrite = TRUE) + } else { + renv_cache_copy(path, cache, overwrite = TRUE) + } + + if (renv_platform_unix()) { + + # change the cache owner if set + user <- Sys.getenv("RENV_CACHE_USER", unset = NA) + if (!is.na(user)) { + parent <- dirname(dirname(dirname(cache))) + renv_system_exec( + command = "chown", + args = c("-Rf", renv_shell_quote(user), renv_shell_path(parent)), + action = "chowning cached package", + quiet = TRUE, + success = NULL + ) + } + + # change file modes after copy if set + mode <- Sys.getenv("RENV_CACHE_MODE", unset = NA) + if (!is.na(mode)) { + parent <- dirname(dirname(dirname(cache))) + renv_system_exec( + command = "chmod", + args = c("-Rf", renv_shell_quote(mode), renv_shell_path(parent)), + action = "chmoding cached package", + quiet = TRUE, + success = NULL + ) + } + + # finally, allow for an arbitrary callback if set + callback <- getOption("renv.cache.callback") + if (is.function(callback)) + callback(cache) + + } + + TRUE + +} + +renv_cache_list <- function(cache = NULL, packages = NULL) { + caches <- cache %||% renv_paths_cache() + paths <- map(caches, renv_cache_list_impl, packages = packages) + unlist(paths, recursive = TRUE, use.names = FALSE) +} + +renv_cache_list_impl <- function(cache, packages) { + + # paths to packages in the cache have the following format: + # + # /// + # + # so find entries in the cache by listing files in each directory + names <- file.path(cache, packages %||% list.files(cache)) + versions <- list.files(names, full.names = TRUE) + hashes <- list.files(versions, full.names = TRUE) + paths <- list.files(hashes, full.names = TRUE) + + # only keep paths that appear to be valid + valid <- grep(renv_regexps_package_name(), basename(paths)) + paths[valid] + +} + +renv_cache_problems <- function(paths, reason) { + + data_frame( + Package = renv_path_component(paths, 1L), + Version = renv_path_component(paths, 3L), + Path = paths, + Reason = reason + ) + +} + +renv_cache_diagnose_corrupt_metadata <- function(paths, problems, verbose) { + + # check for missing metadata files + metapaths <- file.path(paths, "Meta/package.rds") + ok <- file.exists(metapaths) + bad <- paths[!ok] + + if (length(bad)) { + + # nocov start + if (verbose) { + caution_bullets( + "The following package(s) are missing 'Meta/package.rds':", + renv_cache_format_path(bad), + "These packages should be purged and reinstalled." + ) + } + # nocov end + + data <- renv_cache_problems( + paths = bad, + reason = "'Meta/package.rds' does not exist" + ) + + problems$push(data) + + } + + # check for corrupt / unreadable metadata files + ok <- map_lgl(metapaths, function(path) { + rds <- catch(readRDS(path)) + !inherits(rds, "error") + }) + + bad <- paths[!ok] + + if (length(bad)) { + + # nocov start + if (verbose) { + caution_bullets( + "The following package(s) have corrupt 'Meta/package.rds' files:", + renv_cache_format_path(bad), + "These packages should be purged and reinstalled." + ) + } + # nocov end + + data <- renv_cache_problems( + paths = bad, + reason = "'Meta/package.rds' does not exist" + ) + + problems$push(data) + + } + + paths + +} + +renv_cache_diagnose_missing_descriptions <- function(paths, problems, verbose) { + + descpaths <- file.path(paths, "DESCRIPTION") + exists <- file.exists(descpaths) + bad <- paths[!exists] + if (empty(bad)) + return(paths) + + # nocov start + if (verbose) { + caution_bullets( + "The following packages are missing DESCRIPTION files in the cache:", + renv_cache_format_path(bad), + "These packages should be purged and reinstalled." + ) + } + # nocov end + + data <- renv_cache_problems( + paths = bad, + reason = "'DESCRIPTION' file does not exist" + ) + + problems$push(data) + paths[exists] + +} + +renv_cache_diagnose_bad_hash <- function(paths, problems, verbose) { + + expected <- map_chr(paths, renv_cache_path) + wrong <- paths != expected & !file.exists(expected) + if (!any(wrong)) + return(paths) + + # nocov start + if (verbose) { + + lhs <- renv_cache_path_components(paths[wrong]) + rhs <- renv_cache_path_components(expected[wrong]) + + fmt <- "%s %s [Hash: %s != %s]" + entries <- sprintf(fmt, lhs$Package, lhs$Version, lhs$Hash, rhs$Hash) + + caution_bullets( + "The following packages have incorrect hashes:", + entries, + "Consider using `renv::rehash()` to re-hash these packages." + ) + } + # nocov end + + data <- renv_cache_problems( + paths = paths[wrong], + reason = "unexpected hash" + ) + + problems$push(data) + paths + +} + +renv_cache_diagnose_wrong_built_version <- function(paths, problems, verbose) { + + # form paths to DESCRIPTION files + descpaths <- file.path(paths, "DESCRIPTION") + + # parse the version of R each was built for + versions <- map_chr(descpaths, function(descpath) { + + tryCatch( + renv_description_built_version(descpath), + error = function(e) { + warning(e) + NA + } + ) + + }) + + # check for NAs, report and remove them + isna <- is.na(versions) + if (any(isna)) { + + # nocov start + if (verbose) { + + caution_bullets( + "The following packages have no 'Built' field recorded in their DESCRIPTION file:", + paths[isna], + "renv is unable to validate the version of R this package was built for." + ) + + } + # nocov end + + data <- renv_cache_problems( + paths = paths[isna], + reason = "missing Built field" + ) + + problems$push(data) + + paths <- paths[!isna] + versions <- versions[!isna] + + } + + # check for incompatible versions + wrong <- map_lgl(versions, function(version) { + tryCatch( + renv_version_compare(version, getRversion(), 2L) != 0, + error = function(e) { + warning(e) + TRUE + } + ) + }) + + if (!any(wrong)) + return(paths) + + # nocov start + if (verbose) { + + caution_bullets( + "The following packages in the cache were built for a different version of R:", + renv_cache_format_path(paths[wrong]), + "These packages will need to be purged and reinstalled." + ) + + } + # nocov end + + data <- renv_cache_problems( + paths = paths[wrong], + reason = "built for different version of R" + ) + + problems$push(data) + paths + +} + +renv_cache_diagnose <- function(verbose = NULL) { + + verbose <- verbose %||% renv_verbose() + + problems <- stack() + paths <- renv_cache_list() + paths <- renv_cache_diagnose_corrupt_metadata(paths, problems, verbose) + paths <- renv_cache_diagnose_missing_descriptions(paths, problems, verbose) + paths <- renv_cache_diagnose_bad_hash(paths, problems, verbose) + paths <- renv_cache_diagnose_wrong_built_version(paths, problems, verbose) + + invisible(bind(problems$data())) + +} + +renv_cache_acls_reset <- function(target) { + + enabled <- Sys.getenv("RENV_CACHE_ACLS", unset = "TRUE") + if (enabled) + renv_acls_reset(target) + +} + +# copies a package at location 'source' to cache location 'target' +renv_cache_copy <- function(source, target, overwrite = FALSE) { + ensure_parent_directory(target) + renv_file_copy(source, target, overwrite = overwrite) + renv_cache_acls_reset(target) +} + +# moves a package from location 'source' to cache location 'target', +# and then links back from 'target' to 'source' +renv_cache_move <- function(source, target, overwrite = FALSE) { + + # move package into the cache if requested + if (overwrite || !file.exists(target)) { + ensure_parent_directory(target) + renv_file_move(source, target, overwrite = TRUE) + } + + # try to reset ACLs on the cache directory + renv_cache_acls_reset(target) + + # link from the cache back to the target location + renv_file_link(target, source, overwrite = TRUE) + +} + +# nocov start +renv_cache_format_path <- function(paths) { + + # extract path components + names <- format(renv_path_component(paths, 1L)) + hashes <- format(renv_path_component(paths, 2L)) + versions <- format(renv_path_component(paths, 3L)) + + # format and write + fmt <- "%s %s [Hash: %s]" + sprintf(fmt, names, versions, hashes) + +} +# nocov end + +renv_cache_clean_empty <- function(cache = NULL) { + caches <- cache %||% renv_paths_cache() + map(caches, renv_cleanse_empty) +} + +renv_cache_package_validate <- function(path) { + + if (renv_project_type(path) == "package") + return(TRUE) + + type <- renv_file_type(path, symlinks = FALSE) + if (!nzchar(type)) + return(FALSE) + + name <- if (type == "directory") "directory" else "file" + fmt <- "%s %s exists but does not appear to be an R package" + warningf(fmt, name, shQuote(path)) + + FALSE + +} + +renv_cache_config_enabled <- function(project) { + config$cache.enabled() && settings$use.cache(project = project) +} + +renv_cache_config_symlinks <- function(project) { + + usesymlinks <- + config$cache.symlinks(default = NULL) %||% + renv_cache_config_symlinks_default(project = project) + + usesymlinks && settings$use.cache(project = project) + +} + +renv_cache_config_symlinks_default <- function(project) { + + # on linux, we can always use symlinks + if (renv_platform_unix()) + return(TRUE) + + # on Windows, only try to use symlinks (junction points) if the cache + # and the project library appear to live on the same drive + libpath <- renv_paths_library(project = project) + cachepath <- renv_paths_cache() + + # TODO: with this change, anyone using networks not mapped to a local drive + # would need to opt-in to using symlinks, but that's probably okay? + all( + substring(libpath, 1L, 2L) == substring(cachepath, 1L, 2L), + substring(libpath, 2L, 2L) == ":", + substring(cachepath, 2L, 2L) == ":" + ) + + +} + +renv_cache_linkable <- function(project, library) { + renv_cache_config_enabled(project = project) && + renv_cache_config_symlinks(project = project) && + getOption( + "renv.cache.linkable", + renv_path_same(library, renv_paths_library(project = project)) + ) +} + + +# call.R --------------------------------------------------------------------- + + +# given a call of the form e.g. 'pkg::foo()' or 'foo()', +# check that method 'foo()' is truly being called and +# strip off the 'pkg::' part for easier parsing +renv_call_expect <- function(node, package, methods) { + + if (!is.call(node)) + return(NULL) + + # check for call of the form 'pkg::foo(a, b, c)' + colon <- renv_call_matches(node[[1L]], name = c("::", ":::"), n_args = 2) + + if (colon) { + + # validate the package name + lhs <- node[[1L]][[2L]] + if (as.character(lhs) != package) + return(NULL) + + # extract the inner call + rhs <- node[[1L]][[3L]] + node[[1L]] <- rhs + } + + # check for method match + match <- + is.name(node[[1L]]) && + as.character(node[[1L]]) %in% methods + + if (!match) + return(NULL) + + node + +} + +renv_call_normalize <- function(node, stack) { + + # check for magrittr pipe -- if this part of the expression is + # being piped into, then we need to munge the call + ispipe <- renv_call_matches(node, name = c("%>%", "%T>%", "%<>%")) + + if (!ispipe) + return(node) + + # get lhs and rhs of piped expression + lhs <- node[[2L]] + rhs <- node[[3L]] + + # handle rhs symbols + if (is.symbol(rhs)) + rhs <- call(as.character(rhs)) + + # check for usage of '.' + # if it exists, replace each with lhs + hasdot <- FALSE + dot <- as.symbol(".") + for (i in seq_along(rhs)) { + if (identical(dot, rhs[[i]])) { + hasdot <- TRUE + rhs[[i]] <- lhs + } + } + + if (hasdot) + return(rhs) + + # otherwise, mutate rhs call with lhs passed as first argument + args <- as.list(rhs) + as.call(c(args[[1L]], lhs, args[-1L])) + +} + + +renv_call_matches <- function(call, name = NULL, n_args = NULL) { + if (!is.call(call)) + return(FALSE) + + if (!is.null(name)) { + if (!is.name(call[[1]])) + return(FALSE) + + if (!as.character(call[[1]]) %in% name) + return(FALSE) + } + + if (!is.null(n_args) && length(call) != n_args + 1L) + return(FALSE) + + TRUE +} + + +# caution.R ------------------------------------------------------------------ + + +caution <- function(fmt = "", ..., con = stdout()) { + enabled <- getOption("renv.caution.verbose", default = TRUE) + if (!is.null(fmt) && enabled) + writeLines(sprintf(fmt, ...), con = con) +} + +caution_bullets <- function(preamble = NULL, + values = NULL, + postamble = NULL, + ..., + bullets = TRUE, + emitter = NULL) +{ + if (empty(values)) + return(invisible()) + + renv_dots_check(...) + + lines <- c( + if (length(preamble)) paste(preamble, collapse = "\n"), + if (bullets) + paste("-", values, collapse = "\n") + else + paste(values, collapse = "\n"), + if (length(postamble)) paste(postamble, collapse = "\n"), + "" + ) + + text <- paste(lines, collapse = "\n") + renv_caution_impl(text, emitter) +} + +renv_caution_impl <- function(text, emitter = NULL) { + + # NOTE: Used by vetiver, so perhaps is part of the API. + # We should think of a cleaner way of exposing this. + # https://github.com/rstudio/renv/issues/1413 + emitter <- emitter %||% { + getOption("renv.pretty.print.emitter", default = caution) + } + + emitter(text) + invisible(NULL) + +} + + +# cellar.R ------------------------------------------------------------------- + + +renv_cellar_roots <- function(project = NULL) { + c( + renv_paths_renv("cellar", project = project), + renv_paths_renv("local", project = project), + renv_paths_cellar(), + renv_paths_local() + ) +} + +renv_cellar_database <- function(project = NULL) { + + # find cellar root directories + project <- renv_project_resolve(project) + roots <- renv_cellar_roots(project) + + # list files both at top-level + one nested level + paths <- list.files(roots, full.names = TRUE) + paths <- c(paths, list.files(paths, full.names = TRUE)) + + # grab files that look like packages + extpat <- "(?:\\.tar\\.gz|\\.tgz|\\.zip)$" + paths <- grep(extpat, paths, value = TRUE) + + # parse into data.frame + base <- basename(paths) + parts <- strsplit(base, "_", fixed = TRUE) + package <- map_chr(parts, `[[`, 1L) + rest <- map_chr(parts, `[[`, 2L) + version <- sub(extpat, "", rest) + + data_frame( + Package = package, + Version = version, + Path = paths + ) + +} + +renv_cellar_latest <- function(package, project) { + + db <- renv_cellar_database(project = project) + db <- rows(db, db$Package == package) + db <- rows(db, order(package_version(db$Version), decreasing = TRUE)) + if (nrow(db) == 0L) + return(record) + + entry <- db[1, ] + list( + Package = entry$Package, + Version = entry$Version, + Source = "Cellar" + ) + +} + + +# check.R -------------------------------------------------------------------- + + +renv_check_unknown_source <- function(records, project = NULL) { + + # nothing to do if we have no records + if (empty(records)) + return(TRUE) + + # for testing, we ignore renv + if (renv_tests_running()) + records$renv <- NULL + + # keep only records which have unknown source + unknown <- filter(records, function(record) { + + source <- renv_record_source(record) + if (source != "unknown") + return(FALSE) + + localpath <- tryCatch( + renv_retrieve_cellar_find(record, project), + error = function(e) "" + ) + + if (file.exists(localpath)) + return(FALSE) + + TRUE + + }) + + # if all records have a known source, return TRUE + if (empty(unknown)) + return(TRUE) + + # provide warning + if (!renv_tests_running()) + renv_warnings_unknown_sources(unknown) + + # return FALSE to indicate failed validation + FALSE + +} + + + + +# checkout.R ----------------------------------------------------------------- + + +#' Checkout a repository +#' +#' `renv::checkout()` can be used to retrieve the latest-availabe packages from +#' a (set of) package repositories. +#' +#' `renv::checkout()` is most useful with services like the Posit's +#' [Package Manager](https://packagemanager.rstudio.com/), as it +#' can be used to switch between different repository snapshots within an +#' renv project. In this way, you can upgrade (or downgrade) all of the +#' packages used in a particular renv project to the package versions +#' provided by a particular snapshot. +#' +#' If your library contains packages installed from other remote sources (e.g. +#' GitHub), but a version of a package of the same name is provided by the +#' repositories being checked out, then please be aware that the package will be +#' replaced with the version provided by the requested repositories. This could +#' be a concern if your project uses \R packages from GitHub whose name matches +#' that of an existing CRAN package, but is otherwise unrelated to the package +#' on CRAN. +#' +#' @inheritParams renv-params +#' +#' @param repos The \R package repositories to use. +#' +#' @param packages The packages to be installed. When `NULL` (the default), +#' all packages currently used in the project will be installed, as +#' determined by [renv::dependencies()]. The recursive dependencies of these +#' packages will be included as well. +#' +#' @param date The snapshot date to use. When set, the associated snapshot as +#' available from the Posit's public +#' [Package Manager](https://packagemanager.rstudio.com/) instance will be +#' used. Ignored if `repos` is non-`NULL`. +#' +#' @param actions The action(s) to perform with the requested repositories. +#' This can either be "snapshot", in which `renv` will generate a lockfile +#' based on the latest versions of the packages available from `repos`, or +#' "restore" if you'd like to install those packages. You can use +#' `c("snapshot", "restore")` if you'd like to generate a lockfile and +#' install those packages in the same step. +#' +#' @examples +#' \dontrun{ +#' +#' # check out packages from PPM using the date '2023-01-02' +#' renv::checkout(date = "2023-01-02") +#' +#' # alternatively, supply the full repository path +#' renv::checkout(repos = "https://packagemanager.rstudio.com/cran/2023-01-02") +#' +#' # only check out some subset of packages (and their recursive dependencies) +#' renv::checkout(packages = "dplyr", date = "2023-01-02") +#' +#' } +#' @export +checkout <- function(repos = NULL, + ..., + packages = NULL, + date = NULL, + clean = FALSE, + actions = "restore", + project = NULL) +{ + renv_consent_check() + renv_scope_error_handler() + renv_dots_check(...) + + project <- renv_project_resolve(project) + renv_project_lock(project = project) + + # set new repositories + repos <- repos %||% renv_checkout_repos(date) + options(repos = repos) + + # TODO: Activate Bioconductor if it appears to be used by this project + + # select packages to install + packages <- packages %||% renv_checkout_packages(project = project) + + # get the associated remotes for these packages + remotes <- renv_checkout_remotes(packages, project) + + # parse these into package records + records <- map(remotes, renv_remotes_resolve) + + # create a lockfile matching this request + lockfile <- renv_lockfile_init(project) + lockfile$Packages <- records + + # perform requested actions + for (action in actions) { + case( + action == "snapshot" ~ renv_lockfile_write(lockfile, file = renv_lockfile_path(project)), + action == "restore" ~ restore(lockfile = lockfile, clean = clean), + ~ stopf("unrecognized action '%s'") + ) + } + + invisible(lockfile) + +} + +renv_checkout_packages <- function(project) { + renv_dependencies_impl( + project, + field = "Package", + dev = TRUE + ) +} + +renv_checkout_remotes <- function(packages, project) { + + # get available packages + dbs <- available_packages(type = "source") + if (is.null(dbs)) + stop("no package repositories are available") + + # flatten so we only see the latest version of a package + db <- renv_available_packages_flatten(dbs) + + # keep only packages which appear to be available in the repositories + packages <- intersect(packages, db$Package) + + # remove ignored packages -- note we intentionally do this before + # computing recursive dependencies as we don't want to allow users + # to ignore a recursive dependency of a required package + ignored <- c("renv", renv_project_ignored_packages(project)) + packages <- setdiff(packages, ignored) + + # compute recursive dependencies for these packages + renv_checkout_recdeps(packages, db) + +} + +renv_checkout_recdeps <- function(packages, db) { + + # initialize environment (will map package names to discovered remotes) + envir <- new.env(parent = emptyenv()) + + # set R to NA since it's a common non-package 'dependency' for packages + envir$R <- NA + + # iterate through dependencies + for (package in packages) + renv_checkout_recdeps_impl(package, db, envir) + + # get list of discovered dependencies + recdeps <- as.list.environment(envir, all.names = TRUE) + + # drop any NA values + recdeps <- filter(recdeps, Negate(is.na)) + + # return sorted vector + recdeps[csort(names(recdeps))] + +} + +renv_checkout_recdeps_impl <- function(package, db, envir) { + + # check if we've already visited this package + if (!is.null(envir[[package]])) + return() + + # get entry from database + entry <- rows(db, db$Package == package) + if (nrow(entry) == 0L) { + envir[[package]] <- NA_character_ + return() + } + + # set discovered remote + envir[[package]] <- with(entry, paste(Package, Version, sep = "@")) + + # iterate through hard dependencies + fields <- c("Depends", "Imports", "LinkingTo") + for (field in fields) { + value <- entry[[field]] + if (!is.null(value) && !is.na(value)) { + value <- renv_description_parse_field(entry[[field]]) + for (package in value$Package) + if (is.null(envir[[package]])) + renv_checkout_recdeps_impl(package, db, envir) + } + } + + # for soft dependencies, only include those if they're currently installed + # TODO: or check if it's in the lockfile? + value <- entry[["Suggests"]] + if (!is.null(value) && !is.na(value)) { + value <- renv_description_parse_field(value) + for (package in value$Package) + if (is.null(envir[[package]])) + if (renv_package_installed(package)) + renv_checkout_recdeps_impl(package, db, envir) + } + +} + +renv_checkout_repos <- function(date) { + + # if no date was provided, just use default repositories + if (is.null(date)) + return(getOption("repos")) + + # build path to repository snapshot location + root <- dirname(config$ppm.url()) + url <- file.path(root, date) + if (renv_download_available(file.path(url, "src/contrib/PACKAGES"))) + return(c(PPM = url)) + + # requested date not available; try to search a bit + candidate <- date + for (i in 1:7) { + candidate <- format(as.Date(candidate) - 1L) + url <- file.path(root, candidate) + if (renv_download_available(file.path(url, "src/contrib/PACKAGES"))) { + fmt <- "- Snapshot date '%s' not available; using '%s' instead" + printf(fmt, date, candidate) + return(c(PPM = url)) + } + } + + stopf("repository snapshot '%s' not available", date) + +} + + +# clean.R -------------------------------------------------------------------- + + +#' Clean a project +#' +#' Clean up a project and its associated \R libraries. +#' +#' # Actions +#' +#' The following clean actions are available: +#' +#' \describe{ +#' +#' \item{`package.locks`}{ +#' +#' During package installation, \R will create package locks in the +#' library path, typically named `00LOCK-`. On occasion, if package +#' installation fails or \R is terminated while installing a package, these +#' locks can be left behind and will inhibit future attempts to reinstall +#' that package. Use this action to remove such left-over package locks. +#' +#' } +#' +#' \item{`library.tempdirs`}{ +#' +#' During package installation, \R may create temporary directories with +#' names of the form `file\w{12}`, and on occasion those files can be +#' left behind even after they are no longer in use. Use this action to +#' remove such left-over directories. +#' } +#' +#' \item{`system.library`}{ +#' +#' In general, it is recommended that only packages distributed with \R +#' are installed into the default library (the library path referred to +#' by `.Library`). Use this action to remove any user-installed packages +#' that have been installed to the system library. +#' +#' Because this action is destructive, it is by default never run -- it +#' must be explicitly requested by the user. +#' +#' } +#' +#' \item{`unused.packages`}{ +#' +#' Remove packages that are installed in the project library, but no longer +#' appear to be used in the project sources. +#' +#' Because this action is destructive, it is by default only run in +#' interactive sessions when prompting is enabled. +#' +#' } +#' +#' } +#' +#' +#' @inherit renv-params +#' +#' @param actions The set of clean actions to take. See the documentation in +#' **Actions** for a list of available actions, and the default actions +#' taken when no actions are supplied. +#' +#' @export +#' +#' @examples +#' \dontrun{ +#' +#' # clean the current project +#' renv::clean() +#' +#' } +clean <- function(project = NULL, + ..., + actions = NULL, + prompt = interactive()) +{ + renv_scope_error_handler() + renv_dots_check(...) + + project <- renv_project_resolve(project) + renv_project_lock(project = project) + renv_scope_verbose_if(prompt) + + renv_activate_prompt("clean", NULL, prompt, project) + + actions <- actions %||% renv_clean_actions(prompt) + + all <- list( + package.locks = renv_clean_package_locks, + library.tempdirs = renv_clean_library_tempdirs, + system.library = renv_clean_system_library, + unused.packages = renv_clean_unused_packages + ) + + methods <- all[actions] + for (method in methods) + tryCatch(method(project, prompt), error = warnify) + + writef("- The project has been cleaned.") + invisible(project) +} + +renv_clean_actions <- function(prompt) { + + default <- c( + "package.locks", + "library.tempdirs" + ) + + unsafe <- c( + # "system.library", + "unused.packages" + ) + + c(default, if (prompt) unsafe) + +} + +renv_clean_library_tempdirs <- function(project, prompt) { + + ntd <- function() { + writef("- No temporary directories were found in the project library.") + FALSE + } + + library <- renv_paths_library(project = project) + children <- list.files(library, full.names = TRUE) + + bad <- grep("/file\\w{12}$", children, value = TRUE) + if (empty(bad)) + return(ntd()) + + # nocov start + if (prompt || renv_verbose()) { + + caution_bullets("The following directories will be removed:", bad) + + if (prompt && !proceed()) + cancel() + + } + # nocov end + + unlink(bad, recursive = TRUE) + TRUE + +} + + +# remove user packages in system library +renv_clean_system_library <- function(project, prompt) { + + ntd <- function() { + writef("- No non-system packages were discovered in the system library.") + FALSE + } + + # explicitly query for packages + syslib <- renv_path_normalize(renv_libpaths_system()) + db <- installed_packages(lib.loc = syslib, priority = "NA") + packages <- setdiff(db$Package, "translations") + + # also look for leftover package folders + # (primarily for Windows, where .dlls from old packages can be left behind) + + # nocov start + if (renv_platform_windows()) { + folders <- list.files(syslib, full.names = TRUE) + descpaths <- file.path(folders, "DESCRIPTION") + missing <- !file.exists(descpaths) + packages <- union(packages, basename(folders)[missing]) + } + # nocov end + + # check for any packages needing removal + if (empty(packages)) + return(ntd()) + + # nocov start + if (prompt || renv_verbose()) { + + caution_bullets( + "The following non-system packages are installed in the system library:", + packages, + c( + "Normally, only packages distributed with R should be installed in the system library.", + "These packages will be removed.", + "If necessary, consider reinstalling these packages in your site library." + ) + ) + + if (prompt && !proceed()) + cancel() + + } + # nocov end + + remove(packages, library = syslib) + TRUE + +} + +renv_clean_unused_packages <- function(project, prompt) { + + ntd <- function() { + writef("- No unused packages were found in the project library.") + FALSE + } + + # find packages installed in the project library + library <- renv_paths_library(project = project) + installed <- list.files(library) + if (empty(installed)) + return(ntd()) + + # find packages used in the project and their recursive dependencies + packages <- renv_snapshot_dependencies(project, dev = TRUE) + paths <- renv_package_dependencies(packages, project = project) + packages <- names(paths) + + # figure out which packages aren't needed + removable <- renv_vector_diff(installed, packages) + if (empty(removable)) + return(ntd()) + + # nocov start + if (prompt || renv_verbose()) { + + caution_bullets( + c( + "The following packages are installed in the project library,", + "but appear to be no longer used in your project." + ), + removable, + "These packages will be removed." + ) + + if (prompt && !proceed()) + cancel() + + } + # nocov end + + remove(removable, library = library) + return(TRUE) + +} + +renv_clean_package_locks <- function(project, prompt) { + + ntd <- function() { + writef("- No stale package locks were found.") + FALSE + } + + # find 00LOCK directories in library + library <- renv_paths_library(project = project) + lock <- list.files(path = library, pattern = "^00LOCK", full.names = TRUE) + if (empty(lock)) + return(ntd()) + + # check to see which are old + now <- Sys.time() + mtime <- file.mtime(lock) + mtime[is.na(mtime)] <- now + diff <- difftime(now, mtime, units = "secs") + old <- lock[diff > 120] + if (empty(old)) + return(ntd()) + + # nocov start + if (prompt || renv_verbose()) { + + caution_bullets( + "The following stale package locks were discovered in your library:", + basename(old), + "These locks will be removed." + ) + + if (prompt && !proceed()) + cancel() + + } + # nocov end + + unlink(old, recursive = TRUE) + TRUE +} + +# nocov start +renv_clean_cache <- function(project, prompt) { + + ntd <- function() { + writef("- No unused packages were found in the renv cache.") + FALSE + } + + # find projects monitored by renv + projects <- renv_paths_root("projects") + projlist <- character() + if (file.exists(projects)) + projlist <- readLines(projects, warn = FALSE, encoding = "UTF-8") + + # inform user if any projects are missing + missing <- !file.exists(projlist) + if (any(missing)) { + + caution_bullets( + "The following projects are monitored by renv, but no longer exist:", + projlist[missing], + "These projects will be removed from renv's project list." + ) + + if (prompt && !proceed()) + cancel() + + writeLines(projlist[!missing], con = projects, useBytes = TRUE) + + } + + action <- function(project) { + library <- renv_paths_library(project = project) + packages <- list.files(library, full.names = TRUE) + descs <- file.path(packages, "DESCRIPTION") + existing <- file.exists(descs) + map_chr(descs[existing], renv_cache_path, USE.NAMES = FALSE) + } + + # for each project, find packages used in their renv private library, + # and look for entries in the cache + projlist <- projlist[!missing] + callback <- renv_progress_callback(action, length(projlist)) + used <- uapply(projlist, callback) + + # check what packages are actually available in the cache + available <- renv_cache_list() + + diff <- renv_vector_diff(available, used) + if (empty(diff)) + return(ntd()) + + if (prompt || renv_verbose()) { + + caution_bullets( + "The following packages are installed in the cache but no longer used:", + renv_cache_format_path(diff), + "These packages will be removed." + ) + + if (prompt && !proceed()) + cancel() + + } + + # remove the directories + unlink(diff, recursive = TRUE) + renv_cache_clean_empty() + + writef("- %i package(s) have been removed.", length(diff)) + TRUE + +} +# nocov end + + +# cleanse.R ------------------------------------------------------------------ + + +# tools for cleaning up renv's cached data +cleanse <- function() { + + enabled <- Sys.getenv("RENV_CLEANSE_ENABLED", unset = "TRUE") + if (!truthy(enabled)) + return(invisible(FALSE)) + + # remove unused sandbox directories + renv_cleanse_sandbox(path = renv_paths_sandbox()) + + # remove empty directories in the root directory + # we can't do this on Windows, as some empty directories + # might also be broken junctions, and we want to keep + # those around so we can inform the user that they need + # to repair that + if (!renv_platform_windows()) + renv_cleanse_empty(path = renv_paths_root()) + + invisible(TRUE) + +} + +renv_cleanse_sandbox <- function(path) { + + # get sandbox root path + root <- dirname(path) + if (!file.exists(root)) + return(FALSE) + + # list directories within + dirs <- list.files(root, full.names = TRUE) + + # look for apparently-unused sandbox directories + info <- suppressWarnings(file.info(dirs, extra_cols = FALSE)) + age <- difftime(Sys.time(), info$mtime, units = "days") + old <- age >= 7 + + # remove the old sandbox directories + unlink(dirs[old], recursive = TRUE, force = TRUE) + +} + +renv_cleanse_empty <- function(path) { + + # no-op for Solaris + if (renv_platform_solaris()) + return(FALSE) + + if (!file.exists(path)) + return(FALSE) + + renv_scope_wd(path) + + # execute system command for removing empty directories + action <- "removing empty directories" + if (renv_platform_windows()) { + args <- c(".", ".", "/S", "/MOVE") + renv_system_exec("robocopy", args, action, 0:8) + } else { + args <- c(".", "-type", "d", "-empty", "-delete") + renv_system_exec("find", args, action) + } + + TRUE + +} + + +# cli.R ---------------------------------------------------------------------- + + +renv_cli_install <- function(target = NULL) { + + # get path to bundled tool + exe <- if (renv_platform_windows()) "bin/renv.bat" else "bin/renv" + path <- system.file(exe, package = "renv") + + # copy into directory on PATH + target <- target %||% path.expand("~/bin/renv") + ensure_parent_directory(target) + file.copy(path, target) + + writef("- renv binary copied to %s.", renv_path_pretty(target)) + invisible(target) + +} + +renv_cli_exec <- function(clargs = commandArgs(trailingOnly = TRUE)) { + invisible(renv_cli_exec_impl(clargs)) +} + +renv_cli_exec_impl <- function(clargs) { + + # check for tool called without arguments, or called with '--help' + usage <- + length(clargs) == 0 || + clargs[1L] %in% c("help", "--help") + + if (usage) + return(renv_cli_usage()) + + # extract method + method <- clargs[1L] + + # check request for help on requested method + help <- + clargs[2L] %in% c("help", "--help") + + if (help) + return(renv_cli_help(method)) + + # check for known function in renv + exports <- getNamespaceExports("renv") + if (!method %in% exports) + return(renv_cli_unknown(method, exports)) + + # begin building call + args <- list(call("::", as.name("renv"), as.name(method))) + + for (clarg in clargs[-1L]) { + + # convert '--no-' into a FALSE parameter + if (grepl("^--no-", clarg)) { + key <- substring(clarg, 6L) + args[[key]] <- FALSE + } + + # convert '--param=value' flags + else if (grepl("^--[^=]+=", clarg)) { + index <- regexpr("=", clarg, fixed = TRUE) + key <- substring(clarg, 3L, index - 1L) + val <- substring(clarg, index + 1L) + args[[key]] <- renv_cli_parse(val) + } + + # convert '--flag' into a TRUE parameter + else if (grepl("^--", clarg)) { + key <- substring(clarg, 3L) + args[[key]] <- TRUE + } + + # convert 'param=value' flags + else if (grepl("=", clarg, fixed = TRUE)) { + index <- regexpr("=", clarg, fixed = TRUE) + key <- substring(clarg, 1L, index - 1L) + val <- substring(clarg, index + 1L) + args[[key]] <- renv_cli_parse(val) + } + + # take other parameters as-is + else { + args[[length(args) + 1L]] <- renv_cli_parse(clarg) + } + + } + + # invoke method with parsed arguments + expr <- as.call(args) + eval(expr = expr, envir = globalenv()) + +} + +renv_cli_usage <- function() { + + usage <- " +Usage: renv [method] [args...] + +[method] should be the name of a function exported from renv. +[args...] should be arguments accepted by that function. + +Use renv [method] --help for more information about the associated function. + +Examples: + + # basic commands + renv init # initialize a project + renv snapshot # snapshot project library + renv restore # restore project library + renv status # check project status + + # install a package + renv install dplyr + + # run a script in an renv project + renv run path/to/script.R +" + + writeLines(usage, con = stderr()) + +} + +renv_cli_help <- function(method) { + print(help(method, package = "renv")) +} + +renv_cli_unknown <- function(method, exports) { + + # report unknown command + caution("renv: '%s' is not a known command.", method) + + # check for similar commands + distance <- c(adist(method, exports)) + names(distance) <- exports + n <- min(distance) + if (n > 2) + return(1L) + + candidates <- names(distance)[distance == n] + fmt <- "did you mean %s?" + caution(fmt, paste(shQuote(candidates), collapse = " or ")) + return(1L) + +} + +renv_cli_parse <- function(text) { + + # handle logical-like values up-front + if (text %in% c("true", "True", "TRUE")) + return(TRUE) + else if (text %in% c("false", "False", "FALSE")) + return(FALSE) + + # parse the expression + value <- parse(text = text)[[1L]] + if (is.language(value)) text else value + +} + + +# conda.R -------------------------------------------------------------------- + + +# given the path to a Python installation managed by conda, attempt to +# find the conda installation + executable used to create it +renv_conda_find <- function(python) { + + tryCatch( + renv_conda_find_impl(python), + error = function(e) { + warning(e) + "" + } + ) + +} + +renv_conda_find_impl <- function(python) { + + # read the conda environment's history to try to find conda + base <- dirname(python) + if (!renv_platform_windows()) + base <- dirname(base) + + history <- file.path(base, "conda-meta/history") + if (!file.exists(history)) + return("") + + contents <- readLines(history, n = 2L, warn = FALSE) + if (length(contents) < 2) + return("") + + line <- substring(contents[2L], 8L) + index <- regexpr(" ", line, fixed = TRUE) + if (index == -1L) + return("") + + conda <- substring(line, 1L, index - 1L) + if (renv_platform_windows()) + conda <- file.path(dirname(conda), "conda.exe") + + # prefer condabin if it exists + condabin <- file.path(dirname(conda), "../condabin", basename(conda)) + if (file.exists(condabin)) + conda <- condabin + + # bail if conda wasn't found + if (!file.exists(conda)) + return("") + + renv_path_canonicalize(conda) + +} + + +# condition.R ---------------------------------------------------------------- + + +renv_condition_signal <- function(class = NULL, data = NULL) { + condition <- list(message = character(), call = NULL, data = data) + class(condition) <- c(class, "renv.condition", "condition") + signalCondition(condition) +} + + +# config-defaults.R ---------------------------------------------------------- + + +# Auto-generated by renv_zzz_bootstrap_config() + +#' @rdname config +#' @export +#' @format NULL +config <- list( + + activate.prompt = function(..., default = TRUE) { + renv_config_get( + name = "activate.prompt", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + autoloader.enabled = function(..., default = TRUE) { + renv_config_get( + name = "autoloader.enabled", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + auto.snapshot = function(..., default = FALSE) { + renv_config_get( + name = "auto.snapshot", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + bitbucket.host = function(..., default = "api.bitbucket.org/2.0") { + renv_config_get( + name = "bitbucket.host", + type = "character[1]", + default = default, + args = list(...) + ) + }, + + copy.method = function(..., default = "auto") { + renv_config_get( + name = "copy.method", + type = "*", + default = default, + args = list(...) + ) + }, + + connect.timeout = function(..., default = 20L) { + renv_config_get( + name = "connect.timeout", + type = "integer[1]", + default = default, + args = list(...) + ) + }, + + connect.retry = function(..., default = 3L) { + renv_config_get( + name = "connect.retry", + type = "integer[1]", + default = default, + args = list(...) + ) + }, + + cache.enabled = function(..., default = TRUE) { + renv_config_get( + name = "cache.enabled", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + cache.symlinks = function(..., default = .Platform$OS.type == "unix") { + renv_config_get( + name = "cache.symlinks", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + dependency.errors = function(..., default = "reported") { + renv_config_get( + name = "dependency.errors", + type = "character[1]", + default = default, + args = list(...) + ) + }, + + dependencies.limit = function(..., default = 1000L) { + renv_config_get( + name = "dependencies.limit", + type = "integer[1]", + default = default, + args = list(...) + ) + }, + + exported.functions = function(..., default = "*") { + renv_config_get( + name = "exported.functions", + type = "character[*]", + default = default, + args = list(...) + ) + }, + + external.libraries = function(..., default = NULL) { + renv_config_get( + name = "external.libraries", + type = "character[*]", + default = default, + args = list(...) + ) + }, + + filebacked.cache = function(..., default = TRUE) { + renv_config_get( + name = "filebacked.cache", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + github.host = function(..., default = "api.github.com") { + renv_config_get( + name = "github.host", + type = "character[1]", + default = default, + args = list(...) + ) + }, + + gitlab.host = function(..., default = "gitlab.com") { + renv_config_get( + name = "gitlab.host", + type = "character[1]", + default = default, + args = list(...) + ) + }, + + hydrate.libpaths = function(..., default = NULL) { + renv_config_get( + name = "hydrate.libpaths", + type = "character[*]", + default = default, + args = list(...) + ) + }, + + install.build = function(..., default = FALSE) { + renv_config_get( + name = "install.build", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + install.remotes = function(..., default = TRUE) { + renv_config_get( + name = "install.remotes", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + install.shortcuts = function(..., default = TRUE) { + renv_config_get( + name = "install.shortcuts", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + install.staged = function(..., default = TRUE) { + renv_config_get( + name = "install.staged", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + install.transactional = function(..., default = TRUE) { + renv_config_get( + name = "install.transactional", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + install.verbose = function(..., default = FALSE) { + renv_config_get( + name = "install.verbose", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + locking.enabled = function(..., default = FALSE) { + renv_config_get( + name = "locking.enabled", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + mran.enabled = function(..., default = FALSE) { + renv_config_get( + name = "mran.enabled", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + pak.enabled = function(..., default = FALSE) { + renv_config_get( + name = "pak.enabled", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + ppm.enabled = function(..., default = TRUE) { + renv_config_get( + name = "ppm.enabled", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + ppm.default = function(..., default = TRUE) { + renv_config_get( + name = "ppm.default", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + ppm.url = function(..., default = "https://packagemanager.posit.co/cran/latest") { + renv_config_get( + name = "ppm.url", + type = "character[1]", + default = default, + args = list(...) + ) + }, + + repos.override = function(..., default = NULL) { + renv_config_get( + name = "repos.override", + type = "character[*]", + default = default, + args = list(...) + ) + }, + + rspm.enabled = function(..., default = TRUE) { + renv_config_get( + name = "rspm.enabled", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + sandbox.enabled = function(..., default = TRUE) { + renv_config_get( + name = "sandbox.enabled", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + shims.enabled = function(..., default = TRUE) { + renv_config_get( + name = "shims.enabled", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + snapshot.inference = function(..., default = TRUE) { + renv_config_get( + name = "snapshot.inference", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + snapshot.validate = function(..., default = TRUE) { + renv_config_get( + name = "snapshot.validate", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + startup.quiet = function(..., default = NULL) { + renv_config_get( + name = "startup.quiet", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + synchronized.check = function(..., default = TRUE) { + renv_config_get( + name = "synchronized.check", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + updates.check = function(..., default = FALSE) { + renv_config_get( + name = "updates.check", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + updates.parallel = function(..., default = 2L) { + renv_config_get( + name = "updates.parallel", + type = "*", + default = default, + args = list(...) + ) + }, + + user.environ = function(..., default = TRUE) { + renv_config_get( + name = "user.environ", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + user.library = function(..., default = FALSE) { + renv_config_get( + name = "user.library", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + + user.profile = function(..., default = FALSE) { + renv_config_get( + name = "user.profile", + type = "logical[1]", + default = default, + args = list(...) + ) + } + +) + + +# config.R ------------------------------------------------------------------- + + +#' User-level settings +#' +#' Configure different behaviors of renv. +#' +#' For a given configuration option: +#' +#' 1. If an \R option of the form `renv.config.` is available, +#' then that option's value will be used; +#' +#' 2. If an environment variable of the form `RENV_CONFIG_` is available, +#' then that option's value will be used; +#' +#' 3. Otherwise, the default for that particular configuration value is used. +#' +#' Any periods (`.`)s in the option name are transformed into underscores (`_`) +#' in the environment variable name, and vice versa. For example, the +#' configuration option `auto.snapshot` could be configured as: +#' +#' - `options(renv.config.auto.snapshot = <...>)` +#' - `Sys.setenv(RENV_CONFIG_AUTO_SNAPSHOT = <...>)` +#' +#' Note that if both the \R option and the environment variable are defined, the +#' \R option will be used instead. Environment variables can be more useful when +#' you want a particular configuration to be automatically inherited by child +#' processes; if that behavior is not desired, then the R option may be +#' preferred. +#' +#' If you want to set and persist these options across multiple projects, it is +#' recommended that you set them in a a startup `.Renviron` file; e.g. in your +#' own `~/.Renviron`, or in the R installation's `etc/Rprofile.site` file. See +#' [Startup] for more details. +#' +#' Configuration options can also be set within the project `.Rprofile`, but +#' be aware the options should be set before `source("renv/activate.R")` is +#' called. +#' +#' @eval renv_roxygen_config_section() +#' +#' @section Copy methods: +#' +#' If you find that renv is unable to copy some directories in your +#' environment, you may want to try setting the `copy.method` option. By +#' default, renv will try to choose a system tool that is likely to succeed in +#' copying files on your system -- `robocopy` on Windows, and `cp` on Unix. +#' renv will also instruct these tools to preserve timestamps and attributes +#' when copying files. However, you can select a different method as +#' appropriate. +#' +#' The following methods are supported: +#' +#' \tabular{ll}{ +#' `auto` \tab Use `robocopy` on Windows, and `cp` on Unix-alikes. \cr +#' `R` \tab Use \R's built-in `file.copy()` function. \cr +#' `cp` \tab Use `cp` to copy files. \cr +#' `robocopy` \tab Use `robocopy` to copy files. (Only available on Windows.) \cr +#' `rsync` \tab Use `rsync` to copy files. \cr +#' } +#' +#' You can also provide a custom copy method if required; e.g. +#' +#' ``` +#' options(renv.config.copy.method = function(src, dst) { +#' # copy a file from 'src' to 'dst' +#' }) +#' ``` +#' +#' Note that renv will always first attempt to copy a directory first to a +#' temporary path within the target folder, and then rename that temporary path +#' to the final target destination. This helps avoid issues where a failed +#' attempt to copy a directory could leave a half-copied directory behind +#' in the final location. +#' +#' @section Project-local settings: +#' +#' For settings that should persist alongside a particular project, the +#' various settings available in [settings] can be used. +#' +#' @examples +#' +#' # disable automatic snapshots +#' options(renv.config.auto.snapshot = FALSE) +#' +#' # disable with environment variable +#' Sys.setenv(RENV_CONFIG_AUTO_SNAPSHOT = FALSE) +#' +#' @rdname config +#' @name config +NULL + +renv_config_get <- function(name, + scope = "config", + type = "*", + default = NULL, + args = NULL) +{ + # check for R option of associated name + optname <- tolower(name) + optkey <- paste("renv", scope, optname, sep = ".") + optval <- getOption(optkey) + if (!is.null(optval)) + return(renv_config_validate(name, optval, type, default, args)) + + # check for environment variable + envname <- gsub(".", "_", toupper(name), fixed = TRUE) + envkey <- paste("RENV", toupper(scope), envname, sep = "_") + envval <- Sys.getenv(envkey, unset = NA) + if (!is.na(envval) && nzchar(envval)) { + decoded <- renv_config_decode_envvar(envkey, envval) + return(renv_config_validate(name, decoded, type, default, args)) + } + + # return default if nothing found + default + +} + +renv_config_decode_envvar <- function(envname, envval) { + + map <- env( + "NULL" = NULL, + "NA" = NA, + "NaN" = NaN, + "true" = TRUE, + "True" = TRUE, + "TRUE" = TRUE, + "false" = FALSE, + "False" = FALSE, + "FALSE" = FALSE + ) + + if (exists(envval, envir = map, inherits = FALSE)) + return(get(envval, envir = map, inherits = FALSE)) + + libvars <- c("RENV_CONFIG_EXTERNAL_LIBRARIES", "RENV_CONFIG_HYDRATE_LIBPATHS") + pattern <- if (envname %in% libvars) + "\\s*[:;,]\\s*" + else + "\\s*,\\s*" + + strsplit(envval, pattern, perl = TRUE)[[1L]] + +} + +renv_config_validate <- function(name, value, type, default, args) { + + # no validation required for type = '*' + if (identical(type, "*")) + return(value) + + # if 'value' is a function, invoke it with args + if (is.function(value)) { + value <- catch(do.call(value, args)) + if (inherits(value, "error")) { + warning(value, call. = FALSE) + return(default) + } + } + + # parse the type string + pattern <- paste0( + "^", # start of specifier + "([^[(]+)", # type name + "[[(]", # opening bracket + "([^])]+)", # length specifier + "[])]", # closing bracket + "$" # end of specifier + ) + + m <- regexec(pattern, type) + matches <- regmatches(type, m) + fields <- matches[[1L]] + + # extract declared mode, size + mode <- fields[[2L]] + size <- fields[[3L]] + + # validate the requested size for this option + if (!renv_config_validate_size(value, size)) { + fmt <- "value for option '%s' does not satisfy constraint '%s'" + warningf(fmt, name, type) + } + + # convert NULL values to requested type + if (is.null(value)) { + value <- convert(value, mode) + return(value) + } + + # otherwise, validate that this is a valid option + if (identical(storage.mode(value), mode)) + return(value) + + # try converting + converted <- catchall(convert(value, mode)) + if (any(is.na(converted)) || inherits(converted, "condition")) { + fmt <- "'%s' does not satisfy constraint '%s' for config '%s'; using default '%s' instead" + warningf(fmt, stringify(value), type, name, stringify(default)) + return(default) + } + + # ok, validated + converted option + converted + +} + +renv_config_validate_size <- function(value, size) { + + case( + size == "*" ~ TRUE, + size == "+" ~ length(value) > 0, + size == "?" ~ length(value) %in% c(0, 1), + TRUE ~ as.numeric(size) == length(value) + ) + +} + +renv_config_install_staged <- function(default = TRUE) { + + values <- c( + config$install.staged(default = NULL), + config$install.transactional(default = NULL), + default + ) + + values[[1L]] + +} + + +# consent.R ------------------------------------------------------------------ + + +#' Consent to usage of renv +#' +#' Provide consent to renv, allowing it to write and update certain files +#' on your filesystem. +#' +#' As part of its normal operation, renv will write and update some files +#' in your project directory, as well as an application-specific cache +#' directory. These paths are documented within [paths]. +#' +#' In accordance with the +#' [CRAN Repository Policy](https://cran.r-project.org/web/packages/policies.html), +#' renv must first obtain consent from you, the user, before these actions +#' can be taken. Please call `renv::consent()` first to provide this consent. +#' +#' You can also set the \R option: +#' +#' ``` +#' options(renv.consent = TRUE) +#' ``` +#' +#' to implicitly provide consent for e.g. non-interactive \R sessions. +#' +#' @param provided The default provided response. If you need to provide +#' consent from a non-interactive \R session, you can invoke +#' `renv::consent(provided = TRUE)` explicitly. +#' +#' @return `TRUE` if consent is provided, or an \R error otherwise. +#' +#' @export +consent <- function(provided = FALSE) { + + # assume consent if embedded + if (renv_metadata_embedded()) + return(TRUE) + + # compute path to root directory + root <- renv_paths_root() + if (renv_file_type(root) == "directory") { + writef("- Consent to use renv has already been provided -- nothing to do.") + return(invisible(TRUE)) + } + + # write welcome message + template <- system.file("resources/WELCOME", package = "renv") + contents <- readLines(template) + replacements <- list(RENV_PATHS_ROOT = renv_path_pretty(root)) + welcome <- renv_template_replace(contents, replacements) + writef(welcome) + + # ask user if they want to proceed + response <- catchall(proceed(default = provided)) + if (!identical(response, TRUE)) { + msg <- "consent was not provided; operation aborted" + stop(msg, call. = FALSE) + } + + # cache the user response + options(renv.consent = TRUE) + ensure_directory(root) + writef("- %s has been created.", renv_path_pretty(root)) + + invisible(TRUE) + +} + +renv_consent_check <- function() { + + # check for explicit consent + consent <- getOption("renv.consent") + if (identical(consent, TRUE)) + return(TRUE) + else if (identical(consent, FALSE)) + stopf("consent has been explicitly withdrawn") + + # check for existence of root + root <- renv_paths_root() + if (renv_file_type(root) == "directory") + return(TRUE) + + # check for implicit consent + consented <- + !interactive() || + renv_envvar_exists("CI") || + renv_envvar_exists("GITHUB_ACTION") || + renv_envvar_exists("RENV_PATHS_ROOT") || + file.exists("/.singularity.d") || + renv_virtualization_type() != "native" + + if (consented) { + ensure_directory(root) + return(TRUE) + } + + # looks like the user's first interactive use of renv + consent() + +} + + +# cran.R --------------------------------------------------------------------- + + +# nocov start + +renv_cran_status <- function(email = NULL, + package = NULL, + view = "maintainer") +{ + case( + view == "maintainer" ~ renv_cran_status_maintainer(email, package), + TRUE ~ stopf("unrecognized view '%s'", view) + ) + +} + +renv_cran_status_maintainer <- function(email, package) { + + email <- email %||% renv_cran_status_maintainer_email(package = package) + parts <- strsplit(email, "@", fixed = TRUE)[[1L]] + + fmt <- "https://cran.r-project.org/web/checks/check_results_%s_at_%s.html" + url <- sprintf(fmt, parts[[1L]], parts[[2L]]) + + browseURL(url) + +} + +renv_cran_status_maintainer_email <- function(package = NULL) { + + mtr <- renv_package_description_field( + package = package %||% "renv", + field = "Maintainer" + ) + + indices <- gregexpr("[<>]", mtr, perl = TRUE)[[1L]] + substring(mtr, indices[[1L]] + 1L, indices[[2L]] - 1L) + +} + +# nocov end + + +# curl.R --------------------------------------------------------------------- + + +the$curl_valid <- new.env(parent = emptyenv()) + +renv_curl_exe <- function() { + + curl <- Sys.getenv("RENV_CURL_EXECUTABLE", unset = NA) + if (is.na(curl)) + curl <- Sys.which("curl") + + if (!nzchar(curl)) + return(renv_curl_exe_missing(curl)) + + renv_curl_validate(curl) + +} + +renv_curl_validate <- function(curl) { + + the$curl_valid[[curl]] <- the$curl_valid[[curl]] %||% { + renv_curl_validate_impl(curl) + } + +} + +renv_curl_validate_impl <- function(curl) { + + # make sure we can run this copy of curl + # note that 'system2()' will give an error if curl isn't runnable at all + output <- suppressWarnings( + tryCatch( + system2( + command = curl, + args = "--version", + stdout = TRUE, + stderr = TRUE + ), + error = identity + ) + ) + + if (!inherits(output, "error")) { + status <- attr(output, "status") %||% 0L + if (status == 0L) + return(curl) + } + + message <- if (inherits(output, "error")) + conditionMessage(output) + else + output + + fmt <- "Error executing '%s --version': is your copy of curl functional?" + footer <- sprintf(fmt, curl) + all <- c("", header(paste(curl, "--version"), prefix = "$"), message, "", footer) + + defer( + message(paste(all, collapse = "\n")), + scope = renv_dynamic_envir() + ) + + return(curl) + +} + +renv_curl_exe_missing <- function(curl) { + + if (!once()) + return(invisible(curl)) + + parts <- c( + "curl does not appear to be installed; downloads will fail.", + "See for more information." + ) + + msg <- paste(parts, collapse = "\n") + warning(msg, call. = FALSE) + + invisible(curl) + +} + + +# data_frame.R --------------------------------------------------------------- + + +data_frame <- function(...) { + as_data_frame(list(...)) +} + +as_data_frame <- function(data) { + + # split matrices into columns + if (is.matrix(data)) { + result <- vector("list", ncol(data)) + names(result) <- colnames(data) + dimnames(data) <- NULL + for (i in seq_len(ncol(data))) + result[[i]] <- data[, i] + data <- result + } + + # convert other objects to lists + if (!is.list(data)) + data <- as.list(data) + + # recycle columns + n <- lengths(data, use.names = FALSE) + nrow <- max(n) + + # start recycling + for (i in seq_along(data)) { + if (n[[i]] == 0L) { + length(data[[i]]) <- nrow + } else if (n[[i]] != nrow) { + data[[i]] <- rep.int(data[[i]], nrow / n[[i]]) + } + } + + # set attributes + class(data) <- "data.frame" + attr(data, "row.names") <- .set_row_names(nrow) + + # return data + data + +} + + +# dcf.R ---------------------------------------------------------------------- + + +# similar to base::read.dcf(), but: +# - allows for whitespace between fields +# - allows for non-indented field continuations +# - always keeps whitespace +renv_dcf_read <- function(file, text = NULL, ...) { + + # read file + contents <- text %||% renv_dcf_read_impl(file, ...) + + # split on newlines + parts <- strsplit(contents, "\\r?\\n(?=\\S)", perl = TRUE)[[1L]] + + # remove embedded newlines + parts <- gsub("\\r?\\n\\s*", " ", parts, perl = TRUE) + + # split into key / value pairs + index <- regexpr(":", parts, fixed = TRUE) + keys <- substring(parts, 1L, index - 1L) + vals <- substring(parts, index + 1L) + + # trim whitespace + vals <- trimws(vals) + + # return early if everything looks fine + ok <- nzchar(keys) + if (all(ok)) { + storage.mode(vals) <- "list" + names(vals) <- keys + return(vals) + } + + # otherwise, fix up bad continuations + starts <- which(ok) + ends <- c(tail(starts - 1L, n = -1L), length(keys)) + vals <- .mapply( + function(start, end) paste(vals[start:end], collapse = " "), + list(starts, ends), + NULL + ) + + # set up names + names(vals) <- keys[ok] + + # done + vals + +} + +renv_dcf_read_impl_encoding <- function(bytes) { + + # try to find encoding -- if none is declared, assume native encoding? + start <- 0L + while (TRUE) { + + # find 'Encoding' + start <- grepRaw("Encoding:", bytes, fixed = TRUE, offset = start + 1L) + if (length(start) == 0L) + return(NULL) + + # check for preceding newline, or start of file + if (start == 1L || bytes[[start - 1L]] == 0x0A) { + start <- start + 9L + break + } + + } + + # find the end of the encoding field + end <- grepRaw("\\r?\\n", bytes, offset = start + 1L) + if (length(end) == 0L) + end <- length(bytes) + + # pull it out + field <- rawToChar(bytes[start:end]) + trimws(field) + +} + +renv_dcf_read_impl <- function(file, ...) { + + # suppress warnings in this scope + renv_scope_options(warn = -1L) + + # first, read the file as bytes to get encoding + # use a guess for the file size to avoid expensive lookup, but fallback + # if necessary + bytes <- readBin(file, what = "raw", n = 8192L) + if (length(bytes) == 8192L) { + n <- renv_file_size(file) + bytes <- readBin(con = file, what = "raw", n = n) + } + + # try to guess the encoding + encoding <- renv_dcf_read_impl_encoding(bytes) + + # try a bunch of candidate encodings + encodings <- c(encoding, "UTF-8", "latin1", "") + for (encoding in unique(encodings)) { + result <- iconv(list(bytes), from = encoding, to = "UTF-8") + if (!is.na(result)) + return(result) + } + + # all else fails, just pretend it's in the native encoding + rawToChar(bytes) + +} + +renv_dcf_write <- function(x, file = "") { + + keep.white <- c("Description", "Authors@R", "Author", "Built", "Packaged") + result <- write.dcf(as.list(x), file = file, indent = 4L, width = 80L, keep.white = keep.white) + + renv_filebacked_invalidate(file) + + invisible(result) + +} + + +# deactivate.R --------------------------------------------------------------- + +#' @rdname activate +#' @param clean If `TRUE`, will also remove the `renv/` directory and the +#' lockfile. +#' @export +deactivate <- function(project = NULL, clean = FALSE) { + + renv_scope_error_handler() + + project <- renv_project_resolve(project) + renv_project_lock(project = project) + + renv_infrastructure_remove_rprofile(project) + + unload(project) + + if (clean) { + unlink(file.path(project, "renv.lock")) + unlink(file.path(project, "renv"), recursive = TRUE, force = TRUE) + } + + renv_restart_request(project, reason = "renv deactivated") + invisible(project) + +} + + +# debuggify.R ---------------------------------------------------------------- + + +debuggify <- function(expr) { + withCallingHandlers(expr, interrupt = renv_debuggify_dump) +} + +renv_debuggify_dump <- function(cnd) { + + # print a backtrace + status <- sys.status() + calls <- head(status$sys.calls, n = -2L) + frames <- head(status$sys.frames, n = -2L) + traceback <- renv_error_format(calls, frames) + caution(traceback) + + # print information about each frame + n <- length(calls) + for (i in seq_along(calls)) { + renv_debuggify_dump_impl( + index = n - i + 1, + call = calls[[i]], + frame = frames[[i]] + ) + } + +} + +renv_debuggify_dump_impl <- function(index, call, frame) { + writeLines(header(paste("Frame", index))) + vars <- ls(envir = frame, all.names = TRUE) + lapply(vars, renv_debuggify_dump_impl_one, call = call, frame = frame) + writeLines("") +} + +renv_debuggify_dump_impl_one <- function(var, call, frame) { + + if (var %in% c("expr")) + return("") + + str(frame[[var]]) + +} + + +# defer.R -------------------------------------------------------------------- + + +# environment hosting exit callbacks +the$defer_callbacks <- new.env(parent = emptyenv()) + +defer <- function(expr, scope = parent.frame()) { + + handler <- renv_defer_add( + list(expr = substitute(expr), envir = parent.frame()), + envir = scope + ) + + invisible(handler) + +} + +renv_defer_id <- function(envir) { + format.default(envir) +} + +renv_defer_get <- function(envir) { + id <- renv_defer_id(envir) + the$defer_callbacks[[id]] +} + +renv_defer_set <- function(envir, handlers) { + + # get any previously-set handlers. if we don't see any handlers registered, + # this must be our first time registering exit handlers on the environment, + # and so we'll want to register an on.exit handler to call our handlers + oldhandlers <- renv_defer_get(envir) + if (is.null(oldhandlers)) { + call <- as.call(list(renv_defer_execute, envir)) + do.call(base::on.exit, list(substitute(call), TRUE), envir = envir) + } + + # register the newly-set handlers + id <- renv_defer_id(envir) + the$defer_callbacks[[id]] <- handlers + +} + +renv_defer_remove <- function(envir) { + id <- renv_defer_id(envir) + rm(list = id, envir = the$defer_callbacks) +} + +renv_defer_execute <- function(envir = parent.frame()) { + + # check for handlers -- may be NULL if they were intentionally executed + # early via a call to `renv_defer_execute()` + handlers <- renv_defer_get(envir) + if (is.null(handlers)) + return() + + # execute the existing handlers + for (handler in handlers) + tryCatch(eval(handler$expr, handler$envir), error = identity) + + # remove the handlers + renv_defer_remove(envir) + +} + +renv_defer_add <- function(envir, handler) { + handlers <- c(list(handler), renv_defer_get(envir)) + renv_defer_set(envir, handlers) + handler +} + + +# dependencies.R ------------------------------------------------------------- + + +#' Find R package dependencies in a project +#' +#' @description +#' `dependencies()` will crawl files within your project, looking for \R files +#' and the packages used within those \R files. This is done primarily by +#' parsing the code and looking for calls of the form `library(package)`, +#' `require(package)`, `requireNamespace("package")`, and `package::method()`. +#' renv also supports package loading with +#' [box](https://cran.r-project.org/package=box) (`box::use(...)`) and +#' [pacman](https://cran.r-project.org/package=pacman) (`pacman::p_load(...)`) +#' . +#' +#' For \R package projects, dependencies expressed in the `DESCRIPTION` file +#' will also be discovered. +#' +#' Note that the rmarkdown package is required in order to crawl dependencies +#' in R Markdown files. +#' +#' # Missing dependencies +#' +#' `dependencies()` uses static analysis to determine which packages are used +#' by your project. This means that it inspects, but doesn't run, your +#' source. Static analysis generally works well, but is not 100% reliable in +#' detecting the packages required by your project. For example, renv is +#' unable to detect this kind of usage: +#' +#' ```{r eval=FALSE} +#' for (package in c("dplyr", "ggplot2")) { +#' library(package, character.only = TRUE) +#' } +#' ``` +#' +#' It also can't generally tell if one of the packages you use, uses one of +#' its suggested packages. For example, `tidyr::separate_wider_delim()` +#' uses the stringr package which is only suggested, not required by tidyr. +#' +#' If you find that renv's dependency discovery misses one or more packages +#' that you actually use in your project, one escape hatch is to include a file +#' called `_dependencies.R` that includes straightforward library calls: +#' +#' ``` +#' library(dplyr) +#' library(ggplot2) +#' library(stringr) +#' ``` +#' +#' # Explicit dependencies +#' +#' Alternatively, you can suppress dependency discover and instead rely +#' on an explicit set of packages recorded by you in a project `DESCRIPTION` file. +#' Call `renv::settings$snapshot.type("explicit")` to enable "explicit" mode, +#' then enumerate your dependencies in a project `DESCRIPTION` file. +#' +#' In that case, your `DESCRIPTION` might look something like this: +#' +#' ``` +#' Type: project +#' Description: My project. +#' Depends: +#' tidyverse, +#' devtools, +#' shiny, +#' data.table +#' ``` +#' +#' # Ignoring files +#' +#' By default, renv will read your project's `.gitignore`s (if present) to +#' determine whether certain files or folders should be included when traversing +#' directories. If preferred, you can also create a `.renvignore` file (with +#' entries of the same format as a standard `.gitignore` file) to tell renv +#' which files to ignore within a directory. If both `.renvignore` and +#' `.gitignore` exist within a folder, the `.renvignore` will be used in lieu of +#' the `.gitignore`. +#' +#' See for documentation on the +#' `.gitignore` format. Some simple examples here: +#' +#' ``` +#' # ignore all R Markdown files +#' *.Rmd +#' +#' # ignore all data folders +#' data/ +#' +#' # ignore only data folders from the root of the project +#' /data/ +#' ``` +#' +#' Using ignore files is important if your project contains a large number +#' of files; for example, if you have a `data/` directory containing many +#' text files. + +#' # Errors +#' +#' renv's attempts to enumerate package dependencies in your project can fail +#' -- most commonly, because of failures when attempting to parse your \R code. +#' You can use the `errors` argument to suppress these problems, but a +#' more robust solution is tell renv not to look at the problematic code. +#' As well as using `.renvignore`, as described above, you can also suppress errors +#' discovered within individual `.Rmd` chunks by including `renv.ignore=TRUE` +#' in the chunk header. For example: +#' +#' ```{r chunk-label, renv.ignore=TRUE} +#' # code in this chunk will be ignored by renv +#' ``` +#' +#' Similarly, if you'd like renv to parse a chunk that is otherwise ignored +#' (e.g. because it has `eval=FALSE` as a chunk header), you can set: +#' +#' ```{r chunk-label, eval=FALSE, renv.ignore=FALSE} +#' # code in this chunk will _not_ be ignored +#' ``` +#' +#' # Development dependencies +#' +#' renv has some support for distinguishing between development and run-time +#' dependencies. For example, your Shiny app might rely on +#' [ggplot2](https://ggplot2.tidyverse.org) (a run-time dependency) but while +#' you use [usethis](https://usethis.r-lib.org) during development, your app +#' doesn't need it to run (i.e. it's only a development dependency). +#' +#' You can record development dependencies by listing them in the `Suggests` +#' field of your project's `DESCRIPTION` file. Development dependencies will be installed by +#' [renv::install()] (when called without arguments) but will not be tracked in +#' the project snapshot. If you need greater control, you can also try project +#' profiles as discussed in `vignette("profiles")`. +#' +#' @inheritParams renv-params +#' +#' @param path The path to a `.R`, `.Rmd`, `.qmd`, `DESCRIPTION`, a directory +#' containing such files, or an R function. The default uses all files +#' found within the current working directory and its children. +#' +#' @param root The root directory to be used for dependency discovery. +#' Defaults to the active project directory. You may need to set this +#' explicitly to ensure that your project's `.renvignore`s (if any) are +#' properly handled. +#' +#' @param quiet Boolean; be quiet while checking for dependencies? +#' Setting `quiet = TRUE` is equivalent to setting `progress = FALSE` +#' and `errors = "ignored"`, and overrides those options when not `NULL`. +#' +#' @param progress Boolean; report progress output while enumerating +#' dependencies? +#' +#' @param errors How should errors that occur during dependency enumeration be +#' handled? +#' +#' * `"reported"` (the default): errors are reported to the user, but +#' otherwise ignored. +#' * `"fatal"`: errors are fatal and stop execution. +#' * `"ignored"`: errors are ignored and not reported to the user. +#' +#' @param dev Boolean; include development dependencies? These packages are +#' typically required when developing the project, but not when running it +#' (i.e. you want them installed when humans are working on the project but +#' not when computers are deploying it). +#' +#' Development dependencies include packages listed in the `Suggests` field +#' of a `DESCRIPTION` found in the project root, and roxygen2 or devtools if +#' their use is implied by other project metadata. They also include packages +#' used in `~/.Rprofile` if `config$user.profile()` is `TRUE`. +#' +#' @return An \R `data.frame` of discovered dependencies, mapping inferred +#' package names to the files in which they were discovered. Note that the +#' `Package` field might name a package remote, rather than just a plain +#' package name. +#' +#' @export +#' +#' @examples +#' \dontrun{ +#' +#' # find R package dependencies in the current directory +#' renv::dependencies() +#' +#' } +dependencies <- function( + path = getwd(), + root = NULL, + ..., + quiet = NULL, + progress = TRUE, + errors = c("reported", "fatal", "ignored"), + dev = FALSE) +{ + renv_scope_error_handler() + + # special case: if 'path' is a function, parse its body for dependencies + if (is.function(path)) + return(renv_dependencies_discover_r(expr = body(path))) + + renv_dependencies_impl( + path = path, + root = root, + quiet = quiet, + progress = progress, + errors = errors, + dev = dev, + ... + ) +} + +renv_dependencies_impl <- function( + path = getwd(), + ..., + root = NULL, + field = NULL, + quiet = NULL, + progress = FALSE, + errors = c("reported", "fatal", "ignored"), + dev = FALSE) +{ + renv_dots_check(...) + + path <- renv_path_normalize(path, mustWork = TRUE) + root <- root %||% renv_dependencies_root(path) + + # handle 'quiet' parameter + if (quiet %||% FALSE) { + progress <- FALSE + errors <- "ignored" + } + + # ignore errors when testing, unless explicitly asked for + if (renv_tests_running() && missing(errors)) + errors <- "ignored" + + # resolve errors + errors <- match.arg(errors) + + before <- Sys.time() + renv_dependencies_scope(root = root) + files <- renv_dependencies_find(path, root) + deps <- renv_dependencies_discover(files, progress, errors) + after <- Sys.time() + elapsed <- difftime(after, before, units = "secs") + + renv_condition_signal("renv.dependencies.elapsed_time", elapsed) + + renv_dependencies_report(errors) + + deps <- if (empty(deps) || nrow(deps) == 0L) { + renv_dependencies_list_empty() + } else { + # drop NAs, and only keep 'dev' dependencies if requested + rows(deps, deps$Dev %in% c(dev, FALSE)) + } + + take(deps, field) +} + +renv_dependencies_root <- function(path = getwd()) { + + path <- renv_path_normalize(path, mustWork = TRUE) + + project <- renv_project_get(default = NULL) + if (!is.null(project) && all(renv_path_within(path, project))) + return(project) + + roots <- uapply(path, renv_dependencies_root_impl) + if (empty(roots)) + return(NULL) + + uniroot <- unique(roots) + if (length(uniroot) > 1) + return(NULL) + + uniroot + +} + +renv_dependencies_root_impl <- function(path) { + + renv_file_find(path, function(parent) { + anchors <- c("DESCRIPTION", ".git", ".Rproj.user", "renv.lock", "renv") + for (anchor in anchors) + if (file.exists(file.path(parent, anchor))) + return(parent) + }) + +} + +renv_dependencies_callback <- function(path) { + + # user .Rprofile + if (renv_path_same(path, Sys.getenv("R_PROFILE_USER", unset = "~/.Rprofile"))) { + return(function(path) renv_dependencies_discover_r(path, dev = TRUE)) + } + + cbname <- list( + ".Rprofile" = function(path) renv_dependencies_discover_r(path), + "DESCRIPTION" = function(path) renv_dependencies_discover_description(path), + "NAMESPACE" = function(path) renv_dependencies_discover_namespace(path), + "_bookdown.yml" = function(path) renv_dependencies_discover_bookdown(path), + "_pkgdown.yml" = function(path) renv_dependencies_discover_pkgdown(path), + "_quarto.yml" = function(path) renv_dependencies_discover_quarto(path), + "renv.lock" = function(path) renv_dependencies_discover_renv_lock(path), + "rsconnect" = function(path) renv_dependencies_discover_rsconnect(path) + ) + + cbext <- list( + ".rproj" = function(path) renv_dependencies_discover_rproj(path), + ".r" = function(path) renv_dependencies_discover_r(path), + ".qmd" = function(path) renv_dependencies_discover_multimode(path, "qmd"), + ".rmd" = function(path) renv_dependencies_discover_multimode(path, "rmd"), + ".rmarkdown" = function(path) renv_dependencies_discover_multimode(path, "rmd"), + ".rnw" = function(path) renv_dependencies_discover_multimode(path, "rnw"), + ".ipynb" = function(path) renv_dependencies_discover_ipynb(path) + ) + + name <- basename(path) + ext <- tolower(fileext(path)) + + callback <- cbname[[name]] %||% cbext[[ext]] + if (!is.null(callback)) + return(callback) + + # for files without an extension, check if those might be executable by R + if (!nzchar(ext)) { + shebang <- renv_file_shebang(path) + if (grepl("\\b(?:R|r|Rscript)\\b", shebang)) + return(function(path) renv_dependencies_discover_r(path)) + } + +} + +renv_dependencies_find_extra <- function(root) { + + # if we don't have a root, we don't have a project + if (is.null(root)) + return(NULL) + + # only run for root-level dependency checks + project <- renv_project_resolve() + if (!renv_path_same(root, project)) + return(NULL) + + # only run if we have a custom profile + profile <- renv_profile_get() + if (is.null(profile)) + return(NULL) + + # look for dependencies in the associated 'renv' folder + path <- renv_paths_renv(project = project) + renv_dependencies_find_impl(path, root, 0L) + +} + +renv_dependencies_find <- function(path = getwd(), root = getwd()) { + files <- lapply(path, renv_dependencies_find_impl, root = root, depth = 0) + extra <- renv_dependencies_find_extra(root) + + if (config$user.profile()) { + rprofile_path <- Sys.getenv("R_PROFILE_USER", unset = "~/.Rprofile") + if (file.exists(rprofile_path)) { + extra <- c(extra, rprofile_path) + } + } + + unlist(c(files, extra), recursive = TRUE, use.names = FALSE) +} + +renv_dependencies_find_impl <- function(path, root, depth) { + + # check file type + info <- renv_file_info(path) + + # the file might have been removed after listing -- if so, just ignore it + if (is.na(info$isdir)) + return(NULL) + + # if this is a directory, recurse + if (info$isdir) + return(renv_dependencies_find_dir(path, root, depth)) + + path +} + +renv_dependencies_find_dir <- function(path, root, depth) { + + # check if this path should be ignored + excluded <- renv_renvignore_exec(path, root, path) + if (excluded) + return(character()) + + # check if we've already scanned this directory + # (necessary to guard against recursive symlinks) + if (!renv_platform_windows()) { + norm <- renv_path_normalize(path) + state <- renv_dependencies_state() + if (visited(norm, state$scanned)) + return(character()) + } + + # list children + children <- renv_dependencies_find_dir_children(path, root, depth) + + # notify about number of children + renv_condition_signal("renv.dependencies.count", list(path = path, count = length(children))) + + # find recursive dependencies + depth <- depth + 1 + paths <- map(children, renv_dependencies_find_impl, root = root, depth = depth) + + # explicitly include rsconnect folder + # (so we can infer a dependency on rsconnect when appropriate) + rsconnect <- file.path(path, "rsconnect") + if (file.exists(rsconnect)) + paths <- c(rsconnect, paths) + + paths + +} + +# return the set of files / subdirectories within a directory that should be +# crawled for dependencies +renv_dependencies_find_dir_children <- function(path, root, depth) { + + # list files in the folder + children <- renv_file_list(path, full.names = TRUE) + + # skip if this contains too many files + # https://github.com/rstudio/renv/issues/1186 + count <- length(children) + if (count >= config$dependencies.limit()) { + relpath <- renv_path_relative(path, dirname(root)) + renv_dependencies_find_dir_children_overload(relpath, count) + } + + # remove files which are broken symlinks + children <- children[file.exists(children)] + + # remove hard-coded ignores + # (only keep DESCRIPTION files at the top level) + ignored <- c("packrat", "renv", "revdep", "vendor", if (depth) c("DESCRIPTION", "NAMESPACE")) + children <- children[!basename(children) %in% ignored] + + # compute exclusions + excluded <- renv_renvignore_exec(path, root, children) + + # keep only non-excluded children + children[!excluded] + +} + +renv_dependencies_find_dir_children_overload <- function(path, count) { + + # check for missing state (e.g. if internal method called directly) + state <- renv_dependencies_state() + if (is.null(state)) + return() + + fmt <- "directory contains %s; consider ignoring this directory" + msg <- sprintf(fmt, nplural("file", count)) + error <- simpleError(message = msg) + + path <- path %||% state$path + problem <- list(file = path, error = error) + state$problems$push(problem) + +} + +renv_dependencies_discover <- function(paths, progress, errors) { + + if (!renv_dependencies_discover_preflight(paths, errors)) + return(invisible(list())) + + # short path if we're not showing progress + if (identical(progress, FALSE)) + return(bapply(paths, renv_dependencies_discover_impl)) + + # otherwise, run with progress reporting + + # nocov start + printf("Finding R package dependencies ... ") + callback <- renv_progress_callback(renv_dependencies_discover_impl, length(paths)) + deps <- lapply(paths, callback) + writef("Done!") + + bind(deps) + # nocov end + +} + +renv_dependencies_discover_impl <- function(path) { + + callback <- renv_dependencies_callback(path) + if (is.null(callback)) { + return(NULL) + } + + tryCatch( + filebacked("dependencies", path, callback), + error = function(cnd) { + warning(cnd) + NULL + } + ) + +} + +renv_dependencies_discover_preflight <- function(paths, errors) { + + if (identical(errors, "ignored")) + return(TRUE) + + if (length(paths) < config$dependencies.limit()) + return(TRUE) + + lines <- c( + "A large number of files (%i in total) have been discovered.", + "It may take renv a long time to crawl these files for dependencies.", + "Consider using .renvignore to ignore irrelevant files.", + "See `?renv::dependencies` for more information.", + "Set `options(renv.config.dependencies.limit = Inf)` to disable this warning.", + "" + ) + writef(lines, length(paths)) + + if (identical(errors, "reported")) + return(TRUE) + + cancel_if(interactive() && !proceed()) + + TRUE + +} + +renv_dependencies_discover_renv_lock <- function(path) { + renv_dependencies_list(path, "renv") +} + +renv_dependencies_discover_description_fields <- function(path, project = NULL) { + + # most callers don't pass in project so we need to get it from global state + project <- project %||% + renv_dependencies_state(key = "root") %||% + renv_restore_state(key = "root") %||% + renv_project_resolve() + + # by default, respect fields defined in settings + fields <- settings$package.dependency.fields(project = project) + + # if this appears to be the DESCRIPTION associated with the active project, + # and an explicit set of dependencies was provided in install, then use those + if (renv_path_same(file.path(project, "DESCRIPTION"), path)) { + default <- the$install_dependency_fields %||% c(fields, "Suggests") + profile <- sprintf("Config/renv/profiles/%s/dependencies", renv_profile_get()) + fields <- c(default, profile) + } + + fields + +} + +renv_dependencies_discover_description <- function(path, + fields = NULL, + subdir = NULL, + project = NULL) +{ + dcf <- catch(renv_description_read(path = path, subdir = subdir)) + if (inherits(dcf, "error")) + return(renv_dependencies_error(path, error = dcf)) + + # resolve the dependency fields to be used + fields <- fields %||% renv_dependencies_discover_description_fields(path, project) + + # make sure dependency fields are expanded + fields <- renv_description_dependency_fields_expand(fields) + + data <- map( + fields, + renv_dependencies_discover_description_impl, + dcf = dcf, + path = path + ) + + # if this is a bioconductor package, add their implicit dependencies + if ("biocViews" %in% names(dcf)) { + data[[length(data) + 1L]] <- renv_dependencies_list( + source = path, + packages = c(renv_bioconductor_manager(), "BiocVersion") + ) + } + + bind(data) + +} + +renv_dependencies_discover_namespace <- function(path) { + + tryCatch( + renv_dependencies_discover_namespace_impl(path), + error = warnify + ) + +} + +renv_dependencies_discover_namespace_impl <- function(path) { + + # parseNamespaceFile() expects to be called on an installed package, + # so we have to pretend our best here + library <- dirname(dirname(path)) + package <- basename(dirname(path)) + info <- parseNamespaceFile( + package = package, + package.lib = library, + mustExist = TRUE + ) + + # read package names from imports + packages <- map_chr(info$imports, `[[`, 1L) + + renv_dependencies_list( + source = path, + packages = sort(unique(packages)) + ) + +} + +renv_dependencies_discover_description_impl <- function(dcf, field, path) { + + # read field + contents <- dcf[[field]] + if (!is.character(contents)) + return(list()) + + # split on commas + parts <- strsplit(dcf[[field]], "\\s*,\\s*")[[1]] + + # drop any empty fields + x <- parts[nzchar(parts)] + + # match to split on remote, version + pattern <- paste0( + "([^,\\([:space:]]+)", # remote name + "(?:\\s*\\(([><=]+)\\s*([0-9.-]+)\\))?" # optional version specification + ) + + m <- regexec(pattern, x) + matches <- regmatches(x, m) + if (empty(matches)) + return(list()) + + # create dependency list + renv_dependencies_list( + path, + extract_chr(matches, 2L), + extract_chr(matches, 3L), + extract_chr(matches, 4L), + dev = field == "Suggests" + ) + +} + +renv_dependencies_discover_bookdown <- function(path) { + # TODO: other dependencies to parse from bookdown? + renv_dependencies_list(path, "bookdown") +} + +renv_dependencies_discover_pkgdown <- function(path) { + # TODO: other dependencies to parse from pkgdown? + renv_dependencies_list(path, "pkgdown") +} + +renv_dependencies_discover_quarto <- function(path) { + # TODO: other dependencies to parse from quarto? + # + # NOTE: we previously inferred a dependency on the R 'quarto' package here, + # but quarto is normally invoked directly (rather than via the package) and + # so such a dependency is not strictly necessary. + # + # https://github.com/rstudio/renv/issues/995 + renv_dependencies_list_empty() +} + +renv_dependencies_discover_rsconnect <- function(path) { + renv_dependencies_list(path, "rsconnect") +} + +renv_dependencies_discover_multimode <- function(path, mode) { + + # TODO: find in-line R code? + deps <- stack() + + if (mode %in% c("rmd", "qmd")) + deps$push(renv_dependencies_discover_rmd_yaml_header(path, mode)) + + deps$push(renv_dependencies_discover_chunks(path, mode)) + + bind(Filter(NROW, deps$data())) + +} + +renv_dependencies_discover_rmd_yaml_header <- function(path, mode) { + + deps <- stack(mode = "character") + + # R Markdown documents always depend on rmarkdown + if (identical(mode, "rmd")) + deps$push("rmarkdown") + + # try and read the document's YAML header + contents <- renv_file_read(path) + pattern <- "(?:^|\n)\\s*---\\s*(?:$|\n)" + matches <- gregexpr(pattern, contents, perl = TRUE)[[1L]] + + # check that we have something that looks like a YAML header + ok <- length(matches) > 1L && matches[[1L]] == 1L + if (!ok) + return(renv_dependencies_list(path, packages = deps$data())) + + # require yaml package for parsing YAML header + name <- case( + mode == "rmd" ~ "R Markdown", + mode == "qmd" ~ "Quarto Markdown" + ) + + # validate that we actually have the yaml package available + if (!renv_dependencies_require("yaml", name)) { + packages <- deps$data() + return(renv_dependencies_list(path, packages)) + } + + # extract YAML text + yamltext <- substring(contents, matches[[1L]] + 4L, matches[[2L]] - 1L) + yaml <- catch(renv_yaml_load(yamltext)) + if (inherits(yaml, "error")) + return(renv_dependencies_error(path, error = yaml, packages = "rmarkdown")) + + # check for Shiny runtime + runtime <- yaml[["runtime"]] %||% "" + if (pstring(runtime) && grepl("shiny", runtime, fixed = TRUE)) + deps$push("shiny") + + server <- yaml[["server"]] %||% "" + if (identical(server, "shiny")) + deps$push("shiny") + + if (is.list(server) && identical(server[["type"]], "shiny")) + deps$push("shiny") + + pattern <- renv_regexps_package_name() + + # check recursively for package usages of the form 'package::method' + recurse(yaml, function(node, stack) { + # look for keys of the form 'package::method' + values <- c(names(node), if (pstring(node)) node) + for (value in values) { + call <- tryCatch(parse(text = value)[[1]], error = function(err) NULL) + if (renv_call_matches(call, name = c("::", ":::"), n_args = 2)) { + deps$push(as.character(call[[2L]])) + } + } + + }) + + # check for dependency on bslib + theme <- catchall(yaml[[c("output", "html_document", "theme")]]) + if (!inherits(theme, "error") && is.list(theme)) + deps$push("bslib") + + # check for parameterized documents + status <- catch(renv_dependencies_discover_rmd_yaml_header_params(yaml, deps)) + if (inherits(status, "error")) + renv_dependencies_error_push(path, status) + + # get list of dependencies + packages <- deps$data() + renv_dependencies_list(path, packages) + +} + +renv_dependencies_discover_rmd_yaml_header_params <- function(yaml, deps) { + + # check for declared params + params <- yaml[["params"]] + if (!is.list(params)) + return() + + # infer dependency on shiny + deps$push("shiny") + + # iterate through params, parsing dependencies from R code + for (param in params) { + + # check for r types + type <- attr(param, "type", exact = TRUE) + if (!identical(type, "r")) + next + + # attempt to parse dependencies + rdeps <- catch(renv_dependencies_discover_r(text = param)) + if (inherits(rdeps, "error")) + next + + # add each dependency + for (package in sort(unique(rdeps$Package))) + deps$push(package) + + } + +} + +renv_dependencies_discover_chunks_ignore <- function(chunk) { + + # if renv.ignore is set, respect it + ignore <- chunk$params[["renv.ignore"]] + if (!is.null(ignore)) + return(truthy(ignore)) + + # skip non-R chunks + engine <- chunk$params[["engine"]] + ok <- is.character(engine) && engine %in% c("r", "rscript") + if (!ok) + return(TRUE) + + # skip un-evaluated chunks + if (!truthy(chunk$params[["eval"]], default = TRUE)) + return(TRUE) + + # skip learnr exercises + if (truthy(chunk$params[["exercise"]], default = FALSE)) + return(TRUE) + + # skip chunks whose labels end in '-display' + label <- chunk$params[["label"]] %||% "" + if (grepl("-display$", label)) + return(TRUE) + + # ok, don't ignore this chunk + FALSE + +} + +renv_dependencies_discover_chunks <- function(path, mode) { + + # figure out the appropriate begin, end patterns + type <- tolower(file_ext(path)) + if (type %in% c("rmd", "qmd", "rmarkdown")) + type <- "md" + + allpatterns <- renv_knitr_patterns() + patterns <- allpatterns[[type]] + if (is.null(patterns)) { + condition <- simpleCondition("not a recognized multi-mode R document") + return(renv_dependencies_error(path, error = condition)) + } + + # parse the chunks within + # NOTE: we need to proceed line-by-line since the chunk end pattern might + # end chunks not started by the chunk begin pattern (sad face) + encoding <- if (type == "md") "UTF-8" else "unknown" + contents <- readLines(path, warn = FALSE, encoding = encoding) + ranges <- renv_dependencies_discover_chunks_ranges(path, contents, patterns) + + # extract chunk code from the used ranges + chunks <- .mapply(function(lhs, rhs) { + + # parse params in header + header <- contents[[lhs]] + params <- renv_knitr_options_header(header, type) + + # extract chunk contents (preserve newlines for nicer error reporting) + range <- seq.int(lhs + 1, length.out = rhs - lhs - 1) + code <- rep.int("", length(contents)) + code[range] <- contents[range] + + # also parse chunk options + params <- overlay(params, renv_knitr_options_chunk(code)) + + # return list of outputs + list(params = params, code = code) + + }, ranges, NULL) + + # iterate over chunks, and attempt to parse dependencies from each + cdeps <- bapply(chunks, function(chunk) { + + # check whether this chunk should be ignored + if (renv_dependencies_discover_chunks_ignore(chunk)) + return(character()) + + # remove reused chunk placeholders + pattern <- "<<[^>]+>>" + code <- gsub(pattern, "", chunk$code) + + # okay, now we can discover deps + deps <- catch(renv_dependencies_discover_r(path = path, text = code)) + if (inherits(deps, "error")) + return(renv_dependencies_error(path, error = deps)) + + deps + + }) + + # check for dependencies in inline chunks as well + ideps <- renv_dependencies_discover_chunks_inline(path, contents) + + # if this is a .qmd, infer a dependency on rmarkdown if we have any R chunks + qdeps <- NULL + if (mode %in% "qmd") { + for (chunk in chunks) { + engine <- chunk$params[["engine"]] + if (is.character(engine) && engine %in% c("r", "rscript")) { + qdeps <- renv_dependencies_list(path, "rmarkdown") + break + } + } + } + + # paste them all together + deps <- bind(list(cdeps, ideps, qdeps)) + if (is.null(deps)) + return(deps) + + deps$Source <- path + deps + +} + +renv_dependencies_discover_chunks_inline <- function(path, contents) { + + pasted <- paste(contents, collapse = "\n") + matches <- gregexpr("`r ([^`]+)`", pasted, perl = TRUE) + if (identical(c(matches[[1L]]), -1L)) + return(list()) + + text <- unlist(regmatches(pasted, matches), use.names = FALSE, recursive = FALSE) + code <- substring(text, 4L, nchar(text) - 1L) + deps <- renv_dependencies_discover_r(path = path, text = code) + if (inherits(deps, "error")) + return(renv_dependencies_error(path, error = deps)) + + deps + +} + +renv_dependencies_discover_chunks_ranges <- function(path, contents, patterns) { + + output <- list() + + chunk <- FALSE + start <- 1; end <- 1 + for (i in seq_along(contents)) { + + line <- contents[[i]] + + if (chunk == FALSE && grepl(patterns$chunk.begin, line)) { + chunk <- TRUE + start <- i + next + } + + if (chunk == TRUE && grepl(patterns$chunk.begin, line)) { + end <- i + output[[length(output) + 1]] <- list(lhs = start, rhs = end) + start <- i + next + } + + if (chunk == TRUE && grepl(patterns$chunk.end, line)) { + chunk <- FALSE + end <- i + output[[length(output) + 1]] <- list(lhs = start, rhs = end) + next + } + + } + + if (chunk) { + message <- sprintf("chunk starting on line %i is not closed", start) + error <- simpleError(message) + renv_dependencies_error(path, error = error) + } + + bind(output) + +} + +renv_dependencies_discover_ipynb <- function(path) { + + json <- renv_json_read(path) + if (!identical(json$metadata$kernelspec$language, "R")) + return() + + deps <- stack() + if (identical(json$metadata$kernelspec$name, "ir")) + deps$push(renv_dependencies_list(path, "IRkernel")) + + for (cell in json$cells) { + if (cell$cell_type != "code") + next + + code <- paste0(cell$source, collapse = "") + deps$push(renv_dependencies_discover_r(path, text = code)) + } + + bind(deps$data()) + +} + +renv_dependencies_discover_rproj <- function(path) { + + props <- renv_properties_read(path) + + deps <- stack() + if (identical(props$PackageUseDevtools, "Yes")) { + deps$push("devtools") + deps$push("roxygen2") + } + + renv_dependencies_list(path, deps$data(), dev = TRUE) + +} + +renv_dependencies_discover_r <- function(path = NULL, + text = NULL, + expr = NULL, + envir = NULL, + dev = FALSE) +{ + expr <- case( + is.function(expr) ~ body(expr), + is.language(expr) ~ expr, + is.character(expr) ~ catch(renv_parse_text(expr)), + is.character(text) ~ catch(renv_parse_text(text)), + is.character(path) ~ catch(renv_parse_file(path)), + ~ stop("internal error") + ) + + if (inherits(expr, "error")) + return(renv_dependencies_error(path, error = expr)) + + # update current path + state <- renv_dependencies_state() + if (!is.null(state)) + renv_scope_binding(state, "path", path) + + methods <- c( + renv_dependencies_discover_r_methods, + renv_dependencies_discover_r_xfun, + renv_dependencies_discover_r_library_require, + renv_dependencies_discover_r_require_namespace, + renv_dependencies_discover_r_colon, + renv_dependencies_discover_r_pacman, + renv_dependencies_discover_r_modules, + renv_dependencies_discover_r_import, + renv_dependencies_discover_r_box, + renv_dependencies_discover_r_targets, + renv_dependencies_discover_r_glue, + renv_dependencies_discover_r_parsnip, + renv_dependencies_discover_r_database + ) + + envir <- envir %||% new.env(parent = emptyenv()) + recurse(expr, function(node, stack) { + + # normalize calls (handle magrittr pipes) + node <- renv_call_normalize(node, stack) + + # invoke methods on call objects + if (is.call(node)) + for (method in methods) + method(node, stack, envir) + + # return node + node + + }) + + packages <- ls(envir = envir, all.names = TRUE) + renv_dependencies_list(path, packages, dev = dev) +} + +renv_dependencies_discover_r_methods <- function(node, stack, envir) { + + node <- renv_call_expect(node, "methods", c("setClass", "setGeneric")) + if (is.null(node)) + return(FALSE) + + envir[["methods"]] <- TRUE + TRUE + +} + +renv_dependencies_discover_r_xfun <- function(node, stack, envir) { + + node <- renv_call_expect(node, "xfun", c("pkg_attach", "pkg_attach2")) + if (is.null(node)) + return(FALSE) + + # attempt to match the call + prototype <- function(..., install = FALSE, message = TRUE) {} + matched <- catch(match.call(prototype, node, expand.dots = FALSE)) + if (inherits(matched, "error")) + return(FALSE) + + # extract character vectors from `...` + strings <- stack() + recurse(matched[["..."]], function(node, stack) { + if (is.character(node)) + strings$push(node) + }) + + # mark packages as known + packages <- strings$data() + if (empty(packages)) + return(FALSE) + + for (package in packages) + envir[[package]] <- TRUE + + TRUE +} + +renv_dependencies_discover_r_library_require <- function(node, stack, envir) { + + node <- renv_call_expect(node, "base", c("library", "require")) + if (is.null(node)) + return(FALSE) + + # attempt to match the call + matched <- catch(match.call(base::library, node)) + if (inherits(matched, "error")) + return(FALSE) + + # if the 'package' argument is a character vector of length one, we're done + if (is.character(matched$package) && + length(matched$package) == 1) + { + envir[[matched$package]] <- TRUE + return(TRUE) + } + + # if it's a symbol, double check character.only argument + if (is.symbol(matched$package) && + identical(matched$character.only %||% FALSE, FALSE)) + { + envir[[as.character(matched$package)]] <- TRUE + return(TRUE) + } + + FALSE + +} + +renv_dependencies_discover_r_require_namespace <- function(node, stack, envir) { + + node <- renv_call_expect(node, "base", c("requireNamespace", "loadNamespace")) + if (is.null(node)) + return(FALSE) + + f <- get(as.character(node[[1]]), envir = .BaseNamespaceEnv, inherits = FALSE) + matched <- catch(match.call(f, node)) + if (inherits(matched, "error")) + return(FALSE) + + package <- matched$package + if (is.character(package) && length(package == 1)) { + envir[[package]] <- TRUE + return(TRUE) + } + + FALSE + + +} + +renv_dependencies_discover_r_colon <- function(node, stack, envir) { + + ok <- renv_call_matches(node, name = c("::", ":::"), n_args = 2) + + if (!ok) + return(FALSE) + + package <- node[[2L]] + if (is.symbol(package)) + package <- as.character(package) + + if (!is.character(package) || length(package) != 1) + return(FALSE) + + envir[[package]] <- TRUE + TRUE + +} + +renv_dependencies_discover_r_pacman <- function(node, stack, envir) { + + node <- renv_call_expect(node, "pacman", "p_load") + if (is.null(node) || length(node) < 2) + return(FALSE) + + # check for character.only + chonly <- node[["character.only"]] %||% FALSE + + # consider all unnamed arguments + parts <- as.list(node[-1L]) + + # consider packages passed to 'char' parameter + char <- node[["char"]] + + # detect vector of packages passed as vector + if (renv_call_matches(char, name = "c")) + parts <- c(parts, as.list(char[-1L])) + + # detect plain old package name + if (is.character(char)) + parts <- c(parts, as.list(char)) + + # ensure names + names(parts) <- names(parts) %||% rep.int("", length(parts)) + unnamed <- parts[!nzchar(names(parts))] + + # extract symbols / characters + for (arg in unnamed) { + + # skip symbols if necessary + if (chonly && is.symbol(arg)) + next + + # check for character or symbol + ok <- + length(arg) == 1 && + is.character(arg) || + is.symbol(arg) + + if (!ok) + next + + # add it + envir[[as.character(arg)]] <- TRUE + + } + + TRUE + +} + +renv_dependencies_discover_r_modules <- function(node, stack, envir) { + + # check for call of the form 'pkg::foo(a, b, c)' + colon <- renv_call_matches(node[[1]], name = c("::", ":::"), n_args = 2) + + node <- renv_call_expect(node, "modules", c("import")) + if (is.null(node)) + return(FALSE) + + ok <- FALSE + if (colon) { + # include if fully qualified call to modules::import + ok <- TRUE + } else { + # otherwise only consider calls within a 'module' block + # (to reduce confusion with reticulate::import) + for (parent in stack) { + parent <- renv_call_expect(parent, "modules", c("amodule", "module")) + if (!is.null(parent)) { + ok <- TRUE + break + } + } + } + + if (!ok) + return(FALSE) + + # attempt to match the call + prototype <- function(from, ..., attach = TRUE, where = parent.frame()) {} + matched <- catch(match.call(prototype, node, expand.dots = FALSE)) + if (inherits(matched, "error")) + return(FALSE) + + # extract character vector or symbol from `from` + package <- matched[["from"]] + if (empty(package)) + return(FALSE) + + # package could be symbols or character so call as.character + # to be safe then mark packages as known + envir[[as.character(package)]] <- TRUE + + TRUE +} + +renv_dependencies_discover_r_import <- function(node, stack, envir) { + + node <- renv_call_expect(node, "import", c("from", "here", "into")) + if (is.null(node)) + return(FALSE) + + # attempt to match the call + name <- as.character(node[[1L]]) + matched <- if (name == "from") { + catch(match.call(function(.from, ...) {}, node, expand.dots = FALSE)) + } else { + catch(match.call(function(..., .from) {}, node, expand.dots = FALSE)) + } + + if (inherits(matched, "error")) + return(FALSE) + + # the '.from' argument is the package name, either a character vector of length one or a symbol + from <- matched$.from + if (is.symbol(from)) + from <- as.character(from) + + ok <- + is.character(from) && + length(from) == 1 + + if (!ok) + return(FALSE) + + envir[[from]] <- TRUE + TRUE + +} + +renv_dependencies_discover_r_box <- function(node, stack, envir) { + + node <- renv_call_expect(node, "box", "use") + if (is.null(node)) + return(FALSE) + + for (i in seq.int(2L, length.out = length(node) - 1L)) + renv_dependencies_discover_r_box_impl(node[[i]], stack, envir) + + TRUE + +} + +renv_dependencies_discover_r_box_impl <- function(node, stack, envir) { + + # if the call uses /, it's a path, not a package + while (renv_call_matches(node, name = "/")) + return(FALSE) + + # if the node is just a symbol, then it's the name of a package + # otherwise, if it's a call to `[`, the first argument is the package name + name <- if (is.symbol(node) && !identical(node, quote(expr = ))) { + as.character(node) + } else if ( + renv_call_matches(node, name = "[") && + length(node) > 1L && + is.symbol(node[[2L]])) { + as.character(node[[2L]]) + } + + # the names `.` and `..` are special place holders and don't refer to packages + if (is.null(name) || name == "." || name == "..") + return(FALSE) + + envir[[name]] <- TRUE + TRUE + +} + +renv_dependencies_discover_r_targets <- function(node, stack, envir) { + + node <- renv_call_expect(node, "targets", "tar_option_set") + if (is.null(node)) + return(FALSE) + + envir[["targets"]] <- TRUE + + packages <- tryCatch( + renv_dependencies_eval(node$packages), + error = identity + ) + + # TODO: evaluation can fail for a multitude of reasons; + # are any of these worth signalling to the user? + if (inherits(packages, "error")) + return(TRUE) + + if (is.character(packages)) + for (package in packages) + envir[[package]] <- TRUE + + TRUE + +} + +renv_dependencies_discover_r_glue <- function(node, stack, envir) { + + node <- renv_call_expect(node, "glue", "glue") + if (is.null(node)) + return(FALSE) + + # analyze all unnamed strings in the call + args <- as.list(node)[-1L] + nm <- names(args) %||% rep.int("", length(args)) + strings <- args[!nzchar(nm) & map_lgl(args, is.character)] + + # start iterating through the strings, looking for code chunks + for (string in strings) + renv_dependencies_discover_r_glue_impl(string, node, envir) + + TRUE + +} + +renv_dependencies_discover_r_glue_impl <- function(string, node, envir) { + + # get open, close delimiters + ropen <- charToRaw(node$.open %||% "{") + rclose <- charToRaw(node$.close %||% "}") + rcomment <- charToRaw(node$.comment %||% "#") + + # constants + rcomment <- charToRaw("#") + rbackslash <- charToRaw("\\") + rquotes <- c( + charToRaw("'"), + charToRaw("\""), + charToRaw("`") + ) + + # iterate through characters in string + raw <- c(charToRaw(string), as.raw(0L)) + i <- 0L + n <- length(raw) + quote <- raw() + + # index for open delimiter match + index <- 0L + count <- 0L + + while (i < n) { + + # ensure we always advance index + i <- i + 1L + + # handle quoted states + if (length(quote)) { + + # skip escaped characters + if (raw[[i]] == rbackslash) { + i <- i + 1L + next + } + + # check for escape from quote + if (raw[[i]] == quote) { + quote <- raw() + next + } + + } + + # skip comments + if (raw[[i]] == rcomment) { + i <- grepRaw("(?:$|\n)", raw, i) + next + } + + # skip escaped characters + if (raw[[i]] == rbackslash) { + i <- i + 1L + next + } + + # check for quotes + idx <- match(raw[[i]], rquotes, nomatch = 0L) + if (idx > 0) { + quote <- rquotes[[idx]] + next + } + + # check for open delimiter + if (i %in% grepRaw(ropen, raw, i, fixed = TRUE)) { + + # check for duplicate (escape) + j <- i + length(ropen) + if (j %in% grepRaw(ropen, raw, j, fixed = TRUE)) { + i <- j + length(ropen) - 1L + next + } + + # save index if we're starting a match + if (count == 0L) { + index <- i + } + + # increment match count + count <- count + 1L + next + + } + + # check for close delimiter + if (i %in% grepRaw(rclose, raw, i, fixed = TRUE)) { + + # check for duplicate (escape) + j <- i + length(rclose) + if (j %in% grepRaw(rclose, raw, j, fixed = TRUE)) { + i <- j + length(rclose) - 1L + next + } + + if (count > 0L) { + + # decrement count if we have a match + count <- count - 1L + + # check for match and parse dependencies within + if (count == 0L) { + + # extract inner code + lhs <- index + length(ropen) + rhs <- i - 1L + code <- rawToChar(raw[lhs:rhs]) + + # parse dependencies + renv_dependencies_discover_r(text = code, envir = envir) + + } + + } + + } + + } + +} + +renv_dependencies_discover_r_parsnip <- function(node, stack, envir) { + + node <- renv_call_expect(node, "parsnip", "set_engine") + if (is.null(node)) + return(FALSE) + + matched <- catch(match.call(function(object, engine, ...) {}, node)) + if (inherits(matched, "error")) + return(FALSE) + + engine <- matched$engine + if (!is.character(engine) || length(engine) != 1L) + return(FALSE) + + map <- getOption("renv.parsnip.engines", default = list( + glm = "stats", + glmnet = "glmnet", + keras = "keras", + kknn = "kknn", + nnet = "nnet", + rpart = "rpart", + spark = "sparklyr", + stan = "rstanarm" + )) + + packages <- if (is.function(map)) + tryCatch(map(engine), error = function(e) NULL) + else + map[[engine]] + + if (is.null(packages)) + return(FALSE) + + for (package in packages) + envir[[package]] <- TRUE + + # TODO: a number of model routines appear to depend on dials; + # should we just assume it's required by default? or should + # users normally be using tidymodels instead of parsnip directly? + TRUE + +} + +renv_dependencies_discover_r_database <- function(node, stack, envir) { + + found <- FALSE + + db <- renv_dependencies_database() + enumerate(db, function(package, dependencies) { + enumerate(dependencies, function(method, requirements) { + + expect <- renv_call_expect(node, package, method) + if (is.null(expect)) + return(FALSE) + + for (requirement in requirements) + envir[[requirement]] <- TRUE + + found <<- TRUE + TRUE + + }) + }) + + found + +} + +renv_dependencies_database <- function() { + dynamic( + key = list(), + value = renv_dependencies_database_impl() + ) +} + +renv_dependencies_database_impl <- function() { + db <- getOption("renv.dependencies.database", default = list()) + db$ggplot2$geom_hex <- "hexbin" + db +} + +renv_dependencies_list <- function(source, + packages, + require = "", + version = "", + dev = FALSE) +{ + if (empty(packages)) + return(renv_dependencies_list_empty()) + + source <- source %||% rep.int(NA_character_, length(packages)) + + data_frame( + Source = as.character(source), + Package = as.character(packages), + Require = require, + Version = version, + Dev = dev + ) + +} + +renv_dependencies_list_empty <- function() { + + data_frame( + Source = character(), + Package = character(), + Require = character(), + Version = character(), + Dev = logical() + ) + +} + +renv_dependencies_require <- function(package, type = NULL) { + + if (requireNamespace(package, quietly = TRUE)) + return(TRUE) + + if (once()) { + + fmt <- lines( + "The '%1$s' package is required to parse dependencies within %2$s", + "Consider installing it with `install.packages(\"%1$s\")`." + ) + + within <- if (is.null(type)) "this project" else paste(type, "files") + warningf(fmt, package, within) + + } + + return(FALSE) + +} + +the$dependencies_state <- NULL + +renv_dependencies_state <- function(key = NULL) { + state <- the$dependencies_state + if (is.null(key)) state else state[[key]] +} + +renv_dependencies_scope <- function(root = NULL, scope = parent.frame()) { + state <- env(root = root, scanned = env(), problems = stack()) + the$dependencies_state <- state + defer(the$dependencies_state <- NULL, scope = scope) +} + +renv_dependencies_error_push <- function(path = NULL, error = NULL) { + + state <- renv_dependencies_state() + if (is.null(state)) + return() + + path <- path %||% state$path + problem <- list(file = path, error = error) + state$problems$push(problem) + +} + +renv_dependencies_error <- function(path, error = NULL, packages = NULL) { + + # if no error, return early + if (is.null(error)) + return(renv_dependencies_list(path, packages)) + + # push the error report + renv_dependencies_error_push(path, error) + + # return dependency list + renv_dependencies_list(path, packages) + +} + +renv_dependencies_report <- function(errors) { + + if (identical(errors, "ignored")) + return(FALSE) + + state <- renv_dependencies_state() + if (is.null(state)) + return(FALSE) + + problems <- state$problems$data() + if (empty(problems)) + return(TRUE) + + # bind into list + bound <- bapply(problems, function(problem) { + fields <- c(renv_path_aliased(problem$file), problem$line, problem$column) + header <- paste(fields, collapse = ":") + message <- conditionMessage(problem$error) + c(file = problem$file, header = header, message = message) + }) + + # split based on header (group errors from same file) + splat <- split(bound, bound$file) + + # emit messages + lines <- enumerate(splat, function(file, problem) { + messages <- paste("Error", problem$message, sep = ": ", collapse = "\n\n") + paste(c(header(file), messages, ""), collapse = "\n") + }) + + caution_bullets( + "WARNING: One or more problems were discovered while enumerating dependencies.", + c("", lines), + "Please see `?renv::dependencies` for more information.", + bullets = FALSE + ) + + if (identical(errors, "fatal")) { + fmt <- "one or more problems were encountered while enumerating dependencies" + stopf(fmt) + } + + renv_condition_signal("renv.dependencies.problems", problems) + TRUE + +} + +renv_dependencies_eval <- function(expr) { + + # create environment with small subset of "safe" symbols, that + # are commonly used for chunk expressions + syms <- c( + "list", "c", "T", "F", + "{", "(", "[", "[[", + "::", ":::", "$", "@", + ":", + "+", "-", "*", "/", + "<", ">", "<=", ">=", "==", "!=", + "!", + "&", "&&", "|", "||" + ) + + vals <- mget(syms, envir = baseenv()) + envir <- list2env(vals, parent = emptyenv()) + + # evaluate in that environment + eval(expr, envir = envir) + +} + + +# description.R -------------------------------------------------------------- + + +renv_description_read <- function(path = NULL, + package = NULL, + subdir = NULL, + field = NULL, + ...) +{ + # if given a package name, construct path to that package + path <- path %||% find.package(package) + + # normalize non-absolute paths + if (!renv_path_absolute(path)) + path <- renv_path_normalize(path) + + # if 'path' refers to a directory, try to resolve the DESCRIPTION file + if (dir.exists(path)) { + components <- c(path, if (nzchar(subdir %||% "")) subdir, "DESCRIPTION") + path <- paste(components, collapse = "/") + } + + # if the DESCRIPTION file doesn't exist, bail + if (!file.exists(path)) + stopf("DESCRIPTION file %s does not exist", renv_path_pretty(path)) + + # read value with filebacked cache + description <- filebacked( + context = "renv_description_read", + path = path, + callback = renv_description_read_impl, + subdir = subdir, + ... + ) + + if (!is.null(field)) + return(description[[field]]) + + description + +} + +renv_description_read_impl <- function(path = NULL, subdir = NULL, ...) { + + # if we have an archive, attempt to unpack the DESCRIPTION + type <- renv_archive_type(path) + if (type != "unknown") { + + # list files within the archive + files <- renv_archive_list(path) + + # find the DESCRIPTION file. note that for some source tarballs (e.g. + # those from GitHub) the first entry may not be the package name, so + # just consume everything up to the first slash + subdir <- subdir %||% "" + parts <- c("^[^/]+", if (nzchar(subdir)) subdir, "DESCRIPTION$") + pattern <- paste(parts, collapse = "/") + + descs <- grep(pattern, files, value = TRUE) + if (empty(descs)) { + fmt <- "archive '%s' does not appear to contain a DESCRIPTION file" + stopf(fmt, renv_path_aliased(path)) + } + + # choose the shortest DESCRPITION file matching + # unpack into tempdir location + file <- descs[[1]] + exdir <- renv_scope_tempfile("renv-description-") + renv_archive_decompress(path, files = file, exdir = exdir) + + # update path to extracted DESCRIPTION + path <- file.path(exdir, file) + + } + + # read DESCRIPTION as dcf + dcf <- renv_dcf_read(path, ...) + if (empty(dcf)) + stopf("DESCRIPTION file at '%s' is empty", path) + + dcf + +} + +renv_description_path <- function(path) { + childpath <- file.path(path, "DESCRIPTION") + indirect <- file.exists(childpath) + path[indirect] <- childpath[indirect] + path +} + +# parse the dependency requirements normally presented in +# Depends, Imports, Suggests, and so on +renv_description_parse_field <- function(field) { + + # check for invalid / unexpected inputs + if (is.null(field) || is.na(field) || !nzchar(field)) + return(NULL) + + pattern <- paste0( + "([a-zA-Z0-9._]+)", # package name + "(?:\\s*\\(([><=]+)\\s*([0-9.-]+)\\))?" # optional version specification + ) + + # split on commas + parts <- strsplit(field, "\\s*,\\s*")[[1]] + + # drop any empty fields + x <- parts[nzchar(parts)] + + # match to split on package name, version + m <- regexec(pattern, x) + matches <- regmatches(x, m) + if (empty(matches)) + return(NULL) + + data_frame( + Package = extract_chr(matches, 2L), + Require = extract_chr(matches, 3L), + Version = extract_chr(matches, 4L) + ) + +} + +renv_description_resolve <- function(path) { + + case( + is.list(path) ~ path, + is.character(path) ~ renv_description_read(path = path) + ) + +} + +renv_description_built_version <- function(desc = NULL) { + + desc <- renv_description_resolve(desc) + + built <- desc[["Built"]] + if (is.null(built)) + return(NA) + + substring(built, 3L, regexpr(";", built, fixed = TRUE) - 1L) +} + +renv_description_dependency_fields_expand <- function(fields) { + + expanded <- map(fields, function(field) { + + case( + + identical(field, FALSE) + ~ NULL, + + identical(field, "strong") || is.na(field) + ~ c("Depends", "Imports", "LinkingTo"), + + identical(field, "most") || identical(field, TRUE) + ~ c("Depends", "Imports", "LinkingTo", "Suggests"), + + identical(field, "all") ~ + c("Depends", "Imports", "LinkingTo", "Suggests", "Enhances"), + + field + + ) + + }) + + unique(unlist(expanded, recursive = FALSE, use.names = FALSE)) + +} + +renv_description_dependency_fields <- function(fields, project) { + fields <- fields %||% settings$package.dependency.fields(project = project) + renv_description_dependency_fields_expand(fields) +} + +renv_description_remotes <- function(path) { + + desc <- catch(renv_description_read(path)) + if (inherits(desc, "error")) + return(list()) + + profile <- renv_profile_get() + field <- if (is.null(profile)) + "Remotes" + else + sprintf("Config/renv/profiles/%s/remotes", profile) + + remotes <- desc[[field]] + if (is.null(remotes)) + return(list()) + + splat <- strsplit(remotes, "[[:space:]]*,[[:space:]]*")[[1]] + resolved <- lapply(splat, renv_remotes_resolve) + names(resolved) <- extract_chr(resolved, "Package") + resolved + +} + + + +# diagnostics.R -------------------------------------------------------------- + + +#' Print a diagnostics report +#' +#' Print a diagnostics report, summarizing the state of a project using renv. +#' This report can occasionally be useful when diagnosing issues with renv. +#' +#' @inheritParams renv-params +#' +#' @return This function is normally called for its side effects. +#' +#' @export +diagnostics <- function(project = NULL) { + + renv_scope_error_handler() + + project <- renv_project_resolve(project) + renv_project_lock(project = project) + + if (renv_file_type(project, symlinks = FALSE) != "directory") { + fmt <- "project %s is not a directory" + stopf(fmt, renv_path_pretty(project)) + } + + renv_scope_options(renv.verbose = TRUE) + + reporters <- list( + renv_diagnostics_session, + renv_diagnostics_project, + renv_diagnostics_status, + renv_diagnostics_packages, + renv_diagnostics_abi, + renv_diagnostics_profile, + renv_diagnostics_settings, + renv_diagnostics_options, + renv_diagnostics_envvars, + renv_diagnostics_path, + renv_diagnostics_cache + ) + + fmt <- "Diagnostics Report [renv %s]" + title <- sprintf(fmt, renv_metadata_version_friendly()) + lines <- paste(rep.int("=", nchar(title)), collapse = "") + writef(c(title, lines, "")) + + for (reporter in reporters) { + tryCatch(reporter(project), error = renv_error_handler) + writef() + } + +} + +renv_diagnostics_session <- function(project) { + writef(header("Session Info")) + renv_scope_options(width = 80) + print(sessionInfo()) +} + +renv_diagnostics_project <- function(project) { + writef(header("Project")) + writef("Project path: %s", renv_path_pretty(project)) +} + +renv_diagnostics_status <- function(project) { + writef(header("Status")) + status(project = project) +} + +renv_diagnostics_packages <- function(project) { + + writef(header("Packages")) + + # collect state of lockfile, library, dependencies + lockfile <- renv_diagnostics_packages_lockfile(project) + libstate <- renv_diagnostics_packages_library(project) + used <- unique(renv_diagnostics_packages_dependencies(project)$Package) + + # collect recursive package dependencies + recdeps <- renv_package_dependencies( + packages = used, + project = project + ) + + # bundle together + all <- c( + names(lockfile$Packages), + names(libstate$Packages), + names(recdeps), + used + ) + + # sort + all <- csort(unique(all)) + + # check which packages are direct, indirect requirements + deps <- rep.int(NA_character_, length(all)) + names(deps) <- all + deps[names(recdeps)] <- "indirect" + deps[used] <- "direct" + + # build libpaths for installed packages + libpaths <- dirname(map_chr(all, renv_package_find)) + + # use short form + flibpaths <- factor(libpaths, levels = .libPaths()) + + # construct integer codes (to be reported in data output) + libcodes <- as.integer(flibpaths) + libcodes[!is.na(libcodes)] <- sprintf("[%i]", libcodes[!is.na(libcodes)]) + + # add in packages in library + data <- data_frame( + Library = renv_diagnostics_packages_version(libstate, all), + Source = renv_diagnostics_packages_sources(libstate, all), + Lockfile = renv_diagnostics_packages_version(lockfile, all), + Source = renv_diagnostics_packages_sources(lockfile, all), + Path = libcodes, + Dependency = deps + ) + + # we explicitly want to use rownames here + row.names(data) <- names(deps) + + # print it out + renv_scope_options(width = 9000) + print(data, max = 10000) + + # print library codes + fmt <- "[%s]: %s" + writef() + writef(fmt, format(seq_along(levels(flibpaths))), format(levels(flibpaths))) + +} + +renv_diagnostics_packages_version <- function(lockfile, all) { + + data <- rep.int(NA_character_, length(all)) + names(data) <- all + + formatted <- map_chr(lockfile$Packages, `[[`, "Version") + data[names(formatted)] <- formatted + + data + +} + +renv_diagnostics_packages_sources <- function(lockfile, all) { + + data <- rep.int(NA_character_, length(all)) + names(data) <- all + + sources <- map_chr(lockfile$Packages, function(record) { + record$Repository %||% record$Source %||% "" + }) + + data[names(sources)] <- sources + data + +} + +renv_diagnostics_packages_lockfile <- function(project) { + + lockpath <- renv_lockfile_path(project = project) + if (!file.exists(lockpath)) { + writef("This project has not yet been snapshotted: 'renv.lock' does not exist.") + return(list()) + } + + renv_lockfile_read(lockpath) + +} + +renv_diagnostics_packages_library <- function(project) { + + library <- renv_paths_library(project = project) + if (!file.exists(library)) { + fmt <- "The project library %s does not exist." + writef(fmt, renv_path_pretty(library)) + } + + snapshot(project = project, lockfile = NULL, type = "all") + +} + +renv_diagnostics_packages_dependencies <- function(project) { + + renv_dependencies_impl( + project, + errors = "reported", + dev = TRUE + ) + +} + +renv_diagnostics_abi <- function(project) { + + writef(header("ABI")) + tryCatch( + renv_abi_check(), + error = function(e) { + writef(conditionMessage(e)) + } + ) + +} + +renv_diagnostics_profile <- function(project) { + + writef(header("User Profile")) + + userprofile <- "~/.Rprofile" + if (!file.exists(userprofile)) + return(writef("[no user profile detected]")) + + deps <- renv_dependencies_impl( + userprofile, + errors = "reported", + dev = TRUE + ) + + if (empty(deps)) + return(writef("[no R packages referenced in user profile")) + + renv_scope_options(width = 200) + print(deps) + +} + +renv_diagnostics_settings <- function(project) { + writef(header("Settings")) + str(renv_settings_get(project)) +} + +renv_diagnostics_options <- function(project) { + + writef(header("Options")) + + keys <- c( + "defaultPackages", + "download.file.method", + "download.file.extra", + "install.packages.compile.from.source", + "pkgType", + "repos", + grep("^renv[.]", names(.Options), value = TRUE) + ) + + vals <- .Options[keys] + names(vals) <- keys + + str(vals) + +} + +renv_diagnostics_envvars <- function(project) { + + writef(header("Environment Variables")) + + envvars <- convert(as.list(Sys.getenv()), "character") + + useful <- c( + "R_LIBS_USER", "R_LIBS_SITE", "R_LIBS", + "HOME", "LANG", "MAKE", + grep("^RENV_", names(envvars), value = TRUE) + ) + + matches <- envvars[useful] + if (empty(matches)) + return(writef("[no renv environment variables available]")) + + names(matches) <- useful + matches[is.na(matches)] <- "" + matches <- matches[order(names(matches))] + + keys <- names(matches) + vals <- matches + formatted <- paste(format(keys), vals, sep = " = ") + writef(formatted) + +} + +renv_diagnostics_path <- function(project) { + writef(header("PATH")) + path <- strsplit(Sys.getenv("PATH"), .Platform$path.sep, fixed = TRUE)[[1]] + writef(paste("-", path)) +} + +renv_diagnostics_cache <- function(project) { + + writef(header("Cache")) + + fmt <- "There are a total of %s installed in the renv cache." + cachelist <- renv_cache_list() + writef(fmt, nplural("package", length(cachelist))) + writef("Cache path: %s", renv_path_pretty(renv_paths_cache())) + +} + + +# difftime.R ----------------------------------------------------------------- + + +renv_difftime_format <- function(time, digits = 2L) { + + if (testing()) + return("XXXX seconds") + + units <- attr(time, "units") %||% "" + if (units == "secs" && time < 0.1) { + time <- time * 1000 + units <- "milliseconds" + } + + units <- switch( + units, + secs = "seconds", + mins = "minutes", + hours = "hours", + days = "days", + weeks = "weeks", + units + ) + + elapsed <- format(unclass(signif(time, digits = digits))) + if (elapsed %in% c("1", "1.0")) + units <- substring(units, 1L, nchar(units) - 1L) + + paste(elapsed, units) + +} + +renv_difftime_format_short <- function(time, digits = 2L) { + + if (testing()) + return("XXs") + + units <- attr(time, "units") %||% "" + if (units == "secs" && time < 0.1) { + time <- time * 1000 + units <- "ms" + } + + elapsed <- signif(time, digits = digits) + if (nchar(elapsed) == 1L) + elapsed <- paste(elapsed, ".0", sep = "") + + units <- switch( + attr(time, "units"), + secs = "s", + mins = "m", + hours = "h", + days = "d", + weeks = "w", + units + ) + + paste(elapsed, units, sep = "") + +} + + +# dots.R --------------------------------------------------------------------- + + +renv_dots_check <- function(...) { + + dots <- list(...) + parent <- parent.frame() + + # accept 'bioc' as an alias for 'bioconductor' + bioc <- dots[["bioc"]] + if (!is.null(bioc) && exists("bioconductor", envir = parent)) { + if (is.null(parent$bioconductor)) { + assign("bioconductor", bioc, envir = parent) + dots[["bioc"]] <- NULL + } + } + + # allow 'confirm' as an alias for 'prompt' + confirm <- dots[["confirm"]] + if (!is.null(confirm) && exists("prompt", envir = parent)) { + assign("prompt", confirm, envir = parent) + dots[["confirm"]] <- NULL + } + + # check for empty dots + if (length(dots) == 0) + return(TRUE) + + call <- sys.call(sys.parent()) + func <- sys.function(sys.parent()) + matched <- match.call(func, call, expand.dots = FALSE) + + dotcall <- format(matched["..."]) + start <- regexpr("(", dotcall, fixed = TRUE) + end <- nchar(dotcall) - 2L + args <- substring(dotcall, start, end) + n <- length(matched[["..."]]) + + message <- paste("unused", plural("argument", n), args) + stop(simpleError(message = message, call = call)) + +} + + +# download.R ----------------------------------------------------------------- + + +# download a file from 'url' to file 'destfile'. the 'type' +# argument tells us the remote type, which is used to motivate +# what form of authentication is appropriate; the 'quiet' +# argument is used to display / suppress output. use 'headers' +# (as a named character vector) to supply additional headers +download <- function(url, + destfile, + preamble = NULL, + type = NULL, + quiet = FALSE, + headers = NULL) +{ + # allow for user-defined overrides + override <- getOption("renv.download.override") + if (is.function(override)) { + + result <- catch( + override( + url = url, + destfile = destfile, + quiet = quiet, + mode = "wb", + headers = headers + ) + ) + + if (inherits(result, "error")) + renv_download_error(result, "%s", conditionMessage(result)) + + if (!file.exists(destfile)) + renv_download_error(url, "%s does not exist", renv_path_pretty(destfile)) + + return(destfile) + + } + + if (quiet) + renv_scope_options(renv.verbose = FALSE) + + # normalize separators (file URIs should normally use forward + # slashes, even on Windows where the native separator is backslash) + url <- chartr("\\", "/", url) + destfile <- chartr("\\", "/", destfile) + + # notify user we're about to try downloading + preamble <- preamble %||% sprintf("- Downloading '%s' ... ", url) + printf(preamble) + + # add custom headers as appropriate for the URL + custom <- renv_download_custom_headers(url) + headers[names(custom)] <- custom + + # handle local files by just copying the file + if (renv_download_local(url, destfile, headers)) + return(destfile) + + # on Windows, try using our local curl binary if available + renv_scope_downloader() + + # if the file already exists, compare its size with + # the server's reported size for that file + info <- renv_file_info(destfile) + if (identical(info$isdir, FALSE)) { + size <- renv_download_size(url, type, headers) + if (info$size == size) { + writef("OK [file is up to date]") + return(destfile) + } + } + + # back up a pre-existing file if necessary + callback <- renv_file_backup(destfile) + defer(callback()) + + # form path to temporary file + tempfile <- renv_scope_tempfile(tmpdir = dirname(destfile)) + + # request the download + before <- Sys.time() + + status <- renv_download_impl( + url = url, + destfile = tempfile, + type = type, + request = "GET", + headers = headers + ) + + after <- Sys.time() + + # check for failure + if (inherits(status, "condition")) + renv_download_error(url, "%s", conditionMessage(status)) + + if (status != 0L) + renv_download_error(url, "error code %i", status) + + if (!file.exists(tempfile)) + renv_download_error(url, "%s", "unknown reason") + + # double-check archives are readable + status <- renv_download_check_archive(tempfile) + if (inherits(status, "error")) + renv_download_error(url, "%s", "archive cannot be read") + + # everything looks ok: report success + elapsed <- difftime(after, before, units = "auto") + renv_download_report(elapsed, tempfile) + + # move the file to the requested location + renv_file_move(tempfile, destfile) + + # one final sanity check + if (!file.exists(destfile)) { + fmt <- "could not move %s to %s" + msg <- sprintf(fmt, renv_path_pretty(tempfile), renv_path_pretty(destfile)) + renv_download_error(url, msg) + } + + # and return path to successfully retrieved file + destfile +} + +# NOTE: only 'GET' and 'HEAD' are supported +# +# each downloader should return 0 on success +renv_download_impl <- function(url, destfile, type = NULL, request = "GET", headers = NULL) { + + # normalize separators (file URIs should normally use forward + # slashes, even on Windows where the native separator is backslash) + url <- chartr("\\", "/", url) + destfile <- chartr("\\", "/", destfile) + + # check that the destination file is writable + if (!renv_file_writable(destfile)) { + fmt <- "destination path '%s' is not writable; cannot proceed" + stopf(fmt, renv_path_pretty(destfile)) + } + + # select the appropriate downloader + downloader <- switch( + renv_download_method(), + curl = renv_download_curl, + wget = renv_download_wget, + renv_download_default + ) + + # run downloader, catching errors and warnings + catchall(downloader(url, destfile, type, request, headers)) + +} + +renv_download_default_mode <- function(url, method) { + + mode <- "wb" + + fixup <- + renv_platform_windows() && + identical(method, "wininet") && + substring(url, 1L, 5L) == "file:" + + if (fixup) + mode <- "w+b" + + mode + +} + +renv_download_default <- function(url, destfile, type, request, headers) { + + # custom request types are not supported with the default downloader + if (request != "GET") + stopf("the default downloader does not support %s requests", request) + + # try and ensure headers are set for older versions of R + auth <- renv_download_auth(url, type) + headers[names(auth)] <- auth + renv_download_default_agent_scope(headers) + + # on Windows, prefer 'wininet' as most users will have already configured + # authentication etc. to work with this protocol + methods <- c( + Sys.getenv("RENV_DOWNLOAD_METHOD", unset = NA), + Sys.getenv("RENV_DOWNLOAD_FILE_METHOD", unset = NA), + if (renv_platform_windows()) "wininet" else "auto" + ) + + method <- Find(Negate(is.na), methods) + + # headers _must_ be NULL rather than zero-length character + if (length(headers) == 0) + headers <- NULL + + mode <- renv_download_default_mode(url, method) + + # handle absence of 'headers' argument in older versions of R + args <- list(url = url, + destfile = destfile, + method = method, + headers = headers, + mode = mode, + quiet = TRUE) + + fmls <- formals(download.file) + args <- keep(args, names(fmls)) + + renv_download_trace_begin(url, method) + if (renv_download_trace()) + str(args) + + do.call(download.file, args) + +} + +renv_download_default_agent_scope <- function(headers, scope = parent.frame()) { + + if (empty(headers)) + return(FALSE) + + if (getRversion() >= "3.6.0") + return(FALSE) + + renv_download_default_agent_scope_impl(headers, scope) +} + +renv_download_default_agent_scope_impl <- function(headers, scope = parent.frame()) { + + utils <- asNamespace("utils") + makeUserAgent <- utils$makeUserAgent + ok <- + is.function(makeUserAgent) && + identical(formals(makeUserAgent), pairlist(format = TRUE)) + + if (!ok) + return(FALSE) + + agent <- makeUserAgent(FALSE) + all <- c("User-Agent" = agent, headers) + headertext <- paste0(names(all), ": ", all, "\r\n", collapse = "") + + renv_scope_binding(utils, "makeUserAgent", function(format = TRUE) { + if (format) headertext else agent + }, scope = scope) + + return(TRUE) + +} + +renv_download_curl <- function(url, destfile, type, request, headers) { + + renv_download_trace_begin(url, "curl") + + configfile <- renv_scope_tempfile("renv-download-config-") + + fields <- c( + "user-agent" = renv_http_useragent(), + "url" = url, + "output" = destfile + ) + + # set connect timeout + timeout <- config$connect.timeout() + if (is.numeric(timeout)) + fields[["connect-timeout"]] <- timeout + + # set number of retries + retries <- config$connect.retry() + if (is.numeric(retries)) + fields[["retry"]] <- retries + + # set up authentication headers + auth <- renv_download_auth(url, type) + if (length(auth)) { + authtext <- paste(names(auth), auth, sep = ": ") + names(authtext) <- "header" + fields <- c(fields, authtext) + } + + # add other custom headers + if (length(headers)) { + lines <- paste(names(headers), headers, sep = ": ") + names(lines) <- "header" + fields <- c(fields, lines) + } + + # join together + keys <- names(fields) + vals <- renv_json_quote(fields) + text <- paste(keys, vals, sep = " = ") + + # add in stand-along flags + flags <- c("location", "fail", "silent", "show-error") + if (request == "HEAD") + flags <- c(flags, "head", "include") + + # put it all together + text <- c(flags, text) + + writeLines(text, con = configfile) + renv_download_trace_request(text) + + # generate the arguments to be passed to 'curl' + args <- stack() + + # include anything provided explicitly in 'download.file.extra' here + if (identical(getOption("download.file.method"), "curl")) { + extra <- getOption("download.file.extra") + if (length(extra)) + args$push(extra) + } + + # honor R_LIBCURL_SSL_REVOKE_BEST_EFFORT + # https://github.com/wch/r-source/commit/f1ec503e986593bced6720a5e9099df58a4162e7 + if (Sys.getenv("R_LIBCURL_SSL_REVOKE_BEST_EFFORT") %in% c("T", "t", "TRUE", "true")) + args$push("--ssl-revoke-best-effort") + + # add in any user configuration files + userconfig <- getOption( + "renv.curl.config", + renv_download_curl_config() + ) + + for (entry in userconfig) + if (file.exists(entry)) + args$push("--config", renv_shell_path(entry)) + + # add in our own config file (the actual request) + args$push("--config", renv_shell_path(configfile)) + + # perform the download + curl <- renv_curl_exe() + output <- suppressWarnings( + system2(curl, args$data(), stdout = TRUE, stderr = TRUE) + ) + + renv_download_trace_result(output) + + # report non-zero status as warning + status <- attr(output, "status", exact = TRUE) %||% 0L + if (status != 0L) + warning(output, call. = FALSE) + + status + +} + +renv_download_curl_config <- function() { + + rc <- if (renv_platform_windows()) "_curlrc" else ".curlrc" + + homes <- c( + Sys.getenv("CURL_HOME"), + Sys.getenv("HOME"), + Sys.getenv("R_USER"), + path.expand("~/") + ) + + # nocov start + if (renv_platform_windows()) { + extra <- c( + Sys.getenv("APPDATA"), + file.path(Sys.getenv("USERPROFILE"), "Application Data"), + dirname(Sys.which("curl")) + ) + homes <- c(homes, extra) + } + # nocov end + + homes <- Filter(nzchar, homes) + + for (home in homes) { + path <- file.path(home, rc) + if (file.exists(path)) + return(path) + } + + NULL + +} + +# nocov start + +renv_download_wget <- function(url, destfile, type, request, headers) { + + renv_download_trace_begin(url, "wget") + + configfile <- renv_scope_tempfile("renv-download-config-") + + fields <- c( + "user-agent" = renv_http_useragent(), + "quiet" = "on" + ) + + auth <- renv_download_auth(url, type) + if (length(auth)) { + authtext <- paste(names(auth), auth, sep = ": ") + names(authtext) <- "header" + fields <- c(fields, authtext) + } + + if (length(headers)) { + lines <- paste(names(headers), headers, sep = ": ") + names(lines) <- "header" + fields <- c(fields, lines) + } + + keys <- names(fields) + vals <- unlist(fields) + text <- paste(keys, vals, sep = " = ") + + writeLines(text, con = configfile) + renv_download_trace_request(text) + + args <- stack() + + if (identical(getOption("download.file.method"), "wget")) { + extra <- getOption("download.file.extra") + if (length(extra)) + args$push(extra) + } + + args$push("--config", renv_shell_path(configfile)) + + # NOTE: '-O' does not write headers to file; we need to manually redirect + # in that case + status <- if (request == "HEAD") { + args$push("--server-response", "--spider") + args$push(">", renv_shell_path(destfile), "2>&1") + cmdline <- paste("wget", paste(args$data(), collapse = " ")) + return(suppressWarnings(system(cmdline))) + } + + args$push("-O", renv_shell_path(destfile)) + args$push(renv_shell_quote(url)) + + output <- suppressWarnings( + system2("wget", args$data(), stdout = TRUE, stderr = TRUE) + ) + + renv_download_trace_result(output) + + status <- attr(output, "status", exact = TRUE) %||% 0L + if (status != 0L) + warning(output, call. = FALSE) + + status + +} + +# nocov end + +renv_download_auth_type <- function(url) { + + github_hosts <- c( + "https://api.github.com/", + "https://raw.githubusercontent.com/" + ) + + for (host in github_hosts) + if (startswith(url, host)) + return("github") + + gitlab_hosts <- c( + "https://gitlab.com/" + ) + + for (host in gitlab_hosts) + if (startswith(url, host)) + return("gitlab") + + bitbucket_hosts <- c( + "https://api.bitbucket.org/", + "https://bitbucket.org/" + ) + + for (host in bitbucket_hosts) + if (startswith(url, host)) + return("bitbucket") + + "unknown" + +} + +renv_download_auth <- function(url, type) { + + type <- tolower(type %||% renv_download_auth_type(url)) + switch( + type, + bitbucket = renv_download_auth_bitbucket(), + github = renv_download_auth_github(), + gitlab = renv_download_auth_gitlab(), + character() + ) + +} + +renv_download_auth_bitbucket <- function() { + + user <- + Sys.getenv("BITBUCKET_USER", unset = NA) %NA% + Sys.getenv("BITBUCKET_USERNAME", unset = NA) + + pass <- + Sys.getenv("BITBUCKET_PASS", unset = NA) %NA% + Sys.getenv("BITBUCKET_PASSWORD", unset = NA) + + if (is.na(user) || is.na(pass)) + return(character()) + + userpass <- paste(user, pass, sep = ":") + c("Authorization" = paste("Basic", renv_base64_encode(userpass))) + +} + +renv_download_auth_github <- function() { + + pat <- renv_download_auth_github_pat() + if (is.null(pat)) + return(character()) + + c("Authorization" = paste("token", pat)) + +} + +renv_download_auth_github_pat <- function() { + + pat <- Sys.getenv("GITHUB_PAT", unset = NA) + if (!is.na(pat)) + return(pat) + + token <- tryCatch(gitcreds::gitcreds_get(), error = function(e) NULL) + if (!is.null(token)) + return(token$password) + +} + +renv_download_auth_gitlab <- function() { + + pat <- Sys.getenv("GITLAB_PAT", unset = NA) + if (is.na(pat)) + return(character()) + + c("Private-Token" = pat) + +} + +renv_download_headers <- function(url, type, headers) { + + # check for compatible download method + method <- renv_download_method() + if (!method %in% c("libcurl", "curl", "wget")) + return(list()) + + # perform the download + file <- renv_scope_tempfile("renv-headers-") + + status <- renv_download_impl( + url = url, + destfile = file, + type = type, + request = "HEAD", + headers = headers + ) + + # check for failure + failed <- + inherits(status, "error") || + !identical(status, 0L) || + !file.exists(file) + + if (failed) { + unlink(file) + return(list()) + } + + # read the downloaded headers + contents <- read(file) + + # if redirects were required, each set of headers will + # be reported separately, so just report the final set + # of headers (ie: ignore redirects) + splat <- strsplit(contents, "\n\n", fixed = TRUE)[[1]] + text <- strsplit(splat[[length(splat)]], "\n", fixed = TRUE)[[1]] + + # keep only header lines + lines <- grep(":", text, fixed = TRUE, value = TRUE) + headers <- catch(renv_properties_read(text = lines)) + names(headers) <- tolower(names(headers)) + if (inherits(headers, "error")) + return(list()) + + headers + +} + +renv_download_size <- function(url, type = NULL, headers = NULL) { + + memoize( + key = url, + value = renv_download_size_impl(url, type, headers) + ) + +} + +renv_download_size_impl <- function(url, type = NULL, headers = NULL) { + + headers <- catch(renv_download_headers(url, type, headers)) + if (inherits(headers, "error")) + return(-1L) + + size <- headers[["x-gitlab-size"]] + if (!is.null(size)) + return(as.numeric(size)) + + size <- headers[["content-length"]] + if (!is.null(size)) + return(as.numeric(size)) + + return(-1L) + +} + +# select an appropriate download file method. we prefer curl +# when available as it's the most user-customizable of all the +# download methods; when not available, we fall back to libcurl +# and wget (in that order). note that we don't want to use the +# internal or wininet downloaders as we cannot set custom headers +# with those methods. users can force a method with the +# RENV_DOWNLOAD_FILE_METHOD environment variable but we generally +# want to override a user-specified 'download.file.method' +renv_download_method <- function() { + + method <- Sys.getenv("RENV_DOWNLOAD_METHOD", unset = NA) + if (!is.na(method)) + return(method) + + method <- Sys.getenv("RENV_DOWNLOAD_FILE_METHOD", unset = NA) + if (!is.na(method)) + return(method) + + # prefer curl if available + if (nzchar(Sys.which("curl"))) + return("curl") + + # if curl is not available, use libcurl if available + libcurl <- capabilities("libcurl") + if (length(libcurl) && libcurl) + return("libcurl") + + # on windows, just use wininet here + if (renv_platform_windows()) + return("wininet") + + # if neither curl nor libcurl is available, prefer wget + if (nzchar(Sys.which("wget"))) + return("wget") + + # all else fails, use the internal downloader + "internal" + +} + +renv_download_report <- function(elapsed, file) { + + if (!renv_verbose()) + return() + + info <- renv_file_info(file) + size <- if (testing()) + "XXXX bytes" + else + structure(info$size, class = "object_size") + + renv_report_ok( + message = format(size, units = "auto"), + elapsed = elapsed + ) + +} + +renv_download_check_archive <- function(destfile) { + + # validate the file exists + if (!file.exists(destfile)) + return(FALSE) + + # validate archive type + type <- renv_archive_type(destfile) + if (type == "unknown") + return(FALSE) + + # try listing files in the archive + tryCatch({renv_archive_list(destfile); TRUE}, error = identity) + +} + +renv_download_local <- function(url, destfile, headers) { + + # only ever used for downloads from file URIs and server URIs + ok <- + grepl("^file:", url) || + !grepl("^[a-zA-Z]+://", url) + + if (!ok) + return(FALSE) + + methods <- list( + renv_download_local_copy, + renv_download_local_default + ) + + for (method in methods) { + + # perform the copy + before <- Sys.time() + status <- catch(method(url, destfile, headers)) + after <- Sys.time() + + # check for success + if (!identical(status, TRUE)) + next + + # report download summary + elapsed <- difftime(after, before, units = "auto") + renv_download_report(elapsed, destfile) + + return(TRUE) + + } + + FALSE + +} + +renv_download_local_copy <- function(url, destfile, headers) { + + # remove file prefix (to get path to local / server file) + url <- case( + startswith(url, "file:///") ~ substring(url, 8L), + startswith(url, "file://") ~ substring(url, 6L), + startswith(url, "file:") ~ substring(url, 6L), + TRUE ~ url + ) + + # fix up file URIs to local paths on Windows + if (renv_platform_windows()) { + badpath <- grepl("^/[a-zA-Z]:", url) + if (badpath) + url <- substring(url, 2L) + } + + # attempt to copy + ensure_parent_directory(destfile) + status <- catchall(renv_file_copy(url, destfile, overwrite = TRUE)) + if (!identical(status, TRUE)) + return(FALSE) + + TRUE + +} + +renv_download_local_default <- function(url, destfile, headers) { + + status <- renv_download_impl( + url = url, + destfile = destfile, + headers = headers + ) + + identical(status, 0L) + +} + +renv_download_custom_headers <- function(url) { + renv_bootstrap_download_custom_headers(url) +} + +renv_download_available <- function(url) { + + # normalize separators (file URIs should normally use forward + # slashes, even on Windows where the native separator is backslash) + url <- chartr("\\", "/", url) + + # on Windows, try using our local curl binary if available + renv_scope_downloader() + + # if we're not using curl, then use fallback method + method <- renv_download_method() + if (!identical(method, "curl")) + return(renv_download_available_fallback(url)) + + # otherwise, try a couple candidate methods + methods <- list( + renv_download_available_headers, + renv_download_available_range + ) + + for (method in methods) { + result <- catch(method(url)) + if (identical(result, TRUE)) + return(TRUE) + } + + FALSE + +} + +renv_download_available_headers <- function(url) { + + status <- catchall( + renv_download_headers( + url = url, + type = NULL, + headers = renv_download_custom_headers(url) + ) + ) + + if (inherits(status, "condition")) + return(FALSE) + + is.list(status) && length(status) + +} + +renv_download_available_range <- function(url) { + + destfile <- renv_scope_tempfile("renv-download-") + + # instruct curl to request only first byte + extra <- c( + if (identical(getOption("download.file.method"), "curl")) + getOption("download.file.extra"), + "-r 0-0" + ) + + renv_scope_options(download.file.extra = paste(extra, collapse = " ")) + + # perform the download + status <- catchall( + renv_download_curl( + url = url, + destfile = destfile, + type = NULL, + request = "GET", + headers = renv_download_custom_headers(url) + ) + ) + + if (inherits(status, "condition")) + return(FALSE) + + # check for success + identical(status, 0L) + +} + +renv_download_available_fallback <- function(url) { + + destfile <- renv_scope_tempfile("renv-download-") + + # just try downloading the requested URL + status <- catchall( + renv_download_impl( + url = url, + destfile = destfile, + type = NULL, + request = "GET", + headers = renv_download_custom_headers(url) + ) + ) + + if (inherits(status, "condition")) + return(FALSE) + + identical(status, 0L) + +} + +renv_download_error <- function(url, fmt, ...) { + msg <- sprintf(fmt, ...) + writef("\tERROR [%s]", msg) + stopf("error downloading '%s' [%s]", url, msg, call. = FALSE) +} + +renv_download_trace <- function() { + getOption("renv.download.trace", default = FALSE) +} + +renv_download_trace_begin <- function(url, type) { + + if (!renv_download_trace()) + return() + + fmt <- "Downloading '%s' [%s]" + msg <- sprintf(fmt, url, type) + + title <- header(msg, n = 78L) + writef(c("", title, "")) + +} + +renv_download_trace_request <- function(text) { + + if (!renv_download_trace()) + return() + + title <- header("Request", n = 78L, prefix = "##") + writef(c(title, text, "")) + +} + +renv_download_trace_result <- function(output) { + + if (!renv_download_trace()) + return() + + title <- header("Output", prefix = "##", n = 78L) + text <- if (empty(output)) "[no output generated]" else output + all <- c(title, text, "") + writef(all) + + status <- attr(output, "status", exact = TRUE) %||% 0L + title <- header("Status", prefix = "##", n = 78L) + all <- c(title, status, "") + writef(all) + +} + + +# dynamic.R ------------------------------------------------------------------ + + +# +# Tools for so-called 'dynamic' values. These are values which are computed +# once, and then memoized for the rest of the currently-executing call. +# +# An exit handler placed in the top-most (renv) environment is then responsible +# for cleaning up any objects cached for the duration of that frame. +# +# This is a useful way to cache results for repeatedly-computed values +# that one can reasonably expect not to change in the duration of a +# particular call. +# + +the$dynamic_envir <- NULL +the$dynamic_objects <- new.env(parent = emptyenv()) + +dynamic <- function(key, value, envir = NULL) { + + # allow opt-out just in case + enabled <- getOption("renv.dynamic.enabled", default = TRUE) + if (!enabled) + return(value) + + # get a unique id for the scope where this function was invoked + caller <- sys.call(sys.parent())[[1L]] + if (renv_call_matches(caller, name = ":::")) + caller <- caller[[3L]] + + # handle cases like FUN + if (is.null(the$envir_self[[as.character(caller)]])) { + if (!renv_tests_running()) { + fmt <- "internal error: dynamic() received unexpected call '%s'" + stopf(fmt, stringify(sys.call(sys.parent()))) + } + } + + # just return value if this isn't a valid dynamic scope + if (!is.symbol(caller)) { + dlog("dynamic", "invalid dynamic scope '%s'", stringify(sys.call(sys.parent()))) + return(value) + } + + # make sure we have a dynamic scope active + the$dynamic_envir <- the$dynamic_envir %||% renv_dynamic_envir(envir) + + # resolve key from variables in the parent frame + key <- paste( + names(key), + map_chr(key, stringify), + sep = " = ", + collapse = ", " + ) + + # put it together + id <- sprintf("%s(%s)", as.character(caller), key) + + # memoize the result of the expression + the$dynamic_objects[[id]] <- the$dynamic_objects[[id]] %||% { + dlog("dynamic", "memoizing dynamic value for '%s'", id) + value + } + +} + +renv_dynamic_envir <- function(envir = NULL) { + + envir <- envir %||% renv_dynamic_envir_impl() + defer(renv_dynamic_reset(), scope = envir) + + dlog("dynamic", "using dynamic environment '%s'", format(envir)) + envir +} + +renv_dynamic_envir_impl <- function() { + + frames <- sys.frames() + for (i in seq_along(frames)) { + envir <- frames[[i]] + if (identical(parent.env(envir), the$envir_self)) + return(envir) + } + + stop("internal error: no renv frame available for dynamic call") + +} + +renv_dynamic_reset <- function() { + dlog("dynamic", "resetting dynamic objects") + the$dynamic_envir <- NULL + renv_envir_clear(the$dynamic_objects) +} + + +# embed.R -------------------------------------------------------------------- + +#' Capture and re-use dependencies within a `.R` or `.Rmd` +#' +#' @description +#' Together, `embed()` and `use()` provide a lightweight way to specify and +#' restore package versions within a file. `use()` is a lightweight lockfile +#' specification that `embed()` can automatically generate and insert into a +#' script or document. +#' +#' Calling `embed()` inspects the dependencies of the specified document then +#' generates and inserts a call to `use()` that looks something like this: +#' +#' ```R +#' renv::use( +#' "digest@0.6.30", +#' "rlang@0.3.4" +#' ) +#' ``` +#' +#' Then, when you next run your R script or render your `.Rmd`, `use()` will: +#' +#' 1. Create a temporary library path. +#' +#' 1. Install the requested packages and their recursive dependencies into that +#' library. +#' +#' 1. Activate the library, so it's used for the rest of the script. +#' +#' ## Manual usage +#' +#' You can also create calls to `use()` yourself, either specifying the +#' packages needed by hand, or by supplying the path to a lockfile, +#' `renv::use(lockfile = "/path/to/renv.lock")`. +#' +#' This can be useful in projects where you'd like to associate different +#' lockfiles with different documents, as in a blog where you want each +#' post to capture the dependencies at the time of writing. Once you've +#' finished writing each, the post, you can use +#' `renv::snapshot(lockfile = "/path/to/renv.lock")` +#' to "save" the state that was active while authoring that bost, and then use +#' `renv::use(lockfile = "/path/to/renv.lock")` in that document to ensure the +#' blog post always uses those dependencies onfuture renders. +#' +#' `renv::use()` is inspired in part by the [groundhog](https://groundhogr.com/) +#' package, which also allows one to specify a script's \R package requirements +#' within that same \R script. +#' +#' @inherit renv-params +#' +#' @param path +#' The path to an \R or R Markdown script. The default will use the current +#' document, if running within RStudio. +#' +#' @param lockfile +#' The path to an renv lockfile. When `NULL` (the default), the project +#' lockfile will be read (if any); otherwise, a new lockfile will be generated +#' from the current library paths. +#' +#' @export +embed <- function(path = NULL, + ..., + lockfile = NULL, + project = NULL) +{ + path <- path %||% renv_embed_path() + + ext <- tolower(fileext(path)) + method <- case( + ext == ".r" ~ renv_embed_r, + ext == ".rmd" ~ renv_embed_rmd + ) + + if (is.null(method)) { + fmt <- "don't know how to embed lockfile into file %s" + stopf(fmt, renv_path_pretty(path)) + } + + method( + path = path, + lockfile = lockfile, + project = project, + ... + ) + +} + +renv_embed_path <- function() { + + tryCatch( + renv_embed_path_impl(), + error = function(e) NULL + ) + +} + +renv_embed_path_impl <- function() { + rstudio <- as.environment("tools:rstudio") + rstudio$.rs.api.documentPath() +} + +renv_embed_create <- function(path = NULL, + lockfile = NULL, + project = NULL) +{ + # generate lockfile + project <- renv_project_resolve(project) + lockfile <- renv_embed_lockfile_resolve(lockfile, project) + + # figure out recursive package dependencies + deps <- renv_dependencies_impl(path) + packages <- sort(unique(deps$Package)) + all <- renv_package_dependencies(packages) + + # keep only matched records + lockfile$Packages <- keep(lockfile$Packages, c("renv", names(all))) + + # write compact use statement + renv_lockfile_compact(lockfile) +} + +renv_embed_r <- function(path, ..., lockfile = NULL, project = NULL) { + + # resolve project + project <- renv_project_resolve(project) + + # read file contents + contents <- readLines(path, warn = FALSE, encoding = "UTF-8") + + # generate embed + embed <- renv_embed_create( + path = path, + lockfile = lockfile, + project = project + ) + + # check for existing 'renv::use' statement + pattern <- "^\\s*(?:renv:{2,3})?use\\(\\s*$" + index <- grep(pattern, contents, perl = TRUE) + + # if we don't have an index, just insert at start + if (empty(index)) { + contents <- c(embed, "", contents) + writeLines(contents, con = path) + return(TRUE) + } + + # otherwise, try to replace an existing embedded lockfile + start <- index + + # find the end of the block + n <- length(contents) + lines <- grep("^\\s*\\)\\s*$", contents, perl = TRUE) + end <- min(lines[lines > start], n + 1L) + + # inject new lockfile + contents <- c( + head(contents, n = start - 1L), + embed, + tail(contents, n = n - end) + ) + + writeLines(contents, con = path) + return(TRUE) + +} + +renv_embed_create_rmd <- function(path = NULL, + lockfile = NULL, + project = NULL) +{ + # create lockfile + project <- renv_project_resolve(project) + lockfile <- renv_embed_lockfile_resolve(lockfile, project) + + # create embed + embed <- renv_embed_create( + path = path, + lockfile = lockfile, + project = project + ) + + # return embed + c("```{r lockfile, include=FALSE}", embed, "```") + +} + + +renv_embed_rmd <- function(path, + ..., + lockfile = NULL, + project = NULL) +{ + # resolve project + project <- renv_project_resolve(project) + + # read file contents + contents <- readLines(path, warn = FALSE, encoding = "UTF-8") + + # generate embed + embed <- renv_embed_create_rmd( + path = path, + lockfile = lockfile, + project = project + ) + + # check for existing renv.lock in file + # if it exists, we'll want to replace at this location; + # otherwise, insert at end of document + header <- "^\\s*```{r lockfile" + footer <- "```" + start <- grep(header, contents, perl = TRUE) + + # if we don't have an index, insert after YAML header (if any) + if (empty(start)) { + bounds <- which(trimws(contents) == "---") + + all <- if (length(bounds) >= 2) { + index <- bounds[[2L]] + c( + head(contents, n = index), + "", + embed, + "", + tail(contents, n = length(contents) - index) + ) + } else { + c(embed, "", contents) + } + + writeLines(all, con = path) + return(TRUE) + } + + # otherwise, try to replace an existing embedded lockfile + ends <- which(contents == footer) + end <- min(ends[ends > start]) + + # inject new lockfile + contents <- c( + head(contents, n = start - 1L), + embed, + tail(contents, n = length(contents) - end) + ) + + writeLines(contents, con = path) + return(TRUE) + +} + +renv_embed_lockfile_resolve <- function(lockfile, project) { + + # if lockfile is character, assume it's the path to a lockfile + if (is.character(lockfile)) + return(renv_lockfile_read(lockfile)) + + # if lockfile is not NULL, assume lockfile object + if (!is.null(lockfile)) + return(lockfile) + + # check for lockfile in project + path <- renv_lockfile_path(project) + if (file.exists(path)) + return(renv_lockfile_read(path)) + + # no lockfile available; just snapshot + snapshot(project = project, lockfile = NULL) + +} + + +# encoding.R ----------------------------------------------------------------- + + +renv_encoding_mark <- function(x, encoding = "UTF-8") { + Encoding(x) <- "UTF-8" + x +} + + +# ensure.R ------------------------------------------------------------------- + + +ensure_existing_path <- function(path) { + if (!file.exists(path)) + stopf("no file at path '%s'", path) + invisible(path) +} + +ensure_existing_file <- function(path) { + info <- renv_file_info(path) + if (is.na(info$isdir)) + stopf("no file at path '%s'", path) + else if (identical(info$isdir, TRUE)) + stopf("file '%s' exists but is a directory") + invisible(path) +} + +ensure_directory <- function(paths, umask = NULL) { + + # handle zero-path case + if (empty(paths)) + return(invisible(paths)) + + # set umask if necessary + if (!is.null(umask)) + renv_scope_umask("0") + + # for each path, try to either create the directory, or assert that + # the directory already exists. this should also help handle cases + # where 'dir.create()' fails because another process created the + # directory at the same time we attempted to do so + for (path in paths) { + + ok <- + dir.create(path, recursive = TRUE, showWarnings = FALSE) || + dir.exists(path) + + if (!ok) + stopf("failed to create directory at path '%s'", path) + + } + + # return the paths + invisible(paths) + +} + +ensure_parent_directory <- function(path) { + ensure_directory(unique(dirname(path))) +} + + + +# envir.R -------------------------------------------------------------------- + + +renv_envir_self <- function() { + parent.env(environment()) +} + +renv_envir_clear <- function(envir) { + vars <- ls(envir = envir, all.names = TRUE) + rm(list = vars, envir = envir, inherits = FALSE) +} + +renv_envir_unwrap <- function(envir) { + eapply(envir, function(node) { + if (is.environment(node)) + renv_envir_unwrap(node) + else + node + }) +} + + +# envvar.R ------------------------------------------------------------------- + + +renv_envvar_path_add <- function(envvar, value, prepend = TRUE) { + + old <- Sys.getenv(envvar, unset = "") + old <- strsplit(old, .Platform$path.sep)[[1]] + + parts <- if (prepend) union(value, old) else union(old, value) + new <- paste(parts, collapse = .Platform$path.sep) + + names(new) <- envvar + do.call(Sys.setenv, as.list(new)) + + new + +} + +renv_envvar_exists <- function(key) { + !is.na(Sys.getenv(key, unset = NA)) +} + + +# envvars.R ------------------------------------------------------------------ + + +renv_envvars_list <- function() { + c( + "R_PROFILE", "R_PROFILE_USER", + "R_ENVIRON", "R_ENVIRON_USER", + "R_LIBS_USER", "R_LIBS_SITE", "R_LIBS" + ) +} + +renv_envvars_save <- function() { + + # save the common set of environment variables + keys <- renv_envvars_list() + vals <- Sys.getenv(keys, unset = "") + + # check for defaults that have already been set + defkeys <- paste("RENV_DEFAULT", keys, sep = "_") + defvals <- Sys.getenv(defkeys, unset = NA) + if (any(!is.na(defvals))) + return(FALSE) + + # prepare defaults + env <- vals + names(env) <- defkeys + do.call(Sys.setenv, as.list(env)) + + TRUE + +} + +renv_envvars_restore <- function() { + + # read defaults + keys <- renv_envvars_list() + defkeys <- paste("RENV_DEFAULT", renv_envvars_list(), sep = "_") + defvals <- Sys.getenv(defkeys, unset = "") + + # remove previously-unset environment variables + missing <- defvals == "" + Sys.unsetenv(keys[missing]) + + # restore old values for envvars + existing <- as.list(defvals[!missing]) + if (length(existing)) { + names(existing) <- sub("^RENV_DEFAULT_", "", names(existing)) + do.call(Sys.setenv, existing) + } + + # remove saved RENV_DEFAULT values + Sys.unsetenv(defkeys) + TRUE + +} + +renv_envvars_init <- function() { + renv_envvars_normalize() +} + +renv_envvars_normalize <- function() { + + Sys.setenv(R_LIBS_SITE = .expand_R_libs_env_var(Sys.getenv("R_LIBS_SITE"))) + Sys.setenv(R_LIBS_USER = .expand_R_libs_env_var(Sys.getenv("R_LIBS_USER"))) + + keys <- c( + "RENV_PATHS_ROOT", + "RENV_PATHS_LIBRARY", + "RENV_PATHS_LIBRARY_ROOT", + "RENV_PATHS_LIBRARY_STAGING", + "RENV_PATHS_LOCAL", + "RENV_PATHS_CELLAR", + "RENV_PATHS_SOURCE", + "RENV_PATHS_BINARY", + "RENV_PATHS_CACHE", + "RENV_PATHS_RTOOLS", + "RENV_PATHS_EXTSOFT", + "RENV_PATHS_MRAN" + ) + + envvars <- as.list(keep(Sys.getenv(), keys)) + if (empty(envvars)) + return() + + args <- lapply(envvars, renv_path_normalize) + do.call(Sys.setenv, args) + +} + + +# equip-macos.R -------------------------------------------------------------- + + +renv_equip_macos_specs <- function() { + + list( + + "4.0" = list( + url = "https://cran.r-project.org/bin/macosx/tools/clang-8.0.0.pkg", + dst = "/usr/local/clang8" + ), + + "3.7" = list( + url = "https://cran.r-project.org/bin/macosx/tools/clang-8.0.0.pkg", + dst = "/usr/local/clang8" + ), + + "3.6" = list( + url = "https://cran.r-project.org/bin/macosx/tools/clang-7.0.0.pkg", + dst = "/usr/local/clang7" + ), + + "3.5" = list( + url = "https://cran.r-project.org/bin/macosx/tools/clang-6.0.0.pkg", + dst = "/usr/local/clang6" + ) + + ) + +} + +renv_equip_macos_spec <- function(version = getRversion()) { + renv_equip_macos_specs()[[renv_version_maj_min(version)]] +} + +renv_equip_macos <- function() { + + renv_equip_macos_sdk() + renv_equip_macos_toolchain() + +} + +renv_equip_macos_sdk <- function() { + + sdk <- "/Library/Developer/CommandLineTools/SDKs/MacOSX.sdk" + if (file.exists(sdk) || file.exists("/usr/include")) + return(TRUE) + + system("/usr/bin/xcode-select --install") + + # give the user some time to respond to the dialog) + Sys.sleep(5) + +} + +renv_equip_macos_toolchain <- function() { + + if (getRversion() >= "4.1.0") + return() + + spec <- renv_equip_macos_spec() + if (is.null(spec)) { + fmt <- "no known toolchain recorded in renv for R %s" + warningf(fmt, getRversion()) + return(FALSE) + } + + url <- spec$url + dst <- spec$dst + + clang <- file.path(dst, "bin/clang") + if (file.exists(clang)) { + fmt <- "- LLVM toolchain for R %s is already installed at %s." + writef(fmt, getRversion(), shQuote(dst)) + return(TRUE) + } + + destfile <- file.path(tempdir(), basename(url)) + download(url, destfile = destfile) + + if (renv_equip_macos_rstudio(spec, destfile)) + return(TRUE) + + command <- paste("sudo /usr/sbin/installer -pkg", shQuote(destfile), "-target /") + caution_bullets( + "The R LLVM toolchain has been successfully downloaded. Please execute:", + command, + "in a separate terminal to complete installation." + ) + + TRUE + +} + +renv_equip_macos_rstudio <- function(spec, destfile) { + + rstudio <- + renv_rstudio_available() && + requireNamespace("rstudioapi", quietly = TRUE) + + if (!rstudio) + return(FALSE) + + command <- paste("sudo -kS /usr/sbin/installer -pkg", shQuote(destfile), "-target /") + prompt <- paste( + "Installation of the R LLVM toolchain requires sudo.", + "Please enter your account password.", + sep = "\n" + ) + + installed <- local({ + + password <- rstudioapi::askForPassword(prompt) + if (is.null(password)) + return(FALSE) + + status <- system(command, input = password) + if (status != 0L) + return(FALSE) + + TRUE + + }) + + if (!installed) + return(FALSE) + + caution_bullets( + "The R LLVM toolchain has been downloaded and installed to:", + spec$dst, + "This toolchain will be used by renv when installing packages from source." + ) + + return(TRUE) + +} + + +# equip.R -------------------------------------------------------------------- + + +#' Install required system libraries +#' +#' Equip your system with libraries commonly-used during compilation of +#' base and recommended \R packages. This was previously useful with older +#' versions of R on windows, but is no longer terribly helpful. +#' +#' @return This function is normally called for its side effects. +#' @export +#' @keywords internal +#' @examples +#' \dontrun{ +#' +#' # download useful build tools +#' renv::equip() +#' +#' } +equip <- function() { + + renv_scope_error_handler() + + case( + renv_platform_windows() ~ renv_equip_windows(), + renv_platform_macos() ~ renv_equip_macos(), + renv_platform_linux() ~ renv_equip_linux() + ) + + invisible(NULL) + +} + +renv_equip_windows <- function() { + invisible(renv_extsoft_install() && renv_extsoft_use()) +} + +renv_equip_linux <- function() { + stopf("renv::equip() not yet implemented for Linux") +} + + +# errors.R ------------------------------------------------------------------- + + +renv_error_format_srcref <- function(call, srcref) { + + srcfile <- attr(srcref, "srcfile", exact = TRUE) + + if (inherits(srcfile, c("srcfilecopy", "srcfilealias"))) { + start <- srcref[7L] + end <- srcref[8L] + } else { + start <- srcref[1L] + end <- srcref[3L] + } + + srclines <- getSrcLines(srcfile, start, end) + index <- regexpr("[^[:space:]]", srclines) + indent <- min(index) + code <- substring(srclines, indent) + + if (length(code) >= 8L) { + simplified <- renv_error_simplify(call) + if (!identical(simplified, call)) + code <- format(simplified) + } + + n <- length(code) + postfix <- sprintf("at %s#%i", basename(srcfile$filename), srcref[1L]) + code[n] <- paste(code[n], postfix) + + code + +} + +renv_error_simplify <- function(object) { + + case( + is.function(object) ~ renv_error_simplify_function(object), + is.recursive(object) ~ renv_error_simplify_recursive(object), + TRUE ~ object + ) + +} + +renv_error_simplify_function <- function(object) { + f <- function() {} + formals(f) <- formals(object) + body(f) <- quote({ ... }) + f +} + +renv_error_simplify_recursive <- function(object) { + + longcall <- renv_call_matches(object, name = "{") && length(object) >= 8 + + if (longcall) + return(quote(...)) + + for (i in seq_along(object)) + if (!is.null(object[[i]])) + object[[i]] <- renv_error_simplify(object[[i]]) + + object + +} + +renv_error_format <- function(calls, frames) { + + # first, format calls + formatted <- lapply(calls, function(call) { + + srcref <- attr(call, "srcref", exact = TRUE) + if (!is.null(srcref)) { + formatted <- catch(renv_error_format_srcref(call, srcref)) + if (!inherits(formatted, "error")) + return(formatted) + } + + if (is.function(call[[1]])) + return("(...)") + + format(renv_error_simplify(call)) + + }) + + # compute prefixes + numbers <- format(seq_along(formatted)) + prefixes <- sprintf("%s: ", rev(numbers)) + + # generate indent + indent <- paste(rep.int(" ", min(nchar(prefixes))), collapse = "") + + # attach prefixes + indent + annotated <- uapply(seq_along(formatted), function(i) { + code <- formatted[[i]] + prefix <- c(prefixes[[i]], rep.int(indent, length(code) - 1L)) + paste(prefix, code, sep = "") + }) + + header <- "Traceback (most recent calls last):" + c(header, annotated) + +} + +renv_error_find <- function(calls, frames) { + + for (i in rev(seq_along(frames))) { + + fn <- sys.function(which = i) + if (!identical(fn, stop)) + next + + frame <- frames[[i]] + args <- frame[["args"]] + if (is.null(args) || empty(args)) + next + + first <- args[[1L]] + if (!inherits(first, "condition")) + next + + return(first) + + } + +} + +renv_error_handler <- function(...) { + + calls <- head(sys.calls(), n = -1L) + frames <- head(sys.frames(), n = -1L) + + error <- renv_error_find(calls, frames) + if (identical(error$traceback, FALSE)) + return(character()) + + formatted <- renv_error_format(calls, frames) + caution(formatted) + + formatted + +} + +the$traceback <- NULL + +renv_error_capture <- function(e) { + calls <- head(sys.calls(), n = -2L) + frames <- head(sys.frames(), n = -2L) + traceback <- renv_error_format(calls, frames) + the$traceback <- traceback +} + +renv_error_tag <- function(e) { + e$traceback <- the$traceback + e +} + +renv_error_handler_call <- function() { + as.call(list(renv_error_handler)) +} + + +# extsoft.R ------------------------------------------------------------------ + + +renv_extsoft_curl_version <- function() { + Sys.getenv("RENV_EXTSOFT_CURL_VERSION", unset = "7.77.0") +} + +renv_extsoft_install <- function(quiet = FALSE) { + + extsoft <- renv_paths_extsoft() + + ensure_directory(extsoft) + ensure_directory(file.path(extsoft, "lib/i386")) + ensure_directory(file.path(extsoft, "lib/x64")) + + root <- "https://s3.amazonaws.com/rstudio-buildtools/extsoft" + + files <- c( + sprintf("curl-%s-win32-mingw.zip", renv_extsoft_curl_version()), + "glpk32.zip", + "glpk64.zip", + "local323.zip", + "nlopt-2.4.2.zip", + "spatial324.zip" + ) + + # check for missing installs + files <- Filter(renv_extsoft_install_required, files) + if (empty(files)) { + if (!quiet) writef("- External software is up to date.") + return(TRUE) + } + + if (interactive()) { + + caution_bullets( + "The following external software tools will be installed:", + files, + sprintf("Tools will be installed into %s.", renv_path_pretty(extsoft)) + ) + + cancel_if(!proceed()) + + } + + for (file in files) { + + # download the file + url <- file.path(root, file) + destfile <- renv_scope_tempfile("renv-archive-", fileext = ".zip") + download(url, destfile = destfile, quiet = quiet) + + # write manifest + manifest <- renv_extsoft_manifest_path(file) + ensure_parent_directory(manifest) + + before <- list.files(extsoft, recursive = TRUE) + + # unpack archive + if (file == "glpk32.zip") { + + unzip(destfile, files = "include/glpk.h", exdir = extsoft) + unzip(destfile, exdir = file.path(extsoft, "lib/i386"), junkpaths = TRUE) + + } else if (file == "glpk64.zip") { + + unzip(destfile, files = "include/glpk.h", exdir = extsoft) + unzip(destfile, exdir = file.path(extsoft, "lib/x64"), junkpaths = TRUE) + + } else if (file == "nlopt-2.4.2.zip") { + + unzip(destfile, exdir = extsoft) + + file.copy(file.path(extsoft, "nlopt-2.4.2/include"), extsoft, recursive = TRUE) + file.copy(file.path(extsoft, "nlopt-2.4.2/lib"), extsoft, recursive = TRUE) + unlink(file.path(extsoft, "nlopt-2.4.2"), recursive = TRUE) + + + } else { + + unzip(destfile, exdir = extsoft) + + } + + after <- list.files(extsoft, recursive = TRUE) + writeLines(setdiff(after, before), con = manifest) + + } + + writef("- External software successfully updated.") + TRUE + +} + +renv_extsoft_install_required <- function(file) { + + manifest <- renv_extsoft_manifest_path(file) + if (!file.exists(manifest)) + return(TRUE) + + files <- catch(readLines(manifest, warn = FALSE)) + if (inherits(files, "error")) + return(FALSE) + + paths <- renv_paths_extsoft(files) + !all(file.exists(paths)) + +} + +renv_extsoft_use <- function(quiet = FALSE) { + + extsoft <- renv_paths_extsoft() + path <- "~/.R/Makevars" + + ensure_parent_directory(path) + original <- if (file.exists(path)) + readLines(path, warn = FALSE) + else + character() + + contents <- original + + localsoft <- paste("LOCAL_SOFT", extsoft, sep = " = ") + contents <- inject(contents, "^#?LOCAL_SOFT", localsoft) + + localcpp <- "LOCAL_CPPFLAGS = -I\"$(LOCAL_SOFT)/include\"" + contents <- inject(contents, "^#?LOCAL_CPPFLAGS", localcpp) + + locallibs <- "LOCAL_LIBS = -L\"$(LOCAL_SOFT)/lib$(R_ARCH)\" -L\"$(LOCAL_SOFT)/lib\"" + contents <- inject(contents, "^#?LOCAL_LIBS", locallibs) + + libxml <- paste("LIB_XML", extsoft, sep = " = ") + contents <- inject(contents, "^#?LIB_XML", libxml) + + if (identical(original, contents)) + return(TRUE) + + if (interactive()) { + + caution_bullets( + "The following entries will be added to ~/.R/Makevars:", + c(localsoft, libxml, localcpp, locallibs), + "These tools will be used when compiling R packages from source." + ) + + cancel_if(!proceed()) + + } + + if (!quiet) writef("- '%s' has been updated.", path) + writeLines(contents, con = path) + TRUE + +} + +renv_extsoft_manifest_path <- function(file) { + name <- paste(file, "manifest", sep = ".") + renv_paths_extsoft("manifests", name) +} + + +# filebacked.R --------------------------------------------------------------- + + +# tools for caching values read from a file, and invalidating those values if +# the file mtime changes. use `renv_filebacked_set()` to associate some value +# with a file at a particular point in time; `renv_filebacked_get()` will return +# that value, or NULL of the file mtime has changed +the$filebacked_cache <- new.env(parent = emptyenv()) + +renv_filebacked_clear <- function(context, path = NULL) { + + # get cache associated with this context + envir <- renv_filebacked_envir(context) + + # list all available cached results + existing <- ls(envir = envir, all.names = TRUE) + + # if path is set, use it; otherwise remove everything + path <- path %||% existing + + # validate the requested paths exist in the environment + removable <- renv_vector_intersect(path, existing) + + # remove them + rm(list = removable, envir = envir) +} + +renv_filebacked_set <- function(context, path, value) { + + # validate the path + stopifnot(renv_path_absolute(path)) + + # create our cache entry + info <- renv_file_info(path) + entry <- list(value = value, info = info) + + # store it + envir <- renv_filebacked_envir(context) + assign(path, entry, envir = envir) + invisible(value) + +} + +renv_filebacked_get <- function(context, path) { + + # validate the path + if (!renv_path_absolute(path)) + stopf("internal error: '%s' is not an absolute path", path) + + # get contextd sub-environment + envir <- renv_filebacked_envir(context) + + # check for entry in the cache + entry <- envir[[path]] + if (is.null(entry)) + return(NULL) + + # extract pieces of interest + value <- entry$value + oldinfo <- entry$info + newinfo <- renv_file_info(path) + + # if the file didn't exist when we set the entry, + # check and see if it's still not there + if (is.na(oldinfo$isdir) && is.na(newinfo$isdir)) + return(value) + + # compare on fields of interest + fields <- c("size", "isdir", "mtime") + if (!identical(oldinfo[fields], newinfo[fields])) + return(NULL) + + # looks good + value + +} + +renv_filebacked_envir <- function(context) { + the$filebacked_cache[[context]] <- + the$filebacked_cache[[context]] %||% + new.env(parent = emptyenv()) +} + +filebacked <- function(context, path, callback, ...) { + + # don't use filebacked cache when disabled + config <- config$filebacked.cache() + if (identical(config, FALSE)) + return(callback(path, ...)) + + # check for cache entry -- if available, use it + cache <- renv_filebacked_get(context, path) + if (!is.null(cache)) + return(cache) + + # otherwise, generate our value and cache it + result <- callback(path, ...) + renv_filebacked_set(context, path, result) + + result + +} + +renv_filebacked_invalidate <- function(path) { + renv_scope_options(warn = -1L) + eapply(the$filebacked_cache, function(context) { + rm(list = path, envir = context) + }) +} + + +# files.R -------------------------------------------------------------------- + + +# NOTE: all methods here should either return TRUE if they were able to +# operate successfully, or throw an error if not +# +# TODO: some of these operations are a bit racy +renv_file_preface <- function(source, target, overwrite) { + + callback <- function() {} + if (!renv_file_exists(source)) + stopf("source file '%s' does not exist", source) + + if (overwrite) + callback <- renv_file_backup(target) + + if (renv_file_exists(target)) + stopf("target file '%s' already exists", target) + + callback + +} + +renv_file_copy <- function(source, target, overwrite = FALSE) { + + if (renv_file_same(source, target)) + return(TRUE) + + callback <- renv_file_preface(source, target, overwrite) + defer(callback()) + + # check to see if we're copying a plain file -- if so, things are simpler + if (dir.exists(source)) + renv_file_copy_dir(source, target) + else + renv_file_copy_file(source, target) + +} + +renv_file_copy_file <- function(source, target) { + + # copy to temporary path + tmpfile <- renv_scope_tempfile(".renv-copy-", tmpdir = dirname(target)) + status <- catchall(file.copy(source, tmpfile)) + if (inherits(status, "condition")) + stop(status) + + # move from temporary path to final target + status <- catchall(renv_file_move(tmpfile, target)) + if (inherits(status, "condition")) + stop(status) + + # validate that the target file exists + if (!renv_file_exists(target)) { + fmt <- "attempt to copy file %s to %s failed (unknown reason)" + stopf(fmt, renv_path_pretty(source), renv_path_pretty(target)) + } + + invisible(TRUE) + +} + +renv_file_copy_dir_robocopy <- function(source, target) { + renv_robocopy_copy(source, target) +} + +# TODO: the version of rsync distributed with macOS +# does not reliably copy file modified times, etc. +renv_file_copy_dir_rsync <- function(source, target) { + source <- sub("/*$", "/", source) + flags <- if (renv_platform_macos()) "-aAX" else "-a" + args <- c(flags, renv_shell_path(source), renv_shell_path(target)) + renv_system_exec("rsync", args, action = "copying directory") +} + +renv_file_copy_dir_cp <- function(source, target) { + + # ensure 'source' ends with a single trailing slash + source <- sub("/*$", "/", source) + + # ensure tildes are path-expanded + source <- path.expand(source) + target <- path.expand(target) + + # build 'cp' arguments + args <- c("-pPR", renv_shell_path(source), renv_shell_path(target)) + + # execute command + renv_system_exec("cp", args, action = "copying directory") + +} + +renv_file_copy_dir_r <- function(source, target) { + + # create sub-directory to host copy attempt + tempdir <- renv_scope_tempfile(".renv-copy-", tmpdir = dirname(target)) + ensure_directory(tempdir) + + # attempt to copy to generated folder + status <- catchall( + file.copy( + source, + tempdir, + recursive = TRUE, + copy.mode = TRUE, + copy.date = TRUE + ) + ) + + if (inherits(status, "error")) + stop(status) + + # R will copy the directory to a sub-directory in the + # requested folder with the same filename as the source + # folder, so peek into that folder to grab it and rename + tempfile <- file.path(tempdir, basename(source)) + status <- catchall(renv_file_move(tempfile, target)) + if (inherits(status, "condition")) + stop(status) + +} + +renv_file_copy_dir_impl <- function(source, target) { + + methods <- list( + cp = renv_file_copy_dir_cp, + r = renv_file_copy_dir_r, + robocopy = renv_file_copy_dir_robocopy, + rsync = renv_file_copy_dir_rsync + ) + + copy <- config$copy.method() + if (is.function(copy)) + return(copy(source, target)) + + method <- methods[[tolower(copy)]] + if (!is.null(method)) + return(method(source, target)) + + if (renv_platform_windows()) + renv_file_copy_dir_robocopy(source, target) + else if (renv_platform_unix()) + renv_file_copy_dir_cp(source, target) + else + renv_file_copy_dir_r(source, target) + + file.exists(target) + +} + +renv_file_copy_dir <- function(source, target) { + + # create temporary sub-directory + tmpdir <- dirname(target) + ensure_directory(tmpdir) + tempdir <- renv_scope_tempfile(".renv-copy-", tmpdir = tmpdir) + + # copy to that directory + status <- catchall(renv_file_copy_dir_impl(source, tempdir)) + if (inherits(status, "condition")) + stop(status) + + # move directory to final location + status <- catchall(renv_file_move(tempdir, target)) + if (inherits(status, "condition")) + stop(status) + + # validate that the target file exists + if (!renv_file_exists(target)) { + fmt <- "attempt to copy directory %s to %s failed (unknown reason)" + stopf(fmt, renv_path_pretty(source), renv_path_pretty(target)) + } + + invisible(TRUE) + +} + +renv_file_move <- function(source, target, overwrite = FALSE) { + + if (renv_file_same(source, target)) + return(TRUE) + + callback <- renv_file_preface(source, target, overwrite) + defer(callback()) + + # first, attempt to do a plain rename + # use catchall since this might fail for e.g. cross-device links + # (note that junction points on Windows will be copies as-is) + move <- catchall(file.rename(source, target)) + if (renv_file_exists(target)) + return(TRUE) + + # expand tildes + source <- path.expand(source) + target <- path.expand(target) + + # on unix, try using 'mv' command directly + # (can handle cross-device copies / moves a bit more efficiently) + if (renv_platform_unix()) { + args <- c(renv_shell_path(source), renv_shell_path(target)) + status <- catchall(system2("mv", args, stdout = FALSE, stderr = FALSE)) + if (renv_file_exists(target)) + return(TRUE) + } + + # on Windows, similarly try 'robocopy' command + # (should be faster than 'move' for large directories) + if (renv_platform_windows()) { + status <- catchall(renv_robocopy_move(source, target)) + if (renv_file_exists(target)) + return(TRUE) + } + + # nocov start + # rename failed; fall back to copying + # (and be sure to remove the source file / directory on success) + copy <- catchall(renv_file_copy(source, target, overwrite = overwrite)) + if (identical(copy, TRUE) && file.exists(target)) { + unlink(source, recursive = TRUE) + return(TRUE) + } + + # rename and copy both failed: inform the user + fmt <- stack() + fmt$push("could not copy / move file '%s' to '%s'") + if (inherits(move, "condition")) + fmt$push(paste("move:", conditionMessage(move))) + if (inherits(copy, "condition")) + fmt$push(paste("copy:", conditionMessage(copy))) + + text <- paste(fmt$data(), collapse = "\n") + stopf(text, source, target) + # nocov end + +} + +renv_file_link <- function(source, target, overwrite = FALSE) { + + if (renv_file_same(source, target)) + return(TRUE) + + callback <- renv_file_preface(source, target, overwrite) + defer(callback()) + + if (renv_platform_windows()) { + + # use junction points on Windows by default as symlinks + # are unreliable / un-deletable in some circumstances + status <- catchall(Sys.junction(source, target)) + if (identical(status, TRUE)) + return(TRUE) + + # if Sys.junction() fails, it may leave behind an empty + # directory. this may occur if the source and target files + # reside on different volumes. either way, remove an empty + # left-behind directory on failure + unlink(target, recursive = TRUE, force = TRUE) + + } else { + + # on non-Windows, we can try to create a symlink + status <- catchall(file.symlink(source, target)) + if (identical(status, TRUE)) + return(TRUE) + + } + + # all else fails, just perform a copy + renv_file_copy(source, target, overwrite = overwrite) + +} + +renv_file_junction <- function(source, target) { + + if (!renv_platform_windows()) + stopf("'renv_file_junction()' is only available on Windows") + + if (renv_file_exists(target)) + stopf("file '%s' already exists") + + status <- catchall(Sys.junction(source, target)) + if (inherits(status, "condition")) { + unlink(target, recursive = TRUE, force = TRUE) + stop(status) + } + + TRUE + +} + +renv_file_same <- function(source, target) { + + # if the paths are the same, we can return early + if (identical(source, target)) + return(TRUE) + + # check to see if they're equal after normalization + # (e.g. for symlinks pointing to same file) + source <- renv_path_normalize(source) + target <- renv_path_normalize(target) + if (identical(source, target)) + return(TRUE) + + # if either file is missing, return false + if (!renv_file_exists(source) || !renv_file_exists(target)) + return(FALSE) + + # for hard links + junction points, it's difficult to detect + # whether the two files point to the same object; use some + # heuristics to guess (note that these aren't perfect) + sinfo <- renv_file_info(source) + tinfo <- renv_file_info(target) + if (!identical(c(sinfo), c(tinfo))) + return(FALSE) + + TRUE + +} + +# NOTE: returns a callback which should be used in e.g. an defer handler +# to restore the file if the attempt to update the file failed +renv_file_backup <- function(path) { + + # if no file exists then nothing to backup + if (!renv_file_exists(path)) + return(function() {}) + + # normalize the path (since the working directory could change + # by the time the callback is invoked). note that the file may + # be a broken symlink so construct the path by normalizing the + # parent directory and building path relative to that + parent <- renv_path_normalize(dirname(path), mustWork = TRUE) + path <- file.path(parent, basename(path)) + + # attempt to rename the file + pattern <- sprintf(".renv-backup-%i-%s", Sys.getpid(), basename(path)) + tempfile <- tempfile(pattern, tmpdir = dirname(path)) + if (!renv_file_move(path, tempfile)) + return(function() {}) + + # return callback that will restore if needed + function() { + + if (!renv_file_exists(path)) + renv_file_move(tempfile, path) + else + unlink(tempfile, recursive = TRUE) + + } + +} + +renv_file_info <- function(paths, extra_cols = FALSE) { + suppressWarnings(file.info(paths, extra_cols = extra_cols)) +} + +renv_file_mode <- function(paths) { + suppressWarnings(file.mode(paths)) +} + +# NOTE: returns true for files that are broken symlinks +renv_file_exists <- function(path) { + + if (renv_platform_windows()) + renv_file_exists_win32(path) + else + renv_file_exists_unix(path) + +} + +renv_file_exists_win32 <- function(path) { + file.exists(path) +} + +renv_file_exists_unix <- function(path) { + !is.na(Sys.readlink(path)) | file.exists(path) +} + +renv_file_list <- function(path, full.names = TRUE) { + + # list files + files <- renv_file_list_impl(path) + + # NOTE: paths may be marked with UTF-8 encoding; + # if that's the case we need to use paste rather + # than file.path to preserve the encoding + if (full.names && length(files)) + files <- paste(path, files, sep = "/") + + files + +} + +renv_file_list_impl <- function(path) { + if (renv_platform_unix()) + renv_file_list_impl_unix(path) + else + renv_file_list_impl_win32(path) +} + +renv_file_list_impl_unix <- function(path) { + list.files(path, all.files = TRUE, no.. = TRUE) +} + +# nocov start +renv_file_list_impl_win32 <- function(path) { + + # first, try a plain list.files to see if we can get away with that + files <- list.files(path, all.files = TRUE, no.. = TRUE) + if (!any(grepl("?", files, fixed = TRUE))) + return(files) + + # otherwise, try some madness ... + # + # change working directory (done just to avoid encoding issues + # when submitting path to cmd shell) + renv_scope_wd(path) + + # NOTE: a sub-shell is required here in some contexts; e.g. when running + # tests non-interactively or building in the RStudio pane + command <- paste(comspec(), "/U /C dir /B") + conn <- pipe(command, open = "rb", encoding = "native.enc") + defer(close(conn)) + + # read binary output from connection + output <- stack() + + while (TRUE) { + + data <- readBin(conn, what = "raw", n = 1024L) + if (empty(data)) + break + + output$push(data) + + } + + # join into single raw vector + encoded <- unlist(output$data(), recursive = FALSE, use.names = FALSE) + + # convert raw data (encoded as UTF-16LE) to UTF-8 + converted <- iconv(list(encoded), from = "UTF-16LE", to = "UTF-8") + + # split on (Windows) newlines + paths <- strsplit(converted, "\r\n", fixed = TRUE)[[1]] + + # just in case? + paths[nzchar(paths)] + +} +# nocov end + +renv_file_type <- function(paths, symlinks = TRUE) { + + info <- renv_file_info(paths) + + types <- character(length(paths)) + types[info$isdir %in% FALSE] <- "file" + types[info$isdir %in% TRUE ] <- "directory" + + if (symlinks && !renv_platform_windows()) { + links <- Sys.readlink(paths) + types[!is.na(links) & nzchar(links)] <- "symlink" + } + + types + +} + +# nocov start +renv_file_edit <- function(path) { + + # https://github.com/rstudio/renv/issues/44 + dlls <- getLoadedDLLs() + if (is.null(dlls[["(embedding)"]])) + return(utils::file.edit(path)) + + routines <- getDLLRegisteredRoutines("(embedding)") + routine <- routines[[".Call"]][["rs_editFile"]] + if (is.null(routine)) + return(utils::file.edit(path)) + + do.call(.Call, list(routine, path, PACKAGE = "(embedding)")) + +} +# nocov end + +renv_file_find <- function(path, predicate) { + + # canonicalize path + # (note: don't normalize as we don't want to follow symlinks) + path <- renv_path_canonicalize(path) + parent <- dirname(path) + + # compute number of slashes + # (avoid searching beyond home directory, unless we're virtualized) + virtualized <- renv_virtualization_type() != "native" + slashes <- gregexpr("/", path, fixed = TRUE)[[1L]] + n <- length(slashes) - if (virtualized) 0L else 2L + + for (i in 1:n) { + + if (file.exists(path)) { + status <- predicate(path) + if (!is.null(status)) + return(status) + } + + path <- parent + parent <- dirname(path) + + } + + predicate(path) + +} + +renv_file_read <- function(path) { + renv_scope_options(warn = -1L) + contents <- readLines(path, warn = FALSE, encoding = "UTF-8") + paste(contents, collapse = "\n") +} + +renv_file_shebang <- function(path) { + + # NOTE: we use 'condition' as a cheap way to capture both errors and warnings + # since 'file()' may just report a warning rather than an error if it fails + # to open a file due to inadequate permissions + tryCatch( + renv_file_shebang_impl(path), + condition = function(e) "" + ) + +} + +renv_file_shebang_impl <- function(path) { + + renv_scope_options(warn = -1L) + + # open connection to file + con <- file(path, open = "rb", encoding = "native.enc") + defer(close(con)) + + # validate file starts with '#!' -- read using 'raw' vector to avoid + # issues which files that might start with null bytes + bytes <- readBin(con, what = "raw", n = 2L) + expected <- as.raw(c(0x23L, 0x21L)) + if (!identical(bytes, expected)) + return("") + + # read a single line from the connection + readLines(con, n = 1L, warn = FALSE) + +} + +# here, 'broken' implies a file which is a link pointing to a file that +# doesn't exist, so only returns true if the file is "link"-y and the +# file it points to doesn't exist +renv_file_broken <- function(paths) { + if (renv_platform_unix()) + renv_file_broken_unix(paths) + else + renv_file_broken_win32(paths) +} + +renv_file_broken_unix <- function(paths) { + # a symlink is broken if: + # - the file is a symlink (tested via Sys.readlink) + # - the file it points to does not exist (tested via file.exists) + !is.na(Sys.readlink(paths)) & !file.exists(paths) +} + +renv_file_broken_win32 <- function(paths) { + # TODO: the behavior of file.exists() for a broken junction point + # appears to have changed in the development version of R; + # we have to be extra careful here... + if (getRversion() < "4.2.0") { + info <- renv_file_info(paths) + (info$isdir %in% TRUE) & is.na(info$mtime) + } else { + file.access(paths, mode = 0L) == 0L & !file.exists(paths) + } +} + +renv_file_size <- function(path) { + file.info(path, extra_cols = FALSE)$size +} + +renv_file_remove <- function(paths) { + if (renv_platform_windows()) + renv_file_remove_win32(paths) + else + renv_file_remove_unix(paths) +} + +renv_file_remove_win32 <- function(paths) { + for (path in paths) { + command <- paste("rmdir /S /Q", renv_shell_path(path)) + shell(command) + } +} + +renv_file_remove_unix <- function(paths) { + unlink(paths, recursive = TRUE, force = TRUE) +} + +renv_file_writable <- function(path) { + + # allow users to opt-out just in case + override <- getOption("renv.download.check_writable", default = TRUE) + if (!identical(override, TRUE)) + return(TRUE) + + # if we're given the path to a file, use the parent directory instead + info <- renv_file_info(path) + if (!identical(info$isdir, TRUE)) + path <- dirname(path) + + # if we still don't have a directory, bail + info <- renv_file_info(path) + if (!identical(info$isdir, TRUE)) + return(FALSE) + + # try creating and removing a temporary file in this directory + tempfile <- renv_scope_tempfile(".renv-write-test-", tmpdir = path) + ok <- dir.create(tempfile, showWarnings = FALSE) + + # return ok if we succeeded + ok + +} + + +# git.R ---------------------------------------------------------------------- + + +git <- function() { + + gitpath <- Sys.which("git") + if (!nzchar(gitpath)) + stop("failed to find git executable on the PATH") + + gitpath + +} + + +renv_git_preflight <- function() { + if (!nzchar(Sys.which("git"))) + stopf("'git' is not available on the PATH") +} + +renv_git_root <- function(project) { + + project <- renv_path_normalize(project) + renv_file_find(project, function(parent) { + gitroot <- file.path(parent, ".git") + if (file.exists(gitroot)) + return(gitroot) + }) + +} + + +# graph.R -------------------------------------------------------------------- + + +#' Generate a Package Dependency Graph +#' +#' Generate a package dependency graph. +#' +#' @inheritParams renv-params +#' +#' @param root The top-most package dependencies of interest in the dependency graph. +#' +#' @param leaf The bottom-most package dependencies of interest in the dependency graph. +#' +#' @param suggests Should suggested packages be included within +#' the dependency graph? +#' +#' @param enhances Should enhanced packages be included within +#' the dependency graph? +#' +#' @param resolver An \R function accepting a package name, and returning the +#' contents of its `DESCRIPTION` file (as an \R `data.frame` or `list`). +#' When `NULL` (the default), an internal resolver is used. +#' +#' @param renderer Which package should be used to render the resulting graph? +#' +#' @param attributes An \R list of graphViz attributes, mapping node names to +#' attribute key-value pairs. For example, to ask graphViz to prefer orienting +#' the graph from left to right, you can use `list(graph = c(rankdir = "LR"))`. +#' +#' @examples +#' +#' \dontrun{ +#' # graph the relationship between devtools and rlang +#' graph(root = "devtools", leaf = "rlang") +#' +#' # figure out why a project depends on 'askpass' +#' graph(leaf = "askpass") +#' } +#' +#' @keywords internal +graph <- function(root = NULL, + leaf = NULL, + ..., + suggests = FALSE, + enhances = FALSE, + resolver = NULL, + renderer = c("DiagrammeR", "visNetwork"), + attributes = list(), + project = NULL) +{ + renv_scope_error_handler() + project <- renv_project_resolve(project) + + # figure out packages to try and read + root <- root %||% renv_graph_roots(project) + + # resolve fields + fields <- c( + "Depends", "Imports", "LinkingTo", + if (suggests) "Suggests", + if (enhances) "Enhances" + ) + + # resolve renderer + renderer <- renv_graph_renderer(renderer) + + # find dependencies + envir <- new.env(parent = emptyenv()) + revdeps <- new.env(parent = emptyenv()) + for (package in root) + renv_graph_build(package, fields, resolver, envir, revdeps) + + # prune the tree + tree <- renv_graph_prune(root, leaf, envir, revdeps) + + # compute the graph + graph <- enumerate(tree, function(package, dependencies) { + + enumerate(dependencies, function(field, packages) { + attrs <- renv_graphviz_attrs(field, renderer) + renv_graphviz_edge(package, packages, attrs) + }) + + }) + + # figure out which packages remain part of the graph after pruning + ok <- map_lgl(graph, function(items) { + any(map_int(items, length) > 0) + }) + + remaining <- intersect(root, names(graph)[ok]) + if (empty(remaining)) { + fmt <- "- Could not find any relationship between the requested packages." + writef(fmt) + return(invisible(NULL)) + } + + defaults <- renv_graphviz_defaults(renderer) + attributes <- overlay(defaults, attributes) + + # render attributes + attrtext <- renv_graphviz_render(attributes, TRUE) + + # fill package names which are top-level dependencies + topattrs <- renv_graphviz_render( + map(named(remaining), function(name) { + list( + style = "filled", + fillcolor = "#b3cde3" + ) + }), + asis = FALSE + ) + + botattrs <- renv_graphviz_render( + map(named(leaf), function(name) { + list( + style = "filled", + fillcolor = "#ccebc5" + ) + }), + asis = FALSE + ) + + # collapse into text + parts <- c( + 'digraph {', '', + attrtext, '', + topattrs, '', + botattrs, '', + unlist(graph), '', + '}' + ) + + diagram <- paste(parts, collapse = "\n") + + renderer <- case( + + identical(renderer, "DiagrammeR") ~ function(dot) { + DiagrammeR <- renv_namespace_load("DiagrammeR") + DiagrammeR$grViz(diagram = dot) + }, + + identical(renderer, "visNetwork") ~ function(dot) { + + visNetwork <- renv_namespace_load("visNetwork") + graph <- visNetwork$visNetwork(dot = dot) + + graph$x$options$edges$font$background <- "white" + + # TODO: allow hierarchical layout via option? + # graph$x$options$layout = list( + # hierarchical = list( + # blockShifting = TRUE, + # levelSeparation = 50, + # nodeSpacing = 1, + # shakeTowards = "roots", + # sortMethod = "directed" + # ) + # ) + + graph + + }, + + is.function(renderer) ~ renderer, + + ~ stop("unrecognized renderer") + + ) + + renderer(diagram) +} + +renv_graph_build <- function(package, fields, resolver, envir, revdeps) { + + # check if we've already scanned this package + if (exists(package, envir = envir)) + return() + + # read package dependencies + deps <- renv_graph_dependencies(package, fields, resolver) + + # add dependencies to graph + assign(package, deps, envir = envir) + + # recurse + children <- sort(unique(unlist(deps))) + for (child in children) { + assign(child, c(package, revdeps[[child]]), envir = revdeps) + renv_graph_build(child, fields, resolver, envir, revdeps) + } + +} + +renv_graph_revdeps <- function(packages, revdeps) { + + envir <- new.env(parent = emptyenv()) + for (package in packages) + renv_graph_revdeps_impl(package, envir, revdeps) + + ls(envir = envir) + +} + +renv_graph_revdeps_impl <- function(package, envir, revdeps) { + + if (visited(package, envir)) + return() + + for (child in revdeps[[package]]) + renv_graph_revdeps_impl(child, envir, revdeps) + +} + +renv_graph_roots <- function(project) { + + deps <- renv_dependencies_impl(project, errors = "ignored") + sort(unique(deps$Package)) + +} + +renv_graph_dependencies <- function(package, fields, resolver) { + + base <- installed_packages(priority = "base") + + desc <- local({ + + # try using the resolver if supplied + if (!is.null(resolver)) { + desc <- catch(resolver(package)) + if (inherits(desc, "error")) + warning(desc) + else if (!is.null(desc)) + return(desc) + } + + # check for (and prefer) a locally-installed package + path <- renv_package_find(package) + if (nzchar(path)) + return(renv_description_read(path)) + + # otherwise, try and see if this is a known CRAN package + as.list(renv_available_packages_entry(package)) + + }) + + # parse the fields + values <- map(fields, function(field) { + + item <- desc[[field]] + if (is.null(item)) + return(NULL) + + parsed <- renv_description_parse_field(item) + packages <- parsed$Package + + setdiff(packages, c("R", base$Package)) + + }) + + names(values) <- fields + values + +} + +renv_graph_prune <- function(root, leaf, envir, revdeps) { + + # grab all computed dependencies + all <- as.list(envir) + + # if we don't have any leaves, then just return everything + if (empty(leaf)) + return(all) + + # otherwise, find recursive dependencies of the requested packages + rrd <- renv_graph_revdeps(leaf, revdeps) + map(all, function(children) { + map(children, intersect, rrd) + }) + +} + +renv_graphviz_node <- function(nodes, asis, attrs) { + + keys <- names(attrs) + vals <- renv_json_quote(attrs) + attrtext <- paste(keys, vals, sep = "=", collapse = ", ") + + fmt <- if (asis) '%s [%s]' else '"%s" [%s]' + sprintf(fmt, nodes, attrtext) + +} + +renv_graphviz_edge <- function(lhs, rhs, attrs) { + + if (empty(lhs) || empty(rhs)) + return(character()) + + keys <- names(attrs) + vals <- renv_json_quote(attrs) + attrtext <- paste(keys, vals, sep = "=", collapse = ", ") + + fmt <- '"%s" -> "%s" [%s]' + sprintf(fmt, lhs, rhs, attrtext) + +} + +renv_graphviz_attrs <- function(field, renderer) { + + dil <- "#c0c0c0" + + defaults <- list( + + Depends = list( + color = dil, + style = "solid" + ), + + Imports = list( + color = dil, + style = "solid" + ), + + LinkingTo = list( + color = dil, + style = "dashed" + ), + + Suggests = list( + color = "darkgreen", + style = "dashed" + ), + + Enhances = list( + color = "darkblue", + style = "dashed" + ) + + ) + + attrs <- defaults[[field]] + if (identical(renderer, "visNetwork")) { + + extra <- c( + font.align = "middle" + ) + + attrs <- c(attrs, extra) + + } + + attrs + +} + +renv_graphviz_defaults <- function(renderer) { + + case( + identical(renderer, "visNetwork") ~ renv_graphviz_defaults_visnetwork(), + identical(renderer, "DiagrammeR") ~ renv_graphviz_defaults_diagrammer(), + ) + +} + +renv_graphviz_defaults_visnetwork <- function() { + + list( + + node = list( + style = "filled", + shape = "ellipse", + color = "black", + fillcolor = "#e5d8bd", + fontname = "Helvetica" + ) + + ) + +} + +renv_graphviz_defaults_diagrammer <- function() { + + list( + + graph = list( + nodesep = 0.10 + ), + + node = list( + style = "filled", + shape = "ellipse", + fillcolor = "#e5d8bd", + fontname = "Helvetica" + ) + + ) + +} + +renv_graphviz_render <- function(attributes, asis) { + + rendered <- enumerate(attributes, function(key, value) { + + if (is.null(names(value))) { + lhs <- if (asis) key else renv_json_quote(key) + rhs <- renv_graphviz_render_value(value) + if (length(lhs) && length(rhs)) + paste(lhs, rhs, sep = " = ") + } else { + keys <- names(value) + vals <- renv_graphviz_render_value(value) + fmt <- if (asis) '%s [%s]' else '"%s" [%s]' + sprintf(fmt, key, paste(keys, vals, sep = "=", collapse = ", ")) + } + + }) + + unlist(rendered, recursive = TRUE, use.names = FALSE) + +} + +renv_graphviz_render_value <- function(value) { + if (is.numeric(value)) + format(value) + else if (is.logical(value)) + tolower(as.character(value)) + else + renv_json_quote(value) +} + +renv_graph_renderer <- function(renderer) { + + # allow functions as-is + if (is.function(renderer)) + return(renderer) + + # otherwise, match + renderer <- match.arg(renderer, choices = c("DiagrammeR", "visNetwork")) + if (!renv_package_installed(renderer)) { + fmt <- "package '%s' is required to render graphs but is not installed" + stopf(fmt, renderer) + } + + renderer + +} + + + +# hash.R --------------------------------------------------------------------- + + +renv_hash_text <- function(text) { + renv_bootstrap_hash_text(text) +} + +renv_hash_description <- function(path) { + filebacked( + context = "renv_hash_description", + path = path, + callback = renv_hash_description_impl + ) +} + +renv_hash_description_impl <- function(path) { + + dcf <- case( + is.character(path) ~ renv_description_read(path), + is.list(path) ~ path, + ~ stop("unexpected path '%s'", path) + ) + + # include default fields + fields <- c( + "Package", "Version", "Title", "Author", "Maintainer", "Description", + "Depends", "Imports", "Suggests", "LinkingTo" + ) + + # add remotes fields + remotes <- renv_hash_description_remotes(dcf) + + # retrieve these fields + subsetted <- dcf[renv_vector_intersect(c(fields, remotes), names(dcf))] + + # sort names (use C locale to ensure consistent ordering) + ordered <- subsetted[csort(names(subsetted))] + + # write to tempfile (use binary connection to ensure unix-style + # newlines for cross-platform hash stability) + tempfile <- tempfile("renv-description-hash-") + contents <- paste(names(ordered), ordered, sep = ": ", collapse = "\n") + + # remove whitespace -- it's possible that tools (e.g. Packrat) that + # mutate a package's DESCRIPTION file may also inadvertently change + # the structure of whitespace within some fields; that whitespace is + # normally not semantically meaningful so we remove that so such + # DESCRIPTIONS can obtain the same hash value. (this ultimately + # arises as 'write.dcf()' allows both 'indent' and 'width' to be + # configured based on the 'width' option) + contents <- gsub("[[:space:]]", "", contents) + + # create the file connection (use binary so that unix newlines are used + # across platforms, for more stable hashing) + con <- file(tempfile, open = "wb") + + # write to the file + writeLines(enc2utf8(contents), con = con, useBytes = TRUE) + + # flush to ensure we've written to file + flush(con) + + # close the connection and remove the file + close(con) + + # ready for hasing + hash <- unname(tools::md5sum(tempfile)) + + # remove the old file + unlink(tempfile) + + # return hash + invisible(hash) + +} + +renv_hash_description_remotes <- function(dcf) { + + type <- dcf[["RemoteType"]] + if (is.null(type)) + return(character()) + + if (type == "standard") + return(character()) + + grep("^Remote", names(dcf), value = TRUE) + +} + + +# history.R ------------------------------------------------------------------ + + +#' View and revert to a historical lockfile +#' +#' @description +#' `history()` uses your version control system to show prior versions of the +#' lockfile and `revert()` allows you to restore one of them. +#' +#' These functions are currently only implemented for projects that use git. +#' +#' @inherit renv-params +#' +#' @export +#' +#' @return `history()` returns a `data.frame` summarizing the commits in which +#' `renv.lock` has been changed. `revert()` is usually called for its +#' side-effect but also invisibly returns the `commit` used. +#' +#' @examples +#' \dontrun{ +#' +#' # get history of previous versions of renv.lock in VCS +#' db <- renv::history() +#' +#' # choose an older commit +#' commit <- db$commit[5] +#' +#' # revert to that version of the lockfile +#' renv::revert(commit = commit) +#' +#' } +history <- function(project = NULL) { + + renv_scope_error_handler() + + project <- renv_project_resolve(project) + renv_project_lock(project = project) + + lockpath <- renv_lockfile_path(project) + if (!file.exists(lockpath)) + return(data_frame()) + + renv_git_preflight() + + renv_scope_wd(project) + + args <- c("log", "--pretty=format:%H\031%at\031%ct\031%s", renv_shell_path(lockpath)) + data <- renv_system_exec("git", args, action = "retrieving git log") + + parts <- strsplit(data, "\031", fixed = TRUE) + tbl <- bind(parts, names = c("commit", "author_date", "committer_date", "subject")) + tbl$author_date <- as.POSIXct(as.numeric(tbl$author_date), origin = "1970-01-01") + tbl$committer_date <- as.POSIXct(as.numeric(tbl$committer_date), origin = "1970-01-01") + + tbl + +} + +#' @param commit The commit associated with a prior version of the lockfile. +#' @param ... Optional arguments; currently unused. +#' @export +#' @rdname history +revert <- function(commit = "HEAD", ..., project = NULL) { + + renv_scope_error_handler() + renv_dots_check(...) + + project <- renv_project_resolve(project) + renv_project_lock(project = project) + + renv_git_preflight() + + renv_scope_wd(project) + + lockpath <- renv_lockfile_path(project = project) + system2("git", c("checkout", commit, "--", renv_shell_path(lockpath))) + system2("git", c("reset", "HEAD", renv_shell_path(lockpath)), stdout = FALSE, stderr = FALSE) + system2("git", c("diff", "--", renv_shell_path(lockpath))) + + writef("- renv.lock from commit %s has been checked out.", commit) + invisible(commit) + +} + + +# homebrew.R ----------------------------------------------------------------- + + +renv_homebrew_root <- function() { + + # allow override + root <- Sys.getenv("RENV_HOMEBREW_ROOT", unset = NA) + if (!is.na(root)) + return(root) + + # indirection for arm64 macOS + if (renv_platform_macos() && renv_platform_machine() != "x86_64") + return("/opt/homebrew") + + # default to /usr/local + "/usr/local" + +} + + +# http.R --------------------------------------------------------------------- + + +renv_http_useragent <- function() { + agent <- getOption("renv.http.useragent", default = getOption("HTTPUserAgent")) + agent %||% renv_http_useragent_default() +} + +renv_http_useragent_default <- function() { + version <- getRversion() + platform <- with(R.version, paste(version, platform, arch, os)) + sprintf("R/%s R (%s)", version, platform) +} + + +# hydrate.R ------------------------------------------------------------------ + + +#' Copy packages from user libraries to a project library +#' +#' @description +#' `hydrate()` installs missing packages from a user library into the project +#' library. `hydrate()` is called automatically by [init()], and it is rare +#' that you should need it otherwise, as it can easily get your project into +#' an inconsistent state. +#' +#' It may very occasionally be useful to call `hydate(update = "all")` if you +#' want to update project packages to match those installed in your global +#' library (as opposed to using [update()] which will get the latest versions +#' from CRAN). In this case, you should verify that your code continues to work, +#' then call [snapshot()] to record updated package versions in the lockfile. +#' +#' @inherit renv-params +#' +#' @param packages The set of \R packages to install. When `NULL`, the +#' packages found by [dependencies()] are used. +#' +#' @param library The \R library to be hydrated. When `NULL`, the active +#' library as reported by `.libPaths()` is used. +#' +#' @param repos The \R repositories to be used. If the project depends on any +#' \R packages which cannot be found within the user library paths, then +#' those packages will be installed from these repositories instead. +#' +#' @param update Boolean; should `hydrate()` attempt to update already-installed +#' packages if the requested package is already installed in the project +#' library? Set this to `"all"` if you'd like _all_ packages to be refreshed +#' from the source library if possible. +#' +#' @param sources A vector of library paths where renv should look for packages. +#' When `NULL` (the default), `hydrate()` will look in the system libraries +#' (the user library, the site library and the default library) then the +#' renv cache. +#' +#' If a package is not found in any of these locations, `hydrate()` +#' will try to install it from the active R repositories. +#' +#' @param prompt Boolean; prompt the user before taking any action? Ignored +#' when `report = FALSE`. +#' +#' @param report Boolean; display a report of what packages will be installed +#' by `renv::hydrate()`? +#' +#' @return A named \R list, giving the packages that were used for hydration +#' as well as the set of packages which were not found. +#' +#' @export +#' +#' @keywords internal +#' +#' @examples +#' \dontrun{ +#' +#' # hydrate the active library +#' renv::hydrate() +#' +#' } +hydrate <- function(packages = NULL, + ..., + library = NULL, + repos = getOption("repos"), + update = FALSE, + sources = NULL, + prompt = interactive(), + report = TRUE, + project = NULL) +{ + renv_scope_error_handler() + renv_dots_check(...) + + project <- renv_project_resolve(project) + renv_project_lock(project = project) + renv_scope_verbose_if(prompt) + + renv_activate_prompt("hydrate", library, prompt, project) + + renv_scope_options(repos = repos) + library <- renv_path_normalize(library %||% renv_libpaths_active()) + packages <- packages %||% renv_hydrate_packages(project) + + # find packages used in this project, and the dependencies of those packages + deps <- renv_hydrate_dependencies(project, packages, sources) + + # remove 'renv' since it's managed separately + deps$renv <- NULL + + # remove base + missing packages + base <- renv_packages_base() + missing <- deps[!nzchar(deps)] + packages <- deps[renv_vector_diff(names(deps), c(names(missing), base))] + + # figure out if we will copy or link + linkable <- renv_cache_linkable(project = project, library = library) + + # get and construct path to library + ensure_directory(library) + + # only hydrate with packages that are either not currently installed, + # or (if update = TRUE) the version in the library is newer + packages <- renv_hydrate_filter(packages, library, update) + + # inform user about changes + if (report) { + renv_hydrate_report(packages, missing, linkable) + if (length(packages) || length(missing)) + cancel_if(prompt && !proceed()) + } + + # check for nothing to be done + if (empty(packages) && empty(missing)) { + if (report) + writef("- No new packages were discovered in this project; nothing to do.") + return(invisible(list(packages = list(), missing = list()))) + } + + # copy packages from user library to cache + before <- Sys.time() + if (length(packages)) { + if (linkable) + renv_hydrate_link_packages(packages, library, project) + else + renv_hydrate_copy_packages(packages, library, project) + } + after <- Sys.time() + + if (report) { + time <- difftime(after, before, units = "auto") + fmt <- "- Hydrated %s packages in %s." + writef(fmt, length(packages), renv_difftime_format(time)) + } + + # attempt to install missing packages (if any) + missing <- renv_hydrate_resolve_missing(project, library, missing) + + # we're done! + result <- list(packages = packages, missing = missing) + invisible(result) +} + +renv_hydrate_filter <- function(packages, library, update) { + + # run filter + keep <- enumerate( + packages, + renv_hydrate_filter_impl, + library = library, + update = update, + FUN.VALUE = logical(1) + ) + + # filter based on kept packages + packages[keep] + +} + +renv_hydrate_filter_impl <- function(package, path, library, update) { + + # if user has requested hydration of all packages, respect that + if (identical(update, "all")) + return(TRUE) + + # is the package already installed in the requested library? + # if not, then we'll want to hydrate this package + # if so, we'll want to compare the version first and + # hydrate only if the requested version is newer than the current + descpath <- file.path(library, package, "DESCRIPTION") + if (file.exists(descpath)) { + desc <- catch(renv_description_read(path = descpath)) + if (inherits(desc, "error")) + return(TRUE) + } + + # get the current package version + current <- catch(numeric_version(desc[["Version"]])) + if (inherits(current, "error")) + return(TRUE) + + # if the package is already installed and we're not updating, stop here + if (identical(update, FALSE)) + return(FALSE) + + # check to-be-copied package version + requested <- catch({ + desc <- renv_description_read(path = path) + numeric_version(desc[["Version"]]) + }) + + # only hydrate with a newer version + requested > current + +} + +renv_hydrate_packages <- function(project) { + renv_snapshot_dependencies(project, dev = TRUE) +} + +renv_hydrate_dependencies <- function(project, + packages = NULL, + libpaths = NULL) +{ + ignored <- renv_project_ignored_packages(project = project) + packages <- renv_vector_diff(packages, ignored) + libpaths <- libpaths %||% renv_hydrate_libpaths() + renv_package_dependencies(packages, libpaths = libpaths, project = project) +} + +# NOTE: we don't want to look in user / site libraries when testing +# on CRAN, as we may accidentally find versions of packages available +# on CRAN but not that we want to use during tests +renv_hydrate_libpaths <- function() { + + conf <- config$hydrate.libpaths() + if (is.character(conf) && length(conf)) + conf <- unlist(strsplit(conf, ":", fixed = TRUE)) + + libpaths <- case( + renv_tests_running() ~ character(), + length(conf) ~ conf, + ~ c( + renv_libpaths_default(), + renv_libpaths_user(), + renv_libpaths_site(), + renv_libpaths_system() + ) + ) + + libpaths <- .expand_R_libs_env_var(libpaths) + unique(renv_path_normalize(libpaths)) + +} + +# takes a package called 'package' installed at location 'location', +# copies that package into the cache, and then links from the cache +# to the (private) library 'library' +renv_hydrate_link_package <- function(package, location, library) { + + # construct path to cache + record <- catch(renv_snapshot_description(location)) + if (inherits(record, "error")) + return(FALSE) + + cache <- renv_cache_find(record) + if (!nzchar(cache)) + return(FALSE) + + # copy package into the cache + if (!file.exists(cache)) { + ensure_parent_directory(cache) + renv_file_copy(location, cache) + } + + # link package back from cache to library + target <- file.path(library, package) + ensure_parent_directory(target) + renv_file_link(cache, target, overwrite = TRUE) + +} + +renv_hydrate_link_packages <- function(packages, library, project) { + + if (renv_path_same(library, renv_paths_library(project = project))) + printf("- Linking packages into the project library ... ") + else + printf("- Linking packages into %s ... ", renv_path_pretty(library)) + + callback <- renv_progress_callback(renv_hydrate_link_package, length(packages)) + cached <- enumerate(packages, callback, library = library) + writef("Done!") + cached + +} + +# takes a package called 'package' installed at location 'location', +# and copies it to the library 'library' +renv_hydrate_copy_package <- function(package, location, library) { + target <- file.path(library, package) + renv_file_copy(location, target, overwrite = TRUE) +} + +renv_hydrate_copy_packages <- function(packages, library, project) { + + if (renv_path_same(library, renv_paths_library(project = project))) + printf("- Copying packages into the project library ... ") + else + printf("- Copying packages into %s ... ", renv_path_pretty(library)) + + callback <- renv_progress_callback(renv_hydrate_copy_package, length(packages)) + copied <- enumerate(packages, callback, library = library) + writef("Done!") + copied +} + +renv_hydrate_resolve_missing <- function(project, library, na) { + + # make sure requested library is made active + # + # note that we only want to place the requested library on the library path; + # we want to ensure that all required packages are hydrated into the + # reqeusted library + # + # https://github.com/rstudio/renv/issues/1177 + ensure_directory(library) + renv_scope_libpaths(library) + + # figure out which packages are missing (if any) + packages <- names(na) + installed <- installed_packages(lib.loc = library) + if (all(packages %in% installed$Package)) + return() + + writef("- Resolving missing dependencies ... ") + + # define a custom error handler for packages which we cannot retrieve + errors <- stack() + handler <- function(package, action) { + error <- catch(action) + if (inherits(error, "error")) + errors$push(list(package = package, error = error)) + } + + # perform the restore + renv_scope_restore( + project = project, + library = library, + packages = packages, + handler = handler + ) + + records <- retrieve(packages) + renv_install_impl(records) + + # if we failed to restore anything, warn the user + data <- errors$data() + if (empty(data)) + return() + + if (renv_verbose()) { + + text <- map_chr(data, function(item) { + package <- item$package + message <- conditionMessage(item$error) + short <- trunc(paste(message, collapse = ";"), 60L) + sprintf("[%s]: %s", package, short) + }) + + caution_bullets( + "The following package(s) were not installed successfully:", + text, + "You may need to manually download and install these packages." + ) + + } + + invisible(data) + +} + +renv_hydrate_report <- function(packages, na, linkable) { + + if (renv_bootstrap_tests_running()) + return() + + if (length(packages)) { + + # this is mostly a hacky way to get a list of records that the existing + # record pretty-printer can handle in a clean way + records <- enumerate(packages, function(package, library) { + descpath <- file.path(library, "DESCRIPTION") + record <- renv_snapshot_description(descpath) + record$Repository <- NULL + record$Source <- renv_path_aliased(dirname(library)) + record + }) + + preamble <- "The following packages were discovered:" + postamble <- sprintf( + "They will be %s into the project library.", + if (linkable) "linked" else "copied" + ) + + formatter <- function(lhs, rhs) { + renv_record_format_short(rhs, versioned = TRUE) + } + + renv_pretty_print_records_pair( + preamble = preamble, + old = list(), + new = records, + postamble = postamble, + formatter = formatter + ) + + } + + if (length(na)) { + caution_bullets( + "The following packages are used in this project, but not available locally:", + csort(names(na)), + "renv will attempt to download and install these packages." + ) + } + +} + + +# id.R ----------------------------------------------------------------------- + + +renv_id_path <- function(project) { + file.path(project, "renv/project-id") +} + +renv_id_generate <- function() { + + methods <- list( + renv_id_generate_r, + renv_id_generate_kernel, + renv_id_generate_uuidgen, + renv_id_generate_cscript, + renv_id_generate_powershell, + renv_id_generate_csc + ) + + for (method in methods) { + id <- catch(method()) + if (is.character(id) && length(id) == 1 && nzchar(id)) { + id <- toupper(id) + return(id) + } + } + + stop("could not generate project id for this system") + +} + +renv_id_generate_kernel <- function() { + + uuidpath <- "/proc/sys/kernel/random/uuid" + if (!file.exists(uuidpath)) { + fmt <- "%s does not exist on this operating system" + stopf(fmt, renv_path_pretty(uuidpath)) + } + + readLines(uuidpath, n = 1L, warn = FALSE) + +} + +renv_id_generate_uuidgen <- function() { + + if (!nzchar(Sys.which("uuidgen"))) { + fmt <- "program %s does not exist on this system" + stopf(fmt, shQuote("uuidgen")) + } + + system("uuidgen", intern = TRUE) + +} + +renv_id_generate_cscript <- function() { + + if (!renv_platform_windows()) { + fmt <- "this method is only available on Windows" + stopf(fmt) + } + + if (!nzchar(Sys.which("cscript.exe"))) { + fmt <- "could not find cscript.exe" + stopf(fmt) + } + + # create temporary directory + dir <- renv_scope_tempfile("renv-id-") + dir.create(dir) + + # move to it + renv_scope_wd(dir) + + # write helper script + script <- c( + "set object = CreateObject(\"Scriptlet.TypeLib\")", + "WScript.StdOut.WriteLine object.GUID" + ) + + # invoke it + writeLines(script, con = "uuid.vbs") + args <- c("//NoLogo", "uuid.vbs") + id <- renv_system_exec("cscript.exe", args, "generating UUID") + + # remove braces + gsub("(?:^\\{|\\}$)", "", id) + +} + +renv_id_generate_powershell <- function() { + + if (!renv_platform_windows()) { + fmt <- "this method is only available on Windows" + stopf(fmt) + } + + if (!nzchar(Sys.which("powershell.exe"))) { + fmt <- "could not find powershell.exe" + stopf(fmt) + } + + command <- "[guid]::NewGuid().ToString()" + args <- c("-Command", shQuote(command)) + renv_system_exec("powershell.exe", args, "generating UUID") + +} + +renv_id_generate_r <- function() { + + if ("uuid" %in% loadedNamespaces()) + return(uuid::UUIDgenerate()) + + libpaths <- c( + .libPaths(), + renv_libpaths_user(), + renv_libpaths_site(), + renv_libpaths_system() + ) + + if (!requireNamespace("uuid", lib.loc = libpaths, quietly = TRUE)) + stop("could not load package 'uuid'") + + id <- uuid::UUIDgenerate() + catchall(unloadNamespace("uuid")) + id + +} + +renv_id_generate_csc <- function() { + + csc <- local({ + + csc <- Sys.which("csc.exe") + if (nzchar(csc)) + return(csc) + + frameworks <- file.path( + Sys.getenv("SYSTEMDRIVE", unset = "C:"), + "Windows/Microsoft.NET", + c("Framework", "Framework64") + ) + + versions <- list.files(frameworks, full.names = TRUE) + candidates <- file.path(versions, "csc.exe") + candidates[file.exists(candidates)] + + }) + + if (empty(csc) || !file.exists(csc)) + stop("could not find csc.exe") + + + code <- " +class GenerateUUID { + static void Main(string[] args) { + System.Console.WriteLine(System.Guid.NewGuid().ToString()); + } +} +" + + renv_scope_tempdir("renv-uuid-") + writeLines(code, con = "program.cs") + + renv_system_exec( + csc[[1]], + c("/nologo", "/out:program.exe", "program.cs"), + "compiling uuid helper" + ) + + renv_system_exec("program.exe", character(), "generating uuid") + +} + + +# imbue.R -------------------------------------------------------------------- + + +#' Imbue an renv Installation +#' +#' Imbue an renv installation into a project, thereby making the requested +#' version of renv available within. +#' +#' Normally, this function does not need to be called directly by the user; it +#' will be invoked as required by [init()] and [activate()]. +#' +#' @inherit renv-params +#' +#' @param version The version of renv to install. If `NULL`, the version +#' of renv currently installed will be used. The requested version of +#' renv will be retrieved from the renv public GitHub repository, +#' at . +#' +#' @param quiet Boolean; avoid printing output during install of renv? +#' +imbue <- function(project = NULL, + version = NULL, + quiet = FALSE) +{ + renv_scope_error_handler() + project <- renv_project_resolve(project) + + renv_scope_options(renv.verbose = !quiet) + + vtext <- version %||% renv_metadata_version() + writef("Installing renv [%s] ...", vtext) + status <- renv_imbue_impl(project, version) + writef("- Done! renv has been successfully installed.") + + invisible(status) + +} + +renv_imbue_impl <- function(project, + library = NULL, + version = NULL, + force = FALSE) +{ + # don't imbue during tests unless explicitly requested + if (renv_tests_running() && !force) + return(NULL) + + # resolve library path + library <- library %||% renv_paths_library(project = project) + ensure_directory(library) + + # NULL version means imbue this version of renv + if (is.null(version)) + return(renv_imbue_self(project, library = library)) + + # otherwise, try to download and install the requested version + # of renv from GitHub + remote <- paste("rstudio/renv", version %||% "main", sep = "@") + record <- renv_remotes_resolve(remote) + records <- list(renv = record) + + renv_scope_restore( + project = project, + library = library, + records = records, + packages = "renv", + recursive = FALSE + ) + + records <- retrieve("renv") + renv_install_impl(records) + + record <- records[["renv"]] + invisible(record) +} + +renv_imbue_self <- function(project, + library = NULL, + source = NULL) +{ + # construct source, target paths + # (check if 'renv' is loaded to handle embedded case) + source <- source %||% { + if ("renv" %in% loadedNamespaces()) { + renv_namespace_path("renv") + } else { + renv_package_find("renv") + } + } + + if (!file.exists(source)) + stop("internal error: could not find where 'renv' is installed") + + library <- library %||% renv_paths_library(project = project) + target <- file.path(library, "renv") + if (renv_file_same(source, target)) + return(TRUE) + + type <- renv_package_type(source, quiet = TRUE) + case( + type == "source" ~ renv_imbue_self_source(source, target), + type == "binary" ~ renv_imbue_self_binary(source, target) + ) + +} + +renv_imbue_self_source <- function(source, target) { + + # if the package already exists, just skip + if (file.exists(target)) + return(TRUE) + + # otherwise, install it + library <- dirname(target) + ensure_directory(library) + r_cmd_install("renv", source, library) + +} + +renv_imbue_self_binary <- function(source, target) { + ensure_parent_directory(target) + renv_file_copy(source, target, overwrite = TRUE) +} + + +# imports.R ------------------------------------------------------------------ + + +#' @importFrom tools +#' file_ext pskill psnice write_PACKAGES +#' +#' @importFrom utils +#' adist available.packages browseURL citation contrib.url download.file +#' download.packages file.edit getCRANmirrors head help install.packages +#' installed.packages modifyList old.packages packageDescription +#' packageVersion read.table remove.packages Rprof sessionInfo summaryRprof +#' str tail tar toBibtex untar update.packages unzip URLencode zip +NULL + + +# index.R -------------------------------------------------------------------- + + +the$index <- new.env(parent = emptyenv()) + +index <- function(scope, key = NULL, value = NULL, limit = 3600L) { + + enabled <- renv_index_enabled(scope, key) + if (!enabled) + return(value) + + # resolve the root directory + root <- renv_paths_index(scope) + + # make sure the directory we're indexing exists + memoize( + key = root, + value = ensure_directory(root, umask = "0") + ) + + # make sure the directory is readable / writable + # otherwise, attempts to lock will fail + # https://github.com/rstudio/renv/issues/1171 + if (!renv_index_writable(root)) + return(value) + + # resolve other variables + key <- if (!is.null(key)) renv_index_encode(key) + now <- as.integer(Sys.time()) + + # acquire index lock + lockfile <- file.path(root, "index.lock") + renv_scope_lock(lockfile) + + # load the index file + index <- tryCatch(renv_index_load(root, scope), error = identity) + if (inherits(index, "error")) + return(value) + + # return index as-is when key is NULL + if (is.null(key)) + return(index) + + # check for an index entry, and return it if it exists + item <- renv_index_get(root, scope, index, key, now, limit) + if (!is.null(item)) + return(item) + + # otherwise, update the index + renv_index_set(root, scope, index, key, value, now, limit) + +} + +renv_index_load <- function(root, scope) { + + filebacked( + context = "renv_index_load", + path = file.path(root, "index.json"), + callback = renv_index_load_impl + ) + +} + +renv_index_load_impl <- function(path) { + + json <- tryCatch( + withCallingHandlers( + renv_json_read(path), + warning = function(w) invokeRestart("muffleWarning") + ), + error = identity + ) + + if (inherits(json, "error")) { + unlink(path) + return(list()) + } + + json + +} + +renv_index_get <- function(root, scope, index, key, now, limit) { + + # check for index entry + entry <- index[[key]] + if (is.null(entry)) + return(NULL) + + # see if it's expired + if (renv_index_expired(entry, now, limit)) + return(NULL) + + # check for in-memory cached value + value <- the$index[[scope]][[key]] + if (!is.null(value)) + return(value) + + # otherwise, try to read from disk + data <- file.path(root, entry$data) + if (!file.exists(data)) + return(NULL) + + # read data from disk + value <- readRDS(data) + + # add to in-memory cache + the$index[[scope]] <- + the$index[[scope]] %||% + new.env(parent = emptyenv()) + + the$index[[scope]][[key]] <- value + + # return value + value + +} + +renv_index_set <- function(root, scope, index, key, value, now, limit) { + + # force promises + force(value) + + # files being written here should be shared + renv_scope_umask("0") + + # write data into index + data <- tempfile("data-", tmpdir = root, fileext = ".rds") + ensure_parent_directory(data) + saveRDS(value, file = data, version = 2L) + + # clean up stale entries + index <- renv_index_clean(root, scope, index, now, limit) + + # add index entry + index[[key]] <- list(time = now, data = basename(data)) + + # update index file + path <- file.path(root, "index.json") + ensure_parent_directory(path) + + # write to tempfile and then copy to minimize risk of collisions + tempfile <- tempfile(".index-", tmpdir = dirname(path), fileext = ".json") + renv_json_write(index, file = tempfile) + file.rename(tempfile, path) + + # return value + value + +} + +renv_index_encode <- function(key) { + key <- stringify(key) + memoize(key, renv_hash_text(key)) +} + +renv_index_clean <- function(root, scope, index, now, limit) { + + # figure out what cache entries have expired + ok <- enum_lgl( + index, + renv_index_clean_impl, + root = root, + scope = scope, + index = index, + now = now, + limit = limit + ) + + # return the existing cache entries + index[ok] + +} + +renv_index_clean_impl <- function(key, entry, root, scope, index, now, limit) { + + # check if cache entry has expired + expired <- renv_index_expired(entry, now, limit) + if (!expired) + return(TRUE) + + # remove from in-memory cache + cache <- the$index[[scope]] + cache[[key]] <- NULL + + # remove from disk + unlink(file.path(root, entry$data), force = TRUE) + + FALSE + +} + +renv_index_expired <- function(entry, now, limit) { + now - entry$time >= limit +} + +renv_index_enabled <- function(scope, key) { + getOption("renv.index.enabled", default = TRUE) +} + +renv_index_writable <- function(root) { + memoize( + key = root, + value = unname(file.access(root, 7L) == 0L) + ) +} + +# in case of emergency, break glass +renv_index_reset <- function(root = NULL) { + root <- root %||% renv_paths_index() + lockfiles <- list.files(root, pattern = "^index\\.lock$", full.names = TRUE) + unlink(lockfiles) +} + + +# infrastructure.R ----------------------------------------------------------- + + +# tools for writing / removing renv-related infrastructure +renv_infrastructure_write <- function(project = NULL, + profile = NULL, + version = NULL) +{ + # don't do anything in embedded mode + if (renv_metadata_embedded()) + return() + + project <- renv_project_resolve(project) + + renv_infrastructure_write_profile(project, profile = profile) + renv_infrastructure_write_rprofile(project) + renv_infrastructure_write_rbuildignore(project) + renv_infrastructure_write_gitignore(project) + renv_infrastructure_write_activate(project, version = version) +} + +renv_infrastructure_write_profile <- function(project, profile = NULL) { + + path <- renv_paths_renv("profile", profile = FALSE, project = project) + profile <- renv_profile_normalize(profile) + if (is.null(profile)) + return(unlink(path)) + + ensure_parent_directory(path) + writeLines(profile, con = path) + +} + +renv_infrastructure_write_rprofile <- function(project) { + + if (!config$autoloader.enabled()) + return() + + # NOTE: intentionally leave project NULL to compute relative path + path <- renv_paths_activate(project = NULL) + add <- sprintf("source(%s)", renv_json_quote(path)) + + renv_infrastructure_write_entry_impl( + add = add, + remove = character(), + file = file.path(project, ".Rprofile"), + create = TRUE + ) + +} + +renv_infrastructure_write_rbuildignore <- function(project) { + + lines <- c("^renv$", "^renv\\.lock$") + + if (file.exists(file.path(project, "requirements.txt"))) + lines <- c(lines, "^requirements\\.txt$") + + if (file.exists(file.path(project, "environment.yml"))) + lines <- c(lines, "^environment\\.yml$") + + renv_infrastructure_write_entry_impl( + add = lines, + remove = character(), + file = file.path(project, ".Rbuildignore"), + create = renv_project_type(project) == "package" + ) + +} + +renv_infrastructure_write_gitignore <- function(project) { + + if (!settings$vcs.manage.ignores()) + return() + + add <- stack(mode = "character") + remove <- stack(mode = "character") + + stk <- if (settings$vcs.ignore.library()) add else remove + stk$push("library/") + + stk <- if (settings$vcs.ignore.local()) add else remove + stk$push("local/") + + stk <- if (settings$vcs.ignore.cellar()) add else remove + stk$push("cellar/") + + add$push("lock/", "python/", "sandbox/", "staging/") + + renv_infrastructure_write_entry_impl( + add = as.character(add$data()), + remove = as.character(remove$data()), + file = renv_paths_renv(".gitignore", project = project), + create = TRUE + ) + +} + +renv_infrastructure_write_activate <- function(project = NULL, + version = NULL, + create = TRUE) +{ + project <- renv_project_resolve(project) + version <- version %||% renv_activate_version(project) + sha <- attr(version, "sha", exact = TRUE) + + source <- system.file("resources/activate.R", package = "renv") + target <- renv_paths_activate(project = project) + + if (!create && !file.exists(target)) + return(FALSE) + + template <- renv_file_read(source) + new <- renv_template_replace( + text = template, + replacements = list( + version = stringify(as.character(version)), + sha = stringify(sha) + ), + format = "..%s.." + ) + + if (file.exists(target)) { + old <- renv_file_read(target) + if (old == new) + return(TRUE) + } + + ensure_parent_directory(target) + writeLines(new, con = target) +} + + +renv_infrastructure_write_entry_impl <- function(add, remove, file, create) { + + # check to see if file doesn't exist + if (!file.exists(file)) { + + # if we're not forcing file creation, just bail + if (!create) + return(TRUE) + + # otherwise, write the file + ensure_parent_directory(file) + writeLines(add, con = file) + return(TRUE) + + } + + # if the file already has the requested line, nothing to do + before <- readLines(file, warn = FALSE) + after <- before + + # add requested entries + for (item in rev(add)) { + + # check to see if the requested line exists (either commented + # or uncommented). if it exists, we'll attempt to uncomment + # any commented lines + cpattern <- sprintf("^\\s*#?\\s*\\Q%s\\E\\s*(?:#|\\s*$)", item) + matches <- grepl(cpattern, after, perl = TRUE) + if (any(matches)) + after[matches] <- gsub("^(\\s*)#\\s*", "\\1", after[matches]) + else + after <- c(item, after) + + } + + # remove requested entries + for (item in rev(remove)) { + pattern <- sprintf("^\\s*\\Q%s\\E\\s*(?:#|\\s*$)", item) + matches <- grepl(pattern, after, perl = TRUE) + if (any(matches)) { + replacement <- gsub("^(\\s*)", "\\1# ", after[matches], perl = TRUE) + after[matches] <- replacement + } + } + + # write to file if we have changes + if (!identical(before, after)) + writeLines(after, con = file) + + TRUE + +} + + + +renv_infrastructure_remove <- function(project = NULL) { + project <- renv_project_resolve(project) + + renv_infrastructure_remove_rprofile(project) + renv_infrastructure_remove_rbuildignore(project) + + unlink(file.path(project, "renv"), recursive = TRUE) +} + + +renv_infrastructure_remove_rprofile <- function(project) { + + # NOTE: intentionally leave project NULL to compute relative path + path <- renv_paths_activate(project = NULL) + line <- sprintf("source(%s)", renv_json_quote(path)) + + renv_infrastructure_remove_entry_impl( + line = line, + file = file.path(project, ".Rprofile"), + removable = TRUE + ) + +} + +renv_infrastructure_remove_rbuildignore <- function(project) { + + renv_infrastructure_remove_entry_impl( + line = "^renv$", + file = file.path(project, ".Rbuildignore"), + removable = FALSE + ) + +} + +renv_infrastructure_remove_entry_impl <- function(line, file, removable) { + + # if the file doesn't exist, nothing to do + if (!file.exists(file)) + return(TRUE) + + # find and comment out the line + contents <- readLines(file, warn = FALSE) + pattern <- sprintf("^\\s*\\Q%s\\E\\s*(?:#|\\s*$)", line) + matches <- grepl(pattern, contents, perl = TRUE) + + # if this file is removable, check to see if we matched all non-blank + # lines; if so, remove the file + if (removable) { + rest <- contents[!matches] + if (all(grepl("^\\s*$", rest))) + return(unlink(file)) + } + + # otherwise, just mutate the file + replacement <- gsub("^(\\s*)", "\\1# ", contents[matches], perl = TRUE) + contents[matches] <- replacement + writeLines(contents, con = file) + + TRUE + +} + + + + +# init.R --------------------------------------------------------------------- + + +the$init_running <- FALSE + +#' Use renv in a project +#' +#' @description +#' Call `renv::init()` to start using renv in the current project. This will: +#' +#' 1. Set up project infrastructure (as described in [scaffold()]) including +#' the project library and the `.Rprofile` that ensures renv will be +#' used in all future sessions. +#' +#' 1. Discover the packages that are currently being used in your project and +#' install them into the project library (as described in [hydrate()]). +#' +#' 1. Create a lockfile that records the state of the project library so it +#' can be restored by others (as described in [snapshot()]). +#' +#' 1. Restarts R (if running inside RStudio). +#' +#' If you call `init()` on a project that already uses renv, it will attempt +#' to do the right thing: it will restore the project library if it's missing, +#' or otherwise ask you what to do. +#' +#' # Repositories +#' +#' If the default \R repositories have not already been set, renv will use +#' the [Posit Public Package Manager](https://packagemanager.posit.co/) CRAN +#' mirror for package installation. The primary benefit to using this mirror is +#' that it can provide pre-built binaries for \R packages on a variety of +#' commonly-used Linux distributions. This behavior can be configured or +#' disabled if desired -- see the options in [renv::config()] for more details. +#' +#' @inherit renv-params +#' +#' @param project The project directory. When `NULL` (the default), the current +#' working directory will be used. The \R working directory will be +#' changed to match the requested project directory. +#' +#' @param settings A list of [settings] to be used with the newly-initialized +#' project. +#' +#' @param bare Boolean; initialize the project without attempting to discover +#' and install R package dependencies? +#' +#' @param force Boolean; force initialization? By default, renv will refuse +#' to initialize the home directory as a project, to defend against accidental +#' mis-usages of `init()`. +#' +#' @param repos The \R repositories to be used in this project. +#' See **Repositories** for more details. +#' +#' @param bioconductor The version of Bioconductor to be used with this project. +#' Setting this may be appropriate if renv is unable to determine that your +#' project depends on a package normally available from Bioconductor. Set this +#' to `TRUE` to use the default version of Bioconductor recommended by the +#' BiocManager package. +#' +#' @param load Boolean; should the project be loaded after it is initialized? +#' +#' @param restart Boolean; attempt to restart the \R session after initializing +#' the project? A session restart will be attempted if the `"restart"` \R +#' option is set by the frontend embedding \R. +#' +#' @export +#' +#' @example examples/examples-init.R +init <- function(project = NULL, + ..., + profile = NULL, + settings = NULL, + bare = FALSE, + force = FALSE, + repos = NULL, + bioconductor = NULL, + load = TRUE, + restart = interactive()) +{ + renv_consent_check() + renv_scope_error_handler() + renv_dots_check(...) + + renv_scope_binding(the, "init_running", TRUE) + + project <- renv_path_normalize(project %||% getwd()) + renv_project_lock(project = project) + + # initialize profile + if (!is.null(profile)) + renv_profile_set(profile) + + # normalize repos + repos <- renv_repos_normalize(repos %||% renv_init_repos()) + + # form path to lockfile, library + library <- renv_paths_library(project = project) + lockfile <- renv_lockfile_path(project) + + # ask user what type of project this is + type <- settings$snapshot.type %||% renv_init_type(project) + settings$snapshot.type <- type + + # initialize bioconductor pieces + biocver <- renv_init_bioconductor(bioconductor, project) + if (!is.null(biocver)) { + + # make sure a Bioconductor package manager is installed + renv_bioconductor_init(library = library) + + # retrieve bioconductor repositories appropriate for this project + repos <- renv_bioconductor_repos(project = project, version = biocver) + + # notify user + writef("- Using Bioconductor version '%s'.", biocver) + settings[["bioconductor.version"]] <- biocver + + } + + # prepare and move into project directory + renv_init_validate_project(project, force) + renv_init_settings(project, settings) + + # for bare inits, just activate the project + if (bare) { + renv_imbue_impl(project) + return(renv_init_fini(project, profile, load, restart)) + } + + # compute and cache dependencies to (a) reveal problems early and (b) compute once + deps <- renv_snapshot_dependencies(project, type = type, dev = TRUE) + + # determine appropriate action + action <- renv_init_action(project, library, lockfile, bioconductor) + cancel_if(empty(action) || identical(action, "cancel")) + + # compute library paths for this project + libpaths <- renv_init_libpaths(project = project) + + # perform the action + if (action == "init") { + renv_scope_options(renv.config.dependency.errors = "ignored") + renv_imbue_impl(project, library = library) + hydrate(library = library, repos = repos, prompt = FALSE, report = FALSE, project = project) + snapshot(library = libpaths, repos = repos, prompt = FALSE, project = project) + } else if (action == "restore") { + ensure_directory(library) + restore(project = project, library = libpaths, repos = repos, prompt = FALSE) + } + + # activate the newly-hydrated project + renv_init_fini(project, profile, load, restart) + +} + +renv_init_fini <- function(project, profile, load, restart) { + + renv_activate_impl( + project = project, + profile = profile, + version = renv_metadata_version(), + load = load, + restart = restart + ) + + invisible(project) + +} + +renv_init_action <- function(project, library, lockfile, bioconductor) { + + # if the user has asked for bioconductor, treat this as a re-initialization + if (!is.null(bioconductor)) + return("init") + + # figure out appropriate action + case( + + # if both the library and lockfile exist, ask user for intended action + file.exists(lockfile) + ~ renv_init_action_conflict_lockfile(project, library, lockfile), + + # if a private library exists but no lockfile, ask whether we should use it + file.exists(library) + ~ renv_init_action_conflict_library(project, library, lockfile), + + # otherwise, we just want to initialize the project + ~ "init" + + ) + +} + +renv_init_action_conflict_lockfile <- function(project, library, lockfile) { + + if (!interactive()) + return("nothing") + + title <- "This project already has a lockfile. What would you like to do?" + choices <- c( + restore = "Restore the project from the lockfile.", + init = "Discard the lockfile and re-initialize the project.", + nothing = "Activate the project without snapshotting or installing any packages.", + cancel = "Abort project initialization." + ) + + selection <- tryCatch( + utils::select.list(choices, title = title, graphics = FALSE), + interrupt = identity + ) + + if (inherits(selection, "interrupt")) + return(NULL) + + names(selection) + +} + +renv_init_action_conflict_library <- function(project, library, lockfile) { + + if (!interactive()) + return("nothing") + + # if the project library exists, but it's empty, or only renv is installed, + # treat this as a request to initialize the project + # https://github.com/rstudio/renv/issues/1668 + db <- installed_packages(lib.loc = library, priority = NA_character_) + if (nrow(db) == 0L || identical(db$Package, "renv")) + return("init") + + title <- "This project already has a private library. What would you like to do?" + choices <- c( + nothing = "Activate the project and use the existing library.", + init = "Re-initialize the project with a new library.", + cancel = "Abort project initialization." + ) + + selection <- tryCatch( + utils::select.list(choices, title = title, graphics = FALSE), + interrupt = identity + ) + + if (inherits(selection, "interrupt")) + return(NULL) + + names(selection) + +} + +renv_init_validate_project <- function(project, force) { + + # allow all project directories when force = TRUE + if (force) + return(TRUE) + + # disallow attempts to initialize renv in the home directory + home <- path.expand("~/") + msg <- if (renv_file_same(project, home)) + "refusing to initialize project in home directory" + else if (renv_path_within(home, project)) + sprintf("refusing to initialize project in directory '%s'", project) + + if (!is.null(msg)) { + msg <- paste(msg, "-- use renv::init(force = TRUE) to override") + stopf(msg) + } + +} + +renv_init_settings <- function(project, settings) { + + defaults <- renv_settings_get(project) + merged <- renv_settings_merge(defaults, settings) + renv_settings_persist(project, merged) + invisible(merged) + +} + +renv_init_bioconductor <- function(bioconductor, project) { + + # if we're re-initializing a project that appears to depend + # on Bioconductor, then use the latest Bioconductor release + if (is.null(bioconductor)) { + lockpath <- renv_paths_lockfile(project = project) + if (file.exists(lockpath)) { + lockfile <- renv_lockfile_read(lockpath) + bioconductor <- !is.null(lockfile$Bioconductor) + } + } + + # resolve bioconductor argument + case( + is.character(bioconductor) ~ bioconductor, + identical(bioconductor, TRUE) ~ renv_bioconductor_version(project, refresh = TRUE), + identical(bioconductor, FALSE) ~ NULL + ) + +} + +renv_init_repos <- function() { + + # if PPM is disabled, just use default repositories + repos <- convert(getOption("repos"), "list") + if (!renv_ppm_enabled()) + return(repos) + + enabled <- config$ppm.default() + if (!enabled) + return(repos) + + # if we're using the global CDN from RStudio, use PPM instead + rstudio <- attr(repos, "RStudio", exact = TRUE) + if (identical(rstudio, TRUE)) { + repos[["CRAN"]] <- config$ppm.url() + return(repos) + } + + # otherwise, check for some common 'default' CRAN settings + cran <- repos[["CRAN"]] + if (is.character(cran) && length(cran) == 1L) { + cran <- sub("/*$", "", cran) + defaults <- c( + "@CRAN@", + "https://cloud.R-project.org", + "https://cran.rstudio.com", + "https://cran.rstudio.org" + ) + + if (tolower(cran) %in% tolower(defaults)) { + repos[["CRAN"]] <- config$ppm.url() + return(repos) + } + + } + + # repos appears to have been configured separately; just use it + repos + +} + +renv_init_type <- function(project) { + + # check if the user has already requested a snapshot type + type <- renv_settings_get(project, name = "snapshot.type", default = NULL) + if (!is.null(type)) + return(type) + + # if we don't have a DESCRIPTION file, use the default + if (!file.exists(file.path(project, "DESCRIPTION"))) + return(settings$snapshot.type(project = project)) + + # otherwise, ask the user if they want to explicitly enumerate their + # R package dependencies in the DESCRIPTION file + choice <- menu( + + title = c( + "This project contains a DESCRIPTION file.", + "Which files should renv use for dependency discovery in this project?" + ), + + choices = c( + explicit = "Use only the DESCRIPTION file. (explicit mode)", + implicit = "Use all files in this project. (implicit mode)" + ) + + ) + + if (identical(choice, "cancel")) + cancel() + + writef("- Using '%s' snapshot type. Please see `?renv::snapshot` for more details.\n", choice) + choice + +} + + +# install.R ------------------------------------------------------------------ + + +# an explicitly-requested package type in a call to 'install()' +the$install_pkg_type <- NULL + +# an explicitly-requested dependencies field in a call to 'install()' +the$install_dependency_fields <- NULL + +# the formatted width of installation steps printed to the console +the$install_step_width <- 48L + +#' Install packages +#' +#' @description +#' Install one or more \R packages, from a variety of remote sources. +#' `install()` uses the same machinery as [restore()] (i.e. it uses cached +#' packages where possible) but it does not respect the lockfile, instead +#' installing the latest versions available from CRAN. +#' +#' See `vignette("package-install")` for more details. +#' +#' # `Remotes` +#' +#' `install()` (called without arguments) will respect the `Remotes` field +#' of the `DESCRIPTION` file (if present). This allows you to specify places +#' to install a package other than the latest version from CRAN. +#' See for details. +#' +#' # Bioconductor +#' +#' Packages from Bioconductor can be installed by using the `bioc::` prefix. +#' For example, +#' +#' ``` +#' renv::install("bioc::Biobase") +#' ``` +#' +#' will install the latest-available version of Biobase from Bioconductor. +#' +#' renv depends on BiocManager (or, for older versions of \R, BiocInstaller) +#' for the installation of packages from Bioconductor. If these packages are +#' not available, renv will attempt to automatically install them before +#' fulfilling the installation request. +#' +#' @inherit renv-params +#' +#' @param packages Either `NULL` (the default) to install all packages required +#' by the project, or a character vector of packages to install. renv +#' supports a subset of the remotes syntax used for package installation, +#' e.g: +#' +#' * `pkg`: install latest version of `pkg` from CRAN. +#' * `pkg@version`: install specified version of `pkg` from CRAN. +#' * `username/repo`: install package from GitHub +#' * `bioc::pkg`: install `pkg` from Bioconductor. +#' +#' See and the examples +#' below for more details. +#' +#' renv deviates from the remotes spec in one important way: subdirectories +#' are separated from the main repository specification with a `:`, not `/`. +#' So to install from the `subdir` subdirectory of GitHub package +#' `username/repo` you'd use `"username/repo:subdir`. +#' +#' @param exclude Packages which should not be installed. `exclude` is useful +#' when using `renv::install()` to install all dependencies in a project, +#' except for a specific set of packages. +#' +#' @return A named list of package records which were installed by renv. +#' +#' @export +#' +#' @examples +#' \dontrun{ +#' +#' # install the latest version of 'digest' +#' renv::install("digest") +#' +#' # install an old version of 'digest' (using archives) +#' renv::install("digest@@0.6.18") +#' +#' # install 'digest' from GitHub (latest dev. version) +#' renv::install("eddelbuettel/digest") +#' +#' # install a package from GitHub, using specific commit +#' renv::install("eddelbuettel/digest@@df55b00bff33e945246eff2586717452e635032f") +#' +#' # install a package from Bioconductor +#' # (note: requires the BiocManager package) +#' renv::install("bioc::Biobase") +#' +#' # install a package, specifying path explicitly +#' renv::install("~/path/to/package") +#' +#' # install packages as declared in the project DESCRIPTION file +#' renv::install() +#' +#' } +install <- function(packages = NULL, + ..., + exclude = NULL, + library = NULL, + type = NULL, + rebuild = FALSE, + repos = NULL, + prompt = interactive(), + dependencies = NULL, + project = NULL) +{ + renv_consent_check() + renv_scope_error_handler() + + # allow user to provide additional package names as part of '...' + if (!missing(...)) { + dots <- list(...) + names(dots) <- names(dots) %||% rep.int("", length(dots)) + packages <- c(packages, dots[!nzchar(names(dots))]) + } + + project <- renv_project_resolve(project) + renv_project_lock(project = project) + renv_scope_verbose_if(prompt) + + # handle 'dependencies' + if (!is.null(dependencies)) { + fields <- renv_description_dependency_fields(dependencies, project = project) + renv_scope_binding(the, "install_dependency_fields", fields) + } + + # set up library paths + libpaths <- renv_libpaths_resolve(library) + renv_scope_libpaths(libpaths) + + # check for explicitly-provided type -- we handle this specially for PPM + if (!is.null(type)) { + renv_scope_binding(the, "install_pkg_type", type) + renv_scope_options(pkgType = type) + } + + # override repositories if requested + repos <- repos %||% config$repos.override() + if (length(repos)) + renv_scope_options(repos = repos) + + # if users have requested the use of pak, delegate there + if (config$pak.enabled() && !recursing()) { + renv_pak_init() + return(renv_pak_install(packages, libpaths, project)) + } + + # resolve remotes from explicitly-requested packages + remotes <- if (length(packages)) { + remotes <- map(packages, renv_remotes_resolve) + names(remotes) <- map_chr(remotes, `[[`, "Package") + remotes + } + + # figure out which packages we should install + packages <- names(remotes) %||% renv_snapshot_dependencies(project, dev = TRUE) + + # apply exclude parameter + if (length(exclude)) + packages <- setdiff(packages, exclude) + + if (empty(packages)) { + writef("- There are no packages to install.") + return(invisible(list())) + } + + # add bioconductor packages if necessary + if (renv_bioconductor_required(remotes)) { + bioc <- c(renv_bioconductor_manager(), "BiocVersion") + packages <- unique(c(packages, bioc)) + } + + # don't update renv unless it was explicitly requested + if (!"renv" %in% names(remotes)) + packages <- setdiff(packages, "renv") + + # start building a list of records; they should be resolved this priority: + # + # 1. explicit requests from the user + # 2. remotes declarations from the DESCRIPTION file + # 3. existing version in library, if any + # 4. fallback to package repositories + # + # we overlay 1 and 2 here, and then do 3 and 4 dynamically if required + # during the retrieve + install stages + records <- overlay(renv_project_remotes(project), remotes) + + # run install preflight checks + if (!renv_install_preflight(project, libpaths, records)) + cancel_if(prompt && !proceed()) + + # we're now ready to start installation + renv_scope_restore( + project = project, + library = renv_libpaths_active(), + packages = names(remotes), + records = records, + rebuild = rebuild + ) + + # retrieve packages + records <- retrieve(packages) + if (empty(records)) { + writef("- There are no packages to install.") + return(invisible(list())) + } + + if (prompt || renv_verbose()) { + renv_install_report(records, library = renv_libpaths_active()) + cancel_if(prompt && !proceed()) + } + + # install retrieved records + before <- Sys.time() + renv_install_impl(records) + after <- Sys.time() + + time <- renv_difftime_format(difftime(after, before)) + n <- length(records) + writef("Successfully installed %s in %s.", nplural("package", n), time) + + # check loaded packages and inform user if out-of-sync + renv_install_postamble(names(records)) + + invisible(records) +} + +renv_install_impl <- function(records) { + + staged <- renv_config_install_staged() + + writef(header("Installing packages")) + + if (staged) + renv_install_staged(records) + else + renv_install_default(records) + + invisible(TRUE) + +} + +renv_install_staged <- function(records) { + + # get current libpaths + libpaths <- renv_libpaths_all() + + # set up a dummy library path for installation + templib <- renv_install_staged_library_path() + defer(unlink(templib, recursive = TRUE)) + renv_scope_libpaths(c(templib, libpaths)) + + # perform the install + renv_install_default(records) + + # migrate packages into true library + library <- nth(libpaths, 1L) + sources <- list.files(templib, full.names = TRUE) + targets <- file.path(library, basename(sources)) + names(targets) <- sources + enumerate(targets, renv_file_move, overwrite = TRUE) + + # clear filebacked cache entries + descpaths <- file.path(targets, "DESCRIPTION") + renv_filebacked_clear("renv_description_read", descpaths) + renv_filebacked_clear("renv_hash_description", descpaths) + + invisible(targets) + +} + +renv_install_staged_library_path_impl <- function() { + + # get current library path + libpath <- renv_libpaths_active() + + # retrieve current project, library path + stagedlib <- local({ + + # allow user configuration of staged library location + override <- Sys.getenv("RENV_PATHS_LIBRARY_STAGING", unset = NA) + if (!is.na(override)) + return(override) + + # if we have an active project, use that path + project <- renv_project_get(default = NULL) + if (!is.null(project)) + return(renv_paths_renv("staging", project = project)) + + # otherwise, stage within library path + file.path(libpath, ".renv") + + }) + + # attempt to create it + ok <- catch(ensure_directory(stagedlib)) + if (inherits(ok, "error")) + return(tempfile("renv-staging-")) + + # resolve a unique staging directory in this path + # we want to keep paths short just in case; it's easy to blow up the + # path length limit (hence we don't use tempfile below) + for (i in 1:100) { + path <- file.path(stagedlib, i) + if (dir.create(path, showWarnings = FALSE)) + return(path) + } + + # all else fails, use tempfile + tempfile("renv-staging-") + +} + +# NOTE: on Windows, installing packages into very long paths +# can fail, as R's internal unzip utility does not handle +# long Windows paths well. in addition, an renv project's +# library path tends to be long, exasperating the issue. +# for that reason, we try to use a shorter staging directory +# +# part of the challenge here is that the R temporary directory +# and R library path might reside on different mounts, and so +# we may want to try and avoid installing on one mount and then +# copying to another mount (as that could be slow). +# +# note that using the renv folder might be counter-productive, +# since users will want to use renv in projects sync'ed via +# OneDrive and friends, and we don't want those to lock files +# in the staging directory +renv_install_staged_library_path <- function() { + + # compute path + path <- renv_install_staged_library_path_impl() + + # create library directory + ensure_directory(path) + + # try to make sure it has the same permissions as the library itself + if (!renv_platform_windows()) { + libpath <- renv_libpaths_active() + umask <- Sys.umask("0") + defer(Sys.umask(umask)) + info <- renv_file_info(libpath) + Sys.chmod(path, info$mode) + } + + # return the created path + return(path) + +} + +renv_install_default <- function(records) { + state <- renv_restore_state() + handler <- state$handler + + for (record in records) { + package <- record$Package + handler(package, renv_install_package(record)) + } +} + +renv_install_package <- function(record) { + + # get active project (if any) + state <- renv_restore_state() + project <- state$project + + # figure out whether we can use the cache during install + # use library path recorded in restore state as staged installs will have + # mutated the library path, placing a staging library at the front + library <- renv_restore_state("library") + linkable <- renv_cache_linkable(project = project, library = library) + linker <- if (linkable) renv_file_link else renv_file_copy + + cacheable <- + renv_cache_config_enabled(project = project) && + renv_record_cacheable(record) && + !renv_restore_rebuild_required(record) + + if (cacheable) { + + # check for cache entry and install if there + path <- renv_cache_find(record) + if (renv_cache_package_validate(path)) + return(renv_install_package_cache(record, path, linker)) + + } + + # install the package + before <- Sys.time() + withCallingHandlers( + renv_install_package_impl(record), + error = function(e) writef("FAILED") + ) + after <- Sys.time() + + path <- record$Path + type <- renv_package_type(path, quiet = TRUE) + feedback <- renv_install_package_feedback(path, type) + + + # link into cache + if (renv_cache_config_enabled(project = project)) { + renv_cache_synchronize(record, linkable = linkable) + feedback <- paste0(feedback, " and cached") + } + + elapsed <- difftime(after, before, units = "auto") + renv_install_step_ok(feedback, elapsed = elapsed) + + invisible() + +} + +renv_install_package_feedback <- function(path, type) { + + if (identical(type, "source")) + return("built from source") + + if (renv_file_type(path, symlinks = FALSE) == "directory") + return("copied local binary") + + "installed binary" + +} + +renv_install_package_cache <- function(record, cache, linker) { + + if (renv_install_package_cache_skip(record, cache)) + return(TRUE) + + library <- renv_libpaths_active() + target <- file.path(library, record$Package) + + # back up the previous installation if needed + callback <- renv_file_backup(target) + defer(callback()) + + # report successful link to user + renv_install_step_start("Installing", record$Package) + + before <- Sys.time() + linker(cache, target) + after <- Sys.time() + + type <- case( + identical(linker, renv_file_copy) ~ "copied from cache", + identical(linker, renv_file_link) ~ "linked from cache" + ) + + elapsed <- difftime(after, before, units = "auto") + renv_install_step_ok(type, elapsed = elapsed) + + return(TRUE) + +} + +renv_install_package_cache_skip <- function(record, cache) { + + # don't skip if installation was explicitly requested + if (record$Package %in% renv_restore_state("packages")) + return(FALSE) + + # check for matching cache + target paths + library <- renv_restore_state("library") %||% renv_libpaths_active() + target <- file.path(library, record$Package) + + renv_file_same(cache, target) + +} + +renv_install_package_impl_prebuild <- function(record, path, quiet) { + + # check whether user wants us to build before install + if (!identical(config$install.build(), TRUE)) + return(path) + + # if this package already appears to be built, nothing to do + if (renv_package_built(path)) + return(path) + + # if this is an archive, we'll need to unpack it first + info <- renv_file_info(path) + if (identical(info$isdir, FALSE)) { + + # find the package directory + files <- renv_archive_list(path) + descpath <- grep("(?:^|/)DESCRIPTION$", files, value = TRUE) + pkgpath <- dirname(descpath)[nchar(descpath) == min(nchar(descpath))] + + # extract to temporary directory + exdir <- tempfile("renv-build-") + ensure_directory(exdir) + renv_archive_decompress(path, exdir = exdir) + + # update path to package + path <- file.path(exdir, pkgpath) + + # and ensure we build in this directory + renv_scope_wd(path) + + } + + # if this package depends on a VignetteBuilder that is not installed, + # then we can't proceed + descpath <- file.path(path, "DESCRIPTION") + desc <- renv_description_read(descpath) + builder <- desc[["VignetteBuilder"]] + if (!is.null(builder) && !renv_package_installed(builder)) { + fmt <- "Skipping package build: vignette builder '%s' is not installed" + writef(fmt, builder) + return(path) + } + + renv_install_step_start("Building", record$Package) + + before <- Sys.time() + package <- record$Package + newpath <- r_cmd_build(package, path) + after <- Sys.time() + elapsed <- difftime(after, before, units = "auto") + + renv_install_step_ok("from source", elapsed = elapsed) + + newpath + +} + +renv_install_package_impl <- function(record, quiet = TRUE) { + + package <- record$Package + + # get path for package + path <- record$Path + + # check if it's an archive (versus an unpacked directory) + info <- renv_file_info(path) + isarchive <- identical(info$isdir, FALSE) + + subdir <- record$RemoteSubdir %||% "" + if (isarchive) { + # re-pack archives if they appear to have their package + # sources contained as part of a sub-directory + path <- renv_package_unpack(package, path, subdir = subdir) + } else if (nzchar(subdir)) { + # for directories, we may need to use subdir to find the package path + components <- c(path, subdir) + path <- paste(components, collapse = "/") + } + + # check whether we should build before install + path <- renv_install_package_impl_prebuild(record, path, quiet) + renv_install_step_start("Installing", record$Package) + + # run user-defined hooks before, after install + options <- renv_install_package_options(package) + before <- options$before.install %||% identity + after <- options$after.install %||% identity + + before(package) + defer(after(package)) + + # backup an existing installation of the package if it exists + library <- renv_libpaths_active() + destination <- file.path(library, package) + callback <- renv_file_backup(destination) + defer(callback()) + + # normalize paths + path <- renv_path_normalize(path, mustWork = TRUE) + + # get library path + library <- renv_libpaths_active() + + # if a package already exists at that path, back it up first + # this avoids problems with older versions of R attempting to + # overwrite a pre-existing symlink + # + # https://github.com/rstudio/renv/issues/611 + installpath <- file.path(library, package) + callback <- renv_file_backup(installpath) + defer(callback()) + + # if this failed for some reason, just remove it + if (renv_file_broken(installpath)) + renv_file_remove(installpath) + + # if this is the path to an unpacked binary archive, + # we can just copy the folder over + isdir <- renv_file_type(path, symlinks = FALSE) == "directory" + isbin <- renv_package_type(path, quiet = TRUE) == "binary" + copyable <- isdir && isbin + + # shortcut via copying a binary directory if possible, + # otherwise, install the package + if (copyable) + renv_file_copy(path, installpath, overwrite = TRUE) + else + r_cmd_install(package, path) + + # if we just installed a binary package, check that it can be loaded + # (source packages are checked by default on install) + withCallingHandlers( + if (isbin) renv_install_test(package), + error = function(err) unlink(installpath, recursive = TRUE) + ) + + # augment package metadata after install + renv_package_augment(installpath, record) + + # return the path to the package + invisible(installpath) + +} + +renv_install_test <- function(package) { + + # add escape hatch, just in case + # (test binaries by default on Linux, but not Windows or macOS) + enabled <- Sys.getenv("RENV_INSTALL_TEST_LOAD", unset = renv_platform_linux()) + if (!truthy(enabled)) + return(TRUE) + + # check whether we should skip installation testing + opts <- r_cmd_install_option(package, c("install.opts", "INSTALL_opts"), FALSE) + if (is.character(opts)) { + flags <- unlist(strsplit(opts, "\\s+", perl = TRUE)) + if ("--no-test-load" %in% flags) + return(TRUE) + } + + # make sure we use the current library paths in the launched process + rlibs <- paste(renv_libpaths_all(), collapse = .Platform$path.sep) + renv_scope_envvars(R_LIBS = rlibs, R_LIBS_USER = "NULL", R_LIBS_SITE = "NULL") + + # also hide from user .Renviron files + # https://github.com/wch/r-source/blob/1c0a2dc8ce6c05f68e1959ffbe6318a309277df3/src/library/tools/R/check.R#L273-L276 + renv_scope_envvars(R_ENVIRON_USER = "NULL") + + # make sure R_TESTS is unset here, just in case + # https://github.com/wch/r-source/blob/1c0a2dc8ce6c05f68e1959ffbe6318a309277df3/src/library/tools/R/install.R#L76-L79 + renv_scope_envvars(R_TESTS = NULL) + + # the actual code we'll run in the other process + # we use 'loadNamespace()' rather than 'library()' because some packages might + # intentionally throw an error in their .onAttach() hooks + # https://github.com/rstudio/renv/issues/1611 + code <- substitute({ + options(warn = 1L) + loadNamespace(package) + }, list(package = package)) + + # write it to a tempfile + script <- renv_scope_tempfile("renv-install-", fileext = ".R") + writeLines(deparse(code), con = script) + + # check that the package can be loaded in a separate process + renv_system_exec( + command = R(), + args = c("--vanilla", "-s", "-f", renv_shell_path(script)), + action = sprintf("testing if '%s' can be loaded", package) + ) + + # return TRUE to indicate successful validation + TRUE + +} + +renv_install_package_options <- function(package) { + options <- getOption("renv.install.package.options") + options[[package]] +} + +# nocov start +renv_install_preflight_requirements <- function(records) { + + deps <- bapply(records, function(record) { + renv_dependencies_discover_description(record$Path) + }, index = "ParentPackage") + + splat <- split(deps, deps$Package) + bad <- enumerate(splat, function(package, requirements) { + + # skip NULL records (should be handled above) + record <- records[[package]] + if (is.null(record)) + return(NULL) + + version <- record$Version + + # drop packages without explicit version requirement + requirements <- requirements[nzchar(requirements$Require), ] + if (nrow(requirements) == 0) + return(NULL) + + # add in requested version + requirements$RequestedVersion <- version + + # generate expressions to evaluate + fmt <- "package_version('%s') %s package_version('%s')" + code <- with(requirements, sprintf(fmt, RequestedVersion, Require, Version)) + parsed <- parse(text = code) + ok <- map_lgl(parsed, eval, envir = baseenv()) + + # return requirements that weren't satisfied + requirements[!ok, ] + + }) + + bad <- bind(unname(bad)) + if (empty(bad)) + return(TRUE) + + package <- bad$ParentPackage + requires <- sprintf("%s (%s %s)", bad$Package, bad$Require, bad$Version) + actual <- sprintf("%s %s", bad$Package, bad$RequestedVersion) + + fmt <- "Package '%s' requires '%s', but '%s' will be installed" + text <- sprintf(fmt, format(package), format(requires), format(actual)) + if (renv_verbose()) { + caution_bullets( + "The following issues were discovered while preparing for installation:", + text, + "Installation of these packages may not succeed." + ) + } + + if (interactive() && !proceed()) + return(FALSE) + + TRUE + +} +# nocov end + +renv_install_postamble <- function(packages) { + + # only diagnose packages currently loaded + packages <- renv_vector_intersect(packages, loadedNamespaces()) + + installed <- map_chr(packages, renv_package_version) + loaded <- map_chr(packages, renv_namespace_version) + + caution_bullets( + c("", "The following loaded package(s) have been updated:"), + packages[installed != loaded], + "Restart your R session to use the new versions." + ) + + TRUE + +} + +renv_install_preflight_unknown_source <- function(records) { + renv_check_unknown_source(records) +} + +renv_install_preflight_permissions <- function(library) { + + # try creating and deleting a directory in the library folder + file <- renv_scope_tempfile(".renv-write-test-", tmpdir = library) + dir.create(file, recursive = TRUE, showWarnings = FALSE) + + # check if we created the directory successfully + info <- renv_file_info(file) + if (identical(info$isdir, TRUE)) + return(TRUE) + + # nocov start + if (renv_verbose()) { + + # construct header for message + preamble <- "renv appears to be unable to access the requested library path:" + + # construct footer for message + info <- as.list(Sys.info()) + fmt <- "Check that the '%s' user has read / write access to this directory." + postamble <- sprintf(fmt, info$effective_user %||% info$user) + + # print it + caution_bullets( + preamble = preamble, + values = library, + postamble = postamble + ) + + } + # nocov end + + FALSE + +} + +renv_install_preflight <- function(project, libpaths, records) { + + library <- nth(libpaths, 1L) + + all( + renv_install_preflight_unknown_source(records), + renv_install_preflight_permissions(library) + ) + +} + +renv_install_report <- function(records, library) { + renv_pretty_print_records( + "The following package(s) will be installed:", + records, + sprintf("These packages will be installed into %s.", renv_path_pretty(library)) + ) +} + +renv_install_step_start <- function(action, package) { + message <- sprintf("- %s %s ... ", action, package) + printf(format(message, width = the$install_step_width)) +} + +renv_install_step_ok <- function(..., elapsed = NULL) { + renv_report_ok( + message = paste(..., collapse = ""), + elapsed = elapsed + ) +} + + +# installed-packages.R ------------------------------------------------------- + + +installed_packages <- function(lib.loc = NULL, + priority = NULL, + field = NULL) +{ + lib.loc <- lib.loc %||% .libPaths() + + result <- dynamic( + key = list(lib.loc = lib.loc, priority = priority), + value = { + packages <- installed.packages(lib.loc = lib.loc, priority = priority) + as_data_frame(packages) + } + ) + + take(result, field) + +} + + +# isolate.R ------------------------------------------------------------------ + + +#' Isolate a project +#' +#' Copy packages from the renv cache directly into the project library, so +#' that the project can continue to function independently of the renv cache. +#' +#' After calling `isolate()`, renv will still be able to use the cache on +#' future [install()]s and [restore()]s. If you'd prefer that renv copy +#' packages from the cache, rather than use symlinks, you can set the renv +#' configuration option: +#' +#' ``` +#' options(renv.config.cache.symlinks = FALSE) +#' ``` +#' +#' to force renv to copy packages from the cache, as opposed to symlinking +#' them. If you'd like to disable the cache altogether for a project, you can +#' use: +#' +#' ``` +#' settings$use.cache(FALSE) +#' ``` +#' +#' to explicitly disable the cache for the project. +#' +#' @inherit renv-params +#' +#' @export +#' +#' @examples +#' \dontrun{ +#' +#' # isolate a project +#' renv::isolate() +#' +#' } +isolate <- function(project = NULL) { + + project <- renv_project_resolve(project) + renv_project_lock(project = project) + + if (renv_platform_windows()) + renv_isolate_windows(project) + else + renv_isolate_unix(project) + + invisible(project) + +} + +renv_isolate_unix <- function(project) { + + library <- renv_paths_library(project = project) + targets <- list.files(library, full.names = TRUE) + + sources <- Sys.readlink(targets) + islink <- !is.na(sources) & nzchar(sources) + + sources <- sources[islink] + targets <- targets[islink] + names(targets) <- sources + + if (length(targets)) { + printf("- Copying packages into the private library ... ") + unlink(targets) + copy <- renv_progress_callback(renv_file_copy, length(targets)) + enumerate(targets, copy, overwrite = TRUE) + writef("Done!") + } + + writef("- This project has been isolated from the cache.") + invisible(project) + +} + +renv_isolate_windows <- function(project) { + + library <- renv_paths_library(project = project) + targets <- list.files(library, full.names = TRUE) + + sources <- map_chr(targets, renv_cache_path) + names(targets) <- sources + + if (length(targets)) { + printf("- Copying packages into the private library ... ") + targets <- targets[file.exists(sources)] + unlink(targets) + copy <- renv_progress_callback(renv_file_copy, length(targets)) + enumerate(targets, copy, overwrite = TRUE) + writef("Done!") + } + + writef("- This project has been isolated from the cache.") + invisible(project) + +} + + +# json-read.R ---------------------------------------------------------------- + + +renv_json_read <- function(file = NULL, text = NULL) { + + jlerr <- NULL + + # if jsonlite is loaded, use that instead + if ("jsonlite" %in% loadedNamespaces()) { + + json <- catch(renv_json_read_jsonlite(file, text)) + if (!inherits(json, "error")) + return(json) + + jlerr <- json + + } + + # otherwise, fall back to the default JSON reader + json <- catch(renv_json_read_default(file, text)) + if (!inherits(json, "error")) + return(json) + + # report an error + if (!is.null(jlerr)) + stop(jlerr) + else + stop(json) + +} + +renv_json_read_jsonlite <- function(file = NULL, text = NULL) { + text <- paste(text %||% read(file), collapse = "\n") + jsonlite::fromJSON(txt = text, simplifyVector = FALSE) +} + +renv_json_read_default <- function(file = NULL, text = NULL) { + + # find strings in the JSON + text <- paste(text %||% read(file), collapse = "\n") + pattern <- '["](?:(?:\\\\.)|(?:[^"\\\\]))*?["]' + locs <- gregexpr(pattern, text, perl = TRUE)[[1]] + + # if any are found, replace them with placeholders + replaced <- text + strings <- character() + replacements <- character() + + if (!identical(c(locs), -1L)) { + + # get the string values + starts <- locs + ends <- locs + attr(locs, "match.length") - 1L + strings <- substring(text, starts, ends) + + # only keep those requiring escaping + strings <- grep("[[\\]{}:]", strings, perl = TRUE, value = TRUE) + + # compute replacements + replacements <- sprintf('"\032%i\032"', seq_along(strings)) + + # replace the strings + mapply(function(string, replacement) { + replaced <<- sub(string, replacement, replaced, fixed = TRUE) + }, strings, replacements) + + } + + # transform the JSON into something the R parser understands + transformed <- replaced + transformed <- gsub("{}", "`names<-`(list(), character())", transformed, fixed = TRUE) + transformed <- gsub("[[{]", "list(", transformed, perl = TRUE) + transformed <- gsub("[]}]", ")", transformed, perl = TRUE) + transformed <- gsub(":", "=", transformed, fixed = TRUE) + text <- paste(transformed, collapse = "\n") + + # parse it + json <- parse(text = text, keep.source = FALSE, srcfile = NULL)[[1L]] + + # construct map between source strings, replaced strings + map <- as.character(parse(text = strings)) + names(map) <- as.character(parse(text = replacements)) + + # convert to list + map <- as.list(map) + + # remap strings in object + remapped <- renv_json_remap(json, map) + + # evaluate + eval(remapped, envir = baseenv()) + +} + +renv_json_remap <- function(json, map) { + + # fix names + if (!is.null(names(json))) { + lhs <- match(names(json), names(map), nomatch = 0L) + rhs <- match(names(map), names(json), nomatch = 0L) + names(json)[rhs] <- map[lhs] + } + + # fix values + if (is.character(json)) + return(map[[json]] %||% json) + + # handle true, false, null + if (is.name(json)) { + text <- as.character(json) + if (text == "true") + return(TRUE) + else if (text == "false") + return(FALSE) + else if (text == "null") + return(NULL) + } + + # recurse + if (is.recursive(json)) { + for (i in seq_along(json)) { + json[i] <- list(renv_json_remap(json[[i]], map)) + } + } + + json + +} + + +# json-write.R --------------------------------------------------------------- + + +# @param box A vector of names, whose values should be boxed. By default, +# scalar values are unboxed. +renv_json_config <- function(box = character()) { + list(box = box) +} + +renv_json_write <- function(object, + config = NULL, + file = stdout()) +{ + config <- config %||% renv_json_config() + json <- renv_json_convert_impl(NULL, object, config, 0L) + if (is.null(file)) + return(json) + + writeLines(json, con = file) + +} + +renv_json_convert <- function(object, config = renv_json_config()) { + renv_json_convert_impl(NULL, object, config, 0L) +} + +renv_json_convert_impl <- function(key, value, config, depth) { + + if (is.list(value) || !is.null(names(value))) + return(renv_json_convert_list(key, value, config, depth)) + + json <- renv_json_convert_atom(key, value, config, depth) + indent <- renv_json_convert_indent(depth) + paste0(indent, json) + +} + +renv_json_convert_list <- function(key, value, config, depth) { + indent <- renv_json_convert_indent(depth) + if (empty(value)) { + json <- if (is.null(names(value))) "[]" else "{}" + paste0(indent, json) + } else if (is.null(names(value))) { + json <- enum_chr(value, renv_json_convert_impl, config = config, depth = depth + 1L) + paste0(indent, "[", "\n", paste(json, collapse = ",\n"), "\n", indent, "]") + } else { + keys <- renv_json_quote(names(value)) + vals <- enum_chr(value, renv_json_convert_impl, config = config, depth = depth + 1L) + idx <- regexpr("[^[:space:]]", vals) + json <- paste0(substring(vals, 1L, idx - 1L), keys, ": ", substring(vals, idx)) + paste0(indent, "{", "\n", paste(json, collapse = ",\n"), "\n", indent, "}") + } +} + +renv_json_convert_atom <- function(key, value, config, depth) { + + unbox <- is.null(key) || !key %in% config$box || inherits(value, "AsIs") + if (is.null(value)) + return(if (unbox) "null" else "[]") + + n <- length(value) + if (n == 0L) + return("[]") + + if (is.character(value)) { + value <- renv_json_quote(value) + value[value %in% c("NA")] <- "null" + } + + if (is.logical(value)) { + value <- ifelse(value, "true", "false") + value[is.na(value)] <- "null" + } + + if (unbox && n == 1L) + return(if (is.na(value)) "null" else paste0(value)) + + indent <- renv_json_convert_indent(depth) + json <- paste0(renv_json_convert_indent(depth + 1L), value) + paste0("[", "\n", paste(json, collapse = ",\n"), "\n", indent, "]") + +} + +renv_json_convert_indent <- function(level) { + paste(rep(" ", level), collapse = "") +} + + +# json.R --------------------------------------------------------------------- + + +renv_json_quote <- function(text) { + encodeString(text, quote = "\"", justify = "none") +} + + +# knitr.R -------------------------------------------------------------------- + + +renv_knitr_options_header <- function(text, type) { + + # extract the inner options from the header + patterns <- renv_knitr_patterns() + rest <- sub(patterns[[type]]$chunk.begin, "\\1", text) + + # if this is an R Markdown document, parse the initial engine chunk + # (default to 'r' when not set) + engine <- "r" + if (type == "md") { + idx <- regexpr("(?:[ ,]|$)", rest) + engine <- substring(rest, 1, idx - 1) + rest <- sub("^,*\\s*", "", substring(rest, idx + 1)) + } + + # parse the params + params <- renv_knitr_options_header_impl(rest) + + # ensure an engine is set, if any + params[["engine"]] <- params[["engine"]] %||% engine + + # return parsed params + params + +} + +renv_knitr_options_header_impl <- function(rest) { + + # extract an unquoted label + label <- "" + pattern <- "(^\\s*[^=]+)(,|\\s*$)" + matches <- regexec(pattern, rest)[[1]] + if (!identical(c(matches), -1L)) { + submatches <- regmatches(rest, list(matches))[[1]] + label <- trimws(submatches[[2L]]) + rest <- substring(rest, matches[[3L]] + 1L) + } + + # parse as alist + params <- catch(parse(text = sprintf("alist(%s)", rest))[[1]]) + if (inherits(params, "error")) + return(list()) + + # inject the label back in + names(params) <- names(params) %||% rep.int("", length(params)) + if (length(params) > 1 && names(params)[[2L]] == "") + names(params)[[2L]] <- "label" + + # fix up 'label' if it's a missing value + if (identical(params[["label"]], quote(expr = ))) + params[["label"]] <- NULL + + # if we parsed a label, add it in + if (is.null(params[["label"]]) && nzchar(label)) + params[["label"]] <- label + + # evaluate the alist + eval(params, envir = parent.frame()) + +} + +renv_knitr_options_chunk <- function(code) { + + # find chunk option lines + pattern <- "^[[:space:]]*#+[|]" + matches <- grep(pattern, code[nzchar(code)], value = TRUE) + + # remove prefix + text <- gsub(pattern, "", matches) + + # try to guess whether it's YAML + isyaml <- any(grepl("^[[:space:]]*[^[:space:]:]+:", text)) + + # first, try to parse as YAML, then as R code + params <- if (isyaml) { + + # validate that we actually have the yaml package available + if (!renv_dependencies_require("yaml")) + return(list()) + + catch(renv_yaml_load(text)) + + } else { + code <- paste(text, collapse = ", ") + catch(renv_knitr_options_header_impl(code)) + } + + # check for error and report if this is in dependency discovery + if (inherits(params, "error")) { + + state <- renv_dependencies_state() + if (!is.null(state)) { + problem <- list(file = state$path %||% "", error = params) + state$problems$push(problem) + } + + return(list()) + + } + + # return parsed params + params + +} + +renv_knitr_patterns <- function() { + + list( + + rnw = list( + chunk.begin = "^\\s*<<(.*)>>=.*$", + chunk.end = "^\\s*@\\s*(%+.*|)$", + inline.code = "\\\\Sexpr\\{([^}]+)\\}", + inline.comment = "^\\s*%.*", + ref.chunk = "^\\s*<<(.+)>>\\s*$", + header.begin = "(^|\n)\\s*\\\\documentclass[^}]+\\}", + document.begin = "\\s*\\\\begin\\{document\\}" + ), + + tex = list( + chunk.begin = "^\\s*%+\\s*begin.rcode\\s*(.*)", + chunk.end = "^\\s*%+\\s*end.rcode", + chunk.code = "^\\s*%+", + ref.chunk = "^%+\\s*<<(.+)>>\\s*$", + inline.comment = "^\\s*%.*", + inline.code = "\\\\rinline\\{([^}]+)\\}", + header.begin = "(^|\n)\\s*\\\\documentclass[^}]+\\}", + document.begin = "\\s*\\\\begin\\{document\\}" + ), + + html = list( + chunk.begin = "^\\s*", + ref.chunk = "^\\s*<<(.+)>>\\s*$", + inline.code = "", + header.begin = "\\s*" + ), + + md = list( + chunk.begin = "^[\t >]*```+\\s*\\{([a-zA-Z0-9_]+( *[ ,].*)?)\\}\\s*$", + chunk.end = "^[\t >]*```+\\s*$", + ref.chunk = "^\\s*<<(.+)>>\\s*$", + inline.code = "(?>\\s*$", + inline.code = ":r:`([^`]+)`" + ), + + asciidoc = list( + chunk.begin = "^//\\s*begin[.]rcode(.*)$", + chunk.end = "^//\\s*end[.]rcode\\s*$", + chunk.code = "^//+", + ref.chunk = "^\\s*<<(.+)>>\\s*$", + inline.code = "`r +([^`]+)\\s*`|[+]r +([^+]+)\\s*[+]", + inline.comment = "^//.*" + ), + + textile = list( + chunk.begin = "^###[.]\\s+begin[.]rcode(.*)$", + chunk.end = "^###[.]\\s+end[.]rcode\\s*$", + ref.chunk = "^\\s*<<(.+)>>\\s*$", + inline.code = "@r +([^@]+)\\s*@", + inline.comment = "^###[.].*" + ) + + ) + +} + + +# l10n.R --------------------------------------------------------------------- + + +renv_l10n_mbcs <- function() { + info <- l10n_info() + info$MBCS +} + +renv_l10n_utf8 <- function() { + info <- l10n_info() + info$`UTF-8` +} + +renv_l10n_latin1 <- function() { + info <- l10n_info() + info$`Latin-1` +} + + +# libpaths.R ----------------------------------------------------------------- + + +the$libpaths <- new.env(parent = emptyenv()) + +# NOTE: if sandboxing is used then these symbols will be clobbered; +# save them so we can properly restore them later if so required +renv_libpaths_init <- function() { + assign(".libPaths()", .libPaths(), envir = the$libpaths) + assign(".Library", .Library, envir = the$libpaths) + assign(".Library.site", .Library.site, envir = the$libpaths) +} + +renv_libpaths_active <- function() { + .libPaths()[[1L]] +} + +renv_libpaths_all <- function() { + .libPaths() +} + +renv_libpaths_system <- function() { + get(".Library", envir = the$libpaths) +} + +renv_libpaths_site <- function() { + get(".Library.site", envir = the$libpaths) +} + +renv_libpaths_external <- function(project) { + projlib <- settings$external.libraries(project = project) + conflib <- config$external.libraries(project) + .expand_R_libs_env_var(c(projlib, conflib)) +} + +# on Windows, attempting to use a library path containing +# characters considered special by cmd.exe will fail. +# to guard against this, we try to create a junction point +# from the temporary directory to the target library path +# +# https://github.com/rstudio/renv/issues/334 +renv_libpaths_safe <- function(libpaths) { + + if (renv_libpaths_safe_check(libpaths)) + return(libpaths) + + map_chr(libpaths, renv_libpaths_safe_impl) + +} + +renv_libpaths_safe_check <- function(libpaths) { + + # if any of the paths have single quotes, + # then we need to use a safe path + # https://bugs.r-project.org/bugzilla/show_bug.cgi?id=17973 + if (any(grepl("'", libpaths, fixed = TRUE))) + return(FALSE) + + # on Windows, we need to use safe library paths for R < 4.0.0 + # https://bugs.r-project.org/bugzilla/show_bug.cgi?id=17709 + if (renv_platform_windows() && getRversion() < "4.0.0") + return(FALSE) + + # otherwise, we're okay + return(TRUE) + +} + +renv_libpaths_safe_impl <- function(libpath) { + + # check for an unsafe library path + unsafe <- + Encoding(libpath) == "UTF-8" || + grepl("[&<>^|'\"]", libpath) + + # if the path appears safe, use it as-is + if (!unsafe) + return(libpath) + + # try to form a safe library path + methods <- c( + renv_libpaths_safe_tempdir, + renv_libpaths_safe_userlib + ) + + for (method in methods) { + safelib <- catchall(method(libpath)) + if (is.character(safelib)) + return(safelib) + } + + # could not form a safe library path; + # just use the existing library path as-is + libpath + +} + +renv_libpaths_safe_tempdir <- function(libpath) { + safelib <- tempfile("renv-safelib-") + + if (renv_platform_windows()) + renv_file_junction(libpath, safelib) + else + file.symlink(libpath, safelib) + + safelib +} + +renv_libpaths_safe_userlib <- function(libpath) { + + # form path into user library + userlib <- renv_libpaths_user()[[1]] + base <- file.path(userlib, ".renv-links") + ensure_directory(base) + + # create name for actual junction point + name <- renv_hash_text(libpath) + safelib <- file.path(base, name) + + # if the junction already exists, use it + if (renv_file_same(libpath, safelib)) + return(safelib) + + # otherwise, try to create it. note that junction + # points can be removed with a non-recursive unlink + unlink(safelib) + + if (renv_platform_windows()) + renv_file_junction(libpath, safelib) + else + file.symlink(libpath, safelib) + + safelib + +} + +renv_libpaths_set <- function(libpaths) { + oldlibpaths <- .libPaths() + safepaths <- renv_libpaths_safe(libpaths) + .libPaths(safepaths) + oldlibpaths +} + +renv_libpaths_default <- function() { + the$libpaths$`.libPaths()` +} + +# NOTE: may return more than one library path! +renv_libpaths_user <- function() { + + # if renv is active, the user library will be saved + envvars <- c("RENV_DEFAULT_R_LIBS_USER", "R_LIBS_USER") + for (envvar in envvars) { + + value <- Sys.getenv(envvar, unset = NA) + if (is.na(value) || value %in% c("", "", "NULL")) + next + + parts <- strsplit(value, .Platform$path.sep, fixed = TRUE)[[1L]] + return(parts) + + } + + # otherwise, default to active library + # (shouldn't happen but best be safe) + renv_libpaths_active() + +} + +renv_init_libpaths <- function(project) { + + projlib <- renv_paths_library(project = project) + extlib <- renv_libpaths_external(project = project) + userlib <- if (config$user.library()) + renv_libpaths_user() + + libpaths <- c(projlib, extlib, userlib) + lapply(libpaths, ensure_directory) + + libpaths + +} + +renv_libpaths_restore <- function() { + libpaths <- get(".libPaths()", envir = the$libpaths) + renv_libpaths_set(libpaths) +} + +# We need to ensure the system library is included, for cases where users have +# provided an explicit 'library' argument in calls to functions like +# 'renv::restore(library = <...>)') +# +# https://github.com/rstudio/renv/issues/1544 +renv_libpaths_resolve <- function(library = NULL) { + + if (is.null(library)) + return(renv_libpaths_all()) + + unique(c(library, .Library)) + +} + + +# library.R ------------------------------------------------------------------ + + +# check for problems in the project's private library (e.g. broken symlinks +# to the cache or similar) +renv_library_diagnose <- function(project, libpath) { + + children <- list.files(libpath, full.names = TRUE) + if (empty(children)) + return(TRUE) + + # if all symlinks are broken, assume the cache is missing or has been moved + missing <- !file.exists(children) + if (all(missing)) { + msg <- lines( + "The project library's symlinks to the cache are all broken.", + "Has the cache been removed, or is it otherwise inaccessible?", + paste("Cache root:", shQuote(renv_paths_cache()[[1L]])) + ) + warning(msg, call. = FALSE) + return(FALSE) + } + + # if only some symlinks are broken, report to user + if (any(missing)) { + + caution_bullets( + "The following package(s) are missing entries in the cache:", + basename(children[missing]), + "These packages will need to be reinstalled." + ) + + return(FALSE) + + } + + TRUE + +} + + +# license.R ------------------------------------------------------------------ + + +# used to generate the CRAN-compatible license file in R CMD build +renv_license_generate <- function() { + + # only done if we're building + if (!building()) + return(FALSE) + + contents <- c( + paste("YEAR:", format(Sys.Date(), "%Y")), + "COPYRIGHT HOLDER: Posit Software, PBC" + ) + + writeLines(contents, con = "LICENSE") + return(TRUE) + +} + +if (identical(.packageName, "renv")) + renv_license_generate() + + + +# load.R --------------------------------------------------------------------- + + +# are we currently running 'load()'? +the$load_running <- FALSE + +#' Load a project +#' +#' @description +#' `renv::load()` sets the library paths to use a project-local library, +#' sets up the system library [sandbox], if needed, and creates shims +#' for `install.packages()`, `update.packages()`, and `remove.packages()`. +#' +#' You should not generally need to call `renv::load()` yourself, as it's +#' called automatically by the project auto-loader created by [renv::init()]/ +#' [renv::activate()]. However, if needed, you can use `renv::load("")` +#' to explicitly load an renv project located at a particular path. +#' +#' # Shims +#' +#' To help you take advantage of the package cache, renv places a couple of +#' shims on the search path: +#' +#' * `install.packages()` instead calls `renv::install()`. +#' * `remove.packages()` instead calls `renv::remove()`. +#' * `update.packages()` instead calls `renv::update()`. +#' +#' This allows you to keep using your existing muscle memory for installing, +#' updating, and remove packages, while taking advantage of renv features +#' like the package cache. +#' +#' If you'd like to bypass these shims within an \R session, you can explicitly +#' call the version of these functions from the utils package, e.g. with +#' `utils::install.packages(<...>)`. +#' +#' If you'd prefer not to use the renv shims at all, they can be disabled by +#' setting the R option `options(renv.config.shims.enabled = FALSE)` or by +#' setting the environment variable `RENV_CONFIG_SHIMS_ENABLED = FALSE`. See +#' `?config` for more details. +#' +#' @inherit renv-params +#' +#' @param quiet Boolean; be quiet during load? +#' +#' @export +#' +#' @examples +#' \dontrun{ +#' +#' # load a project -- note that this is normally done automatically +#' # by the project's auto-loader, but calling this explicitly to +#' # load a particular project may be useful in some circumstances +#' renv::load() +#' +#' } +load <- function(project = NULL, quiet = FALSE) { + + renv_scope_error_handler() + + project <- renv_path_normalize( + project %||% renv_project_find(project), + mustWork = TRUE + ) + + action <- renv_load_action(project) + if (action[[1L]] == "cancel") { + cancel() + } else if (action[[1L]] == "init") { + return(init(project)) + } else if (action[[1L]] == "alt") { + project <- action[[2L]] + } + + renv_project_lock(project = project) + + # indicate that we're now loading the project + renv_scope_binding(the, "load_running", TRUE) + + # if load is being called via the autoloader, + # then ensure RENV_PROJECT is unset + # https://github.com/rstudio/renv/issues/887 + if (identical(getOption("renv.autoloader.running"), TRUE)) + renv_project_clear() + + # if we're loading a project different from the one currently loaded, + # then unload the current project and reload the requested one + switch <- + !renv_metadata_embedded() && + !is.null(the$project_path) && + !identical(project, the$project_path) + + if (switch) + return(renv_load_switch(project)) + + if (quiet || renv_load_quiet()) + renv_scope_options(renv.verbose = FALSE) + + renv_envvars_save() + + # load a minimal amount of state when testing + if (renv_tests_running()) + return(renv_load_minimal(project)) + + # load rest of renv components + renv_load_init(project) + renv_load_path(project) + renv_load_shims(project) + renv_load_renviron(project) + renv_load_profile(project) + renv_load_settings(project) + renv_load_project(project) + renv_load_sandbox(project) + renv_load_libpaths(project) + renv_load_rprofile(project) + renv_load_cache(project) + + # load components encoded in lockfile + lockfile <- renv_lockfile_load(project) + if (length(lockfile)) { + renv_load_r(project, lockfile$R) + renv_load_python(project, lockfile$Python) + renv_load_bioconductor(project, lockfile$Bioconductor) + } + + # allow failure to write infrastructure here to be non-fatal + # https://github.com/rstudio/renv/issues/574#issuecomment-731159197 + catch({ + renv_infrastructure_write_rbuildignore(project) + renv_infrastructure_write_gitignore(project) + }) + + renv_load_finish(project, lockfile) + + invisible(project) +} + +renv_load_action <- function(project) { + + # don't do anything in non-interactive sessions + if (!interactive()) + return("load") + + # if this project already contains an 'renv' folder, assume it's + # already been initialized and we can directly load it + renv <- renv_paths_renv(project = project, profile = FALSE) + if (dir.exists(renv)) + return("load") + + # if we're running within RStudio at this point, and we're running + # within the auto-loader, we need to defer execution here so that + # the console is able to properly receive user input and update + # https://github.com/rstudio/renv/issues/1650 + autoloading <- getOption("renv.autoloader.running", default = FALSE) + if (autoloading && renv_rstudio_available()) { + setHook("rstudio.sessionInit", function() { + renv::load(project) + }) + } + + # check and see if we're being called within a sub-directory + path <- renv_file_find(dirname(project), function(parent) { + if (file.exists(file.path(parent, "renv"))) + return(parent) + }) + + fmt <- "The project located at %s has not yet been initialized." + header <- sprintf(fmt, renv_path_pretty(project)) + title <- paste("", header, "", "What would you like to do?", sep = "\n") + + choices <- c( + init = "Initialize this project with `renv::init()`.", + load = "Continue loading this project as-is.", + cancel = "Cancel loading this project." + ) + + if (!is.null(path)) { + fmt <- "Load the project located at %s instead." + msg <- sprintf(fmt, renv_path_pretty(path)) + choices <- c(choices, alt = msg) + } + + selection <- tryCatch( + utils::select.list(choices, title = title, graphics = FALSE), + interrupt = identity + ) + + if (inherits(selection, "interrupt")) { + writef() + selection <- choices["cancel"] + } + + list(names(selection), path) + +} + +renv_load_minimal <- function(project) { + + renv_load_libpaths(project) + + lockfile <- renv_lockfile_load(project) + if (length(lockfile)) { + renv_load_r(project, lockfile$R) + renv_load_python(project, lockfile$Python) + } + + renv_load_finish(project, lockfile) + invisible(project) + +} + +renv_load_r <- function(project, fields) { + + # check for missing fields + if (is.null(fields)) { + warning("missing required [R] section in lockfile") + return(NULL) + } + + # load repositories + renv_load_r_repos(fields$Repositories) + + # load (check) version + version <- fields$Version + if (is.null(version)) { + warning("no R version recorded in this lockfile") + return(NULL) + } + + # normalize versions as strings + requested <- renv_version_maj_min(version) + current <- renv_version_maj_min(getRversion()) + + # only compare major, minor versions + if (!identical(requested, current)) { + fmt <- "%s Using R %s (lockfile was generated with R %s)" + writef(fmt, info_bullet(), getRversion(), version) + } + +} + +renv_load_r_repos <- function(repos) { + + # force a character vector (https://github.com/rstudio/renv/issues/127) + repos <- convert(repos, "character") + + # remove trailing slashes + nms <- names(repos) + repos <- sub("/+$", "", repos) + names(repos) <- nms + + # transform PPM URLs if enabled + # this ensures that install.packages() uses binaries by default on Linux, + # where 'getOption("pkgType")' is "source" by default + if (renv_ppm_enabled()) + repos <- renv_ppm_transform(repos) + + # normalize option + repos <- renv_repos_normalize(repos) + + # set sanitized repos + options(repos = repos) + + # and return + repos + +} + +renv_load_init <- function(project) { + + # warn if the project path cannot be translated into the native encoding, + # as (especially on Windows) this will likely prevent renv from working + actual <- enc2utf8(project) + expected <- catch(enc2utf8(enc2native(actual))) + if (identical(actual, expected)) + return(TRUE) + + msg <- paste( + "the project path cannot be represented in the native encoding;", + "renv may not function as expected" + ) + + warning(msg) + +} + +renv_load_path <- function(project) { + + # only required when running in RStudio + if (!renv_rstudio_available()) + return(FALSE) + + # on macOS, read paths from /etc/paths and friends + + # nocov start + if (renv_platform_macos()) { + + # read the current PATH + old <- Sys.getenv("PATH", unset = "") %>% + strsplit(split = .Platform$path.sep, fixed = TRUE) %>% + unlist() + + # get the new PATH entries + files <- c( + if (file.exists("/etc/paths")) "/etc/paths", + list.files("/etc/paths.d", full.names = TRUE) + ) + + new <- uapply(files, readLines, warn = FALSE) + + # mix them together, preferring things in /etc/paths + mix <- unique(c(new, old)) + + # update the PATH + Sys.setenv(PATH = paste(mix, collapse = .Platform$path.sep)) + + } + # nocov end + +} + +renv_load_shims <- function(project) { + if (renv_shims_enabled()) + renv_shims_activate() +} + +renv_load_renviron <- function(project) { + + environs <- c( + renv_paths_root(".Renviron"), + if (config$user.environ()) + Sys.getenv("R_ENVIRON_USER", unset = "~/.Renviron"), + file.path(project, ".Renviron") + ) + + for (environ in environs) + if (file.exists(environ)) + readRenviron(environ) + + renv_envvars_normalize() + +} + +renv_load_profile <- function(project) { + + renv_bootstrap_profile_load(project = project) + +} + +renv_load_settings <- function(project) { + + # migrate settings.dcf => settings.json + renv_settings_migrate(project = project) + + # load settings.R + settings <- renv_paths_renv("settings.R", project = project) + if (!file.exists(settings)) + return(FALSE) + + tryCatch( + eval(parse(settings), envir = baseenv()), + error = warnify + ) + + TRUE + +} + +renv_load_project <- function(project) { + + # update project list if enabled + if (renv_cache_config_enabled(project = project)) { + project <- renv_path_normalize(project) + renv_load_project_projlist(project) + } + + TRUE + +} + +renv_load_project_projlist <- function(project) { + + # read project list + projects <- renv_paths_root("projects") + projlist <- character() + if (file.exists(projects)) + projlist <- readLines(projects, warn = FALSE, encoding = "UTF-8") + + # if the project is already recorded, nothing to do + if (project %in% projlist) + return(TRUE) + + # sort with C locale (ensure consistent sorting across OSes) + projlist <- csort(c(projlist, project)) + + # update the project list + ensure_parent_directory(projects) + catchall(writeLines(enc2utf8(projlist), con = projects, useBytes = TRUE)) + + TRUE + +} + +renv_load_rprofile <- function(project = NULL) { + + project <- renv_project_resolve(project) + + # bail if not enabled by user + enabled <- identical(config$user.profile(), TRUE) + if (!enabled) + return(FALSE) + + # callr will manage sourcing of user profile, so don't try + # to source the user profile if we're in callr + callr <- Sys.getenv("CALLR_CHILD_R_LIBS", unset = NA) + if (!is.na(callr)) + return(FALSE) + + # check for existence of profile + profile <- Sys.getenv("R_PROFILE_USER", unset = "~/.Rprofile") + if (!file.exists(profile)) + return(FALSE) + + renv_scope_libpaths() + renv_load_rprofile_impl(profile) + + TRUE + +} + +renv_load_rprofile_impl <- function(profile) { + + # NOTE: We'd like to use a regular tryCatch() handler here, but + # that will cause issues for user profiles which attempt to add + # global calling handlers. For that reason, we just register a + # bare restart handler, so at least we can catch the jump. + # + # https://github.com/rstudio/renv/issues/1036 + status <- withRestarts( + sys.source(profile, envir = globalenv()), + abort = function() { structure(list(), class = "_renv_error") } + ) + + if (inherits(status, "_renv_error")) { + fmt <- "an error occurred while sourcing %s" + warningf(fmt, renv_path_pretty(profile)) + } + + FALSE + +} + +renv_load_libpaths <- function(project = NULL) { + libpaths <- renv_init_libpaths(project) + lapply(libpaths, renv_library_diagnose, project = project) + Sys.setenv(R_LIBS_USER = paste(libpaths, collapse = .Platform$path.sep)) + renv_libpaths_set(libpaths) +} + +renv_load_sandbox <- function(project) { + renv_sandbox_activate(project) +} + +renv_load_python <- function(project, fields) { + + python <- tryCatch( + renv_load_python_impl(project, fields), + error = function(e) { + warning(e) + NULL + } + ) + + if (is.null(python)) + return(FALSE) + + # set environment variables + # - RENV_PYTHON is the version of Python renv was configured to use + # - RETICULATE_PYTHON used to configure version of Python used by reticulate + Sys.setenv( + RENV_PYTHON = python, + RETICULATE_PYTHON = python + ) + + # place python + relevant utilities on the PATH + bindir <- normalizePath(dirname(python), mustWork = FALSE) + renv_envvar_path_add("PATH", bindir) + + # on Windows, for conda environments, we may also have a Scripts directory + # which will need to be pre-pended to the PATH + if (renv_platform_windows()) { + scriptsdir <- file.path(bindir, "Scripts") + if (file.exists(scriptsdir)) + renv_envvar_path_add("PATH", scriptsdir) + } + + # for conda environments, we should try to find conda and place the conda + # executable on the PATH, in case users want to use conda e.g. from + # the terminal or even via R system calls + # + # we'll also need to set some environment variables to ensure that conda + # uses this environment by default + info <- renv_python_info(python) + if (identical(info$type, "conda")) { + conda <- renv_conda_find(python) + if (file.exists(conda)) { + renv_envvar_path_add("PATH", dirname(conda)) + Sys.setenv(CONDA_PREFIX = info$root) + } + } + + TRUE + +} + +renv_load_python_impl <- function(project, fields) { + + # if RENV_PYTHON is already set, just use it + python <- Sys.getenv("RENV_PYTHON", unset = NA) + if (!is.na(python)) + return(python) + + # set a default reticulate Python environment path + envpath <- renv_paths_renv("python/r-reticulate", project = project) + Sys.setenv(RETICULATE_MINICONDA_PYTHON_ENVPATH = envpath) + + # nothing more to do if no lockfile fields set + if (is.null(fields)) + return(NULL) + + # delegate based on type appropriately + type <- fields$Type + if (is.null(type)) + return(NULL) + + python <- switch(type, + system = renv_load_python_default(project, fields), + virtualenv = renv_load_python_virtualenv(project, fields), + conda = renv_load_python_condaenv(project, fields), + stopf("unrecognized Python type '%s'", type) + ) + + renv_path_canonicalize(python) + +} + +renv_load_python_default <- function(project, fields) { + + # if 'Name' points to a valid copy of Python, use it + name <- fields$Name + if (!is.null(name) && file.exists(name)) + return(name) + + # otherwise, try to find a compatible version of Python + renv_python_find(fields$Version) + +} + +renv_load_python_virtualenv <- function(project, fields) { + + renv_use_python_virtualenv_impl( + project = project, + name = fields[["Name"]] %NA% NULL, + version = fields[["Version"]] %NA% NULL, + python = fields[["Python"]] %NA% NULL + ) + +} + +renv_load_python_condaenv <- function(project, fields) { + + renv_use_python_condaenv_impl( + project = project, + name = fields[["Name"]] %NA% NULL, + version = fields[["Version"]] %NA% NULL, + python = fields[["Python"]] %NA% NULL + ) + +} + +renv_load_bioconductor <- function(project, bioconductor) { + + # we don't try to support older R anymore + if (getRversion() < "3.4") + return() + + # if we don't have a valid Bioconductor version, bail + version <- bioconductor$Version + if (is.null(version)) + return() + + # initialize bioconductor + renv_bioconductor_init() + + # validate version if necessary + validate <- getOption("renv.bioconductor.validate") + if (truthy(validate, default = TRUE)) + renv_load_bioconductor_validate(project, version) + + # update the R repositories + repos <- renv_bioconductor_repos(project, version) + options(repos = repos) + + # notify the user + sprintf("- Using Bioconductor '%s'.", version) + +} + +renv_load_bioconductor_validate <- function(project, version) { + + if (!identical(renv_bioconductor_manager(), "BiocManager")) + return() + + BiocManager <- renv_scope_biocmanager() + if (!is.function(BiocManager$.version_validity)) + return() + + # check for valid version of Bioconductor + # https://github.com/rstudio/renv/issues/1148 + status <- catch(BiocManager$.version_validity(version)) + if (!is.character(status)) + return() + + fmt <- lines( + "This project is configured to use Bioconductor %1$s, which is not compatible with R %2$s.", + "Use 'renv::init(bioconductor = \"%1$s\")' to re-initialize this project with the appropriate Bioconductor release.", + if (renv_package_installed("BiocVersion")) + "Please uninstall the 'BiocVersion' package first, with `remove.packages(\"BiocVersion\")`." + ) + + warningf(fmt, version, getRversion()) + +} + +renv_load_switch <- function(project) { + + # skip when testing + if (testing()) + return(project) + + # safety check: avoid recursive unload attempts + unloading <- getOption("renv.unload.project") + if (!is.null(unloading)) { + fmt <- "ignoring recursive attempt to load project '%s'" + warningf(fmt, renv_path_pretty(project)) + return(project) + } + + # unset the RENV_PATHS_RENV environment variable + # TODO: is there a path forward if different projects use + # different RENV_PATHS_RENV paths? + renvpath <- Sys.getenv("RENV_PATHS_RENV", unset = NA) + Sys.unsetenv("RENV_PATHS_RENV") + + # validate that this project has an activate script + script <- renv_paths_activate(project = project) + if (!file.exists(script)) { + fmt <- "project %s has no activate script and so cannot be activated" + stopf(fmt, renv_path_pretty(project)) + } + + # signal that we're unloading now + renv_scope_options(renv.unload.project = project) + + # perform the unload + unload() + + # unload the current version of renv (but keep track of position + # on search path in case we need to revert later) + path <- renv_namespace_path("renv") + pos <- match("package:renv", search()) + unloadNamespace("renv") + + # move to new project directory + renv_scope_wd(project) + + # source the activate script + source(script) + + # check and see if renv was successfully loaded + if (!"renv" %in% loadedNamespaces()) { + fmt <- "could not load renv from project %s; reloading previously-loaded renv" + warningf(fmt, renv_path_pretty(project)) + loadNamespace("renv", lib.loc = dirname(path)) + Sys.setenv(RENV_PATHS_RENV = renvpath) + if (!is.na(pos)) { + args <- list(package = "renv", pos = pos, character.only = TRUE) + do.call(base::library, args) + } + } + +} + +renv_load_cache <- function(project) { + + if (!interactive()) + return(FALSE) + + oldcache <- renv_paths_cache(version = renv_cache_version_previous())[[1L]] + newcache <- renv_paths_cache(version = renv_cache_version())[[1L]] + if (!file.exists(oldcache) || file.exists(newcache)) + return(FALSE) + + msg <- lines( + "- The cache version has been updated in this version of renv.", + "- Use `renv::rehash()` to migrate packages from the old renv cache." + ) + printf(msg) + +} + +renv_load_check <- function(project) { + renv_load_check_description(project) +} + +renv_load_check_description <- function(project) { + + descpath <- file.path(project, "DESCRIPTION") + if (!file.exists(descpath)) + return(TRUE) + + # read description file, with whitespace trimmed + contents <- read(descpath) %>% trim() %>% chop() + bad <- which(grepl("^\\s*$", contents, perl = TRUE)) + if (empty(bad)) + return(TRUE) + + values <- sprintf("[line %i is blank]", bad) + + caution_bullets( + sprintf("%s contains blank lines:", renv_path_pretty(descpath)), + values, + c( + "DESCRIPTION files cannot contain blank lines between fields.", + "Please remove these blank lines from the file." + ) + ) + + return(FALSE) + +} + +renv_load_quiet <- function() { + default <- identical(renv_verbose(), FALSE) || renv_session_quiet() + config$startup.quiet(default = default) +} + +renv_load_finish <- function(project = NULL, lockfile = NULL) { + + renv_project_set(project) + + renv_load_check(project) + renv_load_report_project(project) + renv_load_report_python(project) + + if (config$updates.check()) + renv_load_report_updates(project) + + if (config$synchronized.check()) + renv_load_report_synchronized(project, lockfile) + + renv_snapshot_auto_update(project = project) + +} + +renv_load_report_project <- function(project) { + + profile <- renv_profile_get() + version <- renv_metadata_version_friendly(shafmt = "; sha: %s") + + if (!is.null(profile)) { + fmt <- "- Project '%s' loaded. [renv %s; using profile '%s']" + writef(fmt, renv_path_aliased(project), version, profile) + } else { + fmt <- "- Project '%s' loaded. [renv %s]" + writef(fmt, renv_path_aliased(project), version) + } + +} + +renv_load_report_python <- function(project) { + # TODO +} + +# nocov start +renv_load_report_updates <- function(project) { + + lockpath <- renv_lockfile_path(project = project) + if (!file.exists(lockpath)) + return(FALSE) + + status <- update(project = project, check = TRUE) + available <- inherits(status, "renv_updates") && length(status$diff) + if (!available) + return(FALSE) + + writef("- Use `renv::update()` to install updated packages.") + if (!interactive()) + print(status) + + TRUE + +} +# nocov end + + +renv_load_report_synchronized <- function(project = NULL, lockfile = NULL) { + + project <- renv_project_resolve(project) + lockfile <- lockfile %||% renv_lockfile_load(project) + + # signal that we're running synchronization checks + renv_scope_binding(the, "project_synchronized_check_running", TRUE) + + # be quiet when checking for dependencies in this scope + # https://github.com/rstudio/renv/issues/1181 + renv_scope_options(renv.config.dependency.errors = "ignored") + + # check for packages referenced in the lockfile which are not installed + lockpkgs <- names(lockfile$Packages) + libpkgs <- renv_snapshot_library( + library = renv_libpaths_all(), + project = project, + records = FALSE + ) + + # ignore renv + lockpkgs <- setdiff(lockpkgs, "renv") + libpkgs <- setdiff(libpkgs, "renv") + + # check for case where no packages are installed (except renv) + if (length(intersect(lockpkgs, libpkgs)) == 0 && length(lockpkgs) > 0L) { + + caution("- None of the packages recorded in the lockfile are currently installed.") + response <- ask("- Would you like to restore the project library?") + if (!response) + return(FALSE) + + restore(project, prompt = FALSE, exclude = "renv") + return(TRUE) + + } + + # check for case where one or more packages are missing + missing <- setdiff(lockpkgs, basename(libpkgs)) + if (length(missing)) { + msg <- lines( + "- One or more packages recorded in the lockfile are not installed.", + "- Use `renv::status()` for more details." + ) + caution(msg) + return(FALSE) + } + + # otherwise, use status to detect if we're synchronized + info <- local({ + renv_scope_options(renv.verbose = FALSE) + renv_scope_caution(FALSE) + status(project = project, sources = FALSE) + }) + + if (!identical(info$synchronized, TRUE)) { + caution("- The project is out-of-sync -- use `renv::status()` for details.") + return(FALSE) + } + + TRUE + +} + + +# lock.R --------------------------------------------------------------------- + + +the$lock_registry <- new.env(parent = emptyenv()) + +renv_lock_acquire <- function(path) { + + # normalize path + path <- renv_lock_path(path) + dlog("lock", "%s [acquiring lock]", renv_path_pretty(path)) + + # if we already have this lock, increment our counter + count <- the$lock_registry[[path]] %||% 0L + if (count > 0L) { + the$lock_registry[[path]] <- count + 1L + return(TRUE) + } + + # make sure parent directory exists + ensure_parent_directory(path) + + # make sure warnings are errors here + renv_scope_options(warn = 2L) + + # loop until we acquire the lock + repeat tryCatch( + renv_lock_acquire_impl(path) && break, + error = function(cnd) Sys.sleep(0.2) + ) + + # mark this path as locked by us + the$lock_registry[[path]] <- 1L + + # notify the watchdog + renv_watchdog_notify("LockAcquired", list(path = path)) + + # TRUE to mark successful lock + dlog("lock", "%s [lock acquired]", renv_path_pretty(path)) + TRUE + +} + +# https://rcrowley.org/2010/01/06/things-unix-can-do-atomically.html +renv_lock_acquire_impl <- function(path) { + + # check for orphaned locks + if (renv_lock_orphaned(path)) { + dlog("lock", "%s: removing orphaned lock", path) + unlink(path, recursive = TRUE, force = TRUE) + } + + # attempt to create the lock + dir.create(path, mode = "0755") + +} + +renv_lock_release <- function(path) { + + # normalize path + path <- renv_lock_path(path) + + # decrement our lock count + count <- the$lock_registry[[path]] <- the$lock_registry[[path]] - 1L + + # remove the lock if we have no more locks + if (count == 0L) { + dlog("lock", "%s [lock released]", renv_path_pretty(path)) + renv_lock_release_impl(path) + } + +} + +renv_lock_release_impl <- function(path) { + renv_scope_options(warn = -1L) + unlink(path, recursive = TRUE, force = TRUE) + rm(list = path, envir = the$lock_registry) + renv_watchdog_notify("LockReleased", list(path = path)) +} + +renv_lock_orphaned <- function(path) { + + timeout <- getOption("renv.lock.timeout", default = 60L) + if (timeout <= 0L) + return(TRUE) + + info <- renv_file_info(path) + if (is.na(info$isdir)) + return(FALSE) + + diff <- difftime(Sys.time(), info$mtime, units = "secs") + diff >= timeout + +} + +renv_lock_refresh <- function(lock) { + Sys.setFileTime(lock, Sys.time()) +} + +renv_lock_unload <- function() { + locks <- ls(envir = the$lock_registry, all.names = TRUE) + unlink(locks, recursive = TRUE, force = TRUE) +} + +renv_lock_path <- function(path) { + + file.path( + renv_path_normalize(dirname(path), mustWork = TRUE), + basename(path) + ) + +} + + +# lockfile-api.R ------------------------------------------------------------- + + +# NOTE: These functions are used by the 'dockerfiler' package, even though +# they are not exported. We retain these functions here just to avoid issues +# during CRAN submission. We'll consider removing them in a future release. + +renv_lockfile_api <- function(lockfile = NULL) { + + .lockfile <- lockfile + .self <- new.env(parent = emptyenv()) + + .self$repos <- function(..., .repos = NULL) { + + if (nargs() == 0) { + repos <- .lockfile$R$Repositories + return(repos) + } + + repos <- .repos %||% list(...) + if (is.null(names(repos)) || "" %in% names(repos)) + stop("repositories must all be named", call. = FALSE) + + .lockfile$R$Repositories <<- as.list(convert(repos, "character")) + invisible(.self) + + } + + .self$version <- function(..., .version = NULL) { + + if (nargs() == 0) { + version <- .lockfile$R$Version + return(version) + } + + version <- .version %||% c(...) + + if (length(version) > 1) { + stop("Version should be length 1 character e.g. `\"3.6.3\"`") + } + + .lockfile$R$Version <<- version + invisible(.self) + + } + + .self$add <- function(..., .list = NULL) { + + records <- renv_lockfile_records(.lockfile) + + dots <- .list %||% list(...) + enumerate(dots, function(package, remote) { + resolved <- renv_remotes_resolve(remote) + records[[package]] <<- resolved + }) + + renv_lockfile_records(.lockfile) <<- records + invisible(.self) + + } + + .self$remove <- function(packages) { + records <- renv_lockfile_records(.lockfile) %>% exclude(packages) + renv_lockfile_records(.lockfile) <<- records + invisible(.self) + } + + .self$write <- function(file = stdout()) { + renv_lockfile_write(.lockfile, file = file) + invisible(.self) + } + + .self$data <- function() { + .lockfile + } + + class(.self) <- "renv_lockfile_api" + .self + +} + +#' Programmatically Create and Modify a Lockfile +#' +#' This function provides an API for creating and modifying `renv` lockfiles. +#' This can be useful when you'd like to programmatically generate or modify +#' a lockfile -- for example, because you want to update or change a package +#' record in an existing lockfile. +#' +#' @inheritParams renv-params +#' +#' @param file The path to an existing lockfile. When no lockfile is provided, +#' a new one will be created based on the current project context. If you +#' want to create a blank lockfile, use `file = NA` instead. +#' +#' @seealso \code{\link{lockfiles}}, for a description of the structure of an +#' `renv` lockfile. +#' +#' @examples +#' +#' \dontrun{ +#' +#' lock <- lockfile("renv.lock") +#' +#' # set the repositories for a lockfile +#' lock$repos(CRAN = "https://cran.r-project.org") +#' +#' # depend on digest 0.6.22 +#' lock$add(digest = "digest@@0.6.22") +#' +#' # write to file +#' lock$write("renv.lock") +#' +#' } +#' +#' @keywords internal +#' @rdname lockfile-api +#' @name lockfile-api +#' +lockfile <- function(file = NULL, project = NULL) { + project <- renv_project_resolve(project) + renv_scope_error_handler() + + lock <- if (is.null(file)) { + + renv_lockfile_create( + project = project, + libpaths = renv_libpaths_all(), + type = settings$snapshot.type(project = project) + ) + + } else if (is.na(file)) { + + renv_lockfile_init(project) + + } else { + + renv_lockfile_read(file = file) + + } + + renv_lockfile_api(lock) + +} + + +# lockfile-diff.R ------------------------------------------------------------ + + +renv_lockfile_diff <- function(old, new, compare = NULL) { + + compare <- compare %||% function(lhs, rhs) { + list(before = lhs, after = rhs) + } + + # ensure both lists have the same names, inserting missing + # entries for those without any value + nms <- union(names(old), names(new)) %||% character() + if (length(nms)) { + + nms <- sort(nms) + old[renv_vector_diff(nms, names(old))] <- list(NULL) + new[renv_vector_diff(nms, names(new))] <- list(NULL) + + old <- old[nms] + new <- new[nms] + + } + + # ensure that these have the same length for comparison + if (is.list(old) && is.list(new)) + length(old) <- length(new) <- max(length(old), length(new)) + + # check for differences + diffs <- mapply( + renv_lockfile_diff_impl, old, new, + MoreArgs = list(compare = compare), + SIMPLIFY = FALSE + ) + + # drop NULL entries + reject(diffs, empty) + +} + +renv_lockfile_diff_impl <- function(lhs, rhs, compare) { + case( + is.list(lhs) && empty(rhs) ~ renv_lockfile_diff(lhs, list(), compare), + empty(lhs) && is.list(rhs) ~ renv_lockfile_diff(list(), rhs, compare), + is.list(lhs) && is.list(rhs) ~ renv_lockfile_diff(lhs, rhs, compare), + !identical(c(lhs), c(rhs)) ~ compare(lhs, rhs), + NULL + ) +} + +renv_lockfile_diff_record <- function(before, after) { + + before <- renv_record_normalize(before) + after <- renv_record_normalize(after) + + # first, compare on version / record existence + type <- case( + is.null(before) ~ "install", + is.null(after) ~ "remove", + before$Version < after$Version ~ "upgrade", + before$Version > after$Version ~ "downgrade" + ) + + if (!is.null(type)) + return(type) + + # if we're running this as part of 'load()', and we're comparing + # packages with unknown sources, then just ignore those -- this + # is because we disable the 'guess repository' hack on startup, + # to avoid a potentially expensive query of package repositories + # + # https://github.com/rstudio/renv/issues/1683 + if (the$load_running) { + unknown <- + identical(before$Source, "unknown") || + identical(after$Source, "unknown") + if (unknown) + return(NULL) + } + + # check for a crossgrade -- where the package version is the same, + # but details about the package's remotes have changed + if (!setequal(renv_record_names(before), renv_record_names(after))) + return("crossgrade") + + nm <- union(renv_record_names(before), renv_record_names(after)) + if (!identical(before[nm], after[nm])) + return("crossgrade") + + NULL + +} + +renv_lockfile_diff_packages <- function(old, new) { + + old <- renv_lockfile_records(old) + new <- renv_lockfile_records(new) + + packages <- named(union(names(old), names(new))) + actions <- lapply(packages, function(package) { + before <- old[[package]]; after <- new[[package]] + renv_lockfile_diff_record(before, after) + }) + + Filter(Negate(is.null), actions) + +} + +renv_lockfile_override <- function(lockfile) { + records <- renv_lockfile_records(lockfile) + overrides <- renv_records_override(records) + renv_lockfile_records(lockfile) <- overrides + lockfile +} + +renv_lockfile_repair <- function(lockfile) { + + records <- renv_lockfile_records(lockfile) + + # fix up records in lockfile + renv_lockfile_records(lockfile) <- enumerate(records, function(package, record) { + + # if this package is from a repository, but doesn't specify an explicit + # version, then use the latest-available version of that package + source <- renv_record_source_normalize(record, record$Source) + if (identical(source, "Repository") && is.null(record$Version)) { + entry <- renv_available_packages_latest(package) + record$Version <- entry$Version + } + + # return normalized record + record + + }) + + lockfile + +} + + +# lockfile-read.R ------------------------------------------------------------ + + +renv_lockfile_read_finish_impl <- function(key, val) { + + # convert repository records to named vectors + # (be careful to handle NAs, NULLs) + if (identical(key, "Repositories") && is.null(names(val))) { + + getter <- function(name) function(record) record[[name]] %||% "" %NA% "" + keys <- map_chr(val, getter("Name")) + vals <- map_chr(val, getter("URL")) + + result <- case( + empty(keys) ~ list(), + any(nzchar(keys)) ~ named(vals, keys), + TRUE ~ vals + ) + + return(as.list(result)) + + } + + # convert the "Requirements" field to a character vector + if (identical(key, "Requirements")) + return(unlist(val)) + + # recurse for lists + if (is.list(val)) + return(enumerate(val, renv_lockfile_read_finish_impl)) + + # return other values as-is + val + +} + +renv_lockfile_read_finish <- function(data) { + data <- enumerate(data, renv_lockfile_read_finish_impl) + class(data) <- "renv_lockfile" + data +} + +renv_lockfile_read_preflight <- function(contents) { + + # check for merge conflict markers + starts <- grep("^[<]+", contents) + ends <- grep("^[>]+", contents) + + hasconflicts <- + length(starts) && + length(ends) && + length(starts) == length(ends) + + if (hasconflicts) { + + parts <- .mapply(function(start, end) { + c(contents[start:end], "") + }, list(starts, ends), NULL) + + all <- unlist(parts, recursive = TRUE, use.names = FALSE) + + caution_bullets( + "The lockfile contains one or more merge conflict markers:", + head(all, n = -1L), + "You will need to resolve these merge conflicts before the file can be read." + ) + + stop("lockfile contains merge conflict markers; cannot proceed", call. = FALSE) + + } + +} + +renv_lockfile_read <- function(file = NULL, text = NULL) { + + # read the lockfile + contents <- if (is.null(file)) + unlist(strsplit(text, "\n", fixed = TRUE)) + else + readLines(file, warn = FALSE, encoding = "UTF-8") + + # check and report some potential errors (e.g. merge conflicts) + renv_lockfile_read_preflight(contents) + withCallingHandlers( + json <- renv_json_read(text = contents), + error = function(err) { + stop("Failed to parse 'renv.lock':\n", conditionMessage(err)) + } + ) + + renv_lockfile_read_finish(json) + +} + + +# lockfile-write.R ----------------------------------------------------------- + + +the$lockfile_state <- new.env(parent = emptyenv()) + +renv_lockfile_state_get <- function(key) { + if (exists(key, envir = the$lockfile_state)) + get(key, envir = the$lockfile_state, inherits = FALSE) +} + +renv_lockfile_state_set <- function(key, value) { + assign(key, value, envir = the$lockfile_state, inherits = FALSE) +} + +renv_lockfile_state_clear <- function() { + rm(list = ls(the$lockfile_state), envir = the$lockfile_state) +} + +renv_lockfile_write_preflight <- function(old, new) { + + diff <- renv_lockfile_diff(old, new) + if (empty(diff)) + return(new) + + packages <- diff$Packages + if (empty(diff$Packages)) + return(new) + + enumerate(packages, function(package, changes) { + + # avoid spurious changes between CRAN and RSPM + spurious <- + identical(changes, list(Repository = list(before = "CRAN", after = "RSPM"))) || + identical(changes, list(Repository = list(before = "RSPM", after = "CRAN"))) + + if (spurious) + new$Packages[[package]]$Repository <<- old$Packages[[package]]$Repository + + # avoid spurious changes between CRAN and PPM + spurious <- + identical(changes, list(Repository = list(before = "CRAN", after = "PPM"))) || + identical(changes, list(Repository = list(before = "PPM", after = "CRAN"))) + + if (spurious) + new$Packages[[package]]$Repository <<- old$Packages[[package]]$Repository + + }) + + new + +} + +renv_lockfile_write <- function(lockfile, file = stdout()) { + + # if we're updating an existing lockfile, try to avoid + # "unnecessary" diffs that might otherwise be annoying + if (is.character(file) && file.exists(file)) { + old <- catch(renv_lockfile_read(file)) + if (!inherits(old, "error")) + lockfile <- renv_lockfile_write_preflight(old, lockfile) + } + + lockfile <- renv_lockfile_sort(lockfile) + result <- renv_lockfile_write_json(lockfile, file) + + if (is.character(file)) + writef("- Lockfile written to %s.", renv_path_pretty(file)) + + result + +} + +renv_lockfile_write_json_prepare_repos <- function(repos) { + + prepared <- enumerate(repos, function(name, url) { + url <- sub("/+$", "", url) + list(Name = name, URL = url) + }) + + unname(prepared) +} + +renv_lockfile_write_json_prepare <- function(key, val) { + + if (key == "Repositories") + renv_lockfile_write_json_prepare_repos(val) + else if (is.list(val) && !is.null(names(val))) + enumerate(val, renv_lockfile_write_json_prepare) + else + val + +} + +renv_lockfile_write_json <- function(lockfile, file = stdout()) { + + prepared <- enumerate(lockfile, renv_lockfile_write_json_prepare) + + box <- c("Depends", "Imports", "Suggests", "LinkingTo", "Requirements") + config <- list(box = box) + json <- renv_json_convert(prepared, config) + if (is.null(file)) + return(json) + + writeLines(json, con = file) + +} + +renv_lockfile_write_internal <- function(lockfile, + file = stdout(), + delim = "=") +{ + if (is.character(file)) { + file <- textfile(file) + defer(close(file)) + } + + emitter <- function(text) writeLines(text, con = file) + + renv_lockfile_state_set("delim", delim) + renv_lockfile_state_set("emitter", emitter) + defer(renv_lockfile_state_clear()) + + renv_lockfile_write_list(lockfile, section = character()) + invisible(lockfile) +} + +renv_lockfile_write_list <- function(entry, section) { + enumerate(entry, renv_lockfile_write_atoms, section = section) + enumerate(entry, renv_lockfile_write_lists, section = section) +} + +renv_lockfile_write_atoms <- function(key, value, section) { + + sublists <- map_lgl(value, function(x) identical(class(x), "list")) + if (all(sublists)) + return() + + subsection <- c(section, key) + label <- sprintf("[%s]", paste(subsection, collapse = "/")) + renv_lockfile_write_emit(label) + + enumerate(value[!sublists], renv_lockfile_write_atom) + renv_lockfile_write_emit() + +} + +renv_lockfile_write_atom <- function(key, value) { + + lhs <- key + rhs <- if (is_named(value)) + paste(sprintf("\n\t%s=%s", names(value), value), collapse = "") + else + paste(value, collapse = ", ") + + delim <- renv_lockfile_state_get("delim") + text <- paste(lhs, rhs, sep = delim) + renv_lockfile_write_emit(text) + +} + +renv_lockfile_write_lists <- function(key, value, section) { + sublists <- map_lgl(value, function(x) identical(class(x), "list")) + renv_lockfile_write_list(value[sublists], section = c(section, key)) +} + +renv_lockfile_write_emit <- function(text = "") { + emitter <- renv_lockfile_state_get("emitter") + emitter(text) +} + + +# lockfile.R ----------------------------------------------------------------- + + +renv_lockfile_init <- function(project) { + + lockfile <- list() + + lockfile$R <- renv_lockfile_init_r(project) + lockfile$Python <- renv_lockfile_init_python(project) + lockfile$Packages <- list() + + class(lockfile) <- "renv_lockfile" + lockfile + +} + +renv_lockfile_init_r_version <- function(project) { + + # NOTE: older versions of renv may have written out an empty array + # for the R version in some cases, so we explicitly check that we + # receive a length-one string here. + version <- settings$r.version(project = project) + if (!pstring(version)) + version <- getRversion() + + format(version) + +} + +renv_lockfile_init_r_repos <- function(project) { + + repos <- getOption("repos") + + # save names + nms <- names(repos) + + # force as character + repos <- as.character(repos) + + # clear RStudio attribute + attr(repos, "RStudio") <- NULL + + # set a default URL + repos[repos == "@CRAN@"] <- getOption( + "renv.repos.cran", + "https://cloud.r-project.org" + ) + + # remove PPM bits from URL + if (renv_ppm_enabled()) { + pattern <- "/__[^_]+__/[^/]+/" + repos <- sub(pattern, "/", repos) + } + + # force as list + repos <- as.list(repos) + + # ensure names + names(repos) <- nms + + repos + +} + +renv_lockfile_init_r <- function(project) { + version <- renv_lockfile_init_r_version(project) + repos <- renv_lockfile_init_r_repos(project) + list(Version = version, Repositories = repos) +} + +renv_lockfile_init_python <- function(project) { + + python <- Sys.getenv("RENV_PYTHON", unset = NA) + if (is.na(python)) + return(NULL) + + if (!file.exists(python)) + return(NULL) + + info <- renv_python_info(python) + if (is.null(info)) + return(NULL) + + version <- renv_python_version(python) + type <- info$type + root <- info$root + name <- renv_python_envname(project, root, type) + + fields <- list() + + fields$Version <- version + fields$Type <- type + fields$Name <- name + + fields + +} + +renv_lockfile_fini <- function(lockfile, project) { + lockfile$Bioconductor <- renv_lockfile_fini_bioconductor(lockfile, project) + lockfile +} + +renv_lockfile_fini_bioconductor <- function(lockfile, project) { + + # check for explicit version in settings + version <- settings$bioconductor.version(project = project) + if (length(version)) + return(list(Version = version)) + + # otherwise, check for a package which required Bioconductor + records <- renv_lockfile_records(lockfile) + if (empty(records)) + return(NULL) + + for (package in c("BiocManager", "BiocInstaller")) + if (!is.null(records[[package]])) + return(list(Version = renv_bioconductor_version(project = project))) + + sources <- extract_chr(records, "Source") + if ("Bioconductor" %in% sources) + return(list(Version = renv_bioconductor_version(project = project))) + + # nothing found; return NULL + NULL + +} + +renv_lockfile_path <- function(project) { + renv_paths_lockfile(project = project) +} + +renv_lockfile_save <- function(lockfile, project) { + file <- renv_lockfile_path(project) + renv_lockfile_write(lockfile, file = file) +} + +renv_lockfile_load <- function(project, strict = FALSE) { + + path <- renv_lockfile_path(project) + if (file.exists(path)) + return(renv_lockfile_read(path)) + + if (strict) { + abort(c( + "This project does not contain a lockfile.", + i = "Have you called `snapshot()` yet?" + )) + } + + renv_lockfile_init(project = project) + +} + +renv_lockfile_sort <- function(lockfile) { + + # extract R records (nothing to do if empty) + records <- renv_lockfile_records(lockfile) + if (empty(records)) + return(lockfile) + + # sort the records + sorted <- records[csort(names(records))] + renv_lockfile_records(lockfile) <- sorted + + # sort top-level fields + fields <- unique(c("R", "Bioconductor", "Python", "Packages", names(lockfile))) + lockfile <- lockfile[intersect(fields, names(lockfile))] + + # return post-sort + lockfile + +} + +renv_lockfile_create <- function(project, + type = NULL, + libpaths = NULL, + packages = NULL, + exclude = NULL, + prompt = NULL, + force = NULL, + dev = FALSE) +{ + libpaths <- libpaths %||% renv_libpaths_all() + type <- type %||% settings$snapshot.type(project = project) + + # use a restart, so we can allow the user to install packages before snapshot + lockfile <- withRestarts( + renv_lockfile_create_impl(project, type, libpaths, packages, exclude, prompt, force, dev = dev), + renv_recompute_records = function() { + renv_dynamic_reset() + renv_lockfile_create_impl(project, type, libpaths, packages, exclude, prompt, force, dev = dev) + } + ) +} + +renv_lockfile_create_impl <- function(project, type, libpaths, packages, exclude, prompt, force, dev = FALSE) { + + lockfile <- renv_lockfile_init(project) + + # compute the project's top-level package dependencies + packages <- packages %||% renv_snapshot_dependencies( + project = project, + type = type, + dev = dev + ) + + # expand the recursive dependencies of these packages + records <- renv_snapshot_packages( + packages = setdiff(packages, exclude), + libpaths = libpaths, + project = project + ) + + # check for missing packages + ignored <- c(renv_project_ignored_packages(project), renv_packages_base(), exclude, "renv") + missing <- setdiff(packages, c(names(records), ignored)) + + # cancel automatic snapshots if we have missing packages + if (length(missing) && the$auto_snapshot_running) { + cancel <- findRestart("cancel") + if (isRestart(cancel)) + invokeRestart(cancel) + } + + # give user a chance to handle missing packages, if any + # + # we only run this in top-level calls to snapshot() since renv will internally + # use snapshot() to create lockfiles, and missing packages are understood / + # tolerated there. this code mostly exists so interactive usages of snapshot() + # can recover and install missing packages + if (identical(topfun(), snapshot)) + renv_snapshot_report_missing(missing, type) + + records <- renv_snapshot_fixup(records) + renv_lockfile_records(lockfile) <- records + + lockfile <- renv_lockfile_fini(lockfile, project) + + keys <- unique(c("R", "Bioconductor", names(lockfile))) + lockfile <- lockfile[intersect(keys, names(lockfile))] + + class(lockfile) <- "renv_lockfile" + lockfile + +} + +renv_lockfile_modify <- function(lockfile, records) { + + enumerate(records, function(package, record) { + renv_lockfile_records(lockfile)[[package]] <<- record + }) + + lockfile + +} + +renv_lockfile_compact <- function(lockfile) { + + records <- renv_lockfile_records(lockfile) + remotes <- map_chr(records, renv_record_format_remote) + + remotes <- csort(remotes) + + formatted <- sprintf(" \"%s\"", remotes) + joined <- paste(formatted, collapse = ",\n") + + all <- c("renv::use(", joined, ")") + paste(all, collapse = "\n") + +} + +renv_lockfile_records <- function(lockfile) { + as.list(lockfile$Packages %||% lockfile) +} + +`renv_lockfile_records<-` <- function(x, value) { + x$Packages <- filter(value, zlength) + invisible(x) +} + +# for compatibility with older versions of RStudio +renv_records <- renv_lockfile_records + + +# lockfiles.R ---------------------------------------------------------------- + + +#' Lockfiles +#' +#' A **lockfile** records the state of a project at some point in time. +#' +#' A lockfile captures the state of a project's library at some point in time. +#' In particular, the package names, their versions, and their sources (when +#' known) are recorded in the lockfile. +#' +#' Projects can be restored from a lockfile using the [restore()] function. This +#' implies reinstalling packages into the project's private library, as encoded +#' within the lockfile. +#' +#' While lockfiles are normally generated and used with [snapshot()] / +#' [restore()], they can also be edited by hand if so desired. Lockfiles are +#' written as `.json`, to allow for easy consumption by other tools. +#' +#' An example lockfile follows: +#' +#' ``` +#' { +#' "R": { +#' "Version": "3.6.1", +#' "Repositories": [ +#' { +#' "Name": "CRAN", +#' "URL": "https://cloud.r-project.org" +#' } +#' ] +#' }, +#' "Packages": { +#' "markdown": { +#' "Package": "markdown", +#' "Version": "1.0", +#' "Source": "Repository", +#' "Repository": "CRAN", +#' "Hash": "4584a57f565dd7987d59dda3a02cfb41" +#' }, +#' "mime": { +#' "Package": "mime", +#' "Version": "0.7", +#' "Source": "Repository", +#' "Repository": "CRAN", +#' "Hash": "908d95ccbfd1dd274073ef07a7c93934" +#' } +#' } +#' } +#' ``` +#' +#' The sections used within a lockfile are described next. +#' +#' ## renv +#' +#' Information about the version of renv used to manage this project. +#' +#' \tabular{ll}{ +#' \strong{Version} \tab The version of the renv package used with this project. \cr +#' } +#' +#' ## R +#' +#' Properties related to the version of \R associated with this project. +#' +#' \tabular{ll}{ +#' \strong{Version} \tab The version of \R used. \cr +#' \strong{Repositories} \tab The \R repositories used in this project. \cr +#' } +#' +#' ## Packages +#' +#' \R package records, capturing the packages used or required by a project +#' at the time when the lockfile was generated. +#' +#' \tabular{ll}{ +#' \strong{Package} \tab The package name. \cr +#' \strong{Version} \tab The package version. \cr +#' \strong{Source} \tab The location from which this package was retrieved. \cr +#' \strong{Repository} \tab The name of the repository (if any) from which this package was retrieved. \cr +#' \strong{Hash} \tab (Optional) A unique hash for this package, used for package caching. \cr +#' } +#' +#' Additional remote fields, further describing how the package can be +#' retrieved from its corresponding source, will also be included as +#' appropriate (e.g. for packages installed from GitHub). +#' +#' ## Python +#' +#' Metadata related to the version of Python used with this project (if any). +#' +#' \tabular{ll}{ +#' \strong{Version} \tab The version of Python being used. \cr +#' \strong{Type} \tab The type of Python environment being used ("virtualenv", "conda", "system") \cr +#' \strong{Name} \tab The (optional) name of the environment being used. +#' } +#' +#' Note that the `Name` field may be empty. In that case, a project-local Python +#' environment will be used instead (when not directly using a system copy of Python). +#' +#' # Caveats +#' +#' These functions are primarily intended for expert users -- in most cases, +#' [snapshot()] and [restore()] are the primariy tools you will need when +#' creating and using lockfiles. +#' +#' @inheritParams snapshot +#' @inheritParams renv-params +#' +#' @param lockfile An `renv` lockfile; typically created by either +#' `lockfile_create()` or `lockfile_read()`. +#' +#' @param file A file path, or \R connection. +#' +#' @family reproducibility +#' @name lockfiles +#' @rdname lockfiles +NULL + +#' @param libpaths The library paths to be used when generating the lockfile. +#' @rdname lockfiles +#' @export +lockfile_create <- function(type = settings$snapshot.type(project = project), + libpaths = .libPaths(), + packages = NULL, + exclude = NULL, + prompt = interactive(), + force = FALSE, + ..., + project = NULL) +{ + renv_dots_check(...) + + project <- renv_project_resolve(project) + renv_scope_verbose_if(prompt) + + renv_lockfile_create( + project = project, + type = type, + libpaths = libpaths, + packages = packages, + exclude = exclude, + prompt = prompt, + force = force + ) +} + +#' @rdname lockfiles +#' @export +lockfile_read <- function(file = NULL, ..., project = NULL) { + project <- renv_project_resolve(project) + file <- file %||% renv_paths_lockfile(project = project) + renv_lockfile_read(file = file) +} + +#' @rdname lockfiles +#' @export +lockfile_write <- function(lockfile, file = NULL, ..., project = NULL) { + project <- renv_project_resolve(project) + file <- file %||% renv_paths_lockfile(project = project) + renv_lockfile_write(lockfile, file = file) +} + +#' @param remotes An \R vector of remote specifications. +#' +#' @param repos A named vector, mapping \R repository names to their URLs. +#' +#' @rdname lockfiles +#' @export +lockfile_modify <- function(lockfile = NULL, + ..., + remotes = NULL, + repos = NULL, + project = NULL) +{ + renv_dots_check(...) + + project <- renv_project_resolve(project) + lockfile <- lockfile %||% renv_lockfile_load(project, strict = TRUE) + + if (!is.null(repos)) + lockfile$R$Repositories <- as.list(repos) + + if (!is.null(remotes)) { + remotes <- renv_records_resolve(remotes, latest = TRUE) + names(remotes) <- map_chr(remotes, `[[`, "Package") + enumerate(remotes, function(package, remote) { + record <- renv_remotes_resolve(remote) + renv_lockfile_records(lockfile)[[package]] <<- record + }) + } + + lockfile + +} + + +# log.R ---------------------------------------------------------------------- + + +# the log level, indicating what severity of messages will be logged +the$log_level <- 4L + +# the file to which log messages will be written +the$log_file <- NULL + +# the scopes for which filtering will be enabled +the$log_scopes <- NULL + +elog <- function(scope, fmt, ...) { + renv_log_impl(4L, scope, fmt, ...) +} + +wlog <- function(scope, fmt, ...) { + renv_log_impl(3L, scope, fmt, ...) +} + +ilog <- function(scope, fmt, ...) { + renv_log_impl(2L, scope, fmt, ...) +} + +dlog <- function(scope, fmt, ...) { + renv_log_impl(1L, scope, fmt, ...) +} + + +renv_log_impl <- function(level, scope, fmt, ...) { + + # check log level + if (level < the$log_level) + return() + + # only include scopes matching the scopes + scopes <- the$log_scopes + if (is.character(scopes) && !scope %in% scopes) + return() + + # build message + message <- sprintf(fmt, ...) + + # annotate with prefix from scope, timestamp + fmt <- "%sZ [renv-%i] %s: %s" + now <- format(Sys.time(), format = "%Y-%m-%d %H:%M:%OS6", tz = "UTC") + all <- sprintf(fmt, now, Sys.getpid(), scope, message) + + # write it out + cat(all, file = the$log_file, sep = "\n", append = TRUE) + +} + +renv_log_init <- function() { + the$log_level <- renv_log_level() + the$log_file <- renv_log_file() + the$log_scopes <- renv_log_scopes() +} + +renv_log_level <- function() { + + level <- Sys.getenv("RENV_LOG_LEVEL", unset = NA) + if (is.na(level)) + return(4L) + + case( + level %in% c("4", "error", "ERROR") ~ 4L, + level %in% c("3", "warning", "WARNING") ~ 3L, + level %in% c("2", "info", "INFO") ~ 2L, + level %in% c("1", "debug", "DEBUG") ~ 1L, + ~ { + warningf("ignoring invalid RENV_LOG_LEVEL '%s'", level) + 4L + } + ) + +} + +renv_log_file <- function() { + + # check for log file + file <- Sys.getenv("RENV_LOG_FILE", unset = NA) + if (!is.na(file)) + return(file) + + # default to stderr, since it's unbuffered + stderr() + +} + +renv_log_scopes <- function() { + + scopes <- Sys.getenv("RENV_LOG_SCOPES", unset = NA) + if (is.na(scopes)) + return(NULL) + + strsplit(scopes, ",", fixed = TRUE)[[1L]] + +} + + + +# manifest-convert.R --------------------------------------------------------- + + +#' Generate `renv.lock` from an RStudio Connect `manifest.json` +#' +#' Use `renv_lockfile_from_manifest()` to convert a `manifest.json` file from +#' an RStudio Connect content bundle into an `renv.lock` lockfile. +#' +#' This function can be useful when you need to recreate the package environment +#' of a piece of content that is deployed to RStudio Connect. The content bundle +#' contains a `manifest.json` file that is used to recreate the package +#' environment. This function will let you convert that manifest file to an +#' `renv.lock` file. Run `renv::restore()` after you've converted the file to +#' restore the package environment. +#' +#' @param manifest +#' The path to a `manifest.json` file. +#' +#' @param lockfile +#' The path to the lockfile to be generated and / or updated. +#' When `NA` (the default), the generated lockfile is returned as an \R +#' object; otherwise, the lockfile will be written to the path specified by +#' `lockfile`. +#' +#' @details +#' By default the `lockfile` argument is set to `NA`. This will not create a new +#' `renv.lock` file. Rather, it will return a lockfile object (see `?lockfile`) +#' that can be used to create a new `renv.lock` file. If `lockfile` is set to a +#' character string, a new file will be created with that path -- e.g. +#' `renv.lock` -- and the lockfile object will be returned. +#' +#' @return +#' An renv lockfile. +#' +#' @keywords internal +renv_lockfile_from_manifest <- function(manifest, + lockfile = NA, + project = NULL) +{ + renv_scope_error_handler() + project <- renv_project_resolve(project) + + # read the manifest (accept both lists and file paths) + manifest <- case( + is.character(manifest) ~ renv_json_read(manifest), + is.list(manifest) ~ manifest, + TRUE ~ renv_type_unexpected(manifest) + ) + + # convert descriptions into records + records <- map(manifest[["packages"]], function(entry) { + desc <- entry[["description"]] + renv_snapshot_description_impl(desc) + }) + + # extract repositories from descriptions + repos <- list() + for (entry in manifest[["packages"]]) { + + if (is.null(entry[["Repository"]])) + next + + src <- entry[["Source"]] %||% "CRAN" + repo <- entry[["Repository"]] + + repos[[src]] <- repo + + } + + # extract version + version <- format(manifest[["platform"]] %||% getRversion()) + + # create R field for lockfile + r <- list(Version = version, Repositories = repos) + + # create the lockfile + lock <- list(R = r, Packages = records) + class(lock) <- "renv_lockfile" + + # return lockfile as R object if requested + if (is.na(lockfile)) + return(lock) + + # otherwise, write to file and report for user + renv_lockfile_write(lock, file = lockfile) + fmt <- "- Lockfile written to %s." + writef(fmt, renv_path_pretty(lockfile)) + + invisible(lock) + +} + + +# mask.R --------------------------------------------------------------------- + + +# functions which mask internal / base R equivalents, usually to provide +# backwards compatibility or guard against common errors + +numeric_version <- function(x, strict = TRUE) { + base::numeric_version(as.character(x), strict = strict) +} + +sprintf <- function(fmt, ...) { + if (nargs() == 1L) + fmt + else + base::sprintf(fmt, ...) +} + +unique <- function(x) { + base::unique(x) +} + +# a wrapper for 'utils::untar()' that throws an error if untar fails +untar <- function(tarfile, + files = NULL, + list = FALSE, + exdir = ".", + tar = Sys.getenv("TAR")) +{ + # delegate to utils::untar() + result <- utils::untar( + tarfile = tarfile, + files = files, + list = list, + exdir = exdir, + tar = tar + ) + + # check for errors (tar returns a status code) + if (is.integer(result) && result != 0L) { + call <- stringify(sys.call()) + stopf("'%s' returned status code %i", call, result) + } + + # return other results as-is + result +} + + + +# memoize.R ------------------------------------------------------------------ + + +the$memoize <- new.env(parent = emptyenv()) + +memo <- function(value, scope = NULL) { + scope <- scope %||% stringify(sys.call(sys.parent())[[1L]]) + (the$memoize[[scope]] <- the$memoize[[scope]] %||% value) +} + +memoize <- function(key, value, scope = NULL) { + + # figure out scope to use + scope <- scope %||% stringify(sys.call(sys.parent())[[1L]]) + + # initialize memoized environment + envir <- + the$memoize[[scope]] <- + the$memoize[[scope]] %||% + new.env(parent = emptyenv()) + + # retrieve, or compute, memoized value + envir[[key]] <- envir[[key]] %||% value + +} + + +# metadata.R ----------------------------------------------------------------- + + +# NOTE: 'the$metadata' is initialized either in 'renv_metadata_init()', for +# stand-alone installations of renv, or via an embedded initialize script for +# vendored copies of renv. + +renv_metadata_create <- function(embedded, version) { + list(embedded = embedded, version = version) +} + +renv_metadata_embedded <- function() { + the$metadata$embedded +} + +renv_metadata_version <- function() { + the$metadata$version +} + +renv_metadata_version_create <- function(record) { + version <- record[["Version"]] + attr(version, "sha") <- record[["RemoteSha"]] + version +} + +renv_metadata_remote <- function(metadata = the$metadata) { + + # check for development versions + sha <- attr(metadata$version, "sha") + if (!is.null(sha) && nzchar(sha)) + return(paste("rstudio/renv", sha, sep = "@")) + + # otherwise, use release version + paste("renv", metadata$version, sep = "@") + +} + +renv_metadata_version_friendly <- function(metadata = the$metadata, + shafmt = NULL) +{ + renv_bootstrap_version_friendly( + version = metadata$version, + shafmt = shafmt + ) +} + +renv_metadata_init <- function() { + + # if renv was embedded, then the$metadata should already be initialized + if (!is.null(the$metadata)) + return() + + # renv doesn't appear to be embedded; initialize metadata + path <- renv_namespace_path("renv") + record <- renv_description_read(path = file.path(path, "DESCRIPTION")) + version <- renv_metadata_version_create(record) + + the$metadata <- renv_metadata_create( + embedded = FALSE, + version = version + ) + +} + + +# methods.R ------------------------------------------------------------------ + + +renv_methods_map <- function() { + + list( + + renv_path_normalize = c( + unix = "renv_path_normalize_unix", + win32 = "renv_path_normalize_win32" + ), + + renv_file_exists = c( + unix = "renv_file_exists_unix", + win32 = "renv_file_exists_win32" + ), + + renv_file_list_impl = c( + unix = "renv_file_list_impl_unix", + win32 = "renv_file_list_impl_win32" + ), + + renv_file_broken = c( + unix = "renv_file_broken_unix", + win32 = "renv_file_broken_win32" + ) + + ) + +} + +renv_methods_init <- function() { + + # get list of method mappings + methods <- renv_methods_map() + + # determine appropriate lookup key for finding alternative + key <- if (renv_platform_windows()) "win32" else "unix" + alts <- map(methods, `[[`, key) + + # update methods in namespace + envir <- renv_envir_self() + enumerate(alts, function(name, alt) { + replacement <- eval(parse(text = alt), envir = envir) + assign(name, replacement, envir = envir) + }) + +} + +renv_methods_error <- function() { + call <- sys.call(sys.parent()) + fmt <- "internal error: '%s()' not initialized in .onLoad()" + stopf(fmt, as.character(call[[1L]]), call. = FALSE) +} + + +# migrate.R ------------------------------------------------------------------ + + +#' Migrate a project from packrat to renv +#' +#' Migrate a project's infrastructure from packrat to renv. +#' +#' # Migration +#' +#' When migrating Packrat projects to renv, the set of components migrated +#' can be customized using the `packrat` argument. The set of components that +#' can be migrated are as follows: +#' +#' \tabular{ll}{ +#' +#' **Name** \tab **Description** \cr +#' +#' `lockfile` \tab +#' Migrate the Packrat lockfile (`packrat/packrat.lock`) to the renv lockfile +#' (`renv.lock`). \cr +#' +#' `sources` \tab +#' Migrate package sources from the `packrat/src` folder to the renv +#' sources folder. Currently, only CRAN packages are migrated to renv -- +#' packages retrieved from other sources (e.g. GitHub) are ignored. +#' \cr +#' +#' `library` \tab +#' Migrate installed packages from the Packrat library to the renv project +#' library. +#' \cr +#' +#' `options` \tab +#' Migrate compatible Packrat options to the renv project. +#' \cr +#' +#' `cache` \tab +#' Migrate packages from the Packrat cache to the renv cache. +#' \cr +#' +#' } +#' +#' @inherit renv-params +#' +#' @param packrat Components of the Packrat project to migrate. See the default +#' argument list for components of the Packrat project that can be migrated. +#' Select a subset of those components for migration as appropriate. +#' +#' @export +#' +#' @examples +#' \dontrun{ +#' +#' # migrate Packrat project infrastructure to renv +#' renv::migrate() +#' +#' } +migrate <- function( + project = NULL, + packrat = c("lockfile", "sources", "library", "options", "cache")) +{ + renv_consent_check() + renv_scope_error_handler() + + project <- renv_project_resolve(project) + renv_project_lock(project = project) + + project <- renv_path_normalize(project, mustWork = TRUE) + if (file.exists(file.path(project, "packrat/packrat.lock"))) { + packrat <- match.arg(packrat, several.ok = TRUE) + renv_migrate_packrat(project, packrat) + } + + invisible(project) +} + +renv_migrate_packrat <- function(project = NULL, components = NULL) { + project <- renv_project_resolve(project) + + if (!requireNamespace("packrat", quietly = TRUE)) + stopf("migration requires the 'packrat' package to be installed") + + callbacks <- list( + lockfile = renv_migrate_packrat_lockfile, + sources = renv_migrate_packrat_sources, + library = renv_migrate_packrat_library, + options = renv_migrate_packrat_options, + cache = renv_migrate_packrat_cache + ) + + components <- components %||% names(callbacks) + callbacks <- callbacks[components] + for (callback in callbacks) + callback(project) + + renv_migrate_packrat_infrastructure(project) + renv_imbue_impl(project) + + fmt <- "- Project '%s' has been migrated from Packrat to renv." + writef(fmt, renv_path_aliased(project)) + + writef("- Consider deleting the project 'packrat' folder if it is no longer needed.") + invisible(TRUE) +} + +renv_migrate_packrat_lockfile <- function(project) { + + plock <- file.path(project, "packrat/packrat.lock") + if (!file.exists(plock)) + return(FALSE) + + # read the lockfile + contents <- read(plock) + splat <- strsplit(contents, "\n{2,}")[[1]] + dcf <- lapply(splat, function(section) { + renv_dcf_read(text = section) + }) + + # split into header + package fields + header <- dcf[[1]] + records <- dcf[-1L] + + # parse the repositories + repos <- getOption("repos") + if (!is.null(header$Repos)) { + parts <- strsplit(header$Repos, "\\s*,\\s*")[[1]] + repos <- renv_properties_read(text = parts, delimiter = "=") + } + + # fix-up some record fields for renv + fields <- c("Package", "Version", "Source") + records <- lapply(records, function(record) { + + # remove an old packrat hash + record$Hash <- NULL + + # add RemoteType for GitHub records + if (any(grepl("^Github", names(record)))) + record$RemoteType <- "github" + + # remap '^Github'-style records to '^Remote' + map <- c( + "GithubRepo" = "RemoteRepo", + "GithubUsername" = "RemoteUsername", + "GithubRef" = "RemoteRef", + "GithubSha1" = "RemoteSha", + "GithubSHA1" = "RemoteSha", + "GithubSubdir" = "RemoteSubdir" + ) + names(record) <- remap(names(record), map) + + # keep only fields of interest + keep <- c(fields, grep("^Remote", names(record), value = TRUE)) + as.list(record[keep]) + + }) + + # pull out names for records + names(records) <- extract_chr(records, "Package") + + # ensure renv is added + records <- renv_snapshot_fixup_renv(records) + + # generate a blank lockfile + lockfile <- structure(list(), class = "renv_lockfile") + lockfile$R <- renv_lockfile_init_r(project) + + # update fields + lockfile$R$Version <- header$RVersion + lockfile$R$Repositories <- as.list(repos) + renv_lockfile_records(lockfile) <- records + + # finish + lockfile <- renv_lockfile_fini(lockfile, project) + + # write the lockfile + lockpath <- renv_lockfile_path(project = project) + renv_lockfile_write(lockfile, file = lockpath) + +} + +renv_migrate_packrat_sources <- function(project) { + + packrat <- asNamespace("packrat") + srcdir <- packrat$srcDir(project = project) + if (!file.exists(srcdir)) + return(TRUE) + + pattern <- paste0( + "^", # start + "[^_]+", # package name + "_", # separator + "\\d+(?:[_.-]\\d+)*", # version + "\\.tar\\.gz", # extension + "$" # end + ) + + suffixes <- list.files( + srcdir, + pattern = pattern, + recursive = TRUE + ) + + sources <- file.path(srcdir, suffixes) + targets <- renv_paths_source("cran", suffixes) + + keep <- !file.exists(targets) + sources <- sources[keep]; targets <- targets[keep] + + printf("- Migrating package sources from Packrat to renv ... ") + copy <- renv_progress_callback(renv_file_copy, length(targets)) + mapply(sources, targets, FUN = function(source, target) { + ensure_parent_directory(target) + copy(source, target) + }) + writef("Done!") + + TRUE + +} + +renv_migrate_packrat_library <- function(project) { + + packrat <- asNamespace("packrat") + + libdir <- packrat$libDir(project = project) + if (!file.exists(libdir)) + return(TRUE) + + sources <- list.files(libdir, full.names = TRUE) + if (empty(sources)) + return(TRUE) + + targets <- renv_paths_library(basename(sources), project = project) + + names(targets) <- sources + targets <- targets[!file.exists(targets)] + if (empty(targets)) { + writef("- The renv library is already synchronized with the Packrat library.") + return(TRUE) + } + + # copy packages from Packrat to renv private library + printf("- Migrating library from Packrat to renv ... ") + ensure_parent_directory(targets) + copy <- renv_progress_callback(renv_file_copy, length(targets)) + enumerate(targets, copy) + writef("Done!") + + # move packages into the cache + if (renv_cache_config_enabled(project = project)) { + printf("- Moving packages into the renv cache ... ") + records <- lapply(targets, renv_description_read) + sync <- renv_progress_callback(renv_cache_synchronize, length(targets)) + lapply(records, sync, linkable = TRUE) + writef("Done!") + } + + TRUE + +} + +renv_migrate_packrat_options <- function(project) { + + packrat <- asNamespace("packrat") + opts <- packrat$get_opts(project = project) + + settings$ignored.packages(opts$ignored.packages, project = project) + +} + +renv_migrate_packrat_cache <- function(project) { + + # find packages in the packrat cache + packrat <- asNamespace("packrat") + cache <- packrat$cacheLibDir() + packages <- list.files(cache, full.names = TRUE) + hashes <- list.files(packages, full.names = TRUE) + sources <- list.files(hashes, full.names = TRUE) + + # sanity check: make sure the source folder is an R package + ok <- file.exists(file.path(sources, "DESCRIPTION")) + sources <- sources[ok] + + # construct cache target paths + targets <- map_chr(sources, renv_cache_path) + names(targets) <- sources + + # only copy to cache target paths that don't exist + targets <- targets[!file.exists(targets)] + if (empty(targets)) { + writef("- The renv cache is already synchronized with the Packrat cache.") + return(TRUE) + } + + # cache each installed package + if (renv_cache_config_enabled(project = project)) + renv_migrate_packrat_cache_impl(targets) + + TRUE + +} + +renv_migrate_packrat_cache_impl <- function(targets) { + + # attempt to copy packages from Packrat to renv cache + printf("- Migrating Packrat cache to renv cache ... ") + ensure_parent_directory(targets) + copy <- renv_progress_callback(renv_file_copy, length(targets)) + + result <- enumerate(targets, function(source, target) { + status <- catch(copy(source, target)) + broken <- inherits(status, "error") + reason <- if (broken) conditionMessage(status) else "" + list(source = source, target = target, broken = broken, reason = reason) + }) + + writef("Done!") + + # report failures + status <- bind(result) + bad <- status[status$broken, ] + if (nrow(bad) == 0) + return(TRUE) + + caution_bullets( + "The following packages could not be copied from the Packrat cache:", + with(bad, sprintf("%s [%s]", format(source), reason)), + "These packages may need to be reinstalled and re-cached." + ) + +} + +renv_migrate_packrat_infrastructure <- function(project) { + unlink(file.path(project, ".Rprofile")) + renv_infrastructure_write(project) + writef("- renv support infrastructure has been written.") + TRUE +} + + +# modify.R ------------------------------------------------------------------- + + +#' Modify a Lockfile +#' +#' Modify a project's lockfile, either interactively or non-interactively. +#' +#' After edit, if the lockfile edited is associated with the active project, any +#' state-related changes (e.g. to \R repositories) will be updated in the +#' current session. +#' +#' @inherit renv-params +#' +#' @param changes A list of changes to be merged into the lockfile. +#' When `NULL` (the default), the lockfile is instead opened for +#' interactive editing. +#' +#' @export +#' +#' @examples +#' \dontrun{ +#' +#' # modify an existing lockfile +#' if (interactive()) +#' renv::modify() +#' +#' } +modify <- function(project = NULL, changes = NULL) { + renv_scope_error_handler() + project <- renv_project_resolve(project) + renv_project_lock(project = project) + renv_modify_impl(project, changes) + invisible(project) +} + +renv_modify_impl <- function(project, changes) { + + lockfile <- if (is.null(changes)) + renv_modify_interactive(project) + else + renv_modify_noninteractive(project, changes) + + if (renv_project_loaded(project)) + renv_modify_fini(lockfile) + +} + +renv_modify_interactive <- function(project) { + + # check for interactive session + if (!interactive()) + stop("can't modify lockfile in non-interactive session") + + # resolve path to lockfile + lockpath <- renv_lockfile_path(project) + if (!file.exists(lockpath)) + stopf("lockfile '%s' does not exist", renv_path_aliased(lockpath)) + + # copy the lockfile to a temporary file + dir <- renv_scope_tempfile("renv-lockfile-") + ensure_directory(dir) + + templock <- file.path(dir, "renv.lock") + file.copy(lockpath, templock) + + # edit the temporary lockfile + renv_file_edit(templock) + + # check that the new lockfile can be read + withCallingHandlers( + lockfile <- catch(renv_lockfile_read(file = templock)), + error = function(cnd) { + stop(lines( + "renv was unable to parse the modified lockfile:", + conditionMessage(cnd), + "Your changes will be discarded" + )) + } + ) + + lockfile + +} + +renv_modify_noninteractive <- function(project, changes) { + + # resolve path to lockfile + lockpath <- renv_lockfile_path(project) + if (!file.exists(lockpath)) + stopf("lockfile '%s' does not exist", renv_path_aliased(lockpath)) + + # read it + lockfile <- renv_lockfile_read(file = lockpath) + + # merge changes + merged <- overlay(lockfile, changes) + + # write updated lockfile to a temporary file + templock <- renv_scope_tempfile("renv-lock-") + renv_lockfile_write(merged, file = templock) + + # try reading it once more + newlock <- renv_lockfile_read(file = templock) + if (!identical(merged, newlock)) + stop("modify produced an invalid lockfile") + + # overwrite the original lockfile + file.rename(templock, lockpath) + + # finish up + merged + +} + +renv_modify_fini <- function(lockfile) { + + # synchronize relevant changes into the session + repos <- lockfile$R$Repositories + options(repos = convert(repos, "character")) + +} + + +# mran.R --------------------------------------------------------------------- + + +renv_mran_enabled <- function() { + !identical(getOption("pkgType"), "source") && config$mran.enabled() +} + +renv_mran_database_path <- function() { + renv_paths_mran("packages.rds") +} + +renv_mran_database_encode <- function(database) { + database <- as.list(database) + encoded <- lapply(database, renv_mran_database_encode_impl) + encoded[order(names(encoded))] +} + +renv_mran_database_encode_impl <- function(entry) { + + entry <- as.list(entry) + keys <- names(entry) + vals <- unlist(entry) + + splat <- strsplit(keys, " ", fixed = TRUE) + + encoded <- data_frame( + Package = map_chr(splat, `[[`, 1L), + Version = map_chr(splat, `[[`, 2L), + Date = as.integer(vals) + ) + + encoded <- encoded[order(encoded$Package, encoded$Version), ] + rownames(encoded) <- NULL + + encoded$Package <- as.factor(encoded$Package) + encoded$Version <- as.factor(encoded$Version) + + encoded + +} + +renv_mran_database_decode <- function(encoded) { + decoded <- lapply(encoded, renv_mran_database_decode_impl) + list2env(decoded, parent = emptyenv()) +} + +renv_mran_database_decode_impl <- function(entry) { + + entry$Package <- as.character(entry$Package) + entry$Version <- as.character(entry$Version) + + keys <- paste(entry$Package, entry$Version) + vals <- as.list(entry$Date) + names(vals) <- keys + + envir <- list2env(vals, parent = emptyenv()) + attr(envir, "keys") <- keys + + envir + +} + +renv_mran_database_save <- function(database, path = NULL) { + + path <- path %||% renv_mran_database_path() + ensure_parent_directory(path) + + encoded <- renv_mran_database_encode(database) + + conn <- xzfile(path) + defer(close(conn)) + saveRDS(encoded, file = conn, version = 2L) + +} + +renv_mran_database_load <- function(path = NULL) { + + filebacked( + context = "renv_mran_database_load", + path = path %||% renv_mran_database_path(), + callback = renv_mran_database_load_impl + ) + +} + +renv_mran_database_load_impl <- function(path) { + + # read from database file if it exists + if (file.exists(path)) { + encoded <- readRDS(path) + return(renv_mran_database_decode(encoded)) + } + + # otherwise, initialize a new database + new.env(parent = emptyenv()) + +} + +renv_mran_database_dates <- function(version, all = TRUE) { + + # release dates for old versions of R + releases <- c( + "3.2" = "2015-04-16", + "3.3" = "2016-05-03", + "3.4" = "2017-04-21", + "3.5" = "2018-04-23", + "3.6" = "2019-04-26", + "4.0" = "2020-04-24", + "4.1" = "2021-05-18", + "4.2" = "2022-04-22", + "4.3" = "2023-05-18", # a guess + "4.4" = "2024-05-18", # a guess + NULL + ) + + # find the start date + index <- match(version, names(releases)) + if (is.na(index)) + stopf("no known release date for R %s", version) + + start <- as.Date(releases[[index]]) + if (!all) + return(start) + + # form end date (ensure not in future) + # we look 2 releases in the future as R builds binaries for + # the previous releases of R as well + end <- min( + as.Date(releases[[index + 2L]]), + as.Date(Sys.time(), tz = "UTC") + ) + + # generate list of dates + seq(start, end, by = 1L) + +} + +renv_mran_database_key <- function(platform, version) { + sprintf("/bin/%s/contrib/%s", platform, version) +} + +renv_mran_database_update <- function(platform, version, dates = NULL) { + + # load database + database <- renv_mran_database_load() + + # get reference to entry in database (initialize if not yet created) + suffix <- renv_mran_database_key(platform, version) + database[[suffix]] <- database[[suffix]] %||% new.env(parent = emptyenv()) + entry <- database[[suffix]] + + # rough release dates for R releases + dates <- as.list(dates %||% renv_mran_database_dates(version)) + + for (date in dates) { + + # attempt to update our database entry for this date + url <- renv_mran_url(date, suffix) + tryCatch( + renv_mran_database_update_impl(date, url, entry), + error = warnify + ) + + } + + # save at end + printf("[%s]: saving database ... ", date) + renv_mran_database_save(database) + writef("DONE") + +} + +renv_mran_database_update_impl <- function(date, url, entry) { + + printf("[%s]: reading package database ... ", date) + + # get date as number of days since epoch + idate <- as.integer(date) + + # retrieve available packages + errors <- new.env(parent = emptyenv()) + db <- renv_available_packages_query_impl(url, errors) + if (is.null(db)) { + writef("ERROR") + return(FALSE) + } + + # insert packages into database + for (i in seq_len(nrow(db))) { + + # construct key for index + name <- db[i, "Package"] + vers <- db[i, "Version"] + key <- paste(name, vers) + + # update database + entry[[key]] <- max(entry[[key]] %||% 0L, idate) + + } + + writef("OK") + TRUE + +} + +renv_mran_url <- function(date, suffix) { + root <- Sys.getenv("RENV_MRAN_URL", unset = "https://mran.microsoft.com/snapshot") + snapshot <- file.path(root, date) + paste(snapshot, suffix, sep = "") +} + +renv_mran_database_url <- function() { + default <- "https://rstudio-buildtools.s3.amazonaws.com/renv/mran/packages.rds" + Sys.getenv("RENV_MRAN_DATABASE_URL", unset = default) +} + +renv_mran_database_refresh <- function(explicit = TRUE) { + + if (explicit || renv_mran_database_refresh_required()) + renv_mran_database_refresh_impl() + +} + +renv_mran_database_refresh_required <- function() { + dynamic( + key = list(), + value = renv_mran_database_refresh_required_impl() + ) +} + +renv_mran_database_refresh_required_impl <- function() { + + # if the cache doesn't exist, we must refresh + path <- renv_mran_database_path() + if (!file.exists(path)) + return(TRUE) + + # if we're using an older version of R, but we have newer package + # versions available in the cache, we don't need to refresh + db <- tryCatch(renv_mran_database_load(), error = identity) + if (!inherits(db, "error")) { + keys <- names(db) + versions <- unique(basename(keys)) + if (any(versions > getRversion())) + return(FALSE) + } + + # read the file mtime + info <- renv_file_info(path) + if (is.na(info$mtime)) + return(FALSE) + + # if it's older than a day, then we should update + difftime(Sys.time(), info$mtime, units = "days") > 1 + +} + +renv_mran_database_refresh_impl <- function() { + + url <- renv_mran_database_url() + path <- renv_mran_database_path() + + if (nzchar(url) && nzchar(path)) { + ensure_parent_directory(path) + download(url = url, destfile = path, quiet = TRUE) + } + +} + +renv_mran_database_sync <- function(platform, version) { + + # read database + database <- renv_mran_database_load() + + # read entry for this platform + version combo + key <- renv_mran_database_key(platform, version) + entry <- database[[key]] + if (is.null(entry)) { + database[[key]] <- new.env(parent = emptyenv()) + entry <- database[[key]] + } + + # get the last known updated date + last <- max(0L, as.integer(as.list(entry))) + if (identical(last, 0L)) { + date <- renv_mran_database_dates(version, all = FALSE) + last <- as.integer(date) + } + + # get yesterday's date + now <- as.integer(as.Date(Sys.time(), tz = "UTC")) - 1L + + # sync up to the last version's release date + dates <- as.integer(renv_mran_database_dates(version)) + now <- min(now, max(dates)) + + # if we've already in sync, nothing to do + if (last >= now) + return(FALSE) + + # invoke update for missing dates + writef("==> Synchronizing MRAN database (%s/%s)", platform, version) + dates <- as.Date(seq(last + 1L, now, by = 1L), origin = "1970-01-01") + renv_mran_database_update(platform, version, dates) + writef("Finished synchronizing MRAN database (%s/%s)", platform, version) + + # return TRUE to indicate update occurred + return(TRUE) + +} + +renv_mran_database_sync_all <- function() { + + # NOTE: this needs to be manually updated since the binary URL for + # packages can change from version to version, especially on macOS + + # R 3.2 + renv_mran_database_sync("windows", "3.2") + renv_mran_database_sync("macosx/mavericks", "3.2") + + # R 3.3 + renv_mran_database_sync("windows", "3.3") + renv_mran_database_sync("macosx/mavericks", "3.3") + + # R 3.4 + renv_mran_database_sync("windows", "3.4") + renv_mran_database_sync("macosx/el-capitan", "3.4") + + # R 3.5 + renv_mran_database_sync("windows", "3.5") + renv_mran_database_sync("macosx/el-capitan", "3.5") + + # R 3.6 + renv_mran_database_sync("windows", "3.6") + renv_mran_database_sync("macosx/el-capitan", "3.6") + + # R 4.0 + renv_mran_database_sync("windows", "4.0") + renv_mran_database_sync("macosx", "4.0") + + # R 4.1 + renv_mran_database_sync("windows", "4.1") + renv_mran_database_sync("macosx", "4.1") + renv_mran_database_sync("macosx/big-sur-arm64", "4.1") + + + +} + + +# namespace.R ---------------------------------------------------------------- + + +renv_namespace_spec <- function(package) { + namespace <- asNamespace(package) + .getNamespaceInfo(namespace, "spec") +} + +renv_namespace_version <- function(package) { + spec <- renv_namespace_spec(package) + spec[["version"]] +} + +renv_namespace_path <- function(package) { + namespace <- asNamespace(package) + .getNamespaceInfo(namespace, "path") +} + +renv_namespace_load <- function(package) { + suppressPackageStartupMessages(getNamespace(package)) +} + +renv_namespace_unload <- function(package) { + unloadNamespace(package) +} + +renv_namespace_parse <- function(package) { + + parseNamespaceFile( + package = package, + package.lib = dirname(renv_package_find(package)), + mustExist = TRUE + ) + +} + + +# new.R ---------------------------------------------------------------------- + + +new <- function(expr) { + + private <- new.env(parent = renv_envir_self()) + public <- new.env(parent = private) + + for (expr in as.list(substitute(expr))[-1L]) { + + assigning <- renv_call_matches(expr, name = c("=", "<-")) + + if (!assigning) + return(eval(expr, envir = public)) + + hidden <- + is.symbol(expr[[2L]]) && + substring(as.character(expr[[2L]]), 1L, 1L) == "." + + eval(expr, envir = if (hidden) private else public) + + } + + public + +} + + +# nexus.R -------------------------------------------------------------------- + + +renv_nexus_enabled <- function(repo) { + + # first, check a global option + enabled <- getOption("renv.nexus.enabled", default = FALSE) + if (enabled) + return(TRUE) + + # otherwise, check cached repository information + info <- renv_repos_info(repo) + identical(info$nexus, TRUE) + +} + + +# once.R --------------------------------------------------------------------- + + +# mechanism for running a block of code only once +the$once <- new.env(parent = emptyenv()) + +once <- function() { + + call <- sys.call(sys.parent())[[1L]] + id <- as.character(call) + + once <- the$once[[id]] %||% TRUE + the$once[[id]] <- FALSE + + once + +} + + +# options.R ------------------------------------------------------------------ + + +renv_options_set <- function(key, value) { + data <- list(value) + names(data) <- key + do.call(base::options, data) +} + +renv_options_resolve <- function(value, arguments) { + + if (is.function(value)) + return(do.call(value, arguments)) + + value + +} + +renv_options_override <- function(scope, key, default = NULL, extra = NULL) { + + # first, check for scoped option + value <- getOption(paste(scope, key, sep = ".")) + if (!is.null(value)) + return(renv_options_resolve(value, list(extra))) + + # next, check for unscoped option + value <- getOption(scope) + if (key %in% names(value)) + return(renv_options_resolve(value[[key]], list(extra))) + + # resolve option value + if (!is.null(value)) + return(renv_options_resolve(value, list(key, extra))) + + # nothing found; use default + default + +} + + +# package.R ------------------------------------------------------------------ + + +# NOTE: intentionally checks library paths before checking loaded namespaces +renv_package_find <- function(package, + lib.loc = renv_libpaths_all(), + check.loaded = TRUE) +{ + map_chr( + package, + renv_package_find_impl, + lib.loc = lib.loc, + check.loaded = check.loaded + ) +} + +renv_package_find_impl <- function(package, + lib.loc = renv_libpaths_all(), + check.loaded = TRUE) +{ + # if we've been given the path to an existing package, use it as-is + if (grepl("/", package) && file.exists(file.path(package, "DESCRIPTION"))) + return(renv_path_normalize(package, mustWork = TRUE)) + + # first, look in the library paths + for (libpath in lib.loc) { + pkgpath <- file.path(libpath, package) + descpath <- file.path(pkgpath, "DESCRIPTION") + if (file.exists(descpath)) + return(pkgpath) + } + + # if that failed, check to see if it's loaded and use the associated path + if (check.loaded && package %in% loadedNamespaces()) { + path <- renv_namespace_path(package) + if (file.exists(path)) + return(path) + } + + # failed to find package + "" +} + +renv_package_installed <- function(package, lib.loc = renv_libpaths_all()) { + paths <- renv_package_find(package, lib.loc, check.loaded = FALSE) + nzchar(paths) +} + +renv_package_available <- function(package) { + package %in% loadedNamespaces() || renv_package_installed(package) +} + +renv_package_version <- function(package) { + renv_package_description_field(package, "Version") +} + +renv_package_description_field <- function(package, field) { + path <- renv_package_find(package) + desc <- renv_description_read(path) + desc[[field]] +} + +renv_package_type <- function(path, quiet = FALSE, default = "source") { + + info <- renv_file_info(path) + if (is.na(info$isdir)) + stopf("no package at path '%s'", renv_path_aliased(path)) + + # for directories, check for Meta + if (info$isdir) { + hasmeta <- file.exists(file.path(path, "Meta")) + type <- if (hasmeta) "binary" else "source" + return(type) + } + + # otherwise, guess based on contents of package + methods <- list( + tar = function(path) untar(tarfile = path, list = TRUE), + zip = function(path) unzip(zipfile = path, list = TRUE)$Name + ) + + # guess appropriate method when possible + type <- renv_archive_type(path) + if (type %in% c("tar", "zip")) + methods <- methods[type] + + for (method in methods) { + + # suppress warnings to avoid issues with e.g. + # 'skipping pax global extended headers' when + # using internal tar + files <- catch(suppressWarnings(method(path))) + if (inherits(files, "error")) + next + + hasmeta <- any(grepl("^[^/]+/Meta/?$", files)) + type <- if (hasmeta) "binary" else "source" + return(type) + + } + + if (!quiet) { + fmt <- "failed to determine type of package '%s'; assuming source" + warningf(fmt, renv_path_aliased(path)) + } + + default + +} + +renv_package_priority <- function(package) { + + # treat 'R' as pseudo base package + if (package == "R") + return("base") + + # read priority from db + db <- installed_packages() + entry <- db[db$Package == package, ] + entry$Priority %NA% "" + +} + +renv_package_tarball_name <- function(path) { + desc <- renv_description_read(path) + with(desc, sprintf("%s_%s.tar.gz", Package, Version)) +} + +renv_package_ext <- function(type) { + + # always use '.tar.gz' for source packages + type <- match.arg(type, c("binary", "source")) + if (type == "source") + return(".tar.gz") + + # otherwise, infer appropriate extension based on platform + case( + renv_platform_macos() ~ ".tgz", + renv_platform_windows() ~ ".zip", + renv_platform_unix() ~ ".tar.gz" + ) + +} + +renv_package_pkgtypes <- function() { + + # only use binaries if the user has specifically requested it + # and binaries are available for this installation of R + # (users may want to install from sources explicitly to take + # advantage of custom local compiler configurations) + binaries <- + !identical(.Platform$pkgType, "source") && + !identical(getOption("pkgType"), "source") + + if (binaries) c("binary", "source") else "source" + +} + +renv_package_augment <- function(installpath, record) { + + # check for remotes fields + remotes <- record[grep("^Remote", names(record))] + if (empty(remotes)) + return(FALSE) + + # for backwards compatibility with older versions of Packrat, + # we write out 'Github*' fields as well + if (identical(record$Source, "GitHub")) { + + map <- list( + "GithubHost" = "RemoteHost", + "GithubRepo" = "RemoteRepo", + "GithubUsername" = "RemoteUsername", + "GithubRef" = "RemoteRef", + "GithubSHA1" = "RemoteSha" + ) + + enumerate(map, function(old, new) { + remotes[[old]] <<- remotes[[old]] %||% remotes[[new]] + }) + + } + + # ensure RemoteType field is written out + remotes$RemoteType <- remotes$RemoteType %||% renv_record_source(record) + remotes <- remotes[c("RemoteType", renv_vector_diff(names(remotes), "RemoteType"))] + + # update package items + renv_package_augment_description(installpath, remotes) + renv_package_augment_metadata(installpath, remotes) + +} + +renv_package_augment_impl <- function(data, remotes) { + remotes <- remotes[map_lgl(remotes, Negate(is.null))] + nonremotes <- grep("^(?:Remote|Github)", names(data), invert = TRUE) + remotes[["Remotes"]] <- data[["Remotes"]] %||% remotes[["Remotes"]] + c(data[nonremotes], remotes) +} + +renv_package_augment_description <- function(path, remotes) { + + descpath <- file.path(path, "DESCRIPTION") + + before <- renv_description_read(descpath) + after <- renv_package_augment_impl(before, remotes) + if (identical(before, after)) + return(FALSE) + + renv_dcf_write(after, file = descpath) + +} + +renv_package_augment_metadata <- function(path, remotes) { + + metapath <- file.path(path, "Meta/package.rds") + if (!file.exists(metapath)) + return(FALSE) + + meta <- readRDS(metapath) + before <- as.list(meta$DESCRIPTION) + after <- renv_package_augment_impl(before, remotes) + if (identical(before, after)) + return(FALSE) + + meta$DESCRIPTION <- map_chr(after, identity) + saveRDS(meta, file = metapath, version = 2L) + +} + +# find recursive dependencies of a package. note that this routine +# doesn't farm out to CRAN; it relies on the package and its dependencies +# all being installed locally. returns a named vector mapping package names +# to the path where they were discovered, or NA if those packages are not +# installed +renv_package_dependencies <- function(packages, + libpaths = NULL, + fields = NULL, + callback = NULL, + project = NULL) +{ + visited <- new.env(parent = emptyenv()) + ignored <- renv_project_ignored_packages(project = project) + packages <- renv_vector_diff(packages, ignored) + libpaths <- libpaths %||% renv_libpaths_all() + fields <- fields %||% settings$package.dependency.fields(project = project) + callback <- callback %||% function(package, location, project) location + project <- renv_project_resolve(project) + + for (package in packages) + renv_package_dependencies_impl(package, visited, libpaths, fields, callback, project) + + as.list(visited) +} + +renv_package_dependencies_impl <- function(package, + visited, + libpaths, + fields = NULL, + callback = NULL, + project = NULL) +{ + # skip the 'R' package + if (package == "R") + return() + + # if we've already visited this package, bail + if (!is.null(visited[[package]])) + return() + + # default to unknown path for visited packages + visited[[package]] <- "" + + # find the package -- note that we perform a permissive lookup here + # because we want to capture potentially invalid / broken package installs + # (that is, the 'package' we find might be an incomplete or broken package + # installation at this point) + location <- find(libpaths, function(libpath) { + candidate <- file.path(libpath, package) + if (renv_file_exists(candidate)) + return(candidate) + }) + + if (is.null(location)) + return(callback(package, "", project)) + + # we know the path, so set it now + visited[[package]] <- callback(package, location, project) + + # find its dependencies from the DESCRIPTION file + deps <- renv_dependencies_discover_description(location, fields = "strong") + subpackages <- deps$Package + for (subpackage in subpackages) + renv_package_dependencies_impl(subpackage, visited, libpaths, fields, callback, project) +} + +renv_package_reload <- function(package, library = NULL) { + status <- catch(renv_package_reload_impl(package, library)) + !inherits(status, "error") && status +} + +renv_package_reload_impl <- function(package, library) { + + if (renv_tests_running()) + return(FALSE) + + # record if package is attached (and, if so, where) + name <- paste("package", package, sep = ":") + pos <- match(name, search()) + + # unload the package + if (!is.na(pos)) + renv_package_reload_impl_searchpath(package, library, pos) + else + renv_package_reload_impl_namespace(package, library) + + TRUE + +} + +renv_package_reload_impl_searchpath <- function(package, library, pos) { + + args <- list(pos = pos, unload = TRUE, force = TRUE) + quietly(do.call(base::detach, args), sink = FALSE) + + args <- list(package = package, pos = pos, lib.loc = library, quietly = TRUE) + quietly(do.call(base::library, args), sink = FALSE) + +} + +renv_package_reload_impl_namespace <- function(package, library) { + unloadNamespace(package) + loadNamespace(package, lib.loc = library) +} + +renv_package_hook <- function(package, hook) { + if (package %in% loadedNamespaces()) + hook() + else + setHook(packageEvent(package, "onLoad"), hook) +} + +renv_package_metadata <- function(package) { + pkgpath <- renv_package_find(package) + metapath <- file.path(pkgpath, "Meta/package.rds") + readRDS(metapath) +} + +renv_package_shlib <- function(package) { + + pkgpath <- renv_package_find(package) + + pkgname <- basename(package) + if (pkgname == "data.table") + pkgname <- "datatable" + + libname <- paste0(pkgname, .Platform$dynlib.ext) + file.path(pkgpath, "libs", libname) + +} + +renv_package_built <- function(path) { + + info <- renv_file_info(path) + + # list files in package + isarchive <- identical(info$isdir, FALSE) + files <- if (isarchive) + renv_archive_list(path) + else + list.files(path, full.names = TRUE, recursive = TRUE) + + # for a source package, the canonical way to determine if it has already + # been built is the presence of a 'Packaged:' field in the DESCRIPTION file + # ('Built:' for binary packages) but we want to avoid the overhead of + # unpacking the package if at all possible + pattern <- "/(?:MD5$|INDEX/|Meta/package\\.rds$)" + matches <- grep(pattern, files) + if (length(matches) != 0L) + return(TRUE) + + # if the above failed, then we'll use the contents of the DESCRIPTION file + descpaths <- grep("/DESCRIPTION$", files, value = TRUE) + if (length(descpaths) == 0L) + return(FALSE) + + n <- nchar(descpaths) + descpath <- descpaths[n == min(n)] + contents <- if (isarchive) + renv_archive_read(path, descpath) + else + readLines(descpath, warn = FALSE) + + # check for signs it was built + pattern <- "^(?:Packaged|Built):" + matches <- grep(pattern, contents) + if (length(matches) != 0L) + return(TRUE) + + # does not appear to be a source package + FALSE + +} + +renv_package_unpack <- function(package, path, subdir = "", force = FALSE) { + + # if this isn't an archive, nothing to do + info <- renv_file_info(path) + if (identical(info$isdir, TRUE)) + return(path) + + # find DESCRIPTION files in the archive + descpaths <- renv_archive_find(path, "(?:^|/)DESCRIPTION$") + + # check for a top-level DESCRIPTION file + # this is done in case the archive has been already been re-packed, so that a + # package originally located within a sub-directory is now at the top level + if (!force) { + descpath <- grep("^[^/]+/DESCRIPTION$", descpaths, perl = TRUE, value = TRUE) + if (length(descpath)) + return(path) + } + + # try to resolve the path to the DESCRIPTION file in the archive + descpath <- if (nzchar(subdir)) { + pattern <- sprintf("(?:^|/)\\Q%s\\E/DESCRIPTION$", subdir) + grep(pattern, descpaths, perl = TRUE, value = TRUE) + } else { + n <- nchar(descpaths) + descpaths[n == min(n)] + } + + # if this failed, error + if (length(descpath) != 1L) { + fmt <- "internal error: couldn't find DESCRIPTION file for package '%s' in archive '%s'" + stopf(fmt, package, path) + } + + # create extraction directory + old <- renv_scope_tempfile("renv-package-old-") + new <- renv_scope_tempfile("renv-package-new-", scope = parent.frame()) + ensure_directory(c(old, new)) + + # decompress archive to dir + renv_archive_decompress(path, exdir = old) + + # rename (without sub-directory) + oldpath <- file.path(old, dirname(descpath)) + newpath <- file.path(new, package) + file.rename(oldpath, newpath) + + # use newpath + newpath + +} + + +# packages.R ----------------------------------------------------------------- + + +the$packages_base <- NULL +the$packages_recommended <- NULL + +renv_packages_base <- function() { + + the$packages_base <- the$packages_base %||% { + db <- installed_packages(lib.loc = .Library, priority = "base") + c("R", db$Package, "translations") + } + +} + +renv_packages_recommended <- function() { + + the$packages_recommended <- the$packages_recommended %||% { + db <- installed_packages(lib.loc = .Library, priority = "recommended") + db$Package + } + +} + + +# pak.R ---------------------------------------------------------------------- + + +# the minimum-required version of 'pak' for renv integration +the$pak_minver <- numeric_version("0.5.1") + +renv_pak_init <- function(stream = NULL, force = FALSE) { + + stream <- stream %||% renv_pak_stream() + if (force || !renv_pak_available()) + renv_pak_init_impl(stream) + + renv_namespace_load("pak") + +} + +renv_pak_stream <- function() { + + # check if stable is new enough + streams <- c("stable", "rc", "devel") + for (stream in streams) { + repos <- renv_pak_repos(stream) + latest <- renv_available_packages_latest("pak", repos = repos) + version <- numeric_version(latest$Version) + if (version >= the$pak_minver) + return(stream) + } + + fmt <- "internal error: pak (>= %s) is not available" + stopf(fmt, format(the$pak_minver)) + +} + +renv_pak_available <- function() { + tryCatch( + packageVersion("pak") >= the$pak_minver, + error = function(e) FALSE + ) +} + +renv_pak_repos <- function(stream) { + + # on macOS, we can only use pak binaries with CRAN R + if (renv_platform_macos() && .Platform$pkgType == "source") + return(getOption("repos")) + + # otherwise, use pre-built pak binaries + fmt <- "https://r-lib.github.io/p/pak/%s/%s/%s/%s" + sprintf(fmt, stream, .Platform$pkgType, version$os, version$arch) + +} + +renv_pak_init_impl <- function(stream) { + + repos <- c("r-lib" = renv_pak_repos(stream)) + renv_scope_options(renv.config.pak.enabled = FALSE, repos = repos) + + library <- renv_libpaths_active() + install("pak", library = library) + loadNamespace("pak", lib.loc = library) + +} + +renv_pak_install <- function(packages, library, project) { + + pak <- renv_namespace_load("pak") + lib <- library[[1L]] + + # transform repositories + if (renv_ppm_enabled()) { + repos <- getOption("repos") + renv_scope_options(repos = renv_ppm_transform(repos)) + } + + # make sure pak::pkg_install() still works even if we're + # running in renv with devtools::load_all() + name <- Sys.getenv("_R_CHECK_PACKAGE_NAME_", unset = NA) + if (identical(name, "renv")) + renv_scope_envvars("_R_CHECK_PACKAGE_NAME_" = NULL) + + # if we received a named list of remotes, use the names + packages <- if (any(nzchar(names(packages)))) + names(packages) + else + as.character(packages) + + if (length(packages) == 0L) + return(pak$local_install_dev_deps(root = project, lib = lib)) + + pak$pkg_install( + pkg = packages, + lib = lib, + upgrade = TRUE + ) + +} + +renv_pak_restore <- function(lockfile, + packages = NULL, + exclude = NULL, + project = NULL) +{ + pak <- renv_namespace_load("pak") + + # transform repositories + if (renv_ppm_enabled()) { + repos <- getOption("repos") + renv_scope_options(repos = renv_ppm_transform(repos)) + } + + # make sure pak::pkg_install() still works even if we're + # running in renv with devtools::load_all() + name <- Sys.getenv("_R_CHECK_PACKAGE_NAME_", unset = NA) + if (identical(name, "renv")) + renv_scope_envvars("_R_CHECK_PACKAGE_NAME_" = NULL) + + # get records to install + records <- renv_lockfile_records(lockfile) + packages <- setdiff(packages %||% names(records), c(exclude, "pak", "renv")) + records <- records[packages] + + # attempt to link packages that have cache entries + if (renv_cache_config_enabled(project = project)) { + linked <- map_lgl(records, renv_cache_synchronize) + records <- records[!linked] + } + + # convert into specs compatible with pak, and install + remotes <- map_chr(records, renv_record_format_remote) + + # TODO: We previously tried converting version-ed remotes into "plain" remotes + # if the package version happened to be current, but then 'pak' would choose + # not to install the package if a newer version was available. Hence, we need + # to preserve the exact remote we wish to install here. + + # return early if there are zero remotes to restore + if (length(remotes) == 0L) { + return(invisible(TRUE)) + } + + # perform installation + pak$pkg_install(remotes) +} + + + +# parallel.R ----------------------------------------------------------------- + + +renv_parallel_cores <- function() { + + if (renv_platform_windows()) + return(1L) + + value <- config$updates.parallel() + case( + identical(value, TRUE) ~ getOption("mc.cores", default = 2L), + identical(value, FALSE) ~ 1L, + ~ as.integer(value) + ) + +} + +renv_parallel_exec <- function(data, callback) { + cores <- renv_parallel_cores() + if (cores > 1) + parallel::mclapply(data, callback, mc.cores = cores) + else + lapply(data, callback) +} + + +# parse.R -------------------------------------------------------------------- + + +renv_parse_file <- function(file = "", ...) { + if (nzchar(file)) { + renv_scope_options(warn = -1L) + text <- readLines(file, warn = FALSE, encoding = "UTF-8") + renv_parse_impl(text, srcfile = file, ...) + } +} + +renv_parse_text <- function(text = NULL, ...) { + if (is.character(text)) { + renv_parse_impl(text, ...) + } +} + +renv_parse_impl <- function(text, ...) { + + # save default encoding + enc <- Encoding(text) + + # disable warnings + encoding conversions + renv_scope_options( + warn = 1L, + encoding = "native.enc" + ) + + # attempt multiple parse methods + methods <- list( + renv_parse_impl_asis, + renv_parse_impl_native, + renv_parse_impl_utf8 + ) + + # attempt with different guessed encodings + encodings <- c("UTF-8", "unknown") + + for (encoding in encodings) { + Encoding(text) <- encoding + for (method in methods) { + parsed <- catch(method(text, ...)) + if (!inherits(parsed, "error")) + return(parsed) + } + } + + # if these all fail, then just try the default + # parse and let the error propagate + defer(Sys.setlocale()) + Encoding(text) <- enc + parse(text = text, ...) + +} + +renv_parse_impl_asis <- function(text, ...) { + defer(Sys.setlocale()) + parse(text = text, ...) +} + +renv_parse_impl_native <- function(text, ...) { + defer(Sys.setlocale()) + parse(text = enc2native(text), encoding = "unknown", ...) +} + +renv_parse_impl_utf8 <- function(text, ...) { + defer(Sys.setlocale()) + parse(text = enc2utf8(text), encoding = "UTF-8", ...) +} + + + +# patch.R -------------------------------------------------------------------- + + +renv_patch_init <- function() { + renv_patch_rprofile() + renv_patch_tar() + renv_patch_repos() + renv_patch_golem() + renv_patch_methods_table() +} + +renv_patch_rprofile <- function() { + + # resolve path to user profile + path <- Sys.getenv("R_PROFILE_USER", unset = "~/.Rprofile") + info <- renv_file_info(path) + if (!identical(info$isdir, FALSE)) + return(FALSE) + + # if the .Rprofile is empty, do nothing + if (info$size == 0) + return(TRUE) + + # check for trailing newline + data <- readBin(path, raw(), n = info$size) + if (empty(data)) + return(TRUE) + + last <- data[length(data)] + endings <- as.raw(c(0x0a, 0x0d)) + if (last %in% endings) + return(TRUE) + + # if it's missing, inform the user + warningf("%s is missing a trailing newline", renv_path_pretty(path)) + FALSE + +} + +renv_patch_tar <- function() { + + # read value of TAR + tar <- Sys.getenv("TAR", unset = "") + + # on Windows, if TAR is unset, then force the usage + # of R's internal tar implementation. this is done to + # avoid issues where e.g. versions of tar which do not + # understand Windows paths are on the PATH + # + # https://github.com/rstudio/renv/issues/521 + if (renv_platform_windows() && !nzchar(tar)) { + Sys.setenv(TAR = "internal") + return(TRUE) + } + + # otherwise, allow empty / internal tars + if (tar %in% c("", "internal")) + return(TRUE) + + # the user (or R itself) has set the TAR environment variable + # validate that it exists (resolve from PATH) + # + # note that the user can set TAR to be a full command; e.g. + # + # TAR = /path/to/tar --force-local + # + # so we need to handle that case appropriately + whitespace <- gregexpr("(?:\\s+|$)", tar, perl = TRUE)[[1L]] + for (index in whitespace) { + candidate <- substring(tar, 1L, index - 1L) + resolved <- Sys.which(candidate) + if (nzchar(resolved)) + return(TRUE) + } + + # TAR appears to be set but invalid; override it + # and warn the user + newtar <- Sys.which("tar") + if (!nzchar(newtar)) + newtar <- "internal" + + Sys.setenv(TAR = newtar) + + # report to the user + fmt <- "requested TAR '%s' does not exist; using '%s' instead" + warningf(fmt, tar, newtar) + +} + +renv_patch_golem <- function() { + renv_package_hook("golem", renv_patch_golem_impl) +} + +renv_patch_golem_impl <- function(...) { + + if (packageVersion("golem") != "0.2.1") + return() + + golem <- getNamespace("golem") + + replacement <- function(file, pattern, replace) { + + # skip .rds files + if (grepl("[.]rds$", file)) + return() + + # skip files containing nul bytes + info <- renv_file_info(file) + bytes <- readBin(file, "raw", info$size) + if (any(bytes == 0L)) + return() + + # otherwise, attempt replacement + old <- readLines(file) + new <- gsub(pattern, replace, old) + writeLines(new, con = file) + + } + + environment(replacement) <- golem + + if ("compiler" %in% loadedNamespaces()) + replacement <- compiler::cmpfun(replacement) + + renv_binding_replace(golem, "replace_word", replacement) + +} + +renv_patch_methods_table <- function() { + catchall(renv_patch_methods_table_impl()) +} + +renv_patch_methods_table_impl <- function() { + + # ensure promises in S3 methods table are forced + # https://bugs.r-project.org/bugzilla/show_bug.cgi?id=16644 + for (envir in list(.BaseNamespaceEnv, renv_namespace_load("utils"))) { + + # unlock binding if it's locked + binding <- ".__S3MethodsTable__." + base <- baseenv() + if (base$bindingIsLocked(binding, env = envir)) { + base$unlockBinding(binding, env = envir) + defer(base$lockBinding(binding, envir)) + } + + # force everything defined in the environment + table <- envir[[binding]] + for (key in ls(envir = table, all.names = TRUE)) + table[[key]] <- force(table[[key]]) + + } + +} + +# puts the current version of renv into an on-disk package repository, +# so that packages using renv can find this version of renv in tests +# this helps renv survive CRAN revdep checks (e.g. jetpack) +renv_patch_repos <- function() { + + # nothing to do in embedded mode + if (renv_metadata_embedded()) + return() + + # nothing to do if we're not running tests + checking <- checking() + if (!checking) + return() + + # nothing to do if we're running our own tests + name <- Sys.getenv("_R_CHECK_PACKAGE_NAME_", unset = NA) + if (identical(name, "renv")) + return() + + # presumably this will never happen when the dev version of renv is + # installed, so we skip to avoid parsing a sha as version + sha <- attr(the$metadata$version, "sha") + if (!is.null(sha)) + return() + + # nothing to do if this version of 'renv' is already available + version <- renv_metadata_version() + entry <- catch(renv_available_packages_entry("renv", filter = version, quiet = TRUE)) + if (!inherits(entry, "error")) + return() + + # check if we've already set repos + if ("RENV" %in% names(getOption("repos"))) + return() + + # use package-local repository path + repopath <- system.file("repos", package = "renv", mustWork = FALSE) + if (!file.exists(repopath)) + return() + + # update our repos option + fmt <- if (renv_platform_windows()) "file:///%s" else "file://%s" + repourl <- sprintf(fmt, repopath) + + # renv needs to be first so the right version is found? + repos <- c(RENV = repourl, getOption("repos")) + names(repos) <- make.names(names(repos)) + options(repos = repos) + + # make sure these repositories are used in restore too + options(renv.config.repos.override = repos) + +} + + +# path.R --------------------------------------------------------------------- + + +the$alpha <- c(letters, LETTERS) + +renv_path_absolute <- function(path) { + + substr(path, 1L, 1L) %in% c("~", "/", "\\") || ( + substr(path, 1L, 1L) %in% the$alpha && + substr(path, 2L, 3L) %in% c(":/", ":\\") + ) + +} + +renv_path_aliased <- function(path) { + + home <- Sys.getenv("HOME", unset = Sys.getenv("R_USER")) + if (!nzchar(home)) + return(path) + + home <- gsub("\\", "/", home, fixed = TRUE) + path <- gsub("\\", "/", path, fixed = TRUE) + + match <- regexpr(home, path, fixed = TRUE, useBytes = TRUE) + path[match == 1L] <- file.path("~", substring(path[match == 1L], nchar(home) + 2L)) + + path + +} + +renv_path_within <- function(path, parent) { + path <- renv_path_canonicalize(path) + prefix <- paste(renv_path_canonicalize(parent), "/", sep = "") + path == parent | substring(path, 1L, nchar(prefix)) == prefix +} + +renv_path_normalize <- function(path, winslash = "/", mustWork = FALSE) { + if (renv_platform_unix()) + renv_path_normalize_unix(path, winslash, mustWork) + else + renv_path_normalize_win32(path, winslash, mustWork) +} + +renv_path_normalize_unix <- function(path, + winslash = "/", + mustWork = FALSE) +{ + # force paths to be absolute + bad <- !map_lgl(path, renv_path_absolute) + if (any(bad)) { + prefix <- normalizePath(".", winslash = winslash) + path[bad] <- paste(prefix, path[bad], sep = winslash) + } + + # normalize the expanded paths + normalizePath(path, winslash, mustWork) +} + +# NOTE: in versions of R < 4.0.0, normalizePath() does not normalize path +# casing; e.g. normalizePath("~/MyPaTh") will not normalize to "~/MyPath" +# (assuming that is the "true" underlying casing on the filesystem) +# +# we work around this by round-tripping between the short name and +# the long name, as Windows then has no choice but to figure out +# the correct casing for us +# +# this isn't 100% reliable (not all paths have a short-path equivalent) +# but seems to be good enough in practice ... +# +# except that, if the path contains characters that cannot be represented in the +# current encoding, then attempting to normalize the short version of that path +# will fail -- so if the path is already UTF-8, then we need to avoid +# round-tripping through the short path. +# +# furthermore, it appears that shortPathName() can mis-encode its result for +# strings marked with latin1 encoding? +# +# https://github.com/rstudio/renv/issues/629 +renv_path_normalize_win32 <- function(path, + winslash = "/", + mustWork = FALSE) +{ + + # see the NOTE above, this workaround is only necessary for R < 4.0.0, + # and it complicates things unnecessarily + if (getRversion() >= "4.0.0") + return(renv_path_normalize_unix(path, winslash, mustWork)) + + # get encoding for this set of paths + enc <- Encoding(path) + + # perform separate operations for each + utf8 <- enc == "UTF-8" + latin1 <- enc == "latin1" + unknown <- enc == "unknown" + + # normalize based on their encoding + path[utf8] <- normalizePath(path[utf8], winslash, mustWork) + path[latin1] <- normalizePath(path[latin1], winslash, mustWork) + path[unknown] <- renv_path_normalize_win32_impl(path[unknown], winslash, mustWork) + + # return resulting path + path +} + +renv_path_normalize_win32_impl <- function(path, + winslash = "/", + mustWork = FALSE) +{ + # get short path + expanded <- path.expand(path) + short <- utils::shortPathName(expanded) + + # if a UTF-8 string is passed to utils::shortPathName(), it seems that + # the string might be latin1-encoded, even though it's marked as UTF-8? + if (!identical(R.version$crt, "ucrt")) { + utf8 <- Encoding(short) == "UTF-8" + Encoding(short[utf8]) <- "latin1" + } + + # normalize + normalizePath(short, winslash, mustWork) +} + +# TODO: this is a lie; for existing paths symlinks will be resolved. +# don't use this for paths that need to be uniquely resolved! +renv_path_canonicalize <- function(path) { + parent <- dirname(path) + root <- renv_path_normalize(parent) + trimmed <- sub("/+$", "", root) + file.path(trimmed, basename(path)) +} + +renv_path_same <- function(lhs, rhs) { + renv_path_canonicalize(lhs) == renv_path_canonicalize(rhs) +} + +# get the nth path component from the end of the path +renv_path_component <- function(path, index = 1) { + splat <- strsplit(path, "[/\\]+") + map_chr(splat, function(parts) parts[length(parts) - index + 1]) +} + +renv_path_pretty <- function(path) { + renv_json_quote(renv_path_aliased(path)) +} + +renv_path_relative <- function(path, root) { + within <- startswith(path, root) + path[within] <- substring(path[within], nchar(root) + 2L) + path +} + + + +# paths.R -------------------------------------------------------------------- + + +the$root <- NULL + +renv_paths_override <- function(name) { + + # # check for value from option + # optname <- paste("renv.paths", name, sep = ".") + # optval <- getOption(optname) + # if (!is.null(optval)) + # return(optval) + + # check for value from envvar + envname <- paste("RENV_PATHS", toupper(name), sep = "_") + envval <- Sys.getenv(envname, unset = NA) + if (!is.na(envval)) + return(envval) + +} + +renv_paths_common <- function(name, prefixes = NULL, ...) { + + # check for single absolute path supplied by user + # TODO: handle multiple? + end <- file.path(...) + if (length(end) == 1 && renv_path_absolute(end)) + return(end) + + # check for path provided via option + root <- renv_paths_override(name) %||% renv_paths_root(name) + + # split path entries containing a separator + if (name %in% c("cache", "local", "cellar")) { + pattern <- if (renv_platform_windows()) "[;]" else "[;:]" + root <- strsplit(root, pattern)[[1L]] + } + + # form rest of path + prefixed <- if (length(prefixes)) + file.path(root, paste(prefixes, collapse = "/")) + else + root + + path <- file.path(prefixed, ...) + if (length(path)) path else "" +} + +renv_paths_library_root <- function(project) { + renv_bootstrap_library_root(project) +} + +renv_paths_library <- function(..., project = NULL) { + project <- renv_project_resolve(project) + root <- renv_paths_library_root(project) + file.path(root, renv_platform_prefix(), ...) %||% "" +} + +renv_paths_lockfile <- function(project = NULL) { + + # allow override + # TODO: profiles? + override <- Sys.getenv("RENV_PATHS_LOCKFILE", unset = NA) + if (!is.na(override)) { + last <- substr(override, nchar(override), nchar(override)) + if (last %in% c("/", "\\")) + override <- paste0(override, "renv.lock") + return(override) + } + + # otherwise, use default location (location location relative to renv folder) + project <- renv_project_resolve(project) + renv <- renv_paths_renv(project = project) + file.path(dirname(renv), "renv.lock") + +} + +renv_paths_settings <- function(project = NULL) { + renv_paths_renv("settings.json", project = project) +} + +renv_paths_activate <- function(project = NULL) { + renv_paths_renv("activate.R", profile = FALSE, project = project) +} + +renv_paths_sandbox <- function(project = NULL) { + + # construct a platform prefix + path <- R() + hash <- memoize(path, renv_hash_text(path), scope = "renv_paths_sandbox") + parts <- c(renv_platform_prefix(), substring(hash, 1L, 8L)) + prefix <- paste(parts, collapse = "/") + + # check for override + root <- Sys.getenv("RENV_PATHS_SANDBOX", unset = NA) + if (!is.na(root)) + return(paste(c(root, prefix), collapse = "/")) + + # otherwise, build path in user data directory + userdir <- renv_bootstrap_user_dir() + paste(c(userdir, "sandbox", prefix), collapse = "/") + +} + +renv_paths_renv <- function(..., profile = TRUE, project = NULL) { + renv_bootstrap_paths_renv(..., profile = profile, project = project) +} + +renv_paths_cellar <- function(...) { + renv_paths_common("cellar", c(), ...) +} + +renv_paths_local <- function(...) { + renv_paths_common("local", c(), ...) +} + +renv_paths_source <- function(...) { + renv_paths_common("source", c(), ...) +} + +renv_paths_binary <- function(...) { + renv_paths_common("binary", c(renv_platform_prefix()), ...) +} + +renv_paths_cache <- function(..., version = NULL) { + platform <- renv_platform_prefix() + version <- version %||% renv_cache_version() + renv_paths_common("cache", c(version, platform), ...) +} + +renv_paths_rtools <- function() { + + root <- renv_paths_override("rtools") + if (is.null(root)) { + spec <- renv_rtools_find() + root <- spec$root + } + + root %||% "" +} + +renv_paths_extsoft <- function(...) { + renv_paths_common("extsoft", c(), ...) +} + +renv_paths_mran <- function(...) { + renv_paths_common("mran", c(), ...) +} + +renv_paths_index <- function(...) { + renv_paths_common("index", c(renv_platform_prefix()), ...) +} + + +renv_paths_root <- function(...) { + root <- renv_paths_override("root") %||% renv_paths_root_default() + file.path(root, ...) %||% "" +} + +# nocov start +renv_paths_root_default <- function() { + + the$root <- the$root %||% { + + # use tempdir for cache when running tests + # this check is necessary here to support packages which might use renv + # during testing (and we don't want those to try to use the user dir) + if (checking()) + renv_paths_root_default_tempdir() + else + renv_paths_root_default_impl() + + } + +} + +renv_paths_root_default_impl <- function() { + + # compute known root directories + roots <- c( + renv_paths_root_default_impl_v2(), + renv_paths_root_default_impl_v1() + ) + + # iterate through those roots, finding the first existing + for (root in roots) + if (file.exists(root)) + return(root) + + # if none exist, choose the most recent definition + roots[[1L]] + +} + +renv_paths_root_default_impl_v2 <- function() { + + # try using tools to get the user directory + tools <- renv_namespace_load("tools") + if (is.function(tools$R_user_dir)) + return(tools$R_user_dir("renv", "cache")) + + renv_paths_root_default_impl_v2_fallback() + +} + +renv_paths_root_default_impl_v2_fallback <- function() { + + # try using our own backfill for older versions of R + envvars <- c("R_USER_CACHE_DIR", "XDG_CACHE_HOME") + for (envvar in envvars) { + root <- Sys.getenv(envvar, unset = NA) + if (!is.na(root)) { + path <- file.path(root, "R/renv") + return(path) + } + } + + # use platform-specific default fallbacks + if (renv_platform_windows()) + file.path(Sys.getenv("LOCALAPPDATA"), "R/cache/R/renv") + else if (renv_platform_macos()) + "~/Library/Caches/org.R-project.R/R/renv" + else + "~/.cache/R/renv" + +} + +renv_paths_root_default_impl_v1 <- function() { + + base <- switch( + Sys.info()[["sysname"]], + Darwin = Sys.getenv("XDG_DATA_HOME", "~/Library/Application Support"), + Windows = Sys.getenv("LOCALAPPDATA", Sys.getenv("APPDATA")), + Sys.getenv("XDG_DATA_HOME", "~/.local/share") + ) + + file.path(base, "renv") + +} + +renv_paths_root_default_tempdir <- function() { + temp <- file.path(tempdir(), "renv") + ensure_directory(temp) + return(temp) +} + +# nocov end + +#' Path for storing global state +#' +#' @description +#' By default, renv stores global state in the following OS-specific folders: +#' +#' \tabular{ll}{ +#' **Platform** \tab **Location** \cr +#' Linux \tab `~/.cache/R/renv` \cr +#' macOS \tab `~/Library/Caches/org.R-project.R/R/renv` \cr +#' Windows \tab `%LOCALAPPDATA%/R/cache/R/renv` \cr +#' } +#' +#' If desired, this path can be customized by setting the `RENV_PATHS_ROOT` +#' environment variable. This can be useful if you'd like, for example, multiple +#' users to be able to share a single global cache. +#' +#' # Customising individual paths +#' +#' The various state sub-directories can also be individually adjusted, if so +#' desired (e.g. you'd prefer to keep the cache of package installations on a +#' separate volume). The various environment variables that can be set are +#' enumerated below: +#' +#' \tabular{ll}{ +#' \strong{Environment Variable} \tab \strong{Description} \cr +#' \code{RENV_PATHS_ROOT} \tab The root path used for global state storage. \cr +#' \code{RENV_PATHS_LIBRARY} \tab The path to the project library. \cr +#' \code{RENV_PATHS_LIBRARY_ROOT} \tab The parent path for project libraries. \cr +#' \code{RENV_PATHS_LIBRARY_STAGING} \tab The parent path used for staged package installs. \cr +#' \code{RENV_PATHS_SANDBOX} \tab The path to the sandboxed \R system library. \cr +#' \code{RENV_PATHS_LOCKFILE} \tab The path to the [lockfile]. \cr +#' \code{RENV_PATHS_CELLAR} \tab The path to the cellar, containing local package binaries and sources. \cr +#' \code{RENV_PATHS_SOURCE} \tab The path containing downloaded package sources. \cr +#' \code{RENV_PATHS_BINARY} \tab The path containing downloaded package binaries. \cr +#' \code{RENV_PATHS_CACHE} \tab The path containing cached package installations. \cr +#' \code{RENV_PATHS_PREFIX} \tab An optional prefix to prepend to the constructed library / cache paths. \cr +#' \code{RENV_PATHS_RENV} \tab The path to the project's renv folder. For advanced users only. \cr +#' \code{RENV_PATHS_RTOOLS} \tab (Windows only) The path to [Rtools](https://cran.r-project.org/bin/windows/Rtools/). \cr +#' \code{RENV_PATHS_EXTSOFT} \tab (Windows only) The path containing external software needed for compilation of Windows source packages. \cr +#' \code{RENV_PATHS_MRAN} \tab The path containing MRAN-related metadata. See `vignette("mran", package = "renv")` for more details. \cr +#' } +#' +#' (If you want these settings to persist in your project, it is recommended that +#' you add these to an appropriate \R startup file. For example, these could be +#' set in: a project-local `.Renviron`, the user-level `.Renviron`, or a +#' site-wide file at `file.path(R.home("etc"), "Renviron.site")`. See +#' [Startup] for more details). +#' +#' Note that renv will append platform-specific and version-specific entries +#' to the set paths as appropriate. For example, if you have set: +#' +#' ``` +#' Sys.setenv(RENV_PATHS_CACHE = "/mnt/shared/renv/cache") +#' ``` +#' +#' then the directory used for the cache will still depend on the renv cache +#' version (e.g. `v2`), the \R version (e.g. `3.5`) and the platform (e.g. +#' `x86_64-pc-linux-gnu`). For example: +#' +#' ``` +#' /mnt/shared/renv/cache/v2/R-3.5/x86_64-pc-linux-gnu +#' ``` +#' +#' This ensures that you can set a single `RENV_PATHS_CACHE` environment variable +#' globally without worry that it may cause collisions or errors if multiple +#' versions of \R needed to interact with the same cache. +#' +#' If reproducibility of a project is desired on a particular machine, it is +#' highly recommended that the renv cache of installed packages + binary +#' packages is backed up and persisted, so that packages can be easily restored +#' in the future -- installation of packages from source can often be arduous. +#' +#' # Sharing state across operating systems +#' +#' If you need to share the same cache with multiple different Linux operating +#' systems, you may want to set the `RENV_PATHS_PREFIX` environment variable +#' to help disambiguate the paths used on Linux. For example, setting +#' `RENV_PATHS_PREFIX = "ubuntu-bionic"` would instruct renv to construct a +#' cache path like: +#' +#' ``` +#' /mnt/shared/renv/cache/v2/ubuntu-bionic/R-3.5/x86_64-pc-linux-gnu +#' ``` +#' +#' If this is required, it's strongly recommended that this environment +#' variable is set in your \R installation's `Renviron.site` file, typically +#' located at `file.path(R.home("etc"), "Renviron.site")`, so that it can be +#' active for any \R sessions launched on that machine. +#' +#' Starting from `renv 0.13.0`, you can also instruct renv to auto-generate +#' an OS-specific component to include as part of library and cache paths, +#' by setting the environment variable: +#' +#' ``` +#' RENV_PATHS_PREFIX_AUTO = TRUE +#' ``` +#' +#' The prefix will be constructed based on fields within the system's +#' `/etc/os-release` file. +#' +#' # Package cellar +#' +#' If your project depends on one or \R packages that are not available in any +#' remote location, you can still provide a locally-available tarball for renv +#' to use during restore. By default, these packages should be made available in +#' the folder as specified by the `RENV_PATHS_CELLAR` environment variable. The +#' package sources should be placed in a file at one of these locations: +#' +#' - `${RENV_PATHS_CELLAR}/_.` +#' - `${RENV_PATHS_CELLAR}//_.` +#' - `/renv/cellar/_.` +#' - `/renv/cellar//_.` +#' +#' where `.` is `.tar.gz` for source packages, or `.tgz` for binaries on +#' macOS and `.zip` for binaries on Windows. During `restore()`, renv will +#' search the cellar for a compatible package, and prefer installation with +#' that copy of the package if appropriate. +#' +#' # Older versions +#' +#' Older version of renv used a different default cache location. +#' Those cache locations are: +#' +#' \tabular{ll}{ +#' **Platform** \tab **Location** \cr +#' Linux \tab `~/.local/share/renv` \cr +#' macOS \tab `~/Library/Application Support/renv` \cr +#' Windows \tab `%LOCALAPPDATA%/renv` \cr +#' } +#' +#' If an renv root directory has already been created in one of the old +#' locations, that will still be used. This change was made to comply with the +#' CRAN policy requirements of \R packages. +#' +#' @rdname paths +#' @name paths +#' +#' @format NULL +#' +#' @export +#' +#' @examples +#' # get the path to the project library +#' path <- renv::paths$library() +paths <- list( + root = renv_paths_root, + library = renv_paths_library, + lockfile = renv_paths_lockfile, + settings = renv_paths_settings, + cache = renv_paths_cache, + sandbox = renv_paths_sandbox +) + + +# pip.R ---------------------------------------------------------------------- + + +pip_freeze <- function(..., python = NULL) { + python <- python %||% renv_python_active() + renv_scope_envvars(PIP_DISABLE_PIP_VERSION_CHECK = "1") + python <- renv_path_canonicalize(python) + args <- c("-m", "pip", "freeze") + action <- "invoking pip freeze" + renv_system_exec(python, args, action, ...) +} + +pip_install <- function(modules, ..., python = NULL) { + python <- python %||% renv_python_active() + renv_scope_envvars(PIP_DISABLE_PIP_VERSION_CHECK = "1") + python <- renv_path_canonicalize(python) + args <- c("-m", "pip", "install", "--upgrade", modules) + action <- paste("installing", paste(shQuote(modules), collapse = ", ")) + renv_system_exec(python, args, action, ...) +} + +pip_install_requirements <- function(requirements, ..., python = NULL) { + + python <- python %||% renv_python_active() + + file <- renv_scope_tempfile("renv-requirements-", fileext = ".txt") + writeLines(requirements, con = file) + + renv_scope_envvars(PIP_DISABLE_PIP_VERSION_CHECK = "1") + python <- renv_path_canonicalize(python) + args <- c("-m", "pip", "install", "--upgrade", "-r", renv_shell_path(file)) + action <- "restoring Python packages" + renv_system_exec(python, args, action, ...) + +} + +pip_uninstall <- function(modules, ..., python = NULL) { + + python <- python %||% renv_python_active() + + renv_scope_envvars(PIP_DISABLE_PIP_VERSION_CHECK = "1") + python <- renv_path_canonicalize(python) + args <- c("-m", "pip", "uninstall", "--yes", modules) + action <- paste("uninstalling", paste(shQuote(modules), collapse = ", ")) + renv_system_exec(python, args, action, ...) + + TRUE + +} + + +# platform.R ----------------------------------------------------------------- + + +the$sysinfo <- NULL + +renv_platform_init <- function() { + the$sysinfo <- Sys.info() +} + +renv_platform_unix <- function() { + .Platform$OS.type == "unix" +} + +renv_platform_windows <- function() { + .Platform$OS.type == "windows" +} + +renv_platform_macos <- function() { + the$sysinfo[["sysname"]] == "Darwin" +} + +renv_platform_linux <- function() { + the$sysinfo[["sysname"]] == "Linux" +} + +renv_platform_solaris <- function() { + the$sysinfo[["sysname"]] == "SunOS" +} + +renv_platform_wsl <- function() { + + pv <- "/proc/version" + if (!file.exists(pv)) + return(FALSE) + + renv_scope_options(warn = -1L) + contents <- catch(readLines(pv, warn = FALSE)) + if (inherits(contents, "error")) + return(FALSE) + + any(grepl("(?:Microsoft|WSL)", contents, ignore.case = TRUE)) + +} + +renv_platform_prefix <- function() { + renv_bootstrap_platform_prefix() +} + +renv_platform_os <- function() { + renv_bootstrap_platform_os() +} + +renv_platform_machine <- function() { + the$sysinfo[["machine"]] +} + + +# ppm.R ---------------------------------------------------------------------- + + +renv_ppm_normalize <- function(url) { + sub("/__[^_]+__/[^/]+/", "/", url) +} + +renv_ppm_transform <- function(repos = getOption("repos")) { + map_chr(repos, function(url) { + tryCatch( + renv_ppm_transform_impl(url), + error = function(e) url + ) + }) +} + +renv_ppm_transform_impl <- function(url) { + + # if this function is being called as part of `install(..., type = "source')` + # then we want to transform binary URLs to source URLs here + if (identical(the$install_pkg_type, "source")) + return(renv_ppm_normalize(url)) + + # repository URL transformation is only necessary on Linux + os <- renv_ppm_os() + if (!identical(os, "__linux__")) + return(url) + + # check for a known platform + platform <- renv_ppm_platform() + if (is.null(platform)) + return(url) + + # don't transform non-https URLs + if (!grepl("^https?://", url)) + return(url) + + # if this already appears to be a binary URL, then avoid + # transforming it + if (grepl("/__[^_]+__/", url)) + return(url) + + # try to parse the repository URL + parts <- catch(renv_url_parse(url)) + if (inherits(parts, "error")) + return(url) + + # only attempt to transform URLs that are formatted like PPM urls: + # + # https://ppm.company.org/cran/checkpoint/id + # + # in particular, there should be at least two trailing + # alphanumeric path components + pattern <- "/[^/]+/[^/]+" + if (!grepl(pattern, parts$path)) + return(url) + + # check if this is an 'ignored' URL; that is, a repository which we + # know is not a PPM URL + mirrors <- catch(getCRANmirrors(local.only = TRUE)) + ignored <- c( + getOption("renv.ppm.ignoredUrls", default = character()), + settings$ppm.ignored.urls(), + mirrors$URL, + "http://cran.rstudio.com", + "http://cran.rstudio.org", + "https://cran.rstudio.com", + "https://cran.rstudio.org" + ) + + if (sub("/+$", "", url) %in% sub("/+$", "", ignored)) + return(url) + + # if this is a 'known' PPM instance, then skip the query step + known <- c( + dirname(dirname(config$ppm.url())), + getOption("renv.ppm.repos", default = NULL) + ) + + if (any(startswith(url, known))) { + parts <- c(dirname(url), "__linux__", platform, basename(url)) + binurl <- paste(parts, collapse = "/") + return(binurl) + } + + # try to query the status endpoint + # TODO: this could fail if the URL is a proxy back to PPM? + base <- dirname(dirname(url)) + status <- catch(renv_ppm_status(base)) + if (inherits(status, "error")) + return(url) + + # iterate through distros and check for a match + for (distro in status$distros) { + + ok <- + identical(distro$binaryURL, platform) && + identical(distro$binaries, TRUE) + + if (ok) { + parts <- c(dirname(url), "__linux__", platform, basename(url)) + binurl <- paste(parts, collapse = "/") + return(binurl) + } + + } + + # no match; return url as-is + url + +} + +renv_ppm_status <- function(base) { + memoize( + key = base, + value = catch(renv_ppm_status_impl(base)) + ) +} + +renv_ppm_status_impl <- function(base) { + + # use a shorter delay to avoid hanging a session + renv_scope_options( + renv.config.connect.timeout = 10L, + renv.config.connect.retry = 1L + ) + + # attempt the download + endpoint <- file.path(base, "__api__/status") + destfile <- renv_scope_tempfile("renv-ppm-status-", fileext = ".json") + quietly(download(endpoint, destfile)) + + # read the downloaded JSON + renv_json_read(destfile) + +} + +renv_ppm_platform <- function(file = "/etc/os-release") { + + platform <- Sys.getenv("RENV_PPM_PLATFORM", unset = NA) + if (!is.na(platform)) + return(platform) + + platform <- Sys.getenv("RENV_RSPM_PLATFORM", unset = NA) + if (!is.na(platform)) + return(platform) + + if (renv_platform_windows()) + return("windows") + + if (renv_platform_macos()) + return("macos") + + renv_ppm_platform_impl(file) + +} + +renv_ppm_platform_impl <- function(file = "/etc/os-release") { + + if (file.exists(file)) { + + properties <- renv_properties_read( + path = file, + delimiter = "=", + dequote = TRUE + ) + + id <- properties$ID %||% "" + + case( + identical(id, "ubuntu") ~ renv_ppm_platform_ubuntu(properties), + identical(id, "centos") ~ renv_ppm_platform_centos(properties), + identical(id, "rhel") ~ renv_ppm_platform_rhel(properties), + grepl("\\bsuse\\b", id) ~ renv_ppm_platform_suse(properties) + ) + + } + +} + +renv_ppm_platform_ubuntu <- function(properties) { + + codename <- properties$VERSION_CODENAME + if (is.null(codename)) + return(NULL) + + codename + +} + +renv_ppm_platform_centos <- function(properties) { + + id <- properties$VERSION_ID + if (is.null(id)) + return(NULL) + + paste0("centos", substring(id, 1L, 1L)) + +} + +renv_ppm_platform_rhel <- function(properties) { + + id <- properties$VERSION_ID + if (is.null(id)) + return(NULL) + + paste0("centos", substring(id, 1L, 1L)) + +} + + +renv_ppm_platform_suse <- function(properties) { + + id <- properties$VERSION_ID + if (is.null(id)) + return(NULL) + + parts <- strsplit(id, ".", fixed = TRUE)[[1L]] + paste0("opensuse", parts[[1L]]) + +} + +renv_ppm_os <- function() { + + os <- Sys.getenv("RENV_PPM_OS", unset = NA) + if (!is.na(os)) + return(os) + + os <- Sys.getenv("RENV_RSPM_OS", unset = NA) + if (!is.na(os)) + return(os) + + if (renv_platform_windows()) + "__windows__" + else if (renv_platform_macos()) + "__macos__" + else if (renv_platform_linux()) + "__linux__" + +} + + +renv_ppm_enabled <- function() { + + # allow environment variable override + enabled <- Sys.getenv("RENV_PPM_ENABLED", unset = NA) + if (!is.na(enabled)) + return(truthy(enabled, default = TRUE)) + + # support older options as well + enabled <- Sys.getenv("RENV_RSPM_ENABLED", unset = NA) + if (!is.na(enabled)) + return(truthy(enabled, default = TRUE)) + + # TODO: can we remove this check? + # https://github.com/rstudio/renv/issues/1132 + if (!testing()) { + + disabled <- + renv_platform_linux() && + identical(renv_platform_machine(), "aarch64") + + if (disabled) + return(FALSE) + + } + + # check for project setting + enabled <- settings$ppm.enabled() + if (!is.null(enabled)) + return(enabled) + + # otherwise, use configuration option + config$ppm.enabled() + +} + + +# predicate.R ---------------------------------------------------------------- + + +pscalar <- function(x) { + length(x) == 1L +} + +pstring <- function(x) { + is.character(x) && length(x) == 1L +} + + + +# preflight.R ---------------------------------------------------------------- + + +# returns TRUE if problems detected +renv_preflight <- function(lockfile) { + + problems <- stack() + + # check that we can compile C programs + renv_preflight_compiler(problems) + + # if rJava is being used, ensure that Java is properly configured + renv_preflight_java(lockfile, problems) + + data <- problems$data() + if (length(data)) { + + feedback <- lines( + "The following problems were detected in your environment:", + "", + paste(data, collapse = "\n\n"), + "", + "The environment may not be restored correctly." + ) + + caution(feedback) + + } + + length(data) == 0 + +} + +renv_preflight_compiler <- function(problems) { + + # try to compile a simple program + program <- "void test() {}" + file <- renv_scope_tempfile("renv-test-compile-", fileext = ".c") + writeLines(program, con = file) + + args <- c("CMD", "SHLIB", renv_shell_path(file)) + status <- system2(R(), args, stdout = FALSE, stderr = FALSE) + + if (!identical(status, 0L)) { + + feedback <- lines( + "- Cannot compile C / C++ files from source.", + " Please ensure you have a compiler toolchain installed." + ) + + problems$push(feedback) + + } + +} + +renv_preflight_java <- function(lockfile, problems) { + + # no need to check if we're not using rJava + records <- renv_lockfile_records(lockfile) + if (is.null(records[["rJava"]])) + return(TRUE) + + # TODO: no need to do anything if we're only installing binaries? + switch( + Sys.info()[["sysname"]], + Windows = renv_preflight_java_windows(problems), + renv_preflight_java_unix(problems) + ) + +} + +renv_preflight_java_windows <- function(problems) { + + home <- Sys.getenv("JAVA_HOME", unset = NA) + feedback <- case( + + is.na(home) ~ lines( + "- JAVA_HOME is not set.", + " Please ensure you have a Java Development Kit (JDK) installed." + ), + + !file.exists(home) ~ lines( + "- JAVA_HOME is set to a non-existent directory.", + " Please ensure you have a Java Development Kit (JDK) installed." + ) + + ) + + if (!is.null(feedback)) + problems$push(feedback) + +} + +renv_preflight_java_unix <- function(problems) { + + args <- c("CMD", "javareconf", "--dry-run") + status <- system2(R(), args, stdout = FALSE, stderr = FALSE) + if (!identical(status, 0L)) { + + feedback <- lines( + "- Cannot compile Java files from source.", + " Please ensure you have a Java Development Kit (JDK) installed." + ) + + problems$push(feedback) + + } + +} + + +# pretty.R ------------------------------------------------------------------- + + +renv_pretty_print_records <- function(preamble, records, postamble = NULL) { + + if (empty(records)) + return(invisible(NULL)) + + if (!renv_verbose()) + return(invisible(NULL)) + + # NOTE: use 'sort()' rather than 'csort()' here so that + # printed output is sorted in the expected way in the users locale + # https://github.com/rstudio/renv/issues/1289 + names(records) <- names(records) %||% map_chr(records, `[[`, "Package") + records <- records[sort(names(records))] + packages <- names(records) + descs <- map_chr(records, renv_record_format_short) + text <- sprintf("- %s [%s]", format(packages), descs) + + all <- c(preamble, text, postamble, if (length(postamble)) "") + renv_caution_impl(all) + +} + +renv_pretty_print_records_pair <- function(preamble, + old, + new, + postamble = NULL, + formatter = NULL) +{ + formatter <- formatter %||% renv_record_format_pair + + all <- c( + c(preamble, ""), + renv_pretty_print_records_pair_impl(old, new, formatter), + if (length(postamble)) c(postamble, "") + ) + + renv_caution_impl(all) +} + +renv_pretty_print_records_pair_impl <- function(old, new, formatter) { + + # NOTE: use 'sort()' rather than 'csort()' here so that + # printed output is sorted in the expected way in the users locale + # https://github.com/rstudio/renv/issues/1289 + all <- sort(union(names(old), names(new))) + + # compute groups + groups <- map_chr(all, function(package) { + + lhs <- old[[package]]; rhs <- new[[package]] + case( + is.null(lhs$Source) ~ rhs$Repository %||% rhs$Source, + is.null(rhs$Source) ~ lhs$Repository %||% lhs$Source, + !is.null(rhs$Repository) ~ rhs$Repository, + !is.null(rhs$Source) ~ rhs$Source + ) + + }) + + n <- max(nchar(all)) + + # iterate over each group and print + uapply(csort(unique(groups)), function(group) { + + lhs <- renv_records_select(old, groups, group) + rhs <- renv_records_select(new, groups, group) + + nms <- union(names(lhs), names(rhs)) + text <- map_chr(nms, function(nm) { + formatter(lhs[[nm]], rhs[[nm]]) + }) + + if (group == "unknown") + group <- "(Unknown Source)" + + c( + header(group), + paste("-", format(nms, width = n), " ", text), + "" + ) + + }) + +} + +# NOTE: Used by vetiver, so perhaps is part of the API. +# We should think of a cleaner way of exposing this. +# https://github.com/rstudio/renv/issues/1413 +renv_pretty_print_impl <- renv_caution_impl + + +# process.R ------------------------------------------------------------------ + + +# NOTE: We use 'psnice()' here as R also supports using that +# for process detection on Windows; on all platforms R returns +# NA if you request information about a non-existent process +renv_process_exists <- function(pid) { + !is.na(psnice(pid)) +} + +renv_process_kill <- function(pid, signal = 15L) { + pskill(pid, signal) +} + + +# profile.R ------------------------------------------------------------------ + + +renv_profile_prefix <- function() { + renv_bootstrap_profile_prefix() +} + +renv_profile_get <- function() { + renv_bootstrap_profile_get() +} + +renv_profile_set <- function(profile) { + renv_bootstrap_profile_set(profile) +} + +renv_profile_normalize <- function(profile) { + renv_bootstrap_profile_normalize(profile) +} + + +# progress.R ----------------------------------------------------------------- + + +renv_progress_create <- function(max, wait = 1.0) { + + # local variables for closure + count <- 0L + max <- max + message <- "" + start <- Sys.time() + + function() { + + # check for and print progress + count <<- count + 1L + + # if not enough time has elapsed yet, nothing to do + if (Sys.time() - start < wait) + return() + + # create message + backspaces <- paste(rep("\b", nchar(message)), collapse = "") + message <<- sprintf("[%i/%i] ", count, max) + all <- paste(backspaces, message, sep = "") + cat(all, file = stdout(), sep = "") + + } + +} + +renv_progress_callback <- function(callback, max, wait = 1.0) { + tick <- renv_progress_create(max, wait) + function(...) { tick(); callback(...) } +} + + +# project.R ------------------------------------------------------------------ + + +# The path to the currently-loaded project, if any. +# NULL when no project is currently loaded. +the$project_path <- NULL + +# Flag indicating whether we're checking if the project is synchronized. +the$project_synchronized_check_running <- FALSE + +#' Retrieve the active project +#' +#' Retrieve the path to the active project (if any). +#' +#' @param default The value to return when no project is +#' currently active. Defaults to `NULL`. +#' +#' @export +#' +#' @return The active project directory, as a length-one character vector. +#' +#' @examples +#' \dontrun{ +#' +#' # get the currently-active renv project +#' renv::project() +#' +#' } +project <- function(default = NULL) { + renv_project_get(default = default) +} + +renv_project_get <- function(default = NULL) { + the$project_path %||% default +} + +# NOTE: RENV_PROJECT kept for backwards compatibility with RStudio +renv_project_set <- function(project) { + the$project_path <- project + Sys.setenv(RENV_PROJECT = project) +} + +# NOTE: 'RENV_PROJECT' kept for backwards compatibility with RStudio +renv_project_clear <- function() { + the$project_path <- NULL + Sys.unsetenv("RENV_PROJECT") +} + +renv_project_resolve <- function(project = NULL, default = getwd()) { + project <- project %||% renv_project_get(default = default) + renv_path_normalize(project) +} + +renv_project_initialized <- function(project) { + + lockfile <- renv_lockfile_path(project) + if (file.exists(lockfile)) + return(TRUE) + + library <- renv_paths_library(project = project) + if (file.exists(library)) + return(TRUE) + + FALSE + +} + +renv_project_type <- function(path) { + + if (!nzchar(path)) + return("unknown") + + path <- renv_path_normalize(path) + filebacked( + context = "renv_project_type", + path = file.path(path, "DESCRIPTION"), + callback = renv_project_type_impl + ) + +} + +renv_project_type_impl <- function(path) { + + if (!file.exists(path)) + return("unknown") + + desc <- tryCatch( + renv_dcf_read(path), + error = identity + ) + + if (inherits(desc, "error")) + return("unknown") + + type <- desc$Type + if (!is.null(type)) + return(tolower(type)) + + package <- desc$Package + if (!is.null(package)) + return("package") + + "unknown" + +} + +renv_project_remotes <- function(project, fields = NULL) { + + descpath <- file.path(project, "DESCRIPTION") + if (!file.exists(descpath)) + return(NULL) + + # first, parse remotes (if any) + remotes <- renv_description_remotes(descpath) + + # next, find packages mentioned in the DESCRIPTION file + deps <- renv_dependencies_discover_description( + path = descpath, + project = project + ) + + if (empty(deps)) + return(list()) + + # split according to package + specs <- split(deps, deps$Package) + + # drop ignored specs + ignored <- renv_project_ignored_packages(project = project) + specs <- specs[setdiff(names(specs), c("R", ignored))] + + # if any Roxygen fields are included, + # infer a dependency on roxygen2 and devtools + desc <- renv_description_read(descpath) + if (any(grepl("^Roxygen", names(desc)))) { + for (package in c("devtools", "roxygen2")) { + if (!package %in% ignored) { + specs[[package]] <- + specs[[package]] %||% + renv_dependencies_list(descpath, package, dev = TRUE) + } + } + } + + # now, try to resolve the packages + records <- enumerate(specs, function(package, spec) { + + # use remote if supplied + if (!is.null(remotes[[package]])) + return(remotes[[package]]) + + # check for explicit version requirement + explicit <- spec[spec$Require == "==", ] + if (nrow(explicit) == 0) + return(renv_remotes_resolve(package)) + + version <- spec$Version[[1]] + if (!nzchar(version)) + return(renv_remotes_resolve(package)) + + entry <- paste(package, version, sep = "@") + renv_remotes_resolve(entry) + + }) + + # return records + records + +} + +renv_project_ignored_packages <- function(project) { + + # if we don't have a project, nothing to do + if (is.null(project)) + return(character()) + + # read base set of ignored packages + ignored <- c( + settings$ignored.packages(project = project), + renv_project_ignored_packages_self(project) + ) + + # return collected set of ignored packages + ignored + +} + +renv_project_ignored_packages_self <- function(project) { + + # only ignore self in package projects + if (renv_project_type(project) != "package") + return(NULL) + + # read current package + desc <- renv_description_read(project) + package <- desc[["Package"]] + + # respect user preference if set + ignore <- getOption("renv.snapshot.ignore.self", default = NULL) + if (identical(ignore, TRUE)) + return(package) + else if (identical(ignore, FALSE)) + return(NULL) + + # don't ignore self in golem projets + golem <- file.path(project, "inst/golem-config.yml") + if (file.exists(golem)) + return(NULL) + + # hack for renv: don't depend on self + if (identical(package, "renv")) + return(NULL) + + # return the package name + package + +} + +renv_project_id <- function(project) { + + idpath <- renv_id_path(project = project) + if (!file.exists(idpath)) { + id <- renv_id_generate() + writeLines(id, con = idpath) + } + + readLines(idpath, n = 1L, warn = FALSE) + +} + +# TODO: this gets really dicey once the user starts configuring where +# renv places its project-local state ... +renv_project_find <- function(path = NULL) { + + path <- path %||% getwd() + + anchors <- c("renv.lock", "renv/activate.R") + resolved <- renv_file_find(path, function(parent) { + for (anchor in anchors) + if (file.exists(file.path(parent, anchor))) + return(parent) + }) + + if (is.null(resolved)) { + fmt <- "couldn't resolve renv project associated with path %s" + stopf(fmt, renv_path_pretty(path)) + } + + resolved + +} + +renv_project_lock <- function(project = NULL) { + + if (!config$locking.enabled()) + return() + + path <- the$project_path + if (!identical(project, path)) + return() + + project <- renv_project_resolve(project) + path <- file.path(project, "renv/lock") + ensure_parent_directory(path) + renv_scope_lock(path, scope = parent.frame()) + +} + +renv_project_loaded <- function(project) { + !is.null(project) && identical(project, the$project_path) +} + + +# properties.R --------------------------------------------------------------- + + +renv_properties_read <- function(path = NULL, + text = NULL, + delimiter = ":", + dequote = TRUE, + trim = TRUE) +{ + renv_scope_options(warn = -1L) + + # read file + contents <- paste(text %||% readLines(path, warn = FALSE), collapse = "\n") + + # split on newlines; allow spaces to continue a value + parts <- strsplit(contents, "\\n(?=\\S)", perl = TRUE)[[1L]] + + # remove comments and blank lines + parts <- grep("^\\s*(?:#|$)", parts, perl = TRUE, value = TRUE, invert = TRUE) + + # split into key / value pairs + index <- regexpr(delimiter, parts, fixed = TRUE) + keys <- substring(parts, 1L, index - 1L) + vals <- substring(parts, index + 1L) + + # trim whitespace when requested + if (trim) { + keys <- trimws(keys) + vals <- gsub("\n\\s*", " ", trimws(vals), perl = TRUE) + } + + # strip quotes if requested + if (dequote) { + keys <- dequote(keys) + vals <- dequote(vals) + } + + # return as named list + storage.mode(vals) <- "list" + names(vals) <- keys + + vals + +} + + +# purge.R -------------------------------------------------------------------- + + +#' Purge packages from the cache +#' +#' Purge packages from the cache. This can be useful if a package which had +#' previously been installed in the cache has become corrupted or unusable, +#' and needs to be reinstalled. +#' +#' `purge()` is an inherently destructive option. It removes packages from the +#' cache, and so any project which had symlinked that package into its own +#' project library would find that package now unavailable. These projects would +#' hence need to reinstall any purged packages. Take heed of this in case you're +#' looking to purge the cache of a package which is difficult to install, or +#' if the original sources for that package are no longer available! +#' +#' @inherit renv-params +#' +#' @param package A single package to be removed from the cache. +#' @param version The package version to be removed. When `NULL`, all versions +#' of the requested package will be removed. +#' @param hash The specific hashes to be removed. When `NULL`, all hashes +#' associated with a particular package's version will be removed. +#' +#' @return The set of packages removed from the renv global cache, +#' as a character vector of file paths. +#' +#' @export +#' +#' @examples +#' \dontrun{ +#' +#' # remove all versions of 'digest' from the cache +#' renv::purge("digest") +#' +#' # remove only a particular version of 'digest' from the cache +#' renv::purge("digest", version = "0.6.19") +#' +#' } +purge <- function(package, + ..., + version = NULL, + hash = NULL, + prompt = interactive()) +{ + renv_scope_error_handler() + renv_dots_check(...) + renv_scope_verbose_if(prompt) + invisible(renv_purge_impl(package, version, hash, prompt)) +} + +renv_purge_impl <- function(package, + version = NULL, + hash = NULL, + prompt = interactive()) +{ + if (length(package) != 1) + stop("argument 'package' is not of length one", call. = FALSE) + + bail <- function() { + writef("- The requested package is not installed in the cache -- nothing to do.") + character() + } + + # get root cache path entry for package + paths <- renv_paths_cache(package) + if (!any(file.exists(paths))) + return(bail()) + + # construct versioned path + paths <- if (is.null(version)) + list.files(paths, full.names = TRUE) + else + file.path(paths, version) + if (!any(file.exists(paths))) + return(bail()) + + # construct hashed path + paths <- if (is.null(hash)) + list.files(paths, full.names = TRUE) + else + file.path(paths, hash) + if (all(!file.exists(paths))) + return(bail()) + + # now add package name + paths <- file.path(paths, renv_path_component(paths, 3)) + + # check that these entries exist + missing <- !file.exists(paths) + if (any(missing)) { + + caution_bullets( + "The following entries were not found in the cache:", + paths[missing], + "They will be ignored." + ) + + paths <- paths[!missing] + + } + + # nocov start + if (prompt || renv_verbose()) { + + caution_bullets( + "The following packages will be purged from the cache:", + renv_cache_format_path(paths) + ) + + cancel_if(prompt && !proceed()) + + } + # nocov end + + unlink(paths, recursive = TRUE) + renv_cache_clean_empty() + + n <- length(paths) + writef("- Removed %s from the cache.", nplural("package", n)) + + invisible(paths) + +} + + +# pyenv.R -------------------------------------------------------------------- + + +renv_pyenv_root <- function() { + root <- Sys.getenv("PYENV_ROOT", unset = renv_pyenv_root_default()) + path.expand(root) +} + +renv_pyenv_root_default <- function() { + + if (renv_platform_windows()) + "~/.pyenv/pyenv-win" + else + "~/.pyenv" + +} + + + +# python-conda.R ------------------------------------------------------------- + + +renv_python_conda_select <- function(name, version = NULL) { + + # get python package + version <- version %||% Sys.getenv("RENV_CONDA_PYTHON_VERSION", unset = "3.7") + packages <- paste("python", version, sep = "=") + + # handle paths (as opposed to environment names) + if (grepl("[/\\\\]", name)) { + if (!file.exists(name)) + return(reticulate::conda_create(envname = name, packages = packages)) + return(renv_python_exe(name)) + } + + # check for an existing conda environment + envs <- reticulate::conda_list() + idx <- which(name == envs$name) + if (length(idx)) + return(envs$python[[idx]]) + + # no environment exists; create it + reticulate::conda_create(envname = name, packages = packages) + +} + +renv_python_conda_export_path <- function(project) { + + # check override + override <- renv_paths_override("CONDA_EXPORT") + if (!is.null(override)) + return(override) + + # use default + file.path(project, "environment.yml") + +} + +# TODO: support prompt +renv_python_conda_snapshot <- function(project, prompt, python) { + + renv_scope_wd(project) + + path <- renv_python_conda_export_path(project = project) + + # find the root of the associated conda environment + lockfile <- renv_lockfile_load(project = project) + name <- lockfile$Python$Name %||% renv_python_envpath(project, "conda", version) + python <- renv_python_conda_select(name) + info <- renv_python_info(python) + prefix <- info$root + + conda <- reticulate::conda_binary() + args <- c( + "env", "export", + "--prefix", renv_shell_path(prefix), + "--file", renv_shell_path(path) + ) + + output <- if (renv_tests_running()) FALSE else "" + system2(conda, args, stdout = output, stderr = output) + + writef("- Wrote Python packages to '%s'.", renv_path_aliased(path)) + return(TRUE) +} + +# TODO: support prompt +renv_python_conda_restore <- function(project, prompt, python) { + + renv_scope_wd(project) + + path <- renv_python_conda_export_path(project = project) + + # find the root of the associated conda environment + lockfile <- renv_lockfile_load(project = project) + name <- lockfile$Python$Name %||% renv_python_envpath(project, "conda", version) + python <- renv_python_conda_select(name) + info <- renv_python_info(python) + prefix <- info$root + + conda <- reticulate::conda_binary() + cmd <- if (file.exists(prefix)) "update" else "create" + args <- c( + "env", cmd, + "--prefix", renv_shell_path(prefix), + "--file", renv_shell_path(path) + ) + + output <- if (renv_tests_running()) FALSE else "" + system2(conda, args, stdout = output, stderr = output) + + return(TRUE) + +} + + +# python-virtualenv.R -------------------------------------------------------- + + +renv_python_virtualenv_home <- function() { + Sys.getenv("WORKON_HOME", unset = "~/.virtualenvs") +} + +renv_python_virtualenv_path <- function(name) { + + # if the name contains a slash, use it as-is + if (grepl("/", name, fixed = TRUE)) + return(renv_path_canonicalize(name)) + + # treat names starting with '.' specially + if (substring(name, 1L, 1L) == ".") + return(renv_path_canonicalize(name)) + + # otherwise, resolve relative to virtualenv home + home <- renv_python_virtualenv_home() + file.path(home, name) + +} + +renv_python_virtualenv_validate <- function(path, version) { + + # get path to python executable + python <- renv_python_exe(path) + + # compare requested + actual versions + if (!is.null(version)) { + request <- renv_version_maj_min(version) + current <- renv_version_maj_min(renv_python_version(python)) + if (request != current) { + fmt <- "Project requested Python version '%s' but '%s' is currently being used" + warningf(fmt, request, current) + } + } + + python + +} + +renv_python_virtualenv_create <- function(python, path) { + + ensure_parent_directory(path) + + python <- renv_path_canonicalize(python) + version <- renv_python_version(python) + module <- if (numeric_version(version) > "3.2") "venv" else "virtualenv" + args <- c("-m", module, renv_shell_path(path)) + renv_system_exec(python, args, "creating virtual environment") + + info <- renv_python_info(path) + info$python + +} + +renv_python_virtualenv_update <- function(python) { + + # resolve python executable path + python <- renv_python_exe(python) + python <- renv_path_canonicalize(python) + + # resolve packages + packages <- c("pip", "setuptools", "wheel") + + # don't upgrade these packages for older versions of python, as we may + # end up installing versions of packages that aren't actually compatible + # with the version of python we're running + version <- renv_python_version(python) + if (renv_version_lt(version, "3.6")) + return(TRUE) + + # perform the install + # make errors non-fatal as the environment will still be functional even + # if we're not able to install or update these packages + status <- catch(pip_install(packages, python = python)) + if (inherits(status, "error")) + warnify(status) + + TRUE + +} + +renv_python_virtualenv_snapshot <- function(project, prompt, python) { + + renv_scope_wd(project) + + path <- file.path(project, "requirements.txt") + before <- character() + if (file.exists(path)) + before <- readLines(path, warn = FALSE) + + after <- pip_freeze(python = python) + if (setequal(before, after)) { + writef("- Python requirements are already up to date.") + return(FALSE) + } + + caution_bullets("The following will be written to requirements.txt:", after) + + cancel_if(prompt && !proceed()) + + writeLines(after, con = path) + + fmt <- "- Wrote Python packages to %s." + writef(fmt, renv_path_pretty(path)) + return(TRUE) + +} + +renv_python_virtualenv_restore <- function(project, prompt, python) { + + renv_scope_wd(project) + + path <- file.path(project, "requirements.txt") + if (!file.exists(path)) + return(FALSE) + + before <- readLines(path, warn = FALSE) + after <- pip_freeze(python = python) + diff <- renv_vector_diff(before, after) + if (empty(diff)) { + writef("- The Python library is already up to date.") + return(FALSE) + } + + caution_bullets("The following Python packages will be restored:", diff) + + cancel_if(prompt && !proceed()) + + pip_install_requirements(diff, python = python, stream = TRUE) + TRUE + +} + + +# python.R ------------------------------------------------------------------- + + +renv_python_resolve <- function(python = NULL) { + + # if Python was explicitly supplied, use it + if (!is.null(python)) { + + resolved <- Sys.which(renv_path_canonicalize(python)) + if (nzchar(resolved)) + return(resolved) + + stopf("'%s' does not refer to a valid python interpreter", python) + + } + + # in interactive sessions, ask user what version of python they'd like to use + if (interactive()) { + + python <- renv_python_select() + + fmt <- "- Selected %s [Python %s]." + writef(fmt, renv_path_pretty(python), renv_python_version(python)) + + return(path.expand(python)) + + } + + # check environment variables + envvars <- c("RETICULATE_PYTHON", "RETICULATE_PYTHON_ENV") + for (envvar in envvars) { + val <- Sys.getenv(envvar, unset = NA) + if (!is.na(val) && file.exists(val)) + return(val) + } + + # check on the PATH (prefer Python 3) + for (binary in c("python3", "python")) { + python <- Sys.which(binary) + if (nzchar(python)) + return(python) + } + + stopf("could not locate Python (not available on the PATH)") + +} + +renv_python_find <- function(version, path = NULL) { + renv_python_find_impl(version, path) +} + +renv_python_find_impl <- function(version, path = NULL) { + + # if we've been given the name of an environment, + # check to see if it's already been initialized + # and use the associated copy of Python if possible + if (!is.null(path) && file.exists(path)) { + python <- catch(renv_python_exe(path)) + if (!inherits(python, "error")) + return(python) + } + + # try to find a compatible version of python + pythons <- renv_python_discover() + if (length(pythons) == 0) { + + fmt <- lines( + "project requested Python %s, but no compatible Python installation could be found.", + "renv's Python integration will be disabled in this session.", + "See `?renv::use_python` for more details." + ) + + stopf(fmt, version) + + } + + # read python versions + pyversions <- map_chr(pythons, function(python) { + tryCatch( + renv_python_version(python), + error = function(e) "0.0.0" + ) + }) + + # try to find a compatible version + renv_version_match(pyversions, version) + +} + +renv_python_exe <- function(path) { + + # if this already looks like a Python executable, use it directly + info <- renv_file_info(path) + if (identical(info$isdir, FALSE) && startswith(basename(path), "python")) + return(renv_path_canonicalize(path)) + + # otherwise, attempt to infer the Python executable type + info <- renv_python_info(path) + if (!is.null(info$python)) + return(renv_path_canonicalize(info$python)) + + fmt <- "failed to find Python executable associated with path %s" + stopf(fmt, renv_path_pretty(path)) + +} + +renv_python_version <- function(python) { + + filebacked( + context = "renv_python_version", + path = renv_path_normalize(python), + callback = renv_python_version_impl + ) + +} + +renv_python_version_impl <- function(python) { + python <- renv_path_canonicalize(python) + code <- "from platform import python_version; print(python_version())" + args <- c("-c", shQuote(code)) + action <- "reading Python version" + renv_system_exec(python, args, action) +} + +renv_python_info <- function(python) { + + found <- renv_file_find(python, function(path) { + + # check for virtual environment files + virtualenv <- + file.exists(file.path(path, "pyvenv.cfg")) || + file.exists(file.path(path, ".Python")) || + file.exists(file.path(path, "bin/activate_this.py")) + + if (virtualenv) { + suffix <- if (renv_platform_windows()) "Scripts/python.exe" else "bin/python" + python <- file.path(path, suffix) + return(list(python = python, type = "virtualenv", root = path)) + } + + # check for conda-meta + condaenv <- + file.exists(file.path(path, "conda-meta")) && + !file.exists(file.path(path, "condabin")) + + if (condaenv) { + suffix <- if (renv_platform_windows()) "python.exe" else "bin/python" + python <- file.path(path, suffix) + return(list(python = python, type = "conda", root = path)) + } + + }) + + if (!is.null(found)) + return(found) + + if (file.exists(python)) + list(python = python, type = "system", root = python) + +} + +renv_python_type <- function(python) { + info <- renv_python_info(python) + info$type +} + +renv_python_action <- function(action, prompt, project) { + + python <- Sys.getenv("RENV_PYTHON", unset = NA) + if (is.na(python) || !file.exists(python)) + return(NULL) + + type <- renv_python_type(python) + if (is.null(type)) + return(NULL) + + if (type == "conda" && !requireNamespace("reticulate", quietly = TRUE)) + return(NULL) + + action(python, type, prompt, project) + +} + +renv_python_snapshot <- function(project, prompt) { + renv_python_action( + renv_python_snapshot_impl, + prompt = prompt, + project = project + ) +} + +renv_python_snapshot_impl <- function(python, type, prompt, project) { + + switch(type, + virtualenv = renv_python_virtualenv_snapshot(project, prompt, python), + conda = renv_python_conda_snapshot(project, prompt, python) + ) + +} + +renv_python_restore <- function(project, prompt) { + renv_python_action( + renv_python_restore_impl, + prompt = prompt, + project = project + ) +} + +renv_python_restore_impl <- function(python, type, prompt, project) { + + case( + type == "virtualenv" ~ renv_python_virtualenv_restore(project, prompt, python), + type == "conda" ~ renv_python_conda_restore(project, prompt, python) + ) + +} + +renv_python_envpath_virtualenv <- function(version) { + sprintf("python/virtualenvs/renv-python-%s", renv_version_maj_min(version)) +} + +renv_python_envpath_condaenv <- function(version) { + "python/condaenvs/renv-python" +} + +renv_python_envpath <- function(project, type, version = NULL) { + + suffix <- case( + type == "virtualenv" ~ renv_python_envpath_virtualenv(version), + type == "conda" ~ renv_python_envpath_condaenv(version), + ~ stopf("internal error: unrecognized environment type '%s'", type) + ) + + renv_paths_renv(suffix, project = project) + +} + +renv_python_envname <- function(project, path, type) { + + # check for a project-local environment + if (renv_path_within(path, project)) { + stem <- substring(path, nchar(project) + 2L) + path <- paste(".", stem, sep = "/") + return(path) + } + + bn <- basename(path) + + # check for file within virtualenv + ok <- + type == "virtualenv" && + identical(renv_python_virtualenv_path(bn), path) + + if (ok) + return(bn) + + # check for named conda environment + ok <- + type == "conda" && + bn %in% reticulate::conda_list()$name + + if (ok) + return(bn) + + # doesn't match any known named environments; return full path + path + +} + +renv_python_discover <- function() { + + all <- stack() + + # find python in some pre-determined root directories + roots <- c( + getOption("renv.python.root"), + Sys.getenv("WORKON_HOME", "~/.virtualenvs"), + "/opt/python", + "/opt/local/python", + "~/opt/python", + file.path(renv_pyenv_root(), "versions") + ) + + for (root in roots) { + versions <- sort(list.files(root, full.names = TRUE), decreasing = TRUE) + exts <- if (renv_platform_windows()) "Scripts/python.exe" else "bin/python" + pythons <- file.path(versions, exts) + all$push(pythons) + } + + # find Homebrew python + if (renv_platform_macos()) { + + homebrew <- renv_homebrew_root() + roots <- sort(list.files( + path = file.path(homebrew, "opt"), + pattern = "^python@[[:digit:]]+[.][[:digit:]]+$", + full.names = TRUE + ), decreasing = TRUE) + + for (root in roots) { + + # homebrew python doesn't install bin/python, so we need + # to be a little bit more clever here + exes <- list.files( + path = file.path(root, "bin"), + pattern = "^python[[:digit:]]+[.][[:digit:]]+$", + full.names = TRUE + ) + + if (length(exes)) + all$push(exes[[1L]]) + + } + + } + + # find Windows python installations + if (renv_platform_windows()) { + + sd <- Sys.getenv("SYSTEMDRIVE", unset = "C:") + roots <- file.path(sd, c("", "Program Files")) + + lad <- Sys.getenv("LOCALAPPDATA", unset = NA) + if (!is.na(lad)) + roots <- c(roots, file.path(lad, "Programs/Python")) + + dirs <- list.files( + path = roots, + pattern = "^Python", + full.names = TRUE + ) + + if (length(dirs)) { + exes <- file.path(dirs, "python.exe") + pythons <- renv_path_normalize(exes) + all$push(pythons) + } + + } + + # find Python installations on the PATH + path <- Sys.getenv("PATH", unset = "") + splat <- strsplit(path, .Platform$path.sep, fixed = TRUE)[[1L]] + for (entry in splat) { + for (exe in c("python3", "python")) { + python <- Sys.which(file.path(entry, exe)) + if (nzchar(python)) + all$push(python) + } + } + + # collect discovered pythons as vector + pythons <- unlist(all$data(), recursive = FALSE, use.names = TRUE) + + # don't include /usr/bin/python on macOS (too old) + if (renv_platform_macos()) + pythons <- setdiff(pythons, "/usr/bin/python") + + # get list of pythons + pythons <- renv_path_canonicalize(pythons[file.exists(pythons)]) + + # don't include WindowsApps + if (renv_platform_windows()) + pythons <- grep("/WindowsApps/", pythons, invert = TRUE, value = TRUE) + + unique(pythons) + +} + +renv_python_select_error <- function() { + + lines <- c( + "renv was unable to find any Python installations on your machine.", + if (renv_platform_windows()) + "Consider installing Python from https://www.python.org/downloads/windows/.", + if (renv_platform_macos()) + "Consider installing Python from https://www.python.org/downloads/mac-osx/." + ) + + stop(paste(lines, collapse = "\n")) + +} + +renv_python_select <- function(candidates = NULL) { + + candidates <- renv_path_aliased(candidates %||% renv_python_discover()) + if (empty(candidates)) + return(renv_python_select_error()) + + title <- "Please select a version of Python to use with this project:" + selection <- tryCatch( + utils::select.list(candidates, title = title, graphics = FALSE), + interrupt = identity + ) + + if (selection %in% "" || inherits(selection, "interrupt")) + stop("operation canceled by user") + + return(path.expand(selection)) + +} + +renv_python_module_available <- function(python, module) { + python <- renv_path_canonicalize(python) + command <- paste("import", module) + args <- c("-c", shQuote(command)) + status <- system2(python, args, stdout = FALSE, stderr = FALSE) + identical(status, 0L) +} + +renv_python_active <- function() { + + python <- Sys.getenv("RENV_PYTHON", unset = NA) + if (is.na(python)) + stop("internal error: RENV_PYTHON is not set") + + renv_python_validate(python) + +} + +renv_python_validate <- function(python) { + + if (!file.exists(python)) { + fmt <- "python %s does not exist" + stopf(fmt, renv_path_pretty(python)) + } + + invisible(python) + +} + + +# r.R ------------------------------------------------------------------------ + + +R <- function() { + bin <- normalizePath(R.home("bin"), winslash = "/") + exe <- if (renv_platform_windows()) "R.exe" else "R" + file.path(bin, exe) +} + +r <- function(args, ...) { + + # ensure R_LIBS is set; unset R_LIBS_USER and R_LIBS_SITE + # so that R_LIBS will always take precedence + rlibs <- paste(renv_libpaths_all(), collapse = .Platform$path.sep) + renv_scope_envvars(R_LIBS = rlibs, R_LIBS_USER = "NULL", R_LIBS_SITE = "NULL") + + # ensure Rtools is on the PATH for Windows + renv_scope_rtools() + + # invoke r + suppressWarnings(system2(R(), args, ...)) + +} + +r_exec_error <- function(package, output, label, extra) { + + # installation failed; write output for user + fmt <- "Error %sing package '%s':" + header <- sprintf(fmt, label, package) + + lines <- paste(rep("=", nchar(header)), collapse = "") + + # try to add diagnostic information if possible + diagnostics <- r_exec_error_diagnostics(package, output) + if (!empty(diagnostics)) { + size <- min(getOption("width"), 78L) + dividers <- paste(rep.int("-", size), collapse = "") + output <- c(output, paste(dividers, diagnostics, collapse = "\n\n")) + } + + # normalize 'extra' + extra <- if (is.integer(extra)) + paste("error code", extra) + else + paste(renv_path_pretty(extra), "does not exist") + + # stop with an error + footer <- sprintf("%s of package '%s' failed [%s]", label, package, extra) + all <- c(header, lines, "", output, footer) + abort(all) + +} + +r_exec_error_diagnostics_fortran_library <- function() { + + checker <- function(output) { + pattern <- "library not found for -l(quadmath|gfortran|fortran)" + idx <- grep(pattern, output, ignore.case = TRUE) + if (length(idx)) + return(unique(output[idx])) + } + + suggestion <- " +R was unable to find one or more FORTRAN libraries during compilation. +This often implies that the FORTRAN compiler has not been properly configured. +Please see https://stackoverflow.com/q/35999874 for more information. +" + + list( + checker = checker, + suggestion = suggestion + ) + +} + +r_exec_error_diagnostics_fortran_binary <- function() { + + checker <- function(output) { + pattern <- "gfortran: no such file or directory" + idx <- grep(pattern, output, ignore.case = TRUE) + if (length(idx)) + return(unique(output[idx])) + } + + suggestion <- " +R was unable to find the gfortran binary. +gfortran is required for the compilation of FORTRAN source files. +Please check that gfortran is installed and available on the PATH. +Please see https://stackoverflow.com/q/35999874 for more information. +" + + list( + checker = checker, + suggestion = suggestion + ) + +} + +r_exec_error_diagnostics_openmp <- function() { + + checker <- function(output) { + pattern <- "unsupported option '-fopenmp'" + idx <- grep(pattern, output, fixed = TRUE) + if (length(idx)) + return(unique(output[idx])) + } + + suggestion <- " +R is currently configured to use a compiler that does not have OpenMP support. +You may need to disable OpenMP, or update your compiler toolchain. +Please see https://support.bioconductor.org/p/119536/ for a related discussion. +" + + list( + checker = checker, + suggestion = suggestion + ) + +} + +r_exec_error_diagnostics <- function(package, output) { + + diagnostics <- list( + r_exec_error_diagnostics_fortran_library(), + r_exec_error_diagnostics_fortran_binary(), + r_exec_error_diagnostics_openmp() + ) + + suggestions <- uapply(diagnostics, function(diagnostic) { + + check <- catch(diagnostic$checker(output)) + if (!is.character(check)) + return() + + suggestion <- diagnostics$suggestion + reasons <- paste("-", shQuote(check), collapse = "\n") + paste(diagnostic$suggestion, "Reason(s):", reasons, sep = "\n") + + }) + + as.character(suggestions) + +} + +# install package called 'package' located at path 'path' +r_cmd_install <- function(package, path, ...) { + + # normalize path to package + path <- renv_path_normalize(path, mustWork = TRUE) + + # unpack .zip source archives before install + # https://github.com/rstudio/renv/issues/1359 + ftype <- renv_file_type(path) + atype <- renv_archive_type(path) + ptype <- renv_package_type(path) + + unpack <- + ftype == "file" && + atype == "zip" && + ptype == "source" + + if (unpack) { + newpath <- renv_package_unpack(package, path, force = TRUE) + if (!identical(newpath, path)) { + path <- newpath + defer(unlink(path, recursive = TRUE)) + } + } + + # rename binary .zip files if necessary + rename <- + ftype == "file" && + atype == "zip" && + ptype == "binary" + + if (rename) { + regexps <- .standard_regexps() + fmt <- "^%s(?:_%s)?\\.zip$" + pattern <- sprintf(fmt, regexps$valid_package_name, regexps$valid_package_version) + if (!grepl(pattern, basename(path), perl = TRUE)) { + dir <- renv_scope_tempfile(package) + ensure_directory(dir) + newpath <- file.path(dir, paste(package, "zip", sep = ".")) + renv_file_copy(path, newpath) + path <- newpath + } + } + + # resolve default library path + library <- renv_libpaths_active() + + # validate that we have command line tools installed and + # available for e.g. macOS + if (renv_platform_macos() && renv_package_type(path) == "source") + renv_xcode_check() + + # perform platform-specific pre-install checks + renv_scope_install() + + # perform the install + # note that we need to supply '-l' below as otherwise the library paths + # could be changed by, for example, site-specific profiles + args <- c( + "--vanilla", + "CMD", "INSTALL", "--preclean", "--no-multiarch", "--with-keep.source", + r_cmd_install_option(package, "configure.args", TRUE), + r_cmd_install_option(package, "configure.vars", TRUE), + r_cmd_install_option(package, c("install.opts", "INSTALL_opts"), FALSE), + "-l", renv_shell_path(library), + ..., + renv_shell_path(path) + ) + + if (config$install.verbose()) { + + status <- r(args, stdout = "", stderr = "") + if (!identical(status, 0L)) + stopf("install of package '%s' failed", package) + + installpath <- file.path(library, package) + if (!file.exists(installpath)) { + fmt <- "install of package '%s' failed: %s does not exist" + stopf(fmt, package, renv_path_pretty(installpath)) + } + + installpath + + } else { + + output <- r(args, stdout = TRUE, stderr = TRUE) + status <- attr(output, "status") %||% 0L + if (!identical(status, 0L)) + r_exec_error(package, output, "install", status) + + installpath <- file.path(library, package) + if (!file.exists(installpath)) + r_exec_error(package, output, "install", installpath) + + installpath + + } + + +} + +r_cmd_build <- function(package, path, ...) { + + path <- renv_path_normalize(path, mustWork = TRUE) + args <- c("--vanilla", "CMD", "build", "--md5", ..., renv_shell_path(path)) + + output <- r(args, stdout = TRUE, stderr = TRUE) + status <- attr(output, "status") %||% 0L + if (!identical(status, 0L)) + r_exec_error(package, output, "build", status) + + pasted <- paste(output, collapse = "\n") + pattern <- "[*] building .([a-zA-Z0-9_.-]+)." + matches <- regexec(pattern, pasted) + text <- regmatches(pasted, matches) + + tarball <- text[[1L]][[2L]] + if (!file.exists(tarball)) + r_exec_error(package, output, "build", tarball) + + file.path(getwd(), tarball) + +} + +r_cmd_install_option <- function(package, options, configure) { + + # read option -- first, check for package-specific option, then + # fall back to 'global' option + for (option in options) { + value <- r_cmd_install_option_impl(package, option, configure) + if (!is.null(value)) + return(value) + } + +} + +r_cmd_install_option_impl <- function(package, option, configure) { + + value <- + getOption(paste(option, package, sep = ".")) %||% + getOption(option) + + if (is.null(value)) + return(NULL) + + # if the value is named, treat it as a list, + # mapping package names to their configure arguments + if (!is.null(names(value))) + value <- as.list(value) + + # check for named values + if (!is.null(names(value))) { + value <- value[[package]] + if (is.null(value)) + return(NULL) + } + + # if this is a configure option, format specially + if (configure) { + confkey <- sub(".", "-", option, fixed = TRUE) + confval <- if (!is.null(names(value))) + shQuote(paste(names(value), value, sep = "=", collapse = " ")) + else + shQuote(paste(value, collapse = " ")) + return(sprintf("--%s=%s", confkey, confval)) + } + + # otherwise, just paste it + paste(value, collapse = " ") + +} + +r_cmd_config <- function(...) { + + renv_system_exec( + command = R(), + args = c("--vanilla", "CMD", "config", ...), + action = "reading R CMD config" + ) + +} + + +# rebuild.R ------------------------------------------------------------------ + + +#' Rebuild the packages in your project library +#' +#' Rebuild and reinstall packages in your library. This can be useful as a +#' diagnostic tool -- for example, if you find that one or more of your +#' packages fail to load, and you want to ensure that you are starting from a +#' clean slate. +#' +#' @inherit renv-params +#' +#' @param packages The package(s) to be rebuilt. When `NULL`, all packages +#' in the library will be reinstalled. +#' +#' @param recursive Boolean; should dependencies of packages be rebuilt +#' recursively? Defaults to `TRUE`. +#' +#' @return A named list of package records which were installed by renv. +#' +#' @export +#' +#' @examples +#' \dontrun{ +#' +#' # rebuild the 'dplyr' package + all of its dependencies +#' renv::rebuild("dplyr", recursive = TRUE) +#' +#' # rebuild only 'dplyr' +#' renv::rebuild("dplyr", recursive = FALSE) +#' +#' } +rebuild <- function(packages = NULL, + recursive = TRUE, + ..., + type = NULL, + prompt = interactive(), + library = NULL, + project = NULL) +{ + renv_consent_check() + renv_scope_error_handler() + renv_dots_check(...) + + project <- renv_project_resolve(project) + renv_project_lock(project = project) + renv_scope_verbose_if(prompt) + + libpaths <- renv_libpaths_resolve(library) + library <- nth(libpaths, 1L) + + # get collection of packages currently installed + records <- renv_snapshot_libpaths(libpaths = libpaths, project = project) + packages <- setdiff(packages %||% names(records), "renv") + + # add in missing packages + for (package in packages) { + records[[package]] <- records[[package]] %||% + renv_available_packages_latest(package) + } + + # make sure records are named + names(records) <- map_chr(records, `[[`, "Package") + if (empty(records)) { + writef("- There are no packages currently installed -- nothing to rebuild.") + return(invisible(records)) + } + + + # apply any overrides + records <- renv_records_override(records) + + # notify the user + preamble <- if (recursive) + "The following package(s) and their dependencies will be reinstalled:" + else + "The following package(s) will be reinstalled:" + + renv_pretty_print_records(preamble, records[packages]) + cancel_if(prompt && !proceed()) + + # figure out rebuild parameter + rebuild <- if (recursive) NA else packages + + # perform the install + install( + packages = records[packages], + library = libpaths, + type = type, + rebuild = rebuild, + project = project + ) +} + + +# record.R ------------------------------------------------------------------- + + +#' Update package records in a lockfile +#' +#' Use `record()` to record a new entry within an existing renv lockfile. +#' +#' This function can be useful when you need to change one or more of the +#' package records within an renv lockfile -- for example, because a recorded +#' package cannot be restored in a particular environment, and you know of a +#' suitable alternative. +#' +#' # Records +#' +#' Records can be provided either using the **remotes** short-hand syntax, +#' or by using an \R list of entries to record within the lockfile. See +#' `?lockfiles` for more information on the structure of a package record. +#' +#' @inheritParams renv-params +#' +#' @param records A list of named records, mapping package names to a definition +#' of their source. See **Records** for more details. +#' +#' @example examples/examples-record.R +#' @export +record <- function(records, + lockfile = NULL, + project = NULL) +{ + renv_scope_error_handler() + + project <- renv_project_resolve(project) + renv_project_lock(project = project) + + lockfile <- lockfile %||% renv_lockfile_path(project) + + records <- case( + is.character(records) ~ lapply(records, renv_remotes_resolve, latest = TRUE), + is.list(records) ~ renv_records_resolve(records, latest = TRUE), + ~ stopf("unexpected records format '%s'", typeof(records)) + ) + + names(records) <- enum_chr(records, function(package, record) { + if (is.null(package) || is.na(package) || !nzchar(package)) + record[["Package"]] + else + package + }) + + if (is.list(lockfile)) + return(renv_lockfile_modify(lockfile, records)) + + if (!file.exists(lockfile)) { + fmt <- "no lockfile exists at path %s" + stopf(fmt, renv_path_pretty(lockfile)) + } + + old <- renv_lockfile_read(lockfile) + new <- renv_lockfile_modify(old, records) + + local({ + renv_scope_options(renv.verbose = FALSE) + renv_lockfile_write(new, lockfile) + }) + + n <- length(records) + fmt <- "- Updated %s in %s." + writef(fmt, nplural("record", n), renv_path_pretty(lockfile)) + + renv <- records[["renv"]] + if (!is.null(renv) && !is.null(renv[["Version"]])) { + renv_infrastructure_write_activate( + project = project, + version = renv[["Version"]] + ) + } + + invisible(lockfile) + +} + +renv_record_normalize <- function(record) { + + # normalize source + source <- record$Source %||% "unknown" + if (source %in% c("CRAN", "PPM", "RSPM")) + record$Source <- "Repository" + + # drop remotes from records with a repository source + if (identical(record$Source, "Repository") || + identical(record$RemoteType, "standard")) + record <- record[grep("^Remote", names(record), invert = TRUE)] + + # keep only specific records for comparison + remotes <- grep("^Remote", names(record), value = TRUE) + keep <- c("Package", "Version", "Source", remotes) + record <- record[intersect(names(record), keep)] + + # return normalized record + record + +} + + +# records.R ------------------------------------------------------------------ + + +renv_records_select <- function(records, actions, action) { + records <- renv_lockfile_records(records) + matching <- actions[actions %in% action] + keep(records, names(matching)) +} + +renv_records_sort <- function(records) { + records[csort(names(records))] +} + +renv_records_override <- function(records) { + enumerate(records, renv_options_override, scope = "renv.records") +} + +renv_record_names <- function(record, fields = NULL) { + fields <- fields %||% c("Package", "Version", "Source") + remotes <- grep("^Remote", names(record), value = TRUE) + nms <- c(fields, setdiff(remotes, "Remotes")) + renv_vector_intersect(nms, names(record)) +} + +renv_record_cacheable <- function(record) { + + # check if the record has been marked as cacheable + cacheable <- record$Cacheable %||% TRUE + if (identical(cacheable, FALSE)) + return(FALSE) + + # check for unknown source + source <- renv_record_source(record) + if (source == "unknown") + return(FALSE) + + # record is ok + TRUE + +} + +renv_record_source <- function(record, normalize = FALSE) { + + # if this appears to be a file path, then keep it as-is + source <- record$Source %||% "unknown" + if (grepl("[/\\]", source)) + return(source) + + # otherwise, try to normalize it + source <- tolower(record$Source %||% "unknown") + if (normalize) + source <- renv_record_source_normalize(record, source) + + source + +} + +renv_record_source_normalize <- function(record, source) { + + # normalize different types of git remotes + if (source %in% c("git2r", "xgit")) + source <- "git" + + # handle old lockfiles where 'source' was explicitly set as CRAN + if (source %in% c("cran")) + source <- "repository" + + # check for ad-hoc requests to install from bioc + if (identical(source, "repository")) { + repos <- record$Repository %||% "" + if (tolower(repos) %in% c("bioc", "bioconductor")) + source <- "bioconductor" + } + + # all done; return normalized source + source + +} + +renv_record_validate <- function(package, record) { + + # check for a record -- minimally, a list with a package name + if (is.list(record) && is.character(record$Package)) + return(record) + + # if we're running tests, or in CI, then report + if (renv_tests_running() || renv_envvar_exists("CI")) { + fmt <- "! Internal error: unexpected record for package '%s'" + writef(fmt, package) + print(record) + } + + # return record as-is + record + +} + +renv_record_format_remote <- function(record) { + + remotes <- c("RemoteUsername", "RemoteRepo") + if (all(remotes %in% names(record))) + return(renv_record_format_short_remote(record)) + + paste(record$Package, record$Version, sep = "@") + +} + +renv_record_format_short <- function(record, versioned = FALSE) { + + remotes <- c("RemoteUsername", "RemoteRepo") + if (all(remotes %in% names(record))) { + remote <- renv_record_format_short_remote(record) + if (versioned) + remote <- sprintf("%s [%s]", record$Version %||% "", remote) + return(remote) + } + + record$Version + +} + +renv_record_format_short_remote <- function(record) { + + text <- paste(record$RemoteUsername, record$RemoteRepo, sep = "/") + + subdir <- record$RemoteSubdir %||% "" + if (nzchar(subdir)) + text <- paste(text, subdir, sep = ":") + + if (!is.null(record$RemoteRef)) { + ref <- record$RemoteRef + if (!identical(ref, "master")) + text <- paste(text, record$RemoteRef, sep = "@") + } else if (!is.null(record$RemoteSha)) { + sha <- substring(record$RemoteSha, 1L, 8L) + text <- paste(text, sha, sep = "@") + } + + text + +} + +renv_record_format_pair <- function(lhs, rhs) { + + # check for install / remove + if (is.null(lhs)) + return(sprintf("[* -> %s]", renv_record_format_short(rhs))) + else if (is.null(rhs)) + return(sprintf("[%s -> *]", renv_record_format_short(lhs))) + + map <- list( + Source = "src", + Repository = "repo", + Version = "ver", + RemoteHost = "host", + RemoteUsername = "user", + RemoteRepo = "repo", + RemoteRef = "ref", + RemoteSha = "sha", + RemoteSubdir = "subdir" + ) + + fields <- names(map) + + # check to see which fields have changed between the two + diff <- map_lgl(fields, function(field) { + !identical(lhs[[field]], rhs[[field]]) + }) + + changed <- names(which(diff)) + + if (empty(changed)) { + fmt <- "[%s: unchanged]" + lhsf <- renv_record_format_short(lhs) + return(sprintf(fmt, lhsf)) + } + + # check for CRAN packages; in such cases, we typically want to ignore + # the Remote fields which might've been added by 'pak' or other tools + isrepo <- + nzchar(lhs$Version %||% "") && + nzchar(rhs$Version %||% "") && + nzchar(lhs$Repository %||% "") && + nzchar(rhs$Repository %||% "") && + identical(lhs$Repository, rhs$Repository) + + if (isrepo) { + fmt <- "[%s -> %s]" + lhsf <- renv_record_format_short(lhs) + rhsf <- renv_record_format_short(rhs) + return(sprintf(fmt, lhsf, rhsf)) + } + + # check for only sha changed + usesha <- + setequal(changed, "RemoteSha") || + setequal(changed, c("RemoteSha", "Version")) + + if (usesha) { + + user <- lhs$RemoteUsername %||% "*" + repo <- lhs$RemoteRepo %||% "*" + spec <- paste(user, repo, sep = "/") + + ref <- lhs$RemoteRef %||% "*" + if (!ref %in% c("master", "*")) + spec <- paste(spec, ref, sep = "@") + + fmt <- "[%s: %s -> %s]" + lsha <- substring(lhs$RemoteSha %||% "*", 1L, 8L) + rsha <- substring(rhs$RemoteSha %||% "*", 1L, 8L) + + return(sprintf(fmt, spec, lsha, rsha)) + + } + + # check for only source change + if (setequal(changed, "Source")) { + fmt <- "[%s: %s -> %s]" + ver <- lhs$Version %||% "*" + lhsf <- lhs$Source %||% "*" + rhsf <- rhs$Source %||% "*" + return(sprintf(fmt, ver, lhsf, rhsf)) + } + + # check only version changed + if (setequal(changed, "Version")) { + fmt <- "[%s -> %s]" + lhsf <- lhs$Version %||% "*" + rhsf <- rhs$Version %||% "*" + return(sprintf(fmt, lhsf, rhsf)) + } + + # if the source has changed, highlight that + if ("Source" %in% changed) { + fmt <- "[%s -> %s]" + lhsf <- renv_record_format_short(lhs) + rhsf <- renv_record_format_short(rhs) + return(sprintf(fmt, lhsf, rhsf)) + } + + # otherwise, report each diff individually + diffs <- map_chr(changed, function(field) { + + lhsf <- lhs[[field]] %||% "*" + rhsf <- rhs[[field]] %||% "*" + + if (field == "RemoteSha") { + lhsf <- substring(lhsf, 1L, 8L) + rhsf <- substring(rhsf, 1L, 8L) + } + + fmt <- "%s: %s -> %s" + sprintf(fmt, map[[field]], lhsf, rhsf) + }) + + sprintf("[%s]", paste(diffs, collapse = "; ")) + +} + +renv_records_equal <- function(lhs, rhs) { + + lhs <- reject(lhs, is.null) + rhs <- reject(rhs, is.null) + + nm <- setdiff(union(names(lhs), names(rhs)), "Hash") + identical(keep(lhs, nm), keep(rhs, nm)) + +} + +renv_records_resolve <- function(records, latest = FALSE) { + + enumerate(records, function(package, record) { + + # check for already-resolved records + if (is.null(record) || is.list(record)) + return(record) + + # check for version-only specifications and + # prepend the package name in such a case + pattern <- "^(?:[[:digit:]]+[.-]){1,}[[:digit:]]+$" + if (grepl(pattern, record)) + record <- paste(package, record, sep = "@") + + # resolve the record + renv_remotes_resolve(record, latest) + + }) + +} + + +# recurse.R ------------------------------------------------------------------ + + +recurse <- function(object, callback, ...) { + renv_recurse_impl(list(), object, callback, ...) +} + +renv_recurse_impl <- function(stack, object, callback, ...) { + + # ignore missing values + if (missing(object) || identical(object, quote(expr = ))) + return(FALSE) + + # push node on to stack + stack[[length(stack) + 1]] <- object + + # invoke callback + result <- callback(object, stack, ...) + if (is.call(result)) + object <- result + else if (identical(result, FALSE)) + return(FALSE) + + # recurse + if (is.recursive(object)) + for (i in seq_along(object)) + renv_recurse_impl(stack, object[[i]], callback, ...) + +} + + +# refresh.R ------------------------------------------------------------------ + + +#' Refresh the local cache of available packages +#' +#' Query the active R package repositories for available packages, and +#' update the in-memory cache of those packages. +#' +#' Note that \R also maintains its own on-disk cache of available packages, +#' which is used by `available.packages()`. Calling `refresh()` will force +#' an update of both types of caches. renv prefers using an in-memory +#' cache as on occasion the temporary directory can be slow to access (e.g. +#' when it is a mounted network filesystem). +#' +#' @return A list of package databases, invisibly -- one for each repository +#' currently active in the \R session. Note that this function is normally +#' called for its side effects. +#' +#' @export +#' +#' @examples +#' \dontrun{ +#' +#' # check available packages +#' db <- available.packages() +#' +#' # wait some time (suppose packages are uploaded / changed in this time) +#' Sys.sleep(5) +#' +#' # refresh the local available packages database +#' # (the old locally cached db will be removed) +#' db <- renv::refresh() +#' +#' } +refresh <- function() { + + pkgtype <- getOption("pkgType", default = "source") + + srcok <- pkgtype %in% c("both", "source") || + getOption("install.packages.check.source", default = "yes") %in% "yes" + + binok <- pkgtype %in% "both" || + grepl("binary", pkgtype, fixed = TRUE) + + list( + binary = if (binok) available_packages(type = "binary", limit = 0L), + source = if (srcok) available_packages(type = "source", limit = 0L) + ) + +} + + +# regexps.R ------------------------------------------------------------------ + + +renv_regexps_package_name <- function() { + paste0("^", .standard_regexps()$valid_package_name, "$") +} + +renv_regexps_package_version <- function() { + paste0("^", .standard_regexps()$valid_package_version, "$") +} + +renv_regexps_escape <- function(regexp) { + pattern <- "([\\-\\[\\]\\{\\}\\(\\)\\*\\+\\?\\.\\,\\\\\\^\\$\\|\\#\\s])" + gsub(pattern, "\\\\\\1", regexp, perl = TRUE) +} + +renv_regexps_join <- function(regexps, capture = TRUE) { + fmt <- if (capture) "(%s)" else "(?:%s)" + sprintf(fmt, paste(regexps, collapse = "|")) +} + + +# rehash.R ------------------------------------------------------------------- + + +#' Re-hash packages in the renv cache +#' +#' Re-hash packages in the renv cache, ensuring that any previously-cached +#' packages are copied to a new cache location appropriate for this version of +#' renv. This can be useful if the cache scheme has changed in a new version +#' of renv, but you'd like to preserve your previously-cached packages. +#' +#' Any packages which are re-hashed will retain links to the location of the +#' newly-hashed package, ensuring that prior installations of renv can still +#' function as expected. +#' +#' @inheritParams renv-params +#' +#' @export +rehash <- function(prompt = interactive(), ...) { + renv_scope_error_handler() + renv_dots_check(...) + renv_scope_verbose_if(prompt) + invisible(renv_rehash_impl(prompt)) +} + +renv_rehash_impl <- function(prompt) { + + # check for cache migration + oldcache <- renv_paths_cache(version = renv_cache_version_previous())[[1L]] + newcache <- renv_paths_cache(version = renv_cache_version())[[1L]] + if (file.exists(oldcache) && !file.exists(newcache)) + renv_rehash_cache(oldcache, prompt, renv_file_copy, "copied") + + # re-cache packages as necessary + renv_rehash_cache(newcache, prompt, renv_file_move, "moved") + +} + +renv_rehash_cache <- function(cache, prompt, action, label) { + + # re-compute package hashes + old <- renv_cache_list(cache = cache) + + printf("- Re-computing package hashes ... ") + new <- map_chr(old, renv_progress_callback(renv_cache_path, length(old))) + writef("Done!") + + changed <- which(old != new & file.exists(old) & !file.exists(new)) + if (empty(changed)) { + writef("- Your cache is already up-to-date -- nothing to do.") + return(TRUE) + } + + if (prompt) { + + fmt <- "%s [%s -> %s]" + packages <- basename(old)[changed] + oldhash <- renv_path_component(old[changed], 2L) + newhash <- renv_path_component(new[changed], 2L) + caution_bullets( + "The following packages will be re-cached:", + sprintf(fmt, format(packages), format(oldhash), format(newhash)), + sprintf("Packages will be %s to their new locations in the cache.", label) + ) + + cancel_if(prompt && !proceed()) + + } + + sources <- old[changed] + targets <- new[changed] + names(sources) <- targets + names(targets) <- sources + + printf("- Re-caching packages ... ") + enumerate(targets, renv_progress_callback(action, length(targets))) + writef("Done!") + + n <- length(targets) + fmt <- "Successfully re-cached %s." + writef(fmt, nplural("package", n)) + renv_cache_clean_empty() + + TRUE +} + + +# release.R ------------------------------------------------------------------ + + +renv_release_preflight <- function() { + + ok <- all( + renv_release_preflight_urlcheck() + ) + + if (!ok) + stop("one or more pre-flight release checks failed") + + ok + +} + +renv_release_preflight_urlcheck <- function() { + + # check for bad URLs + urlchecker <- renv_namespace_load("urlchecker") + result <- urlchecker$url_check() + + # report to user + print(result) + + # return success + nrow(result) == 0L + +} + + +# remotes.R ------------------------------------------------------------------ + + +#' Resolve a Remote +#' +#' Given a remote specification, resolve it into an renv package record that +#' can be used for download and installation (e.g. with [install]). +#' +#' @param spec A remote specification. This should be a string, conforming +#' to the Remotes specification as defined in +#' . +#' +remote <- function(spec) { + renv_scope_error_handler() + renv_remotes_resolve(spec) +} + +# take a short-form remotes spec, parse that into a remote, +# and generate a corresponding package record +renv_remotes_resolve <- function(spec, latest = FALSE) { + + # check for already-resolved specs + if (is.null(spec) || is.list(spec)) + return(spec) + + # remove a trailing slash + # https://github.com/rstudio/renv/issues/1135 + spec <- gsub("/+$", "", spec, perl = TRUE) + + # check for archive URLs -- this is a bit hacky + if (grepl("^(?:file|https?)://", spec)) { + for (suffix in c(".zip", ".tar.gz", ".tgz", "/tarball")) + if (endswith(spec, suffix)) + return(renv_remotes_resolve_url(spec, quiet = TRUE)) + } + + # remove github prefix + spec <- gsub("^https?://(?:www\\.)?github\\.com/", "", spec) + + # check for paths to existing local files + first <- substring(spec, 1L, 1L) + local <- first %in% c("~", "/", ".") || renv_path_absolute(spec) + + if (local) { + record <- catch(renv_remotes_resolve_path(spec)) + if (!inherits(record, "error")) + return(record) + } + + # define error handler (tag error with extra context when possible) + error <- function(e) { + + # build error message + fmt <- "failed to resolve remote '%s'" + prefix <- sprintf(fmt, spec) + message <- paste(prefix, e$message, sep = " -- ") + + # otherwise, propagate the error + stop(simpleError(message = message, call = e$call)) + + } + + # attempt the parse + withCallingHandlers( + renv_remotes_resolve_impl(spec, latest), + error = error + ) + +} + +renv_remotes_resolve_impl <- function(spec, latest = FALSE) { + + remote <- renv_remotes_parse(spec) + + # fixup for bioconductor + isbioc <- + identical(remote$type, "repository") && + identical(remote$repository, "bioc") + + if (isbioc) + remote$type <- "bioc" + + resolved <- switch( + remote$type, + bioc = renv_remotes_resolve_bioc(remote), + bitbucket = renv_remotes_resolve_bitbucket(remote), + gitlab = renv_remotes_resolve_gitlab(remote), + github = renv_remotes_resolve_github(remote), + repository = renv_remotes_resolve_repository(remote, latest), + git = renv_remotes_resolve_git(remote), + url = renv_remotes_resolve_url(remote$url, quiet = TRUE), + stopf("unknown remote type '%s'", remote$type %||% "") + ) + + # ensure that attributes on the record are preserved, but drop NULL entries + for (key in names(resolved)) + if (is.null(resolved[[key]])) + resolved[[key]] <- NULL + + resolved + +} + +renv_remotes_parse_impl <- function(spec, pattern, fields, perl = FALSE) { + + matches <- regexec(pattern, spec, perl = perl) + strings <- regmatches(spec, matches)[[1]] + if (empty(strings)) + stopf("'%s' is not a valid remote", spec) + + if (length(fields) != length(strings)) + stop("internal error: field length mismatch in renv_remotes_parse_impl") + + names(strings) <- fields + remote <- as.list(strings) + lapply(remote, function(item) if (nzchar(item)) item) + +} + +renv_remotes_parse_repos <- function(spec) { + + pattern <- paste0( + "^", # start + "(?:([^:]+)::)?", # optional repository name + "([[:alnum:].]+)", # package name + "(?:@([[:digit:]_.-]+))?", # optional package version + "$" + ) + + fields <- c("spec", "repository", "package", "version") + renv_remotes_parse_impl(spec, pattern, fields) + +} + +renv_remotes_parse_remote <- function(spec) { + + pattern <- paste0( + "^", + "(?:([[:alpha:]][[:alnum:].]*[[:alnum:]])=)?", # optional package name + "(?:([^@:]+)(?:@([^:]+))?::)?", # optional prefix, providing type + host + "([^/#@:]+)", # a username + "(?:/([^@#:]+))?", # a repository (allow sub-repositories) + "(?::([^@#:]+))?", # optional subdirectory + "(?:#([^@#:]+))?", # optional hash (e.g. pull request) + "(?:@([^@#:]+))?", # optional ref (e.g. branch or commit) + "$" + ) + + fields <- c( + "spec", "package", "type", + "host", "user", "repo", + "subdir", "pull", "ref" + ) + + remote <- renv_remotes_parse_impl(spec, pattern, fields) + if (!nzchar(remote$repo)) + stopf("'%s' is not a valid remote", spec) + + renv_remotes_parse_finalize(remote) + +} + +renv_remotes_parse_gitssh <- function(spec) { + + pattern <- paste0( + "^", + "(?:([[:alpha:]][[:alnum:].]*[[:alnum:]])=)?", # optional package name + "(?:(git)::)?", # optional git prefix + "(", # url start + "([^@]+)@", # user (typically, 'git') + "([^:]+):", # host + "([^:#@]+)", # the rest of the repo url + ")", # url end + "(?::([^@#:]+))?", # optional sub-directory + "(?:#([^@#:]+))?", # optional hash (e.g. pull request) + "(?:@([^@#:]+))?", # optional ref (e.g. branch or commit) + "$" + ) + + fields <- c( + "spec", "package", "type", "url", + "user", "host", "repo", + "subdir", "pull", "ref" + ) + + remote <- renv_remotes_parse_impl(spec, pattern, fields, perl = TRUE) + if (!nzchar(remote$repo)) + stopf("'%s' is not a valid remote", spec) + + remote$type <- remote$type %||% "git" + renv_remotes_parse_finalize(remote) + +} + +renv_remotes_parse_git <- function(spec) { + + hostpattern <- paste0( + "(", + "(?:(?:(?!-))(?:xn--|_{1,1})?[a-z0-9-]{0,61}[a-z0-9]{1,1}\\.)*", + "(?:xn--)?", + "(?:[a-z0-9][a-z0-9\\-]{0,60}|[a-z0-9-]{1,30}\\.[a-z]{2,})", + ")" + ) + + pattern <- paste0( + "^", + "(?:([[:alpha:]][[:alnum:].]*[[:alnum:]])=)?", # optional package name + "(?:(git)::)?", # optional git prefix + "(", # URL start + "(?:(https?|git|ssh)://)?", # protocol + "(?:([^@]+)@)?", # login (probably git) + hostpattern, # host + "[/:]([\\w_.-]+)", # a username + "(?:/([^@#:]+?))?", # a repository (allow sub-repositories) + "(?:\\.(git))?", # optional .git extension + ")", # URL end + "(?::([^@#:]+))?", # optional sub-directory + "(?:#([^@#:]+))?", # optional hash (e.g. pull request) + "(?:@([^@#:]+))?", # optional ref (e.g. branch or commit) + "$" + ) + + fields <- c( + "spec", "package", "type", + "url", "protocol", "login", "host", "user", "repo", "ext", + "subdir", "pull", "ref" + ) + + remote <- renv_remotes_parse_impl(spec, pattern, fields, perl = TRUE) + if (!nzchar(remote$repo)) + stopf("'%s' is not a valid remote", spec) + + # If type has not been found & repo looks like a git repo, set it as git + # (note that this parser also accepts entries which are not truly git + # references, so we try to "fix up" after the fact) + if ("git" %in% c(remote$login, remote$type, remote$ext, remote$protocol)) + remote$type <- tolower(remote$type %||% "git") + + renv_remotes_parse_finalize(remote) + +} + +# NOTE: to avoid ambiguity with git remote specs, we require URL +# remotes to begin with a 'url::' prefix +renv_remotes_parse_url <- function(spec) { + + pattern <- paste0( + "^", + "(?:([[:alpha:]][[:alnum:].]*[[:alnum:]])=)?", # optional package name + "(url)::", # type (required for URL remotes) + "((https?)://([^:]+))", # url, protocol, path + "(?::([^@#:]+))?", # optional subdir + "$" + ) + + fields <- c("spec", "package", "type", "url", "protocol", "path", "subdir") + remote <- renv_remotes_parse_impl(spec, pattern, fields, perl = TRUE) + if (!nzchar(remote$url)) + stopf("'%s' is not a valid remote", spec) + + renv_remotes_parse_finalize(remote) +} + +renv_remotes_parse_finalize <- function(remote) { + + # default remote type is github + remote$type <- tolower(remote$type %||% "github") + + # custom finalization for different remote types + case( + remote$type == "github" ~ renv_remotes_parse_finalize_github(remote), + TRUE ~ remote + ) + +} + +renv_remotes_parse_finalize_github <- function(remote) { + + # split repo spec into pieces + repo <- remote$repo %||% "" + parts <- strsplit(repo, "/", fixed = TRUE)[[1]] + if (length(parts) < 2) + return(remote) + + # form subdir from tail of repo + remote$repo <- paste(head(parts, n = 1L), collapse = "/") + remote$subdir <- paste(tail(parts, n = -1L), collapse = "/") + + # return modified remote + remote + +} + +renv_remotes_parse <- function(spec) { + + remote <- catch(renv_remotes_parse_repos(spec)) + if (!inherits(remote, "error")) { + remote$type <- "repository" + return(remote) + } + + remote <- catch(renv_remotes_parse_remote(spec)) + if (!inherits(remote, "error")) { + remote$type <- remote$type %||% "github" + return(remote) + } + + remote <- catch(renv_remotes_parse_gitssh(spec)) + if (!inherits(remote, "error")) { + remote$type <- remote$type %||% "git" + return(remote) + } + + remote <- catch(renv_remotes_parse_url(spec)) + if (!inherits(remote, "error")) { + remote$type <- remote$type %||% "url" + return(remote) + } + + remote <- catch(renv_remotes_parse_git(spec)) + if (!inherits(remote, "error")) { + remote$type <- remote$type %||% "git" + return(remote) + } + + stopf("failed to parse remote spec '%s'", spec) + +} + +renv_remotes_resolve_bioc_version <- function(version) { + + # initialize Bioconductor + renv_bioconductor_init() + BiocManager <- renv_scope_biocmanager() + + # handle versions like 'release' and 'devel' + versions <- BiocManager$.version_map() + row <- versions[versions$BiocStatus == version, ] + if (nrow(row)) + return(row$Bioc) + + # otherwise, use the default version + BiocManager$version() + +} + +renv_remotes_resolve_bioc_plain <- function(remote) { + + list( + Package = remote$package, + Version = remote$version, + Source = "Bioconductor" + ) + +} + +renv_remotes_resolve_bioc <- function(remote) { + + # if we parsed this as a repository remote, use that directly + if (!is.null(remote$package)) + return(renv_remotes_resolve_bioc_plain(remote)) + + # otherwise, this was parsed as a regular remote, declaring the package + # should be obtained from a particular Bioconductor release + package <- remote$repo + biocversion <- renv_remotes_resolve_bioc_version(remote$user) + biocrepos <- renv_bioconductor_repos(version = biocversion) + record <- renv_available_packages_latest(package, repos = biocrepos) + + # update fields + record$Source <- "Bioconductor" + record$Repository <- NULL + + # return the resolved record + record + +} + +renv_remotes_resolve_bitbucket <- function(remote) { + + user <- remote$user + repo <- remote$repo + subdir <- remote$subdir + ref <- remote$ref %||% getOption("renv.bitbucket.default_branch", "master") + + host <- remote$host %||% config$bitbucket.host() + + # scope authentication + renv_scope_auth(repo) + + # get commit sha for ref + fmt <- "%s/repositories/%s/%s/commit/%s" + origin <- renv_retrieve_origin(host) + url <- sprintf(fmt, origin, user, repo, ref) + + destfile <- renv_scope_tempfile("renv-bitbucket-") + download(url, destfile = destfile, type = "bitbucket", quiet = TRUE) + json <- renv_json_read(file = destfile) + sha <- json$hash + + # get DESCRIPTION file + fmt <- "%s/repositories/%s/%s/src/%s/DESCRIPTION" + origin <- renv_retrieve_origin(host) + url <- sprintf(fmt, origin, user, repo, ref) + + destfile <- renv_scope_tempfile("renv-description-") + download(url, destfile = destfile, type = "bitbucket", quiet = TRUE) + desc <- renv_dcf_read(destfile) + + list( + Package = desc$Package, + Version = desc$Version, + Source = "Bitbucket", + RemoteType = "bitbucket", + RemoteHost = host, + RemoteUsername = user, + RemoteRepo = repo, + RemoteSubdir = subdir, + RemoteRef = ref, + RemoteSha = sha + ) + +} + +renv_remotes_resolve_repository <- function(remote, latest) { + + package <- remote$package + if (package %in% renv_packages_base()) + return(renv_remotes_resolve_base(package)) + + version <- remote$version + repository <- remote$repository + + if (latest && is.null(version)) { + remote <- renv_available_packages_latest(package) + version <- remote$Version + } + + list( + Package = package, + Version = version, + Source = "Repository", + Repository = repository + ) + +} + +renv_remotes_resolve_base <- function(package) { + + list( + Package = package, + Version = renv_package_version(package), + Source = "R" + ) + +} + +renv_remotes_resolve_github_sha_pull <- function(host, user, repo, pull) { + + # scope authentication + renv_scope_auth(repo) + + # make request + fmt <- "%s/repos/%s/%s/pulls/%s" + origin <- renv_retrieve_origin(host) + url <- sprintf(fmt, origin, user, repo, pull) + jsonfile <- renv_scope_tempfile("renv-json-") + download(url, destfile = jsonfile, type = "github", quiet = TRUE) + + # read resulting JSON + json <- renv_json_read(jsonfile) + json$head$sha + +} + +renv_remotes_resolve_github_sha_ref <- function(host, user, repo, ref) { + + # scope authentication + renv_scope_auth(repo) + + # build url for github commits endpoint + fmt <- "%s/repos/%s/%s/commits/%s" + origin <- renv_retrieve_origin(host) + ref <- ref %||% getOption("renv.github.default_branch", default = "master") + url <- sprintf(fmt, origin, user, repo, ref %||% "master") + + # prepare headers + headers <- c(Accept = "application/vnd.github.sha") + + # make request to endpoint + shafile <- renv_scope_tempfile("renv-sha-") + download( + url, + destfile = shafile, + type = "github", + quiet = TRUE, + headers = headers + ) + + # read downloaded content + sha <- renv_file_read(shafile) + + # check for JSON response (in case our headers weren't sent) + if (nchar(sha) > 40L) { + json <- renv_json_read(text = sha) + sha <- json$sha + } + + sha + +} + +renv_remotes_resolve_github_modules <- function(host, user, repo, subdir, sha) { + + # form path to .gitmodules file + subdir <- subdir %||% "" + parts <- c( + if (nzchar(subdir)) URLencode(subdir), + ".gitmodules" + ) + + path <- paste(parts, collapse = "/") + + # scope authentication + renv_scope_auth(repo) + + # add headers + headers <- c(Accept = "application/vnd.github.raw") + + # get the file contents + fmt <- "%s/repos/%s/%s/contents/%s?ref=%s" + origin <- renv_retrieve_origin(host) + url <- sprintf(fmt, origin, user, repo, path, sha) + jsonfile <- renv_scope_tempfile("renv-json-") + status <- suppressWarnings( + catch( + download(url, destfile = jsonfile, type = "github", quiet = TRUE, headers = headers) + ) + ) + + # just return a status code whether or not submodules are included + !inherits(status, "error") + +} + +renv_remotes_resolve_github_description <- function(host, user, repo, subdir, sha) { + + # form DESCRIPTION path + subdir <- subdir %||% "" + parts <- c( + if (nzchar(subdir)) URLencode(subdir), + "DESCRIPTION" + ) + + descpath <- paste(parts, collapse = "/") + + # scope authentication + renv_scope_auth(repo) + + # add headers + headers <- c( + Accept = "application/vnd.github.raw", + renv_download_auth_github() + ) + + # get the DESCRIPTION contents + fmt <- "%s/repos/%s/%s/contents/%s?ref=%s" + origin <- renv_retrieve_origin(host) + url <- sprintf(fmt, origin, user, repo, descpath, sha) + destfile <- renv_scope_tempfile("renv-json-") + download(url, destfile = destfile, type = "github", quiet = TRUE, headers = headers) + + # try to read the file; detect JSON versus raw content in case + # headers were not sent for some reason + contents <- renv_file_read(destfile) + if (substring(contents, 1L, 1L) == "{") { + json <- renv_json_read(text = contents) + contents <- renv_base64_decode(json$content) + } + + # normalize newlines + contents <- gsub("\r\n", "\n", contents, fixed = TRUE) + + # read as DCF + renv_dcf_read(text = contents) + +} + +renv_remotes_resolve_github_ref <- function(host, user, repo) { + + tryCatch( + renv_remotes_resolve_github_ref_impl(host, user, repo), + error = function(e) { + warning(e) + getOption("renv.github.default_branch", default = "master") + } + ) + +} + +renv_remotes_resolve_github_ref_impl <- function(host, user, repo) { + + # scope authentication + renv_scope_auth(repo) + + # build url to repos endpoint + fmt <- "%s/repos/%s/%s" + origin <- renv_retrieve_origin(host) + url <- sprintf(fmt, origin, user, repo) + + # download JSON data at endpoint + jsonfile <- renv_scope_tempfile("renv-github-ref-", fileext = ".json") + download(url, destfile = jsonfile, type = "github", quiet = TRUE) + json <- renv_json_read(jsonfile) + + # read default branch + json$default_branch %||% getOption("renv.github.default_branch", default = "master") + +} + +renv_remotes_resolve_github <- function(remote) { + + # resolve the reference associated with this repository + host <- remote$host %||% config$github.host() + user <- remote$user + repo <- remote$repo + spec <- remote$spec + subdir <- remote$subdir + + # resolve ref + ref <- remote$ref %||% renv_remotes_resolve_github_ref(host, user, repo) + + # handle '*release' refs + if (identical(ref, "*release")) + ref <- renv_remotes_resolve_github_release(host, user, repo, spec) + + # resolve the sha associated with the ref / pull + pull <- remote$pull %||% "" + sha <- case( + nzchar(pull) ~ renv_remotes_resolve_github_sha_pull(host, user, repo, pull), + nzchar(ref) ~ renv_remotes_resolve_github_sha_ref(host, user, repo, ref) + ) + + # if an abbreviated sha was provided as the ref, expand it here + if (nzchar(ref) && startswith(sha, ref)) + ref <- sha + + # check whether the repository has a .gitmodules file; if so, then we'll have + # to use a plain 'git' client to retrieve the package + modules <- renv_remotes_resolve_github_modules(host, user, repo, subdir, sha) + url <- if (modules) { + origin <- fsub("api.github.com", "github.com", renv_retrieve_origin(host)) + parts <- c(origin, user, repo) + paste(parts, collapse = "/") + } + + # read DESCRIPTION + desc <- renv_remotes_resolve_github_description(host, user, repo, subdir, sha) + + list( + Package = desc$Package, + Version = desc$Version, + Source = if (modules) "git" else "GitHub", + RemoteType = if (modules) "git" else "github", + RemoteUrl = if (modules) url, + RemoteHost = host, + RemoteUsername = user, + RemoteRepo = repo, + RemoteSubdir = subdir, + RemoteRef = ref, + RemoteSha = sha + ) + +} + +renv_remotes_resolve_github_release <- function(host, user, repo, spec) { + + # scope authentication + renv_scope_auth(repo) + + # build url for github releases endpoint + fmt <- "%s/repos/%s/%s/releases?per_page=1" + origin <- renv_retrieve_origin(host) + url <- sprintf(fmt, origin, user, repo) + + # prepare headers + headers <- c(Accept = "application/vnd.github.raw+json") + + # make request to endpoint + releases <- renv_scope_tempfile("renv-releases-") + download( + url = url, + destfile = releases, + type = "github", + quiet = TRUE, + headers = headers + ) + + # get reference associated with this tag + json <- renv_json_read(releases) + if (empty(json)) { + fmt <- "could not find any releases associated with remote '%s'" + stopf(fmt, sub("[*]release$", "", spec)) + } + + json[[1L]][["tag_name"]] + +} + +renv_remotes_resolve_git <- function(remote) { + + package <- remote$package %||% basename(remote$repo) + url <- remote$url + subdir <- remote$subdir + + # handle git ref + pull <- remote$pull %||% "" + ref <- remote$ref %||% "" + + # resolve ref from pull if set + if (nzchar(pull)) + ref <- renv_remotes_resolve_git_pull(ref) + + record <- list( + Package = package, + Version = "", + Source = "git", + RemoteType = "git", + RemoteUrl = url, + RemoteSubdir = subdir, + RemoteRef = ref + ) + + desc <- renv_remotes_resolve_git_description(record) + + record$Package <- desc$Package + record$Version <- desc$Version + + record +} + + +renv_remotes_resolve_git_sha_ref <- function(record) { + + renv_git_preflight() + + origin <- record$RemoteUrl + ref <- record$RemoteRef %||% record$RemoteSha + args <- c("ls-remote", origin, ref) + + output <- local({ + renv_scope_auth(record) + renv_scope_git_auth() + renv_system_exec("git", args, "checking git remote") + }) + + if (empty(output)) + return("") + + # format of output is, for example: + # + # $ git ls-remote https://github.com/rstudio/renv refs/tags/0.14.0 + # 20ca74bdcc3c87848e5665effa2fc8ee8b039c69 refs/tags/0.14.0 + # + # take first line of output, split on tab character, and take leftmost entry + strsplit(output[[1L]], "\t", fixed = TRUE)[[1L]][[1L]] + +} + + +renv_remotes_resolve_git_description <- function(record) { + + path <- renv_scope_tempfile("renv-git-") + ensure_directory(path) + + # TODO: is there a cheaper way for us to accomplish this? + # it'd be nice if we could retrieve the contents of a single + # file, without needing to pull an entire repository branch + local({ + renv_scope_options(renv.verbose = FALSE) + renv_retrieve_git_impl(record, path) + }) + + # subdir may be NULL + subdir <- record$RemoteSubdir + desc <- renv_description_read(path, subdir = subdir) + + desc +} + +renv_remotes_resolve_git_pull <- function(pr) { + # to be able to checkout PR 760: + # git fetch origin pull/760/head:pr-760 + # or: + # git fetch origin pull/760/head:pull/760 + + # so format for ref is: + # pull/{ref_number}/head:pr-{ref_number} + fmt <- "pull/%s/head:pull/%s" + + remote_ref <- sprintf(fmt, pr, pr) + remote_ref +} + +renv_remotes_resolve_gitlab_ref <- function(host, user, repo) { + + tryCatch( + renv_remotes_resolve_gitlab_ref_impl(host, user, repo), + error = function(e) { + warning(e) + getOption("renv.gitlab.default_branch", default = "master") + } + ) + +} + +renv_remotes_resolve_gitlab_ref_impl <- function(host, user, repo) { + + # scope authentication + renv_scope_auth(repo) + + # get list of available branches + fmt <- "%s/api/v4/projects/%s/repository/branches" + origin <- renv_retrieve_origin(host) + id <- URLencode(paste(user, repo, sep = "/"), reserved = TRUE) + url <- sprintf(fmt, origin, id) + + destfile <- renv_scope_tempfile("renv-gitlab-commits-") + download(url, destfile = destfile, type = "gitlab", quiet = TRUE) + json <- renv_json_read(file = destfile) + + # iterate through and find the default + for (info in json) + if (identical(info$default, TRUE)) + return(info$name) + + # if no default was found, use master branch + # (for backwards compatibility with existing projects) + getOption("renv.gitlab.default_branch", default = "master") + +} + +renv_remotes_resolve_gitlab <- function(remote) { + + host <- remote$host %||% config$gitlab.host() + user <- remote$user + repo <- remote$repo + subdir <- remote$subdir %||% "" + + ref <- remote$ref %||% renv_remotes_resolve_gitlab_ref(host, user, repo) + + parts <- c(if (nzchar(subdir)) subdir, "DESCRIPTION") + descpath <- URLencode(paste(parts, collapse = "/"), reserved = TRUE) + + # scope authentication + renv_scope_auth(repo) + + # retrieve sha associated with this ref + fmt <- "%s/api/v4/projects/%s/repository/commits/%s" + origin <- renv_retrieve_origin(host) + id <- URLencode(paste(user, repo, sep = "/"), reserved = TRUE) + ref <- URLencode(ref, reserved = TRUE) + url <- sprintf(fmt, origin, id, ref) + + destfile <- renv_scope_tempfile("renv-gitlab-commits-") + download(url, destfile = destfile, type = "gitlab", quiet = TRUE) + json <- renv_json_read(file = destfile) + sha <- json$id + + # retrieve DESCRIPTION file + fmt <- "%s/api/v4/projects/%s/repository/files/%s/raw?ref=%s" + origin <- renv_retrieve_origin(host) + id <- URLencode(paste(user, repo, sep = "/"), reserved = TRUE) + url <- sprintf(fmt, origin, id, descpath, ref) + + destfile <- renv_scope_tempfile("renv-description-") + download(url, destfile = destfile, type = "gitlab", quiet = TRUE) + desc <- renv_dcf_read(destfile) + + list( + Package = desc$Package, + Version = desc$Version, + Source = "GitLab", + RemoteType = "gitlab", + RemoteHost = host, + RemoteUsername = user, + RemoteRepo = repo, + RemoteSubdir = subdir, + RemoteRef = ref, + RemoteSha = sha + ) + +} + +renv_remotes_resolve_url <- function(url, quiet = FALSE) { + + tempfile <- renv_scope_tempfile("renv-url-") + writeLines(url, con = tempfile) + hash <- tools::md5sum(tempfile) + + ext <- fileext(url, default = ".tar.gz") + name <- paste(hash, ext, sep = "") + path <- renv_paths_source("url", name) + + ensure_parent_directory(path) + download(url, path, quiet = quiet) + + desc <- renv_description_read(path) + + list( + Package = desc$Package, + Version = desc$Version, + Source = "URL", + RemoteType = "url", + RemoteUrl = url, + Path = path + ) + +} + +renv_remotes_resolve_path <- function(path) { + + # if this package lives within one of the cellar paths, + # then treat it as a cellar source + roots <- renv_cellar_roots() + for (root in roots) + if (renv_path_within(path, root)) + return(renv_remotes_resolve_path_cellar(path)) + + # first, check for a common extension + if (renv_archive_type(path) %in% c("tar", "zip")) + return(renv_remotes_resolve_path_impl(path)) + + # otherwise, if this is the path to a package project, use the sources as-is + if (renv_project_type(path) == "package") + return(renv_remotes_resolve_path_impl(path)) + + stopf("there is no package at path '%s'", path) + +} + +renv_remotes_resolve_path_cellar <- function(path) { + + desc <- renv_description_read(path) + list( + Package = desc$Package, + Version = desc$Version, + Source = "Cellar", + Cacheable = FALSE + ) + +} + +renv_remotes_resolve_path_impl <- function(path) { + + desc <- renv_description_read(path) + list( + Package = desc$Package, + Version = desc$Version, + Source = "Local", + RemoteType = "local", + RemoteUrl = path, + Cacheable = FALSE + ) + +} + + +# remove.R ------------------------------------------------------------------- + + +#' Remove packages +#' +#' Remove (uninstall) \R packages. +#' +#' @inherit renv-params +#' +#' @param packages A character vector of \R packages to remove. +#' @param library The library from which packages should be removed. When +#' `NULL`, the active library (that is, the first entry reported in +#' `.libPaths()`) is used instead. +#' +#' @return A vector of package records, describing the packages (if any) which +#' were successfully removed. +#' +#' @export +#' +#' @example examples/examples-init.R +remove <- function(packages, + ..., + library = NULL, + project = NULL) +{ + renv_scope_error_handler() + renv_dots_check(...) + + project <- renv_project_resolve(project) + renv_project_lock(project = project) + + library <- renv_path_normalize(library %||% renv_libpaths_active()) + + # NOTE: users might request that we remove packages which aren't currently + # installed, so we need to catch errors when trying to snapshot those packages + descpaths <- file.path(library, packages, "DESCRIPTION") + records <- lapply(descpaths, compose(catch, renv_snapshot_description)) + names(records) <- packages + records <- Filter(function(record) !inherits(record, "error"), records) + + if (library == renv_paths_library(project = project)) { + writef("- Removing package(s) from project library ...") + } else { + fmt <- "- Removing package(s) from library '%s' ..." + writef(fmt, renv_path_aliased(library)) + } + + if (length(packages) == 1) { + renv_remove_impl(packages, library) + return(invisible(records)) + } + + count <- 0 + for (package in packages) { + if (renv_remove_impl(package, library)) + count <- count + 1 + } + + writef("- Done! Removed %s.", nplural("package", count)) + invisible(records) +} + +renv_remove_impl <- function(package, library) { + + path <- file.path(library, package) + if (!renv_file_exists(path)) { + writef("- Package '%s' is not installed -- nothing to do.", package) + return(FALSE) + } + + recursive <- renv_file_type(path) == "directory" + printf("Removing package '%s' ... ", package) + unlink(path, recursive = recursive) + writef("Done!") + + TRUE + +} + + +# renv-package.R ------------------------------------------------------------- + + +#' Project-local Environments for R +#' +#' Project-local environments for \R. +#' +#' You can use renv to construct isolated, project-local \R libraries. +#' Each project using renv will share package installations from a global +#' cache of packages, helping to avoid wasting disk space on multiple +#' installations of a package that might otherwise be shared across projects. +#' +"_PACKAGE" + + +# renvignore.R --------------------------------------------------------------- + + +# given a path within a project, read all relevant ignore files +# and generate a pattern that can be used to filter file results +renv_renvignore_pattern <- function(path = getwd(), root = path) { + + if (is.null(root)) + return(NULL) + + stopifnot( + renv_path_absolute(path), + renv_path_absolute(root) + ) + + # prepare ignores + ignores <- stack() + + # read ignore files + parent <- path + while (parent != dirname(parent)) { + + # attempt to read either .renvignore or .gitignore + for (file in c(".renvignore", ".gitignore")) { + candidate <- file.path(parent, file) + if (file.exists(candidate)) { + contents <- readLines(candidate, warn = FALSE) + parsed <- renv_renvignore_parse(contents, parent) + if (length(parsed)) + ignores$push(parsed) + break + } + } + + # stop once we've hit the project root + if (parent == root) + break + + parent <- dirname(parent) + + } + + # collect patterns read + patterns <- ignores$data() + + # separate exclusions, exclusions + include <- unlist(extract(patterns, "include")) + exclude <- unlist(extract(patterns, "exclude")) + + # allow for inclusion / exclusion via option + # (primarily intended for internal use with packrat) + include <- c(include, renv_renvignore_pattern_extra("include", root)) + exclude <- c(exclude, renv_renvignore_pattern_extra("exclude", root)) + + # ignore hidden directories by default + exclude <- c("/[.][^/]*/$", exclude) + + list(include = include, exclude = exclude) + +} + +# reads a .gitignore / .renvignore file, and translates the associated +# entries into PCREs which can be combined and used during directory traversal +renv_renvignore_parse <- function(contents, prefix = "") { + + # read the ignore entries + contents <- grep("^\\s*(?:#|$)", contents, value = TRUE, invert = TRUE) + if (empty(contents)) + return(list()) + + # split into inclusion, exclusion patterns + negate <- substring(contents, 1L, 1L) == "!" + exclude <- contents[!negate] + include <- substring(contents[negate], 2L) + + # For include rules, if we're explicitly including a file within + # a sub-directory, then we need to force all parent directories + # to also be included. In other words, a rule like: + # + # !a/b/c + # + # needs to be implicitly treated like + # + # !/a + # !/a/b + # !/a/b/c + # + # so we perform that transformation here. + # + # Note that this isn't perfect; for example, with the .gitignore file + # + # dir + # !dir/matched + # + # The exclusion of 'dir' will take precedence, and dir/matched won't + # get a chance to apply. + include <- sort(unique(unlist(map(include, function(rule) { + idx <- gregexpr("(?:/|$)", rule, perl = TRUE)[[1L]] + gsub("^/*", "/", substring(rule, 1L, idx)) + })))) + + # parse patterns separately + list( + exclude = renv_renvignore_parse_impl(exclude, prefix), + include = renv_renvignore_parse_impl(include, prefix) + ) + +} + +renv_renvignore_parse_impl <- function(entries, prefix = "") { + + # check for empty entries list + if (empty(entries)) + return(character()) + + # remove trailing whitespace + entries <- gsub("\\s+$", "", entries) + + # entries without a slash (other than a trailing one) should match in tree + noslash <- grep("/", gsub("/*$", "", entries), fixed = TRUE, invert = TRUE) + entries[noslash] <- paste("**", entries[noslash], sep = "/") + + # remove a leading slash (avoid double-slashing) + entries <- gsub("^/+", "", entries) + + # save any '**' entries seen + entries <- gsub("**/", "\001", entries, fixed = TRUE) + entries <- gsub("/**", "\002", entries, fixed = TRUE) + + # transform '*' and '?' + entries <- gsub("*", "\\E[^/]*\\Q", entries, fixed = TRUE) + entries <- gsub("?", "\\E[^/]\\Q", entries, fixed = TRUE) + + # restore '**' entries + entries <- gsub("\001", "\\E(?:.*/)?\\Q", entries, fixed = TRUE) + entries <- gsub("\002", "/\\E.*\\Q", entries, fixed = TRUE) + + # if we don't have a trailing slash, then we can match both files and dirs + noslash <- grep("/$", entries, invert = TRUE) + entries[noslash] <- paste0(entries[noslash], "\\E(?:/)?\\Q") + + # enclose in \\Q \\E to ensure e.g. plain '.' are not treated + # as regex characters + entries <- sprintf("\\Q%s\\E$", entries) + + # prepend prefix + entries <- sprintf("^\\Q%s/\\E%s", prefix, entries) + + # remove \\Q\\E + entries <- gsub("\\Q\\E", "", entries, fixed = TRUE) + + # all done! + entries + +} + +renv_renvignore_exec <- function(path, root, children) { + + # the root directory is always included + if (identical(root, children)) + return(FALSE) + + # compute exclusion patterns + patterns <- renv_renvignore_pattern(path, root) + + # if we have no patterns, then we're not excluding anything + if (empty(patterns) || empty(patterns$exclude)) + return(logical(length(children))) + + # append slashes to files which are directories + info <- renv_file_info(children) + dirs <- info$isdir %in% TRUE + children[dirs] <- paste0(children[dirs], "/") + + # get the entries that need to be excluded + excludes <- logical(length = length(children)) + for (pattern in patterns$exclude) + if (nzchar(pattern)) + excludes <- excludes | grepl(pattern, children, perl = TRUE) + + if (length(patterns$include)) { + + # check for entries that should be explicitly included + # (note that these override any excludes) + includes <- logical(length = length(children)) + for (pattern in patterns$include) + if (nzchar(pattern)) + includes <- includes | grepl(pattern, children, perl = TRUE) + + # unset those excludes + excludes[includes] <- FALSE + + } + + # return vector of excludes + excludes + +} + +renv_renvignore_pattern_extra <- function(key, root) { + + # check for value from option + optname <- paste("renv.renvignore", key, sep = ".") + patterns <- getOption(optname) + if (is.null(patterns)) + return(NULL) + + # should we use the pattern as-is? + asis <- attr(patterns, "asis", exact = TRUE) + if (identical(asis, TRUE)) + return(patterns) + + # otherwise, process it as an .renvignore-style ignore + root <- attr(patterns, "root", exact = TRUE) %||% root + patterns <- renv_renvignore_parse(patterns, root) + patterns[[key]] + +} + + +# repair.R ------------------------------------------------------------------- + + +#' Repair a project +#' +#' Use `repair()` to recover from some common issues that can occur with +#' a project. Currently, two operations are performed: +#' +#' 1. Packages with broken symlinks into the cache will be re-installed. +#' +#' 2. Packages that were installed from sources, but appear to be from +#' an remote source (e.g. GitHub), will have their `DESCRIPTION` files +#' updated to record that remote source explicitly. +#' +#' @inheritParams renv-params +#' +#' @param lockfile The path to a lockfile (if any). When available, renv +#' will use the lockfile when attempting to infer the remote associated +#' with the inaccessible version of each missing package. When `NULL` +#' (the default), the project lockfile will be used. +#' +#' @export +repair <- function(library = NULL, + lockfile = NULL, + project = NULL) +{ + renv_consent_check() + renv_scope_error_handler() + + project <- renv_project_resolve(project) + renv_project_lock(project = project) + + libpaths <- renv_path_normalize(library %||% renv_libpaths_all()) + library <- libpaths[[1L]] + + writef(header("Library cache links")) + renv_repair_links(library, lockfile, project) + writef() + + writef(header("Package sources")) + renv_repair_sources(library, lockfile, project) + writef() + + invisible() +} + +renv_repair_links <- function(library, lockfile, project) { + + + # figure out which library paths (junction points?) appear to be broken + paths <- list.files(library, full.names = TRUE) + broken <- renv_file_broken(paths) + packages <- basename(paths[broken]) + if (empty(packages)) { + writef("- No issues found with the project library's cache links.") + return(invisible(packages)) + } + + # try to find records for these packages in the lockfile + # TODO: what if one of the requested packages isn't in the lockfile? + lockfile <- lockfile %||% renv_lockfile_load(project = project) + records <- renv_repair_records(packages, lockfile, project) + + # install these records + install( + packages = records, + library = library, + project = project + ) + +} + +renv_repair_records <- function(packages, lockfile, project) { + map(packages, function(package) { + lockfile$Packages[[package]] %||% package + }) +} + +renv_repair_sources <- function(library, lockfile, project) { + + # get package description files + db <- installed_packages(lib.loc = library, priority = NA_character_) + descpaths <- with(db, file.path(LibPath, Package, "DESCRIPTION")) + dcfs <- map(descpaths, renv_description_read) + names(dcfs) <- map_chr(dcfs, `[[`, "Package") + + # try to infer sources as necessary + inferred <- map(dcfs, renv_repair_sources_infer) + inferred <- filter(inferred, Negate(is.null)) + if (length(inferred) == 0L) { + writef("- All installed packages appear to be from a known source.") + return(TRUE) + } + + # ask used + renv_scope_options(renv.verbose = TRUE) + caution_bullets( + c( + "The following package(s) do not have an explicitly-declared remote source.", + "However, renv was available to infer remote sources from their DESCRIPTION file." + ), + sprintf("%s [%s]", format(names(inferred)), inferred), + "`renv::restore()` may fail for packages without an explicitly-declared remote source." + ) + + choice <- menu( + + choices = c( + update = "Let renv infer the remote sources for these packages.", + cancel = "Do nothing and resolve the situation another way." + ), + + title = "What would you like to do?" + + ) + + cancel_if(identical(choice, "cancel")) + + enumerate(inferred, function(package, remote) { + record <- renv_remotes_resolve(remote) + record[["RemoteSha"]] <- NULL + renv_package_augment(file.path(library, package), record) + }) + + n <- length(inferred) + writef("- Updated %i package DESCRIPTION %s.", n, nplural("file", n)) + + TRUE + +} + +renv_repair_sources_infer <- function(dcf) { + + # if this package appears to have a declared remote, use as-is + for (field in c("RemoteType", "Repository", "biocViews")) + if (!is.null(dcf[[field]])) + return(NULL) + + # ok, this is a package installed from sources that "looks" like + # the development version of a package; try to guess its remote + guess <- function(pattern, field) { + urls <- strsplit(dcf[[field]] %||% "", "\\s*,\\s*")[[1L]] + for (url in urls) { + matches <- regmatches(url, regexec(pattern, url, perl = TRUE))[[1L]] + if (length(matches) == 3L) + return(paste(matches[[2L]], matches[[3L]], sep = "/")) + } + } + + # first, check bug reports + remote <- guess("^https://(?:www\\.)?github\\.com/([^/]+)/([^/]+)/issues$", "BugReports") + if (!is.null(remote)) + return(remote) + + # next, check the URL field + remote <- guess("^https://(?:www\\.)?github\\.com/([^/]+)/([^/]+)", "URL") + if (!is.null(remote)) + return(remote) + +} + + +# report.R ------------------------------------------------------------------- + + +renv_report_ok <- function(message, elapsed = 0) { + + # treat 'quick' times specially + if (!testing() && elapsed < 0.1) + return(writef("OK [%s]", message)) + + # otherwise, report step with elapsed time + fmt <- "OK [%s in %s]" + writef(fmt, message, renv_difftime_format_short(elapsed)) + +} + + +# repos.R -------------------------------------------------------------------- + + +renv_repos_normalize <- function(repos = getOption("repos")) { + + # ensure repos are a character vector + repos <- convert(repos, "character") + + # force a CRAN mirror when needed + cran <- getOption("renv.repos.cran", "https://cloud.r-project.org") + repos[repos == "@CRAN@"] <- cran + + # if repos is length 1 but has no names, then assume it's CRAN + nms <- names(repos) %||% rep.int("", length(repos)) + if (identical(nms, "")) + nms <- names(repos) <- "CRAN" + + # ensure all values are named + unnamed <- !nzchar(nms) + if (any(unnamed)) { + nms[unnamed] <- paste0("V", seq_len(sum(unnamed))) + names(repos) <- nms + } + + # return normalized repository + repos + +} + +renv_repos_validate <- function(repos = getOption("repos")) { + + # allow empty repository explicitly + if (empty(repos)) + return(character()) + + # otherwise, ensure it's a named list or character vector + ok <- is.list(repos) || is.character(repos) + if (!ok) + stopf("repos has unexpected type '%s'", typeof(repos)) + + # read repository names + nm <- names(repos) %||% rep.int("", length(repos)) + if (any(nm %in% "")) { + + # if this is a length-one repository, assume it's CRAN + if (length(repos) == 1L) { + repos <- c(CRAN = repos) + return(renv_repos_normalize(repos)) + } + + # otherwise, error + stopf("all repository entries must be named") + + } + + # normalize the repos option + renv_repos_normalize(repos) + +} + +renv_repos_info <- function(url) { + + memoize( + key = url, + value = renv_repos_info_impl(url) + ) + +} + +renv_repos_info_impl <- function(url) { + + # make sure the repository URL includes a trailing slash + url <- gsub("/*$", "/", url) + + # if this is a file repository, return early + if (grepl("^file:", url)) + return(list(nexus = FALSE)) + + # try to download it + destfile <- renv_scope_tempfile("renv-repos-") + status <- catch(download(url, destfile = destfile, quiet = TRUE)) + if (inherits(status, "error")) + return(status) + + # read the contents of the page + contents <- renv_file_read(destfile) + + # determine if this is a Nexus repository + nexus <- + grepl("Nexus Repository Manager", contents, fixed = TRUE) || + grepl("
", contents, fixed = TRUE) + + list( + nexus = nexus + ) + +} + + +# restart.R ------------------------------------------------------------------ + + +# whether or not we're already trying to restart the session +the$restarting <- FALSE + +renv_restart_request <- function(project = NULL, reason = "", ...) { + + project <- renv_project_resolve(project) + + # if we're running in RStudio, explicitly open the project + # if it differs from the current project + if (renv_rstudio_available()) { + status <- renv_restart_request_rstudio(project, reason, ...) + return(invisible(status)) + } + + renv_restart_request_default(project, reason, ...) + +} + +renv_restart_request_default <- function(project, reason, ...) { + + # use 'restart' helper defined by front-end (if any) + restart <- getOption("restart") + if (is.function(restart)) + return(renv_restart_invoke(restart)) + + # otherwise, ask the user to restart + if (interactive()) { + fmt <- "- %s -- please restart the R session." + writef(fmt, sprintf(reason, ...)) + } + +} + +renv_restart_request_rstudio <- function(project, reason, ...) { + + # if we're running tests, don't restart + if (renv_tests_running()) + return(renv_restart_request_default(project, reason, ...)) + + # if we don't have a tools env, bail + tools <- catch(as.environment("tools:rstudio")) + if (inherits(tools, "error")) + return(renv_restart_request_default(project, reason, ...)) + + # if RStudio is too old, use default restart impl + old <- + is.null(tools$.rs.getProjectDirectory) || + is.null(tools$.rs.api.openProject) + + if (old) + return(renv_restart_request_default(project, reason, ...)) + + # if the requested project matches the current project, just + # restart the R session -- but note that we cannot respect + # the 'restart' option here as the version RStudio uses + # tries to preserve session state that we need to change. + # + # https://github.com/rstudio/renv/issues/1530 + projdir <- tools$.rs.getProjectDirectory() %||% "" + if (renv_file_same(projdir, project)) { + restart <- getOption("renv.restart.function", default = function() { + tools$.rs.api.executeCommand("restartR", quiet = TRUE) + }) + return(renv_restart_invoke(restart)) + } + + # otherwise, explicitly open the new project + renv_restart_invoke(function() { + invisible(tools$.rs.api.openProject(project, newSession = FALSE)) + }) + +} + +renv_restart_invoke <- function(callback) { + + # avoid multiple attempts to restart in a single call, just in case + if (!the$restarting) { + the$restarting <- TRUE + callback() + } + +} + + +# restore.R ------------------------------------------------------------------ + + +the$restore_running <- FALSE +the$restore_state <- NULL + +#' Restore project library from a lockfile +#' +#' Restore a project's dependencies from a lockfile, as previously generated by +#' [snapshot()]. `renv::restore()` compares packages recorded in the lockfile to +#' the packages installed in the project library. Where there are differences +#' it resolves them by installing the lockfile-recorded package into the +#' project library. If `clean = TRUE`, `restore()` will additionally delete any +#' packages in the project library that don't appear in the lockfile. +#' +#' @inherit renv-params +#' +#' @param library The library paths to be used during restore. See **Library** +#' for details. +#' +#' @param packages A subset of packages recorded in the lockfile to restore. +#' When `NULL` (the default), all packages available in the lockfile will be +#' restored. Any required recursive dependencies of the requested packages +#' will be restored as well. +#' +#' @param exclude A subset of packages to be excluded during restore. This can +#' be useful for when you'd like to restore all but a subset of packages from +#' a lockfile. Note that if you attempt to exclude a package which is required +#' as the recursive dependency of another package, your request will be +#' ignored. +#' +#' @return A named list of package records which were installed by renv. +#' +#' @family reproducibility +#' +#' @export +#' +#' @example examples/examples-init.R +restore <- function(project = NULL, + ..., + library = NULL, + lockfile = NULL, + packages = NULL, + exclude = NULL, + rebuild = FALSE, + repos = NULL, + clean = FALSE, + prompt = interactive()) +{ + renv_consent_check() + renv_scope_error_handler() + renv_dots_check(...) + + renv_scope_binding(the, "restore_running", TRUE) + + project <- renv_project_resolve(project) + renv_project_lock(project = project) + renv_scope_verbose_if(prompt) + + # resolve library, lockfile arguments + libpaths <- renv_libpaths_resolve(library) + lockfile <- lockfile %||% renv_lockfile_load(project = project, strict = TRUE) + + # check and ask user if they need to activate first + renv_activate_prompt("restore", library, prompt, project) + + # activate the requested library (place at front of library paths) + library <- nth(libpaths, 1L) + ensure_directory(library) + renv_scope_libpaths(libpaths) + + # resolve the lockfile + if (is.character(lockfile)) + lockfile <- renv_lockfile_read(lockfile) + + # inject overrides (if any) + lockfile <- renv_lockfile_override(lockfile) + + # repair potential issues in the lockfile + lockfile <- renv_lockfile_repair(lockfile) + + # override repositories if requested + repos <- repos %||% config$repos.override() %||% lockfile$R$Repositories + + # transform PPM repositories if appropriate + if (renv_ppm_enabled()) + repos <- renv_ppm_transform(repos) + + if (length(repos)) + renv_scope_options(repos = convert(repos, "character")) + + # if users have requested the use of pak, delegate there + if (config$pak.enabled() && !recursing()) { + renv_pak_init() + renv_pak_restore( + lockfile = lockfile, + packages = packages, + exclude = exclude, + project = project + ) + } + + # set up Bioconductor version + repositories + biocversion <- lockfile$Bioconductor$Version + if (!is.null(biocversion)) { + renv_bioconductor_init(library = library) + biocversion <- package_version(biocversion) + renv_scope_options(renv.bioconductor.version = biocversion) + } + + # get records for R packages currently installed + current <- snapshot(project = project, + library = libpaths, + lockfile = NULL, + type = "all") + + # compare lockfile vs. currently-installed packages + diff <- renv_lockfile_diff_packages(current, lockfile) + + # don't remove packages unless 'clean = TRUE' + diff <- renv_vector_diff(diff, if (!clean) "remove") + + # only remove packages from the project library + is_package <- map_lgl(names(diff), function(package) { + path <- find.package(package, lib.loc = libpaths, quiet = TRUE) + identical(dirname(path), library) + }) + diff <- diff[!(diff == "remove" & !is_package)] + + # don't take any actions with ignored packages + ignored <- renv_project_ignored_packages(project = project) + diff <- diff[renv_vector_diff(names(diff), ignored)] + + # only take action with requested packages + packages <- setdiff(packages %||% names(diff), exclude) + diff <- diff[intersect(names(diff), packages)] + + if (!length(diff)) { + name <- if (!missing(library)) "library" else "project" + writef("- The %s is already synchronized with the lockfile.", name) + return(renv_restore_successful(diff, prompt, project)) + } + + # TODO: should we avoid double-prompting here? + # we prompt once here for the preflight check, and then again below based + # on the actions we'll perform. + if (!renv_restore_preflight(project, libpaths, diff, current, lockfile)) + cancel_if(prompt && !proceed()) + + if (prompt || renv_verbose()) { + renv_restore_report_actions(diff, current, lockfile) + cancel_if(prompt && !proceed()) + } + + # perform the restore + records <- renv_restore_run_actions(project, diff, current, lockfile, rebuild) + renv_restore_successful(records, prompt, project) +} + +renv_restore_run_actions <- function(project, actions, current, lockfile, rebuild) { + + packages <- names(actions) + + renv_scope_restore( + project = project, + library = renv_libpaths_active(), + records = renv_lockfile_records(lockfile), + packages = packages, + rebuild = rebuild + ) + + # first, handle package removals + removes <- actions[actions == "remove"] + enumerate(removes, function(package, action) { + renv_restore_remove(project, package, current) + }) + + # next, handle installs + installs <- actions[actions != "remove"] + packages <- names(installs) + + # perform the install + records <- retrieve(packages) + renv_install_impl(records) + + # detect dependency tree repair + diff <- renv_lockfile_diff_packages(renv_lockfile_records(lockfile), records) + diff <- diff[diff != "remove"] + if (!empty(diff)) { + renv_pretty_print_records( + "The dependency tree was repaired during package installation:", + records[names(diff)], + "Call `renv::snapshot()` to capture these dependencies in the lockfile." + ) + } + + # check installed packages and prompt for reload if needed + renv_install_postamble(names(records)) + + # return status + invisible(records) + +} + +renv_restore_state <- function(key = NULL) { + state <- the$restore_state + if (is.null(key)) state else state[[key]] +} + +renv_restore_begin <- function(project = NULL, + library = NULL, + records = NULL, + packages = NULL, + handler = NULL, + rebuild = NULL, + recursive = TRUE) +{ + # resolve rebuild request + rebuild <- case( + identical(rebuild, TRUE) ~ packages, + identical(rebuild, FALSE) ~ character(), + identical(rebuild, "*") ~ NA_character_, + as.character(rebuild) + ) + + # get previous restore state (so we can restore it after if needed) + oldstate <- the$restore_state + + # set new restore state + the$restore_state <- env( + + # the active project (if any) used for restore + project = project, + + # the library path into which packages will be installed. + # this is set because some behaviors depend on whether the target + # library is the project library, but during staged installs the + # library paths might be mutated during restore + library = library, + + # the package records used for restore, providing information + # on the packages to be installed (their version, source, etc) + records = records, + + # the set of packages to be installed in this restore session; + # as explicitly requested by the user / front-end API call. + # packages in this list should be re-installed even if a compatible + # version appears to be already installed + packages = packages, + + # an optional handler, to be used during retrieve / restore + # TODO: should we split this into separate handlers? + handler = handler %||% function(package, action) action, + + # packages which should be rebuilt (skipping the cache) + rebuild = rebuild, + + # should package dependencies be crawled recursively? this is useful if + # the records list is incomplete and needs to be built as packages are + # downloaded + recursive = recursive, + + # packages which we have attempted to retrieve + retrieved = new.env(parent = emptyenv()), + + # packages which need to be installed + install = stack(), + + # a collection of the requirements imposed on dependent packages + # as they are discovered + requirements = new.env(parent = emptyenv()), + + # the number of packages that were downloaded + downloaded = 0L + + ) + + # return prior state + oldstate + +} + +renv_restore_end <- function(state) { + the$restore_state <- state +} + +# nocov start + +renv_restore_report_actions <- function(actions, current, lockfile) { + + if (!renv_verbose() || empty(actions)) + return(invisible(NULL)) + + lhs <- renv_lockfile_records(current) + rhs <- renv_lockfile_records(lockfile) + renv_pretty_print_records_pair( + "The following package(s) will be updated:", + lhs[names(lhs) %in% names(actions)], + rhs[names(rhs) %in% names(actions)] + ) + +} + +# nocov end + +renv_restore_remove <- function(project, package, lockfile) { + records <- renv_lockfile_records(lockfile) + record <- records[[package]] + printf("- Removing %s [%s] ... ", package, record$Version) + paths <- renv_paths_library(project = project, package) + recursive <- renv_file_type(paths) == "directory" + unlink(paths, recursive = recursive) + writef("OK [removed from library]") + TRUE +} + +renv_restore_preflight <- function(project, libpaths, actions, current, lockfile) { + records <- renv_lockfile_records(lockfile) + matching <- keep(records, names(actions)) + renv_install_preflight(project, libpaths, matching) +} + +renv_restore_find <- function(package, record) { + + # skip packages whose installation was explicitly requested + state <- renv_restore_state() + record <- renv_record_validate(package, record) + if (package %in% state$packages) + return("") + + # check the active library paths to see if this package is already installed + for (library in renv_libpaths_all()) { + path <- renv_restore_find_impl(package, record, library) + if (nzchar(path)) + return(path) + } + + "" + +} + +renv_restore_find_impl <- function(package, record, library) { + + path <- file.path(library, package) + if (!file.exists(path)) + return("") + + # attempt to read DESCRIPTION + current <- catch(as.list(renv_description_read(path))) + if (inherits(current, "error")) + return("") + + # check for an up-to-date version from R package repository + if (renv_record_source(record) %in% c("cran", "repository")) { + fields <- c("Package", "Version") + if (identical(record[fields], current[fields])) + return(path) + } + + # otherwise, match on remote fields + fields <- renv_record_names(record, c("Package", "Version")) + if (identical(record[fields], current[fields])) + return(path) + + # failed to match; return empty path + "" + +} + +renv_restore_rebuild_required <- function(record) { + state <- renv_restore_state() + any(c(NA_character_, record$Package) %in% state$rebuild) +} + +renv_restore_successful <- function(records, prompt, project) { + + # ensure the activate script is up-to-date + renv_infrastructure_write_activate(project, create = FALSE) + + # perform python-related restore steps + renv_python_restore(project, prompt) + + # return restored records + invisible(records) + +} + + +# retrieve.R ----------------------------------------------------------------- + + +the$repos_archive <- new.env(parent = emptyenv()) + +# this routine retrieves a package + its dependencies, and as a side +# effect populates the restore state's `retrieved` member with a +# list of package records which can later be used for install +retrieve <- function(packages) { + + # confirm that we have restore state set up + state <- renv_restore_state() + if (is.null(state)) + stopf("renv_restore_begin() must be called first") + + # normalize repositories (ensure @CRAN@ is resolved) + options(repos = renv_repos_normalize()) + + # transform repository URLs for PPM + if (renv_ppm_enabled()) { + repos <- getOption("repos") + renv_scope_options(repos = renv_ppm_transform(repos)) + } + + # ensure HTTPUserAgent is set (required for PPM binaries) + agent <- renv_http_useragent() + if (!grepl("renv", agent)) { + renv <- sprintf("renv (%s)", renv_metadata_version()) + agent <- paste(renv, agent, sep = "; ") + } + renv_scope_options(HTTPUserAgent = agent) + + before <- Sys.time() + handler <- state$handler + for (package in packages) + handler(package, renv_retrieve_impl(package)) + after <- Sys.time() + + state <- renv_restore_state() + count <- state$downloaded + if (count) { + elapsed <- difftime(after, before, units = "secs") + writef("Successfully downloaded %s in %s.", nplural("package", count), renv_difftime_format(elapsed)) + writef("") + } + + data <- state$install$data() + names(data) <- extract_chr(data, "Package") + data + +} + +renv_retrieve_impl <- function(package) { + + # skip packages with 'base' priority + if (package %in% renv_packages_base()) + return() + + # if we've already attempted retrieval of this package, skip + state <- renv_restore_state() + if (visited(package, envir = state$retrieved)) + return() + + # extract record for package + records <- state$records + record <- records[[package]] %||% renv_retrieve_resolve(package) + + # normalize the record source + source <- renv_record_source(record, normalize = TRUE) + + # don't install packages from incompatible OS + ostype <- tolower(record[["OS_type"]] %||% "") + + skip <- + renv_platform_unix() && identical(ostype, "windows") || + renv_platform_windows() && identical(ostype, "unix") + + if (skip) + return() + + # if this is a package from Bioconductor, activate those repositories now + if (source %in% c("bioconductor")) { + project <- renv_restore_state(key = "project") + renv_scope_bioconductor(project = project) + } + + # if this is a package from R-Forge, activate its repository + if (source %in% c("repository")) { + repository <- record$Repository %||% "" + if (tolower(repository) %in% c("rforge", "r-forge")) { + repos <- getOption("repos") + if (!"R-Forge" %in% names(repos)) { + repos[["R-Forge"]] <- "https://R-Forge.R-project.org" + renv_scope_options(repos = repos) + } + } + } + + # if the record doesn't declare the package version, + # treat it as a request for the latest version on CRAN + # TODO: should make this behavior configurable + uselatest <- + source %in% c("repository", "bioconductor") && + is.null(record$Version) + + if (uselatest) { + record <- withCallingHandlers( + renv_available_packages_latest(package), + error = function(err) stopf("package '%s' is not available", package) + ) + } + + # if the requested record is incompatible with the set + # of requested package versions thus far, request the + # latest version on the R package repositories + # + # TODO: handle more explicit dependency requirements + # TODO: report to the user if they have explicitly requested + # installation of this package version despite it being incompatible + compat <- renv_retrieve_incompatible(package, record) + if (NROW(compat)) { + + # get the latest available package version + replacement <- renv_available_packages_latest(package) + if (is.null(replacement)) + stopf("package '%s' is not available", package) + + # if it's not compatible, then we might need to try again with + # a source version (assuming type = "both") + pkgtype <- getOption("pkgType") + if (identical(pkgtype, "both")) { + iscompat <- renv_retrieve_incompatible(package, replacement) + if (NROW(iscompat)) { + replacement <- renv_available_packages_latest(package, type = "source") + } + } + + # report if we couldn't find a compatible package + renv_retrieve_incompatible_report(package, record, replacement, compat) + record <- replacement + + } + + if (!renv_restore_rebuild_required(record)) { + + # if we have an installed package matching the requested record, finish early + path <- renv_restore_find(package, record) + if (file.exists(path)) { + install <- !dirname(path) %in% renv_libpaths_all() + return(renv_retrieve_successful(record, path, install = install)) + } + + # if the requested record already exists in the cache, + # we'll use that package for install + cacheable <- + renv_cache_config_enabled(project = state$project) && + renv_record_cacheable(record) + + if (cacheable) { + + # try to find the record in the cache + path <- renv_cache_find(record) + if (nzchar(path) && renv_cache_package_validate(path)) + return(renv_retrieve_successful(record, path)) + } + + } + + # if this is a URL source, then it should already have a local path + # check for the Path and Source fields and see if they resolve + fields <- c("Path", "Source") + for (field in fields) { + + # check for a valid field + path <- record[[field]] + if (is.null(path)) + next + + # check whether it looks like an explicit source + isurl <- + is.character(path) && + nzchar(path) && + grepl("[/\\]|[.](?:zip|tgz|gz)$", path) + + if (!isurl) + next + + # error if the field is declared but doesn't exist + if (!file.exists(path)) { + fmt <- "record for package '%s' declares local source '%s', but that file does not exist" + stopf(fmt, record$Package, path) + } + + # otherwise, success + path <- renv_path_normalize(path, mustWork = TRUE) + return(renv_retrieve_successful(record, path)) + + } + + if (!renv_restore_rebuild_required(record)) { + + # try some early shortcut methods + shortcuts <- c( + renv_retrieve_explicit, + renv_retrieve_cellar, + if (!renv_tests_running() && config$install.shortcuts()) + renv_retrieve_libpaths + ) + + for (shortcut in shortcuts) { + retrieved <- catch(shortcut(record)) + if (identical(retrieved, TRUE)) + return(TRUE) + } + + } + + state$downloaded <- state$downloaded + 1L + if (state$downloaded == 1L) + writef(header("Downloading packages")) + + # time to retrieve -- delegate based on previously-determined source + switch(source, + bioconductor = renv_retrieve_bioconductor(record), + bitbucket = renv_retrieve_bitbucket(record), + git = renv_retrieve_git(record), + github = renv_retrieve_github(record), + gitlab = renv_retrieve_gitlab(record), + repository = renv_retrieve_repos(record), + url = renv_retrieve_url(record), + renv_retrieve_unknown_source(record) + ) + +} + +renv_retrieve_name <- function(record, type = "source", ext = NULL) { + package <- record$Package + version <- record$RemoteSha %||% record$Version + ext <- ext %||% renv_package_ext(type) + sprintf("%s_%s%s", package, version, ext) +} + +renv_retrieve_path <- function(record, type = "source", ext = NULL) { + + # extract relevant record information + package <- record$Package + name <- renv_retrieve_name(record, type, ext) + source <- renv_record_source(record) + + # check for packages from an PPM binary URL, and + # update the package type if known + if (renv_ppm_enabled()) { + url <- attr(record, "url") + if (is.character(url) && grepl("/__[^_]+__/", url)) + type <- "binary" + } + + # form path for package to be downloaded + if (type == "source") + renv_paths_source(source, package, name) + else if (type == "binary") + renv_paths_binary(source, package, name) + else + stopf("unrecognized type '%s'", type) +} + +renv_retrieve_bioconductor <- function(record) { + + # try to read the bioconductor version from the record + version <- renv_retrieve_bioconductor_version(record) + + # activate Bioconductor repositories in this context + project <- renv_restore_state(key = "project") + renv_scope_bioconductor(project = project, version = version) + + # retrieve record using updated repositories + renv_retrieve_repos(record) + +} + +renv_retrieve_bioconductor_version <- function(record) { + + # read git branch + branch <- record[["git_branch"]] + if (is.null(branch)) + return(NULL) + + # try and parse version + parts <- strsplit(branch, "_", fixed = TRUE)[[1L]] + ok <- + length(parts) == 3L && + tolower(parts[[1L]]) == "release" + + if (!ok) + return(NULL) + + # we have a version; use it + paste(tail(parts, n = -1L), collapse = ".") + +} + +renv_retrieve_bitbucket <- function(record) { + + # query repositories endpoint to find download URL + host <- record$RemoteHost %||% config$bitbucket.host() + origin <- renv_retrieve_origin(host) + username <- record$RemoteUsername + repo <- record$RemoteRepo + + # scope authentication + renv_scope_auth(repo) + + fmt <- "%s/repositories/%s/%s" + url <- sprintf(fmt, origin, username, repo) + + destfile <- renv_scope_tempfile("renv-bitbucket-") + download(url, destfile = destfile, quiet = TRUE) + json <- renv_json_read(destfile) + + # now build URL to tarball + base <- json$links$html$href + ref <- record$RemoteSha %||% record$RemoteRef + + fmt <- "%s/get/%s.tar.gz" + url <- sprintf(fmt, base, ref) + + path <- renv_retrieve_path(record) + + renv_retrieve_package(record, url, path) + +} + +renv_retrieve_github <- function(record) { + + host <- record$RemoteHost %||% config$github.host() + origin <- renv_retrieve_origin(host) + username <- record$RemoteUsername + repo <- record$RemoteRepo + ref <- record$RemoteSha %||% record$RemoteRef + + if (is.null(ref)) { + fmt <- "GitHub record for package '%s' has no recorded 'RemoteSha' / 'RemoteRef'" + stopf(fmt, record$Package) + } + + fmt <- "%s/repos/%s/%s/tarball/%s" + url <- with(record, sprintf(fmt, origin, username, repo, ref)) + path <- renv_retrieve_path(record) + renv_retrieve_package(record, url, path) + +} + +renv_retrieve_gitlab <- function(record) { + + host <- record$RemoteHost %||% config$gitlab.host() + origin <- renv_retrieve_origin(host) + + user <- record$RemoteUsername + repo <- record$RemoteRepo + id <- URLencode(paste(user, repo, sep = "/"), reserved = TRUE) + + fmt <- "%s/api/v4/projects/%s/repository/archive.tar.gz" + url <- sprintf(fmt, origin, id) + path <- renv_retrieve_path(record) + + sha <- record$RemoteSha %||% record$RemoteRef + if (!is.null(sha)) + url <- paste(url, paste("sha", sha, sep = "="), sep = "?") + + renv_retrieve_package(record, url, path) + +} + +renv_retrieve_git <- function(record) { + # NOTE: This path will later be used during the install step, so we don't + # want to clean it up afterwards + path <- tempfile("renv-git-") + ensure_directory(path) + renv_retrieve_git_impl(record, path) + renv_retrieve_successful(record, path) +} + +renv_retrieve_git_impl <- function(record, path) { + + renv_git_preflight() + + package <- record$Package + url <- record$RemoteUrl + ref <- record$RemoteRef + sha <- record$RemoteSha + + # figure out the default ref + gitref <- case( + nzchar(sha %||% "") ~ sha, + nzchar(ref %||% "") ~ ref, + "HEAD" + ) + + # be quiet if requested + quiet <- getOption("renv.git.quiet", default = TRUE) + quiet <- if (quiet) "--quiet" else "" + + template <- heredoc(' + git init ${QUIET} + git remote add origin "${ORIGIN}" + git fetch ${QUIET} --depth=1 origin "${REF}" + git reset ${QUIET} --hard FETCH_HEAD + ') + + data <- list( + ORIGIN = url, + REF = gitref, + QUIET = quiet + ) + + commands <- renv_template_replace(template, data) + command <- gsub("\n", " && ", commands, fixed = TRUE) + if (renv_platform_windows()) + command <- paste(comspec(), "/C", command) + + printf("- Cloning '%s' ... ", url) + + before <- Sys.time() + + status <- local({ + ensure_directory(path) + renv_scope_wd(path) + renv_scope_auth(record) + renv_scope_git_auth() + system(command) + }) + + after <- Sys.time() + + if (status != 0L) { + fmt <- "error cloning '%s' from '%s' [status code %i]" + stopf(fmt, package, url, status) + } + + fmt <- "OK [cloned repository in %s]" + elapsed <- difftime(after, before, units = "auto") + writef(fmt, renv_difftime_format(elapsed)) + + TRUE + +} + + +renv_retrieve_cellar_find <- function(record, project = NULL) { + + project <- renv_project_resolve(project) + + # packages installed with 'remotes::install_local()' will + # have a RemoteUrl entry that we can use + url <- record$RemoteUrl %||% "" + if (file.exists(url)) { + path <- renv_path_normalize(url, mustWork = TRUE) + type <- if (fileext(path) %in% c(".tgz", ".zip")) "binary" else "source" + return(named(path, type)) + } + + # otherwise, look in the cellar + roots <- renv_cellar_roots(project) + for (type in c("binary", "source")) { + + name <- renv_retrieve_name(record, type = type) + for (root in roots) { + + package <- record$Package + paths <- c( + file.path(root, package, name), + file.path(root, name) + ) + + for (path in paths) + if (file.exists(path)) + return(named(path, type)) + + } + } + + fmt <- "%s [%s] is not available locally" + stopf(fmt, record$Package, record$Version) + +} + +renv_retrieve_cellar_report <- function(record) { + + source <- renv_record_source(record) + if (source == "cellar") + return(record) + + fmt <- "- Package %s [%s] will be installed from the cellar." + with(record, writef(fmt, Package, Version)) + + record + +} + +renv_retrieve_cellar <- function(record) { + source <- renv_retrieve_cellar_find(record) + record <- renv_retrieve_cellar_report(record) + renv_retrieve_successful(record, source) +} + +renv_retrieve_libpaths <- function(record) { + + libpaths <- c(renv_libpaths_user(), renv_libpaths_site()) + for (libpath in libpaths) + if (renv_retrieve_libpaths_impl(record, libpath)) + return(TRUE) + +} + +renv_retrieve_libpaths_impl <- function(record, libpath) { + + # form path to installed package's DESCRIPTION + path <- file.path(libpath, record$Package) + if (!file.exists(path)) + return(FALSE) + + # read DESCRIPTION + desc <- renv_description_read(path = path) + + # check if it's compatible with the requested record + fields <- c("Package", "Version", grep("^Remote", names(record), value = TRUE)) + compatible <- identical(record[fields], desc[fields]) + if (!compatible) + return(FALSE) + + # check that it was built for a compatible version of R + built <- desc[["Built"]] + if (is.null(built)) + return(FALSE) + + ok <- catch(renv_description_built_version(desc)) + if (!identical(ok, TRUE)) + return(FALSE) + + # check that this package has a known source + source <- renv_snapshot_description_source(desc) + if (identical(source$Source, "unknown")) + return(FALSE) + + # OK: copy this package as-is + renv_retrieve_successful(record, path) + +} + +renv_retrieve_explicit <- function(record) { + + # try parsing as a local remote + source <- record$Path %||% record$RemoteUrl %||% "" + if (nzchar(source)) { + resolved <- catch(renv_remotes_resolve_path(source)) + if (inherits(resolved, "error")) + return(FALSE) + } + + # treat as 'local' source but extract path + normalized <- renv_path_normalize(source, mustWork = TRUE) + resolved$Source <- "Local" + renv_retrieve_successful(resolved, normalized) + +} + +renv_retrieve_repos <- function(record) { + + # if this record is tagged with a type + url, we can + # use that directly for retrieval + if (all(c("type", "url") %in% names(attributes(record)))) + return(renv_retrieve_repos_impl(record)) + + # figure out what package sources are okay to use here + pkgtype <- getOption("pkgType", default = "source") + + srcok <- pkgtype %in% c("both", "source") || + getOption("install.packages.check.source", default = "yes") %in% "yes" + + binok <- pkgtype %in% c("both") || grepl("binary", pkgtype, fixed = TRUE) + + # collect list of 'methods' for retrieval + methods <- stack(mode = "list") + + # add binary package methods + if (binok) { + + # prefer repository binaries if available + methods$push(renv_retrieve_repos_binary) + + # also try fallback binary locations (for Nexus) + methods$push(renv_retrieve_repos_binary_fallback) + + # if MRAN is enabled, check those binaries as well + if (renv_mran_enabled()) + methods$push(renv_retrieve_repos_mran) + + } + + # next, try to retrieve from sources + if (srcok) { + + # retrieve from source repositories + methods$push(renv_retrieve_repos_source) + + # also try fallback source locations (for Nexus) + methods$push(renv_retrieve_repos_source_fallback) + + # if this is a package from r-universe, try restoring from github + # (currently inferred from presence for RemoteUrl field) + unifields <- c("RemoteUrl", "RemoteRef", "RemoteSha") + if (all(unifields %in% names(record))) + methods$push(renv_retrieve_git) + else + methods$push(renv_retrieve_repos_archive) + + } + + # capture errors for reporting + errors <- stack() + + for (method in methods$data()) { + + status <- catch( + withCallingHandlers( + method(record), + renv.retrieve.error = function(error) { + errors$push(error$data) + } + ) + ) + + if (inherits(status, "error")) { + errors$push(status) + next + } + + if (identical(status, TRUE)) + return(TRUE) + + if (!is.logical(status)) { + fmt <- "internal error: unexpected status code '%s'" + warningf(fmt, stringify(status)) + } + + } + + # if we couldn't download the package, report the errors we saw + local({ + renv_scope_options(warn = 1) + for (error in errors$data()) + warning(error) + }) + + stopf("failed to retrieve package '%s'", renv_record_format_remote(record)) + +} + +renv_retrieve_repos_error_report <- function(record, errors) { + + if (empty(errors)) + return() + + messages <- extract(errors, "message") + if (empty(messages)) + return() + + messages <- unlist(messages, recursive = TRUE, use.names = FALSE) + if (empty(messages)) + return() + + fmt <- "The following error(s) occurred while retrieving '%s':" + preamble <- sprintf(fmt, record$Package) + + caution_bullets( + preamble = preamble, + values = paste("-", messages) + ) + + if (renv_verbose()) + str(errors) + +} + +renv_retrieve_url <- function(record) { + + if (is.null(record$RemoteUrl)) { + fmt <- "package '%s' has no recorded RemoteUrl" + stopf(fmt, record$Package) + } + + resolved <- renv_remotes_resolve_url(record$RemoteUrl, quiet = FALSE) + renv_retrieve_successful(record, resolved$Path) + +} + +renv_retrieve_repos_archive_name <- function(record, type = "source") { + + file <- record$File + if (length(file) && !is.na(file)) + return(file) + + ext <- renv_package_ext(type) + paste0(record$Package, "_", record$Version, ext) + +} + +renv_retrieve_repos_mran <- function(record) { + + # MRAN does not make binaries available on Linux + if (renv_platform_linux()) + return(FALSE) + + # ensure local MRAN database is up-to-date + renv_mran_database_refresh(explicit = FALSE) + + # check that we have an available database + path <- renv_mran_database_path() + if (!file.exists(path)) + return(FALSE) + + # attempt to read it + database <- catch(renv_mran_database_load()) + if (inherits(database, "error")) { + warning(database) + return(FALSE) + } + + # get entry for this version of R + platform + suffix <- contrib.url("", type = "binary") + entry <- database[[suffix]] + if (is.null(entry)) + return(FALSE) + + # check for known entry for this package + version + key <- paste(record$Package, record$Version) + idate <- entry[[key]] + if (is.null(idate)) + return(FALSE) + + # convert from integer to date + date <- as.Date(idate, origin = "1970-01-01") + + # form url to binary package + base <- renv_mran_url(date, suffix) + name <- renv_retrieve_name(record, type = "binary") + url <- file.path(base, name) + + # form path to saved file + path <- renv_retrieve_path(record, "binary") + + # attempt to retrieve + renv_retrieve_package(record, url, path) + +} + +renv_retrieve_repos_binary <- function(record) { + renv_retrieve_repos_impl(record, "binary") +} + +renv_retrieve_repos_binary_fallback <- function(record) { + + for (repo in getOption("repos")) { + if (renv_nexus_enabled(repo)) { + repourl <- contrib.url(repo, type = "binary") + status <- catch(renv_retrieve_repos_impl(record, "binary", repo = repourl)) + if (!inherits(status, "error")) + return(status) + } + } + + FALSE + +} + +renv_retrieve_repos_source <- function(record) { + renv_retrieve_repos_impl(record, "source") +} + +renv_retrieve_repos_source_fallback <- function(record, repo) { + + for (repo in getOption("repos")) { + if (renv_nexus_enabled(repo)) { + repourl <- contrib.url(repo, type = "source") + status <- catch(renv_retrieve_repos_impl(record, "source", repo = repourl)) + if (!inherits(status, "error")) + return(status) + } + } + + FALSE + +} + +renv_retrieve_repos_archive <- function(record) { + + for (repo in getOption("repos")) { + + # try to determine path to package in archive + url <- renv_retrieve_repos_archive_path(repo, record) + if (is.null(url)) + next + + # attempt download + name <- renv_retrieve_repos_archive_name(record, type = "source") + status <- catch(renv_retrieve_repos_impl(record, "source", name, url)) + if (identical(status, TRUE)) + return(TRUE) + + } + + return(FALSE) + +} + +renv_retrieve_repos_archive_path <- function(repo, record) { + + # allow users to provide a custom archive path for a record, + # in case they're using a repository that happens to archive + # packages with a different format than regular CRAN network + # https://github.com/rstudio/renv/issues/602 + override <- getOption("renv.retrieve.repos.archive.path") + if (is.function(override)) { + result <- override(repo, record) + if (!is.null(result)) + return(result) + } + + # if we already know the format of the repository, use that + if (exists(repo, envir = the$repos_archive)) { + formatter <- get(repo, envir = the$repos_archive) + root <- formatter(repo, record) + return(root) + } + + # otherwise, try determining the archive paths with a couple + # custom locations, and cache the version that works for the + # associated repository + formatters <- list( + + # default CRAN format + function(repo, record) { + with(record, file.path(repo, "src/contrib/Archive", Package)) + }, + + # format used by Artifactory + # https://github.com/rstudio/renv/issues/602 + function(repo, record) { + with(record, file.path(repo, "src/contrib/Archive", Package, Version)) + }, + + # format used by Nexus + # https://github.com/rstudio/renv/issues/595 + function(repo, record) { + with(record, file.path(repo, "src/contrib")) + } + + ) + + name <- renv_retrieve_repos_archive_name(record, "source") + for (formatter in formatters) { + root <- formatter(repo, record) + url <- file.path(root, name) + if (renv_download_available(url)) { + assign(repo, formatter, envir = the$repos_archive) + return(root) + } + } + +} + +# NOTE: If 'repo' is provided, it should be the path to the appropriate 'arm' +# of a repository, which is normally generated from the repository URL via +# 'contrib.url()'. +renv_retrieve_repos_impl <- function(record, + type = NULL, + name = NULL, + repo = NULL) +{ + package <- record$Package + version <- record$Version + + type <- type %||% attr(record, "type", exact = TRUE) + name <- name %||% renv_retrieve_repos_archive_name(record, type) + repo <- repo %||% attr(record, "url", exact = TRUE) + + # if we weren't provided a repository for this package, try to find it + if (is.null(repo)) { + + entry <- catch( + renv_available_packages_entry( + package = package, + type = type, + filter = version, + prefer = record[["Repository"]] + ) + ) + + if (inherits(entry, "error")) { + attr(entry, "record") <- record + renv_condition_signal("renv.retrieve.error", entry) + return(FALSE) + } + + # get repository path + repo <- entry$Repository + + # add in the path if available + path <- entry$Path + if (length(path) && !is.na(path)) + repo <- file.path(repo, path) + + # update the tarball name if it was declared + file <- entry$File + if (length(file) && !is.na(file)) + name <- file + + } + + url <- file.path(repo, name) + path <- renv_retrieve_path(record, type) + + renv_retrieve_package(record, url, path) + +} + + +renv_retrieve_package <- function(record, url, path) { + + ensure_parent_directory(path) + type <- renv_record_source(record) + status <- local({ + renv_scope_auth(record) + preamble <- renv_retrieve_package_preamble(record, url) + catch(download(url, preamble = preamble, destfile = path, type = type)) + }) + + # report error for logging upstream + if (inherits(status, "error")) { + attr(status, "record") <- record + renv_condition_signal("renv.retrieve.error", status) + } + + # handle FALSE returns (shouldn't normally happen?) + if (identical(status, FALSE)) { + fmt <- "an unknown error occurred installing '%s' (%s)" + msg <- sprintf(fmt, record$Package, renv_record_format_remote(record)) + status <- simpleError(msg) + } + + # handle errors + if (inherits(status, "error")) + stop(status) + + # handle success + renv_retrieve_successful(record, path) + +} + +renv_retrieve_package_preamble <- function(record, url) { + + message <- sprintf( + "- Downloading %s from %s ... ", + record$Package, + record$Repository %||% record$Source + ) + + format(message, width = the$install_step_width) + +} + +renv_retrieve_successful_subdir <- function(record, path) { + + # if it's a file, assume RemoteSubdir needs to be honored + info <- file.info(path, extra_cols = FALSE) + if (identical(info$isdir, FALSE)) + return(record$RemoteSubdir) + + # otherwise, respect RemoteSubdir only if it seems to + # point at a valid DESCRPITION file + if (!is.null(record$RemoteSubdir)) { + parts <- c(path, record$RemoteSubdir, "DESCRIPTION") + descpath <- paste(parts, collapse = "/") + if (file.exists(descpath)) + return(record$RemoteSubdir) + } + +} + +renv_retrieve_successful <- function(record, path, install = TRUE) { + + # if we downloaded an archive, adjust its permissions here + mode <- Sys.getenv("RENV_CACHE_MODE", unset = NA) + if (!is.na(mode)) { + info <- file.info(path, extra_cols = FALSE) + if (identical(info$isdir, FALSE)) { + parent <- dirname(path) + renv_system_exec( + command = "chmod", + args = c("-Rf", renv_shell_quote(mode), renv_shell_path(parent)), + action = "chmoding cached package", + quiet = TRUE, + success = NULL + ) + } + } + + # the handling of 'subdir' here is a little awkward, as this function + # can receive: + # + # - archives, whose package might live within a sub-directory; + # - folders, whose package might live within a sub-directory; + # - cache paths, for which the subdir is no longer relevant + # + # this warrants a proper cleanup, but for now we we use a hack + subdir <- renv_retrieve_successful_subdir(record, path) + + # augment record with information from DESCRIPTION file + desc <- renv_description_read(path, subdir = subdir) + + # update the record's package name, version + # TODO: should we warn if they didn't match for some reason? + record$Package <- desc$Package + record$Version <- desc$Version + + # add in path information to record (used later during install) + record$Path <- path + + # record this package's requirements + state <- renv_restore_state() + requirements <- state$requirements + + # figure out the dependency fields to use -- if the user explicitly requested + # this package be installed, but also provided a 'dependencies' argument in + # the call to 'install()', then we want to use those + fields <- if (record$Package %in% state$packages) the$install_dependency_fields else "strong" + deps <- renv_dependencies_discover_description(path, subdir = subdir, fields = fields) + if (length(deps$Source)) + deps$Source <- record$Package + + rowapply(deps, function(dep) { + package <- dep$Package + requirements[[package]] <- requirements[[package]] %||% stack() + requirements[[package]]$push(dep) + }) + + # read and handle remotes declared by this package + remotes <- desc$Remotes + if (length(remotes) && config$install.remotes()) + renv_retrieve_remotes(remotes) + + # ensure its dependencies are retrieved as well + if (state$recursive) local({ + repos <- if (is.null(desc$biocViews)) getOption("repos") else renv_bioconductor_repos() + renv_scope_options(repos = repos) + renv_retrieve_successful_recurse(deps) + }) + + # mark package as requiring install if needed + if (install) + state$install$push(record) + + TRUE + +} + +renv_retrieve_successful_recurse <- function(deps) { + remotes <- unique(deps$Package) + for (remote in remotes) + renv_retrieve_successful_recurse_impl(remote) +} + +renv_retrieve_successful_recurse_impl <- function(remote) { + + dynamic( + key = list(remote = remote), + value = renv_retrieve_successful_recurse_impl_one(remote) + ) + +} + +renv_retrieve_successful_recurse_impl_one <- function(remote) { + + # ignore base packages + base <- renv_packages_base() + if (remote %in% base) + return(list()) + + # if this is a 'plain' package remote, retrieve it + if (grepl(renv_regexps_package_name(), remote)) { + renv_retrieve_impl(remote) + return(list()) + } + + # otherwise, handle custom remotes + record <- renv_retrieve_remotes_impl(remote) + if (length(record)) { + renv_retrieve_impl(record$Package) + return(list()) + } + + list() + +} + +renv_retrieve_unknown_source <- function(record) { + + # try to find a matching local package + status <- catch(renv_retrieve_cellar(record)) + if (!inherits(status, "error")) + return(status) + + # failed; parse as though from R package repository + record$Source <- "Repository" + renv_retrieve_repos(record) + +} + +# TODO: what should we do if we detect incompatible remotes? +# e.g. if pkg A requests 'r-lib/rlang@0.3' but pkg B requests +# 'r-lib/rlang@0.2'. +renv_retrieve_remotes <- function(remotes) { + remotes <- strsplit(remotes, "\\s*,\\s*")[[1L]] + for (remote in remotes) + renv_retrieve_remotes_impl(remote) +} + +renv_retrieve_remotes_impl <- function(remote) { + + dynamic( + key = list(remote = remote), + value = renv_retrieve_remotes_impl_one(remote) + ) + +} + +renv_retrieve_remotes_impl_one <- function(remote) { + + # TODO: allow customization of behavior when remote parsing fails? + resolved <- catch(renv_remotes_resolve(remote)) + if (inherits(resolved, "error")) { + warningf("failed to resolve remote '%s'; skipping", remote) + return(invisible(NULL)) + } + + # get the current package record + state <- renv_restore_state() + package <- resolved$Package + record <- state$records[[package]] + + # if we already have a package record, and it's not a 'plain' + # repository record, skip + skip <- + !is.null(record) && + !identical(record, list(Package = package, Source = "Repository")) + + if (skip) { + dlog("retrieve", "skipping remote '%s'; it's already been declared", remote) + dlog("retrieve", "using existing remote '%s'", stringify(record)) + return(invisible(NULL)) + } + + # update the requested record + dlog("retrieve", "using remote '%s'", remote) + state$records[[package]] <- resolved + + # mark the record as needing retrieval + state$retrieved[[package]] <- FALSE + + # return new record + invisible(resolved) + +} + +renv_retrieve_resolve <- function(package) { + tryCatch( + renv_snapshot_description(package = package), + error = function(e) { + renv_retrieve_missing_record(package) + } + ) +} + +renv_retrieve_missing_record <- function(package) { + + # TODO: allow users to configure the action to take here, e.g. + # + # 1. retrieve latest from R repositories (the default), + # 2. request a package + version to be retrieved, + # 3. hard error + # + record <- renv_available_packages_latest(package) + if (!is.null(record)) + return(record) + + fmt <- heredoc(" + renv was unable to find a compatible version of package '%1$s'. + + The latest-available version %1$s is '%2$s', but that version + does not appear to be compatible with this version of R. + + You may need to manually re-install a different version of '%1$s'. + ") + + entry <- renv_available_packages_entry(package, type = "source") + version <- entry$Version %||% "" + + writef(fmt, package, version) + + stopf("failed to find a compatible version of the '%s' package", package) + +} + +# check to see if this requested record is incompatible +# with the set of required dependencies recorded thus far +# during the package retrieval process +renv_retrieve_incompatible <- function(package, record) { + + state <- renv_restore_state() + record <- renv_record_validate(package, record) + + # check and see if the installed version satisfies all requirements + requirements <- state$requirements[[package]] + if (is.null(requirements)) + return(NULL) + + data <- bind(requirements$data()) + explicit <- data[nzchar(data$Require) & nzchar(data$Version), ] + if (nrow(explicit) == 0) + return(NULL) + + # drop 'Dev' column + explicit$Dev <- NULL + + # retrieve record version + version <- record$Version + if (is.null(version)) + return(NULL) + + # for each row, compute whether we're compatible + rversion <- numeric_version(version) + compatible <- map_lgl(seq_len(nrow(explicit)), function(i) { + expr <- call(explicit$Require[[i]], rversion, explicit$Version[[i]]) + eval(expr, envir = baseenv()) + }) + + # keep whatever wasn't compatible + explicit[!compatible, ] + +} + +renv_retrieve_incompatible_report <- function(package, record, replacement, compat) { + + # only report if the user explicitly requesting installation of a particular + # version of a package, but that package isn't actually compatible + state <- renv_restore_state() + if (!package %in% state$packages) + return() + + fmt <- "%s (requires %s %s %s)" + values <- with(compat, sprintf(fmt, Source, Package, Require, Version)) + + fmt <- "Installation of '%s %s' was requested, but the following constraints are not met:" + preamble <- with(record, sprintf(fmt, Package, Version)) + + fmt <- "renv will try to install '%s %s' instead." + postamble <- with(replacement, sprintf(fmt, Package, Version)) + + if (!renv_tests_running()) { + caution_bullets( + preamble = preamble, + values = values, + postamble = postamble + ) + } + +} + +renv_retrieve_origin <- function(host) { + + # NOTE: some host URLs may come with a protocol already formed; + # if we find a protocol, use it as-is + if (grepl("://", host, fixed = TRUE)) + return(host) + + # otherwise, prepend protocol (assume https) + paste("https", host, sep = "://") + +} + + +# robocopy.R ----------------------------------------------------------------- + + +renv_robocopy_exec <- function(source, target, flags = NULL) { + + source <- path.expand(source) + target <- path.expand(target) + + # add other flags + flags <- c(flags, "/E", "/Z", "/R:5", "/W:10") + + # https://docs.microsoft.com/en-us/windows-server/administration/windows-commands/robocopy + # > Any value greater than 8 indicates that there was at least one failure + # > during the copy operation. + renv_system_exec( + command = "robocopy", + args = c(flags, renv_shell_path(source), renv_shell_path(target)), + action = "copying directory", + success = 0:8, + quiet = TRUE + ) + +} + +renv_robocopy_copy <- function(source, target) { + renv_robocopy_exec(source, target) +} + +renv_robocopy_move <- function(source, target) { + renv_robocopy_exec(source, target, "/MOVE") +} + + +# roxygen.R ------------------------------------------------------------------ + + +#' @param project The project directory. If `NULL`, then the active project will +#' be used. If no project is currently active, then the current working +#' directory is used instead. +#' +#' @param type The type of package to install ("source" or "binary"). Defaults +#' to the value of `getOption("pkgType")`. +#' +#' @param lockfile Path to a lockfile. When `NULL` (the default), the +#' `renv.lock` located in the root of the current project will be used. +#' +#' @param library The \R library to be used. When `NULL`, the active project +#' library will be used instead. +#' +#' @param prompt Boolean; prompt the user before taking any action? For backwards +#' compatibility, `confirm` is accepted as an alias for `prompt`. +#' +#' @param ... Unused arguments, reserved for future expansion. If any arguments +#' are matched to `...`, renv will signal an error. +#' +#' @param clean Boolean; remove packages not recorded in the lockfile from +#' the target library? Use `clean = TRUE` if you'd like the library state +#' to exactly reflect the lockfile contents after `restore()`. +#' +#' @param rebuild Force packages to be rebuilt, thereby bypassing any installed +#' versions of the package available in the cache? This can either be a +#' boolean (indicating that all installed packages should be rebuilt), or a +#' vector of package names indicating which packages should be rebuilt. +#' +#' @param repos The repositories to use when restoring packages installed +#' from CRAN or a CRAN-like repository. By default, the repositories recorded +#' in the lockfile will be, ensuring that (e.g.) CRAN packages are +#' re-installed from the same CRAN mirror. +#' +#' Use `repos = getOptions(repos)` to override with the repositories set +#' in the current session, or see the `repos.override` option in [config] for +#' an alternate way override. +#' +#' @param profile The profile to be activated. When `NULL`, the default +#' profile is activated instead. See `vignette("profiles", package = "renv")` +#' for more information. +#' +#' @param dependencies A vector of DESCRIPTION field names that should be used +#' for package dependency resolution. When `NULL` (the default), the value +#' of `renv::settings$package.dependency.fields` is used. The aliases +#' "strong", "most", and "all" are also supported. +#' See [tools::package_dependencies()] for more details. +#' +#' @return The project directory, invisibly. Note that this function is normally +#' called for its side effects. +#' +#' @name renv-params +NULL + +renv_roxygen_config_section <- function() { + + # read config + config <- yaml::read_yaml("inst/config.yml") + + # generate items + items <- map_chr(config, function(entry) { + + # extract fields + name <- entry$name + type <- entry$type + default <- entry$default + description <- entry$description + + # deparse default value + default <- case( + identical(default, list()) ~ "NULL", + TRUE ~ deparse(default) + ) + + # generate table row + fmt <- "\\subsection{renv.config.%s}{%s Defaults to \\code{%s}.}" + sprintf(fmt, name, description, default) + + }) + + c( + "@section Configuration:", + "", + "The following renv configuration options are available:", + "", + items, + "" + ) + +} + + +# rstudio.R ------------------------------------------------------------------ + + +renv_rstudio_available <- function() { + + # NOTE: detecting whether we're running within RStudio is a bit + # tricky because not all of the expected RStudio bits have been + # initialized when the R session is being initialized (e.g. + # when the .Rprofile is being executed) + args <- commandArgs(trailingOnly = FALSE) + args[[1L]] == "RStudio" || .Platform$GUI == "RStudio" + +} + +renv_rstudio_initialize <- function(project) { + + tools <- catch(as.environment("tools:rstudio")) + if (inherits(tools, "error")) + return(FALSE) + + if (is.null(tools$.rs.api.initializeProject)) + return(FALSE) + + tools$.rs.api.initializeProject(project) + TRUE + +} + +renv_rstudio_fixup <- function() { + + # if RStudio's tools are on the search path, we should try + # to fix them up so that renv's own routines don't get seen + tools <- catch(as.environment("tools:rstudio")) + if (inherits(tools, "error")) + return(FALSE) + + helper <- tools[[".rs.clearVar"]] + if (is.null(helper)) + return(FALSE) + + # if the helper environment has been fixed up (as e.g. by + # newer versions of RStudio) then nothing to do + if (identical(tools, environment(helper))) + return(FALSE) + + # put common tools from base into the environment + envir <- environment(helper) + for (var in c("assign", "exists", "get", "remove", "paste")) + envir[[var]] <- get(var, envir = baseenv()) + + TRUE + +} + + +# rtools.R ------------------------------------------------------------------- + + +renv_rtools_list <- function() { + + drive <- Sys.getenv("SYSTEMDRIVE", unset = "C:") + + roots <- c( + + renv_rtools_registry(), + + Sys.getenv("RTOOLS43_HOME", unset = file.path(drive, "rtools43")), + Sys.getenv("RTOOLS42_HOME", unset = file.path(drive, "rtools42")), + Sys.getenv("RTOOLS40_HOME", unset = file.path(drive, "rtools40")), + file.path(drive, "Rtools"), + list.files(file.path(drive, "RBuildTools"), full.names = TRUE), + + "~/Rtools", + list.files("~/RBuildTools", full.names = TRUE) + + ) + + roots <- unique(roots[file.exists(roots)]) + lapply(roots, renv_rtools_read) + +} + +renv_rtools_find <- function() { + + for (spec in renv_rtools_list()) + if (renv_rtools_compatible(spec)) + return(spec) + + NULL + +} + +renv_rtools_read <- function(root) { + + list( + root = root, + version = renv_rtools_version(root) + ) + +} + +renv_rtools_version <- function(root) { + + name <- basename(root) + + # check for 'rtools' folder + # e.g. C:/rtools42 + pattern <- "^rtools(\\d)(\\d)$" + if (grepl(pattern, name, perl = TRUE, ignore.case = TRUE)) + return(gsub(pattern, "\\1.\\2", name, perl = TRUE, ignore.case = TRUE)) + + # check for versioned installation path + # e.g. C:/RBuildTools/4.2 + version <- catch(numeric_version(name)) + if (!inherits(version, "error")) + return(format(version)) + + # detect older Rtools installations + path <- file.path(root, "VERSION.txt") + if (!file.exists(path)) + return(NULL) + + contents <- readLines(path, warn = FALSE) + version <- gsub("[^[:digit:].]", "", contents) + numeric_version(version) + +} + +renv_rtools_compatible <- function(spec) { + + if (is.null(spec$version)) + return(FALSE) + + ranges <- list( + "4.3" = c("4.3.0", "9.9.9"), + "4.2" = c("4.2.0", "4.3.0"), + "4.0" = c("4.0.0", "4.2.0"), + "3.5" = c("3.3.0", "4.0.0"), + "3.4" = c("3.3.0", "4.0.0"), + "3.3" = c("3.2.0", "3.3.0"), + "3.2" = c("3.1.0", "3.2.0"), + "3.1" = c("3.0.0", "3.1.0") + ) + + version <- numeric_version(spec$version)[1, 1:2] + range <- ranges[[format(version)]] + if (is.null(range)) + return(FALSE) + + rversion <- getRversion() + range[[1]] <= rversion && rversion < range[[2]] + +} + +renv_rtools_registry <- function() { + + status <- tryCatch( + utils::readRegistry( + key = "SOFTWARE\\R-Core\\Rtools", + hive = "HLM" + ), + error = function(e) list() + ) + + path <- status$InstallPath %||% "" + if (file.exists(path)) + return(renv_path_normalize(path)) + +} + +renv_rtools_envvars <- function(root) { + + version <- renv_rtools_version(root) + + if (version < "4.0") + renv_rtools_envvars_default(root) + else if (version < "4.2") + renv_rtools_envvars_rtools40(root) + else if (version < "4.3") + renv_rtools_envvars_rtools42(root) + else + renv_rtools_envvars_rtools43(root) + +} + +renv_rtools_envvars_default <- function(root) { + + # add Rtools utilities to path + bin <- normalizePath(file.path(root, "bin"), mustWork = FALSE) + path <- paste(bin, Sys.getenv("PATH"), sep = .Platform$path.sep) + + # set BINPREF (note: trailing slash is required) + # file.path drops trailing separators on Windows, so we use paste + binpref <- paste(renv_path_normalize(root), "mingw_$(WIN)/bin/", sep = "/") + + list(PATH = path, BINPREF = binpref) + +} + +renv_rtools_envvars_rtools43 <- function(root) { + + # add Rtools utilities to path + bin <- normalizePath(file.path(root, "usr/bin"), mustWork = FALSE) + path <- paste(bin, Sys.getenv("PATH"), sep = .Platform$path.sep) + + # set BINPREF + binpref <- "" + + list(PATH = path, BINPREF = binpref) + +} + +renv_rtools_envvars_rtools42 <- function(root) { + + # add Rtools utilities to path + bin <- normalizePath(file.path(root, "usr/bin"), mustWork = FALSE) + + path <- paste(bin, Sys.getenv("PATH"), sep = .Platform$path.sep) + + # set BINPREF + binpref <- "" + + list(PATH = path, BINPREF = binpref) + +} + +renv_rtools_envvars_rtools40 <- function(root) { + + # add Rtools utilities to path + bin <- normalizePath(file.path(root, "usr/bin"), mustWork = FALSE) + path <- paste(bin, Sys.getenv("PATH"), sep = .Platform$path.sep) + + # set BINPREF (note: trailing slash is required) + binpref <- "/mingw$(WIN)/bin/" + + list(PATH = path, BINPREF = binpref) + +} + + +# run.R ---------------------------------------------------------------------- + + +#' Run a script +#' +#' Run an \R script, in the context of a project using renv. The script will +#' be run within an \R sub-process. +#' +#' @inherit renv-params +#' +#' @param script The path to an \R script. +#' +#' @param job Run the requested script as an RStudio job? Requires a recent +#' version of both RStudio and the rstudioapi packages. When `NULL`, the +#' script will be run as a job if possible, and as a regular \R process +#' launched by [system2()] if not. +#' +#' @param name The name to associate with the job, for scripts run as a job. +#' +#' @param project The path to the renv project. This project will be loaded +#' before the requested script is executed. When `NULL` (the default), renv +#' will automatically determine the project root for the associated script +#' if possible. +#' +#' @export +run <- function(script, ..., job = NULL, name = NULL, project = NULL) { + + renv_scope_error_handler() + renv_dots_check(...) + + script <- renv_path_normalize(script, mustWork = TRUE) + + # find the project directory + project <- project %||% renv_file_find(script, function(path) { + paths <- file.path(path, c("renv", "renv.lock")) + if (any(file.exists(paths))) + return(path) + }) + + if (is.null(project)) { + fmt <- "could not determine project root for script '%s'" + stopf(fmt, renv_path_aliased(script)) + } + + # ensure that it has an activate script + activate <- renv_paths_activate(project = project) + if (!file.exists(activate)) { + fmt <- "project '%s' does not have an renv activate script" + stopf(fmt, renv_path_aliased(project)) + } + + # run as a job when possible in RStudio + jobbable <- + !identical(job, FALSE) && + renv_rstudio_available() && + renv_package_installed("rstudioapi") && + renv_package_version("rstudioapi") >= "0.10" && + rstudioapi::verifyAvailable("1.2.1335") + + if (identical(job, TRUE) && identical(jobbable, FALSE)) + stopf("cannot run script as job: required versions of RStudio + rstudioapi not available") + + if (jobbable) + renv_run_job(script = script, name = name, project = project) + else + renv_run_impl(script = script, name = name, project = project) + +} + +renv_run_job <- function(script, name, project) { + + activate <- renv_paths_activate(project = project) + jobscript <- tempfile("renv-job-", fileext = ".R") + + exprs <- substitute(local({ + defer(unlink(jobscript)) + source(activate) + source(script) + }), list(activate = activate, script = script, jobscript = jobscript)) + + code <- deparse(exprs) + writeLines(code, con = jobscript) + + rstudioapi::jobRunScript( + path = jobscript, + workingDir = project, + name = name + ) + +} + +renv_run_impl <- function(script, name, project) { + renv_scope_wd(project) + system2(R(), c("-s", "-f", renv_shell_path(script))) +} + + +# sandbox.R ------------------------------------------------------------------ + + +renv_sandbox_init <- function() { + + # check for envvar override + enabled <- Sys.getenv("RENV_SANDBOX_LOCKING_ENABLED", unset = NA) + if (!is.na(enabled)) { + enabled <- truthy(enabled, default = FALSE) + options(renv.sandbox.locking_enabled = enabled) + } + + # don't use sandbox in watchdog process + type <- Sys.getenv("RENV_PROCESS_TYPE") + if (type == "watchdog-server") + return() + + # if renv was launched with a sandbox path on the library paths, + # then immediately try to activate the sandbox + # https://github.com/rstudio/renv/issues/1565 + for (libpath in .libPaths()) { + if (file.exists(file.path(libpath, ".renv-sandbox"))) { + renv_sandbox_activate_impl(sandbox = libpath) + break + } + } + +} + +renv_sandbox_activate <- function(project = NULL) { + + # record start time + before <- Sys.time() + + # attempt the activation + status <- catch(renv_sandbox_activate_impl(project)) + if (inherits(status, "error")) + warnify(status) + + # record end time + after <- Sys.time() + + # check for long elapsed time + elapsed <- difftime(after, before, units = "secs") + + # if it took too long to activate the sandbox, warn the user + if (elapsed > 10) { + + fmt <- heredoc(" + renv took longer than expected (%s) to activate the sandbox. + + The sandbox can be disabled by setting: + + RENV_CONFIG_SANDBOX_ENABLED = FALSE + + within an appropriate start-up .Renviron file. + + See `?renv::config` for more details. + ") + + + warningf(fmt, renv_difftime_format(elapsed)) + + } + + # return status + status + +} + +renv_sandbox_activate_impl <- function(project = NULL, sandbox = NULL) { + + # lock access to the sandbox + if (config$sandbox.enabled()) { + sandbox <- sandbox %||% renv_sandbox_path(project = project) + lockfile <- paste(sandbox, "lock", sep = ".") + ensure_parent_directory(lockfile) + renv_scope_lock(lockfile) + ensure_directory(sandbox) + } + + # get current library paths + oldlibs <- .libPaths() + syslibs <- c(renv_libpaths_site(), renv_libpaths_system()) + syslibs <- renv_path_normalize(syslibs) + + # override .Library.site + base <- .BaseNamespaceEnv + renv_binding_replace(base, ".Library.site", NULL) + + # generate sandbox + if (config$sandbox.enabled()) { + renv_sandbox_generate(sandbox) + renv_binding_replace(base, ".Library", sandbox) + } + + # update library paths + newlibs <- renv_vector_diff(oldlibs, syslibs) + renv_libpaths_set(newlibs) + + # protect against user profiles that might update library paths + if (config$sandbox.enabled()) + renv_sandbox_activate_check(newlibs) + + # return new library paths + renv_libpaths_all() + +} + +renv_sandbox_activated <- function() { + !identical(.Library, renv_libpaths_system()) +} + +renv_sandbox_activate_check <- function(libs) { + + envir <- globalenv() + + danger <- + exists(".First", envir = envir, inherits = FALSE) && + identical(getOption("renv.autoloader.running"), TRUE) + + if (!danger) + return(FALSE) + + .First <- get(".First", envir = envir, inherits = FALSE) + wrapper <- function() { + + # scope the library paths as currently defined + renv_scope_libpaths() + + # call the user-defined .First function + status <- tryCatch(.First(), error = warnify) + + # double-check if we should restore .First (this is extra + # paranoid but in theory .First could remove itself) + if (identical(wrapper, get(".First", envir = envir))) + assign(".First", .First, envir = envir) + + # return result of .First + invisible(status) + + } + + assign(".First", wrapper, envir = envir) + return(TRUE) + +} + +renv_sandbox_generate <- function(sandbox) { + + # make the library temporarily writable + lock <- getOption("renv.sandbox.locking_enabled", default = TRUE) + + if (lock) { + dlog("sandbox", "unlocking sandbox") + renv_sandbox_unlock(sandbox) + } + + # find system packages in the system library + priority <- getOption("renv.sandbox.priority", default = c("base", "recommended")) + syspkgs <- installed_packages( + lib.loc = renv_libpaths_system(), + priority = priority + ) + + # link into sandbox + sources <- with(syspkgs, file.path(LibPath, Package)) + targets <- with(syspkgs, file.path(sandbox, Package)) + names(targets) <- sources + enumerate(targets, function(source, target) { + if (!renv_file_same(source, target)) + renv_file_link(source, target, overwrite = TRUE) + }) + + # create marker indicating this is a sandbox + # (or, if it already exists, re-create it and update its ctime / mtime) + marker <- file.path(sandbox, ".renv-sandbox") + file.create(marker) + + # update mtime on the sandbox itself as well + Sys.setFileTime(sandbox, time = Sys.time()) + + # make the library unwritable again + if (lock) { + dlog("sandbox", "locking sandbox") + renv_sandbox_lock(sandbox) + } + + # return sandbox path + sandbox + +} + +renv_sandbox_deactivate <- function() { + + # get library paths sans .Library, .Library.site + old <- renv_libpaths_all() + syslibs <- renv_path_normalize(c(.Library, .Library.site)) + + # restore old bindings + base <- .BaseNamespaceEnv + renv_binding_replace(base, ".Library", renv_libpaths_system()) + renv_binding_replace(base, ".Library.site", renv_libpaths_site()) + + # update library paths + new <- renv_vector_diff(old, syslibs) + renv_libpaths_set(new) + + renv_libpaths_all() + +} + +renv_sandbox_task <- function(...) { + + # check if we're enabled + if (!renv_sandbox_activated()) + return() + + # allow opt-out if necessary + enabled <- getOption("renv.sandbox.task", default = TRUE) + if (!enabled) + return() + + # get sandbox path + sandbox <- tail(.libPaths(), n = 1L) + + # make sure it exists + if (!file.exists(sandbox)) { + warning("the renv sandbox was deleted; it will be re-generated", call. = FALSE) + ensure_directory(sandbox) + renv_sandbox_generate(sandbox) + } + + # update the sandbox write time / mtime + Sys.setFileTime(sandbox, time = Sys.time()) + +} + +renv_sandbox_path <- function(project = NULL) { + renv_paths_sandbox(project = project) +} + +renv_sandbox_lock <- function(sandbox = NULL, project = NULL) { + sandbox <- sandbox %||% renv_sandbox_path(project = project) + Sys.chmod(sandbox, mode = "0555") +} + +renv_sandbox_locked <- function(sandbox = NULL, project = NULL) { + sandbox <- sandbox %||% renv_sandbox_path(project = project) + mode <- suppressWarnings(file.mode(sandbox)) + mode == 365L # as.integer(as.octmode("0555")) +} + +renv_sandbox_unlock <- function(sandbox = NULL, project = NULL) { + sandbox <- sandbox %||% renv_sandbox_path(project = project) + Sys.chmod(sandbox, mode = "0755") +} + +#' The default library sandbox +#' +#' @description +#' An \R installation can have up to three types of library paths available +#' to the user: +#' +#' - The _user library_, where \R packages downloaded and installed by the +#' current user are installed. This library path is only visible to that +#' specific user. +#' +#' - The _site library_, where \R packages maintained by administrators of a +#' system are installed. This library path, if it exists, is visible to all +#' users on the system. +#' +#' - The _default library_, where \R packages distributed with \R itself are +#' installed. This library path is visible to all users on the system. +#' +#' Normally, only so-called "base" and "recommended" packages should be installed +#' in the default library. (You can get a list of these packages with +#' `installed.packages(priority = c("base", "recommended"))`). However, it is +#' possible for users and administrators to install packages into the default +#' library, if the filesystem permissions permit them to do so. (This, for +#' example, is the default behavior on macOS.) +#' +#' Because the site and default libraries are visible to all users, having those +#' accessible in renv projects can potentially break isolation -- that is, +#' if a package were updated in the default library, that update would be visible +#' to all \R projects on the system. +#' +#' To help defend against this, renv uses something called the "sandbox" to +#' isolate renv projects from non-"base" packages that are installed into the +#' default library. When an renv project is loaded, renv will: +#' +#' - Create a new, empty library path (called the "sandbox"), +#' +#' - Link only the "base" and "recommended" packages from the default library +#' into the sandbox, +#' +#' - Mark the sandbox as read-only, so that users are unable to install packages +#' into this library, +#' +#' - Instruct the \R session to use the "sandbox" as the default library. +#' +#' This process is mostly transparent to the user. However, because the sandbox +#' is read-only, if you later need to remove the sandbox, you'll need to reset +#' file permissions manually; for example, with `renv::sandbox$unlock()`. +#' +#' If you'd prefer to keep the sandbox unlocked, you can also set: +#' +#' ``` +#' RENV_SANDBOX_LOCKING_ENABLED = FALSE +#' ``` +#' +#' in an appropriate startup `.Renviron` or `Renviron.site` file. +#' +#' The sandbox can also be disabled entirely with: +#' +#' ``` +#' RENV_CONFIG_SANDBOX_ENABLED = FALSE +#' ``` +#' +#' The sandbox library path can also be configured using the `RENV_PATHS_SANDBOX` +#' environment variable: see [paths] for more details. +#' +#' @format NULL +#' @export +sandbox <- list( + path = renv_sandbox_path, + lock = renv_sandbox_lock, + locked = renv_sandbox_locked, + unlock = renv_sandbox_unlock +) + + +# scaffold.R ----------------------------------------------------------------- + +#' Generate project infrastructure +#' +#' @description +#' Create the renv project infrastructure. This will: +#' +#' - Create a project library, `renv/library`. +#' +#' - Install renv into the project library. +#' +#' - Update the project `.Rprofile` to call `source("renv/activate.R")` so +#' that renv is automatically loaded for new \R sessions launched in +#' this project. +#' +#' - Create `renv/.gitignore`, which tells git to ignore the project library. +#' +#' - Create `.Rbuildignore`, if the project is also a package. This tells +#' `R CMD build` to ignore the renv infrastructure, +#' +#' - Write a (bare) [lockfile], `renv.lock`. +#' +#' @inheritParams renv-params +#' +#' @param version The version of renv to associate with this project. By +#' default, the version of renv currently installed is used. +#' +#' @param repos The \R repositories to associate with this project. +#' +#' @param settings A list of renv settings, to be applied to the project +#' after creation. These should map setting names to the desired values. +#' See [settings] for more details. +#' +#' @examples +#' +#' \dontrun{ +#' # create scaffolding with 'devtools' ignored +#' renv::scaffold(settings = list(ignored.packages = "devtools")) +#' } +#' +#' @export +scaffold <- function(project = NULL, + version = NULL, + repos = getOption("repos"), + settings = NULL) +{ + renv_scope_error_handler() + renv_scope_options(repos = repos) + + project <- renv_project_resolve(project) + renv_project_lock(project = project) + + # install renv into project library + renv_imbue_impl(project, version) + + # write out project infrastructure + renv_infrastructure_write(project, version) + + # update project settings + if (is.list(settings)) + renv_settings_persist(project, settings) + + # generate a lockfile + lockfile <- renv_lockfile_create( + project = project, + libpaths = renv_paths_library(project = project), + type = "implicit" + ) + + renv_lockfile_write(lockfile, file = renv_lockfile_path(project)) + + # notify user + fmt <- "- renv infrastructure has been generated for project %s." + writef(fmt, renv_path_pretty(project)) + + # return project invisibly + invisible(project) +} + + +# scope.R -------------------------------------------------------------------- + + +renv_scope_tempdir <- function(pattern = "renv-tempdir-", + tmpdir = tempdir(), + umask = NULL, + scope = parent.frame()) +{ + dir <- renv_scope_tempfile(pattern = pattern, tmpdir = tmpdir, scope = scope) + ensure_directory(dir, umask = umask) + + renv_scope_wd(dir, scope = scope) + dir +} + +renv_scope_auth <- function(record, scope = parent.frame()) { + + package <- if (is.list(record)) record$Package else record + auth <- renv_options_override("renv.auth", package, extra = record) + + if (empty(auth)) + return(FALSE) + + envvars <- catch({ + if (is.function(auth)) + auth(record) + else + auth + }) + + # warn user if auth appears invalid + if (inherits(envvars, "error")) { + warning(envvars) + return(FALSE) + } + + if (empty(envvars)) + return(FALSE) + + renv_scope_envvars(list = as.list(envvars), scope = scope) + return(TRUE) + +} + +renv_scope_libpaths <- function(new = .libPaths(), scope = parent.frame()) { + old <- renv_libpaths_set(new) + defer(renv_libpaths_set(old), scope = scope) +} + +renv_scope_options <- function(..., scope = parent.frame()) { + new <- list(...) + old <- options(new) + defer(options(old), scope = scope) +} + +renv_scope_locale <- function(category = "LC_ALL", locale = "", scope = parent.frame()) { + saved <- Sys.getlocale(category) + Sys.setlocale(category, locale) + defer(Sys.setlocale(category, saved), scope = scope) +} + +renv_scope_envvars <- function(..., list = NULL, scope = parent.frame()) { + + dots <- list %||% list(...) + old <- as.list(Sys.getenv(names(dots), unset = NA)) + names(old) <- names(dots) + + unset <- map_lgl(dots, is.null) + Sys.unsetenv(names(dots[unset])) + if (length(dots[!unset])) + do.call(Sys.setenv, dots[!unset]) + + defer({ + na <- is.na(old) + Sys.unsetenv(names(old[na])) + if (length(old[!na])) + do.call(Sys.setenv, old[!na]) + }, scope = scope) + +} + +renv_scope_error_handler <- function(scope = parent.frame()) { + + error <- getOption("error") + if (!is.null(error)) + return(FALSE) + + call <- renv_error_handler_call() + options(error = call) + + defer({ + if (identical(getOption("error"), call)) + options(error = error) + }, scope = scope) + + TRUE + +} + +# used to enforce usage of curl 7.64.1 within the +# renv_paths_extsoft folder when available on Windows + +# nocov start +renv_scope_downloader <- function(scope = parent.frame()) { + + if (!renv_platform_windows()) + return(FALSE) + + if (nzchar(Sys.which("curl"))) + return(FALSE) + + curlroot <- sprintf("curl-%s-win32-mingw", renv_extsoft_curl_version()) + curl <- renv_paths_extsoft(curlroot, "bin/curl.exe") + if (!file.exists(curl)) + return(FALSE) + + old <- Sys.getenv("PATH", unset = NA) + if (is.na(old)) + return(FALSE) + + new <- paste(renv_path_normalize(dirname(curl)), old, sep = .Platform$path.sep) + + renv_scope_envvars(PATH = new, scope = scope) + +} +# nocov end + +# nocov start +renv_scope_rtools <- function(scope = parent.frame()) { + + if (!renv_platform_windows()) + return(FALSE) + + # check for Rtools + root <- renv_paths_rtools() + if (!file.exists(root)) + return(FALSE) + + # get environment variables appropriate for version of Rtools + vars <- renv_rtools_envvars(root) + + # scope envvars in parent + renv_scope_envvars(list = vars, scope = scope) + +} +# nocov end + +# nocov start +renv_scope_install <- function(scope = parent.frame()) { + + if (renv_platform_macos()) + renv_scope_install_macos(scope) + + if (renv_platform_wsl()) + renv_scope_install_wsl(scope) + +} + +renv_scope_install_macos <- function(scope = parent.frame()) { + + # check that we have command line tools available before invoking + # R CMD config, as this might fail otherwise + if (once()) { + if (!renv_xcode_available()) { + message("- macOS is reporting that command line tools (CLT) are not installed.") + message("- Run 'xcode-select --install' to install command line tools.") + message("- Without CLT, attempts to install packages from sources may fail.") + } + } + + # get the current compiler + args <- c("CMD", "config", "CC") + cc <- system2(R(), args, stdout = TRUE, stderr = TRUE) + + # check to see if we're using the system toolchain + # (need to be careful since users might put e.g. ccache or other flags + # into the CC variable) + + # helper for creating regex matching compiler bits + matches <- function(pattern) { + regex <- paste("(?:[[:space:]]|^)", pattern, "(?:[[:space:]]|$)", sep = "") + grepl(regex, cc) + } + + sysclang <- case( + matches("/usr/bin/clang") ~ TRUE, + matches("clang") ~ Sys.which("clang") == "/usr/bin/clang", + FALSE + ) + + # check for an appropriate LLVM toolchain -- if it exists, use it + spec <- renv_equip_macos_spec() + if (sysclang && !is.null(spec) && file.exists(spec$dst)) { + path <- paste(file.path(spec$dst, "bin"), Sys.getenv("PATH"), sep = ":") + renv_scope_envvars(PATH = path, scope = scope) + } + + # generate a custom makevars that should better handle compilation + # with the system toolchain (or other toolchains) + makevars <- stack() + + # if we don't have an LLVM toolchain available, then try to generate + # a Makeconf that shields compilation from usages of '-fopenmp' + if (sysclang) { + + makeconf <- readLines(file.path(R.home("etc"), "Makeconf"), warn = FALSE) + mplines <- grep(" -fopenmp", makeconf, fixed = TRUE, value = TRUE) + + # read a user makevars (if any) + contents <- character() + mvsite <- Sys.getenv( + "R_MAKEVARS_SITE", + unset = file.path(R.home("etc"), "Makevars.site") + ) + + if (file.exists(mvsite)) + contents <- readLines(mvsite, warn = FALSE) + + # override usages of '-fopenmp' + replaced <- gsub(" -fopenmp", "", mplines, fixed = TRUE) + amended <- unique(c(contents, replaced)) + makevars$push(amended) + + } + + # write makevars to file + path <- tempfile("Makevars-") + contents <- unlist(makevars$data(), recursive = TRUE, use.names = FALSE) + if (length(contents)) { + writeLines(contents, con = path) + renv_scope_envvars(R_MAKEVARS_SITE = path, scope = scope) + } + + TRUE + +} + +renv_scope_install_wsl <- function(scope = parent.frame()) { + renv_scope_envvars(R_INSTALL_STAGED = "FALSE", scope = scope) +} +# nocov end + +renv_scope_restore <- function(..., scope = parent.frame()) { + state <- renv_restore_begin(...) + defer(renv_restore_end(state), scope = scope) +} + +renv_scope_git_auth <- function(scope = parent.frame()) { + + # try and tell git to be non-interactive by default + if (renv_platform_windows()) { + renv_scope_envvars( + GIT_TERMINAL_PROMPT = "0", + scope = scope + ) + } else { + renv_scope_envvars( + GIT_TERMINAL_PROMPT = "0", + GIT_ASKPASS = "/bin/echo", + scope = scope + ) + } + + # use GIT_PAT when provided + pat <- Sys.getenv("GIT_PAT", unset = NA) + if (!is.na(pat)) { + renv_scope_envvars( + GIT_USERNAME = pat, + GIT_PASSWORD = "x-oauth-basic", + scope = scope + ) + } + + # only set askpass when GIT_USERNAME + GIT_PASSWORD are set + user <- + Sys.getenv("GIT_USERNAME", unset = NA) %NA% + Sys.getenv("GIT_USER", unset = NA) + + pass <- + Sys.getenv("GIT_PASSWORD", unset = NA) %NA% + Sys.getenv("GIT_PASS", unset = NA) + + if (is.na(user) || is.na(pass)) + return(FALSE) + + askpass <- if (renv_platform_windows()) + system.file("resources/scripts-git-askpass.cmd", package = "renv") + else + system.file("resources/scripts-git-askpass.sh", package = "renv") + + renv_scope_envvars(GIT_ASKPASS = askpass, scope = scope) + return(TRUE) + +} + +renv_scope_bioconductor <- function(project = NULL, + version = NULL, + scope = parent.frame()) +{ + # get current repository + repos <- getOption("repos") + + # remove old / stale bioc repositories + stale <- grepl("Bioc", names(repos)) + repos <- repos[!stale] + + # retrieve bioconductor repositories appropriate for this project + biocrepos <- renv_bioconductor_repos(project = project, version = version) + + # put it all together + allrepos <- c(repos, biocrepos) + + # activate repositories in this context + renv_scope_options(repos = renv_vector_unique(allrepos), scope = scope) +} + +renv_scope_lock <- function(path = NULL, scope = parent.frame()) { + renv_lock_acquire(path) + defer(renv_lock_release(path), scope = scope) +} + +renv_scope_trace <- function(what, tracer, scope = parent.frame()) { + + call <- sys.call() + call[[1L]] <- base::trace + call[["print"]] <- FALSE + defer(suppressMessages(untrace(substitute(what))), scope = scope) + + suppressMessages(eval(call, envir = parent.frame())) + +} + + +renv_scope_binding <- function(envir, symbol, replacement, scope = parent.frame()) { + if (exists(symbol, envir, inherits = FALSE)) { + old <- renv_binding_replace(envir, symbol, replacement) + defer(renv_binding_replace(envir, symbol, old), scope = scope) + } else { + assign(symbol, replacement, envir) + defer(rm(list = symbol, envir = envir, inherits = FALSE), scope = scope) + } +} + +renv_scope_tempfile <- function(pattern = "renv-tempfile-", + tmpdir = tempdir(), + fileext = "", + scope = parent.frame()) +{ + path <- renv_path_normalize(tempfile(pattern, tmpdir, fileext)) + defer(unlink(path, recursive = TRUE, force = TRUE), scope = scope) + invisible(path) +} + +renv_scope_umask <- function(umask, scope = parent.frame()) { + oldmask <- Sys.umask(umask) + defer(Sys.umask(oldmask), scope = scope) + invisible(oldmask) +} + +renv_scope_wd <- function(dir = getwd(), scope = parent.frame()) { + owd <- setwd(dir) + defer(setwd(owd), scope = scope) + invisible(owd) +} + +renv_scope_sandbox <- function(scope = parent.frame()) { + sandbox <- renv_sandbox_activate() + defer(renv_sandbox_deactivate(), scope = scope) + invisible(sandbox) +} + +renv_scope_biocmanager <- function(scope = parent.frame()) { + + # silence BiocManager messages when setting repositories + renv_scope_options(BiocManager.check_repositories = FALSE, scope = scope) + + # R-devel (4.4.0) warns when BiocManager calls .make_numeric_version() without + # a character argument, so just suppress those warnings in this scope + # + # https://github.com/wch/r-source/commit/1338a95618ddcc8a0af77dc06e4018625de06ec3 + renv_scope_options(warn = -1L, scope = scope) + + # return reference to BiocManager namespace + renv_namespace_load("BiocManager") + +} + +renv_scope_caution <- function(value) { + renv_scope_options( + renv.caution.verbose = value, + scope = parent.frame() + ) +} + +renv_scope_verbose_if <- function(value, scope = parent.frame()) { + if (value) { + renv_scope_options( + renv.verbose = TRUE, + scope = scope + ) + } +} + + +# sdkroot.R ------------------------------------------------------------------ + + +renv_sdkroot_init <- function() { + + if (!renv_platform_macos()) + return() + + enabled <- Sys.getenv("RENV_SDKROOT_ENABLED", unset = "TRUE") + if (!truthy(enabled, default = TRUE)) + return() + + sdkroot <- Sys.getenv("SDKROOT", unset = NA) + if (!is.na(sdkroot)) + return() + + sdk <- "/Library/Developer/CommandLineTools/SDKs/MacOSX.sdk" + if (!file.exists(sdk)) + return() + + makeconf <- file.path(R.home("etc"), "Makeconf") + if (!file.exists(makeconf)) + return() + + contents <- readLines(makeconf) + cxx <- grep("^CXX\\s*=", contents, value = TRUE, perl = TRUE) + if (length(cxx) == 0L) + return() + + if (!grepl("(?:/usr/local|/opt/homebrew)/opt/llvm", cxx)) + return() + + Sys.setenv(SDKROOT = sdk) + +} + + +# session.R ------------------------------------------------------------------ + + +renv_session_quiet <- function() { + + args <- commandArgs(trailingOnly = FALSE) + + index <- match("--args", args) + if (!is.na(index)) + args <- head(args, n = index - 1L) + + quiet <- c("-s", "--slave", "--no-echo") + any(quiet %in% args) + +} + + +# settings.R ----------------------------------------------------------------- + + +the$settings <- new.env(parent = emptyenv()) + +renv_settings_default <- function(name) { + default <- the$settings[[name]]$default + renv_options_override("renv.settings", name, default) +} + +renv_settings_defaults <- function() { + + keys <- ls(envir = the$settings, all.names = TRUE) + vals <- lapply(keys, renv_settings_default) + names(vals) <- keys + vals[order(names(vals))] + +} + +renv_settings_validate <- function(name, value) { + + # NULL implies restore default value + if (is.null(value)) + return(renv_settings_default(name)) + + # run coercion method + value <- the$settings[[name]]$coerce(value) + + # validate the user-provided value + validate <- the$settings[[name]]$validate + ok <- case( + is.character(validate) ~ value %in% validate, + is.function(validate) ~ validate(value), + TRUE + ) + + if (identical(ok, TRUE)) + return(value) + + # validation failed; warn the user and use default + fmt <- "%s is an invalid value for setting '%s'; using default %s instead" + default <- renv_settings_default(name) + warningf(fmt, deparsed(value), name, deparsed(default)) + default + +} + +renv_settings_read <- function(path) { + + filebacked( + context = "renv_settings_read", + path = path, + callback = renv_settings_read_impl + ) + +} + +renv_settings_read_impl <- function(path) { + + # check that file exists + if (!file.exists(path)) + return(NULL) + + # read settings + settings <- case( + endswith(path, ".dcf") ~ renv_settings_read_impl_dcf(path), + endswith(path, ".json") ~ renv_settings_read_impl_json(path), + ~ stopf("don't know how to read settings file %s", renv_path_pretty(path)) + ) + + # keep only known settings + known <- ls(envir = the$settings, all.names = TRUE) + settings <- keep(settings, known) + + # validate + settings <- enumerate(settings, renv_settings_validate) + + # merge in defaults + defaults <- renv_settings_defaults() + missing <- renv_vector_diff(names(defaults), names(settings)) + settings[missing] <- defaults[missing] + + # and return + settings + +} + +renv_settings_read_impl_dcf <- function(path) { + + # try to read it + dcf <- catch(renv_dcf_read(path)) + if (inherits(dcf, "error")) { + warning(dcf) + return(NULL) + } + + # decode encoded values + enumerate(dcf, function(name, value) { + + case( + value == "NULL" ~ NULL, + value == "NA" ~ NA, + value == "NaN" ~ NaN, + value == "TRUE" ~ TRUE, + value == "FALSE" ~ FALSE, + ~ strsplit(value, "\\s*,\\s*")[[1]] + ) + + }) + +} + +renv_settings_read_impl_json <- function(path) { + + json <- catch(renv_json_read(path)) + if (inherits(json, "error")) { + warning(json) + return(NULL) + } + + json + +} + +renv_settings_get <- function(project, name = NULL, default = NULL) { + + # when 'name' is NULL, return all settings + if (is.null(name)) { + names <- ls(envir = the$settings, all.names = TRUE) + settings <- lapply(names, renv_settings_get, project = project) + names(settings) <- names + return(settings[order(names(settings))]) + } + + # check for an override via option + override <- renv_options_override("renv.settings", name) + if (!is.null(override)) + return(override) + + # try to read settings file + path <- renv_settings_path(project) + settings <- renv_settings_read(path) + if (!is.null(settings)) + return(settings[[name]]) + + # if a 'default' value was provided, use it + if (!missing(default)) + return(default) + + # no value recorded; use default + renv_settings_default(name) + +} + +renv_settings_set <- function(project, name, value, persist = TRUE) { + + # read old settings + settings <- renv_settings_get(project) + + # update setting value + old <- settings[[name]] %||% renv_settings_default(name) + new <- renv_settings_validate(name, value) + settings[[name]] <- new + + # persist if requested + if (persist) + renv_settings_persist(project, settings) + + # save session-cached value + path <- renv_settings_path(project) + value <- renv_filebacked_set("renv_settings_read", path, settings) + + # invoke update callback if value changed + if (!identical(old, new)) + renv_settings_updated(project, name, old, new) + + # return value + invisible(value) + +} + +renv_settings_updated <- function(project, name, old, new) { + update <- the$settings[[name]]$update %||% function(...) {} + update(project, old, new) +} + +renv_settings_persist <- function(project, settings) { + + path <- renv_settings_path(project) + settings <- settings[order(names(settings))] + + # figure out which settings are scalar + scalar <- map_lgl(names(settings), function(name) { + the$settings[[name]]$scalar + }) + + # use that to determine which objects should be boxed + config <- renv_json_config(box = names(settings)[!scalar]) + + # write json + ensure_parent_directory(path) + renv_json_write( + object = settings, + config = config, + file = path + ) + +} + +renv_settings_merge <- function(settings, merge) { + settings[names(merge)] <- merge + settings +} + +renv_settings_path <- function(project) { + renv_paths_settings(project = project) +} + + +# nocov start + +renv_settings_updated_cache <- function(project, old, new) { + + # if the cache is being disabled, then copy packages from their + # symlinks back into the library. note that we don't use symlinks + # on windows (we use hard links) so in that case there's nothing + # to be done + if (renv_platform_windows()) + return(FALSE) + + library <- renv_paths_library(project = project) + pkgpaths <- list.files(library, full.names = TRUE) + cachepaths <- map_chr(pkgpaths, renv_cache_path) + names(pkgpaths) <- cachepaths + + if (empty(pkgpaths)) { + fmt <- "- The cache has been %s for this project." + writef(fmt, if (new) "enabled" else "disabled") + return(TRUE) + } + + printf("- Synchronizing project library with the cache ... ") + + if (new) { + + # enabling the cache: for any package in the project library, replace + # that copy with a symlink into the cache, moving the associated package + # into the cache if appropriate + + # ignore existing symlinks; only copy 'real' packages into the cache + pkgtypes <- renv_file_type(pkgpaths) + cachepaths <- cachepaths[pkgtypes != "symlink"] + + # move packages from project library into cache + callback <- renv_progress_callback(renv_cache_move, length(cachepaths)) + enumerate(cachepaths, callback, overwrite = FALSE) + + } else { + + # disabling the cache: for any package which is a symlink into the cache, + # replace that symlink with a copy of the cached package + + # figure out which package directories are symlinks + pkgtypes <- renv_file_type(pkgpaths) + pkgpaths <- pkgpaths[pkgtypes == "symlink"] + + # remove the existing symlinks + unlink(pkgpaths) + + # overwrite these symlinks with packages from the cache + callback <- renv_progress_callback(renv_file_copy, length(pkgpaths)) + enumerate(pkgpaths, callback, overwrite = TRUE) + + } + + writef("Done!") + + fmt <- "- The cache has been %s for this project." + writef(fmt, if (new) "enabled" else "disabled") + +} + +renv_settings_updated_ignore <- function(project, old, new) { + renv_infrastructure_write_gitignore(project = project) +} + +renv_settings_migrate <- function(project) { + + old <- renv_paths_renv("settings.dcf", project = project) + if (!file.exists(old)) + return() + + new <- renv_paths_renv("settings.json", project = project) + if (file.exists(new)) + return() + + # update settings + settings <- renv_settings_read(old) + renv_settings_persist(project, settings) + +} + +renv_settings_impl <- function(name, default, scalar, validate, coerce, update) { + + force(name) + + the$settings[[name]] <- list( + default = default, + coerce = coerce, + scalar = scalar, + validate = validate, + update = update + ) + + function(value, project = NULL, persist = TRUE) { + project <- renv_project_resolve(project) + if (missing(value)) + renv_settings_get(project, name) + else + renv_settings_set(project, name, value, persist) + } + +} + + +# nocov end + +#' Project settings +#' +#' @description +#' Define project-local settings that can be used to adjust the behavior of +#' renv with your particular project. +#' +#' * Get the current value of a setting with (e.g.) `settings$snapshot.type()` +#' * Set current value of a setting with (e.g.) +#' `settings$snapshot.type("explicit")`. +#' +#' Settings are automatically persisted across project sessions by writing to +#' `renv/settings.json`. You can also edit this file by hand, but you'll need +#' to restart the session for those changes to take effect. +#' +#' ## `bioconductor.version` +#' +#' The Bioconductor version to be used with this project. Use this if you'd +#' like to lock the version of Bioconductor used on a per-project basis. +#' When unset, renv will try to infer the appropriate Bioconductor release +#' using the BiocVersion package if installed; if not, renv uses +#' `BiocManager::version()` to infer the appropriate Bioconductor version. +#' +#' ## `external.libraries` +#' +#' A vector of library paths, to be used in addition to the project's own +#' private library. This can be useful if you have a package available for use +#' in some system library, but for some reason renv is not able to install +#' that package (e.g. sources or binaries for that package are not publicly +#' available, or you have been unable to orchestrate the pre-requisites for +#' installing some packages from source on your machine). +#' +#' ## `ignored.packages` +#' +#' A vector of packages, which should be ignored when attempting to snapshot +#' the project's private library. Note that if a package has already been +#' added to the lockfile, that entry in the lockfile will not be ignored. +#' +#' ## `package.dependency.fields` +#' +#' When explicitly installing a package with `install()`, what fields +#' should be used to determine that packages dependencies? The default +#' uses `Imports`, `Depends` and `LinkingTo` fields, but you also want +#' to install `Suggests` dependencies for a package, you can set this to +#' `c("Imports", "Depends", "LinkingTo", "Suggests")`. +#' +#' ## `ppm.enabled` +#' +#' Enable [Posit Package Manager](https://packagemanager.posit.co/) +#' integration in this project? When `TRUE`, renv will attempt to transform +#' repository URLs used by PPM into binary URLs as appropriate for the +#' current Linux platform. Set this to `FALSE` if you'd like to continue using +#' source-only PPM URLs, or if you find that renv is improperly transforming +#' your repository URLs. You can still set and use PPM repositories with this +#' option disabled; it only controls whether renv tries to transform source +#' repository URLs into binary URLs on your behalf. +#' +#' ## `ppm.ignored.urls` +#' +#' When [Posit Package Manager](https://packagemanager.posit.co/) integration +#' is enabled, `renv` will attempt to transform source repository URLs into +#' binary repository URLs. This setting can be used if you'd like to avoid this +#' transformation with some subset of repository URLs. +#' +#' ## `r.version` +#' +#' The version of \R to encode within the lockfile. This can be set as a +#' project-specific option if you'd like to allow multiple users to use +#' the same renv project with different versions of \R. renv will +#' still warn the user if the major + minor version of \R used in a project +#' does not match what is encoded in the lockfile. +#' +#' ## `snapshot.type` +#' +#' The type of snapshot to perform by default. See [snapshot] for more +#' details. +#' +#' ## `use.cache` +#' +#' Enable the renv package cache with this project. When active, renv will +#' install packages into a global cache, and link packages from the cache into +#' your renv projects as appropriate. This can greatly save on disk space +#' and install time when for \R packages which are used across multiple +#' projects in the same environment. +#' +#' ## `vcs.manage.ignores` +#' +#' Should renv attempt to manage the version control system's ignore files +#' (e.g. `.gitignore`) within this project? Set this to `FALSE` if you'd +#' prefer to take control. Note that if this setting is enabled, you will +#' need to manually ensure internal data in the project's `renv/` folder +#' is explicitly ignored. +#' +#' ## `vcs.ignore.cellar` +#' +#' Set whether packages within a project-local package cellar are excluded +#' from version control. See `vignette("cellar", package = "renv")` for +#' more information. +#' +#' ## `vcs.ignore.library` +#' +#' Set whether the renv project library is excluded from version control. +#' +#' ## `vcs.ignore.local` +#' +#' Set whether renv project-specific local sources are excluded from version +#' control. +#' +#' # Defaults +#' +#' You can change the default values of these settings for newly-created renv +#' projects by setting \R options for `renv.settings` or `renv.settings.`. +#' For example: +#' +#' ```R +#' options(renv.settings = list(snapshot.type = "all")) +#' options(renv.settings.snapshot.type = "all") +#' ``` +#' +#' If both of the `renv.settings` and `renv.settings.` options are set +#' for a particular key, the option associated with `renv.settings.` is +#' used instead. We recommend setting these in an appropriate startup profile, +#' e.g. `~/.Rprofile` or similar. +#' +#' @return +#' A named list of renv settings. +#' +#' @format NULL +#' +#' @export +#' +#' @examples +#' +#' \dontrun{ +#' +#' # view currently-ignored packaged +#' renv::settings$ignored.packages() +#' +#' # ignore a set of packages +#' renv::settings$ignored.packages("devtools", persist = FALSE) +#' +#' } +settings <- list( + + bioconductor.version = renv_settings_impl( + name = "bioconductor.version", + default = NULL, + scalar = TRUE, + validate = is.character, + coerce = as.character, + update = NULL + ), + + ignored.packages = renv_settings_impl( + name = "ignored.packages", + default = character(), + scalar = FALSE, + validate = is.character, + coerce = as.character, + update = NULL + ), + + external.libraries = renv_settings_impl( + name = "external.libraries", + default = character(), + scalar = FALSE, + validate = is.character, + coerce = as.character, + update = NULL + ), + + package.dependency.fields = renv_settings_impl( + name = "package.dependency.fields", + default = c("Imports", "Depends", "LinkingTo"), + scalar = FALSE, + validate = is.character, + coerce = as.character, + update = NULL + ), + + ppm.enabled = renv_settings_impl( + name = "ppm.enabled", + default = NULL, + scalar = TRUE, + validate = is.logical, + coerce = as.logical, + update = FALSE + ), + + ppm.ignored.urls = renv_settings_impl( + name = "ppm.ignored.urls", + default = NULL, + scalar = FALSE, + validate = is.character, + coerce = as.character, + update = NULL + ), + + r.version = renv_settings_impl( + name = "r.version", + default = NULL, + scalar = TRUE, + validate = is.character, + coerce = as.character, + update = NULL + ), + + snapshot.type = renv_settings_impl( + name = "snapshot.type", + default = "implicit", + scalar = TRUE, + validate = c("all", "custom", "implicit", "explicit", "packrat", "simple"), + coerce = as.character, + update = NULL + ), + + use.cache = renv_settings_impl( + name = "use.cache", + default = TRUE, + scalar = TRUE, + validate = is.logical, + coerce = as.logical, + update = renv_settings_updated_cache + ), + + vcs.manage.ignores = renv_settings_impl( + name = "vcs.manage.ignores", + default = TRUE, + scalar = TRUE, + validate = is.logical, + coerce = as.logical, + update = NULL + ), + + vcs.ignore.cellar = renv_settings_impl( + name = "vcs.ignore.cellar", + default = TRUE, + scalar = TRUE, + validate = is.logical, + coerce = as.logical, + update = renv_settings_updated_ignore + ), + + vcs.ignore.library = renv_settings_impl( + name = "vcs.ignore.library", + default = TRUE, + scalar = TRUE, + validate = is.logical, + coerce = as.logical, + update = renv_settings_updated_ignore + ), + + vcs.ignore.local = renv_settings_impl( + name = "vcs.ignore.local", + default = TRUE, + scalar = TRUE, + validate = is.logical, + coerce = as.logical, + update = renv_settings_updated_ignore + ) + +) + + +# shell.R -------------------------------------------------------------------- + + +renv_shell_quote <- function(x) { + if (length(x)) + shQuote(x) +} + +renv_shell_path <- function(x) { + if (length(x)) + shQuote(path.expand(x)) +} + + +# shims.R -------------------------------------------------------------------- + + +the$shims <- new.env(parent = emptyenv()) + +renv_shim_install_packages <- function(pkgs, ...) { + + # place Rtools on PATH + renv_scope_rtools() + + # currently we only handle the case where only 'pkgs' was specified + if (missing(pkgs) || nargs() != 1) { + call <- sys.call() + call[[1L]] <- quote(utils::install.packages) + return(eval(call, envir = parent.frame())) + } + + # otherwise, we get to handle it + install(pkgs) + +} + +renv_shim_update_packages <- function(lib.loc = NULL, ...) { + + # handle only 0-argument case + if (nargs() != 0) { + call <- sys.call() + call[[1L]] <- quote(utils::update.packages) + return(eval(call, envir = parent.frame())) + } + + update(library = lib.loc) + +} + +renv_shim_remove_packages <- function(pkgs, lib) { + + # handle single-argument case + if (nargs() != 1) { + call <- sys.call() + call[[1L]] <- quote(utils::remove.packages) + return(eval(call, envir = parent.frame())) + } + + remove(pkgs) + +} + +renv_shim_create <- function(shim, sham) { + formals(shim) <- formals(sham) + shim +} + +renv_shims_enabled <- function(project) { + config$shims.enabled() +} + +renv_shims_activate <- function() { + + renv_shims_deactivate() + + install_shim <- renv_shim_create(renv_shim_install_packages, utils::install.packages) + assign("install.packages", install_shim, envir = the$shims) + + update_shim <- renv_shim_create(renv_shim_update_packages, utils::update.packages) + assign("update.packages", update_shim, envir = the$shims) + + remove_shim <- renv_shim_create(renv_shim_remove_packages, utils::remove.packages) + assign("remove.packages", remove_shim, envir = the$shims) + + args <- list(the$shims, name = "renv:shims", warn.conflicts = FALSE) + do.call(base::attach, args) + +} + +renv_shims_deactivate <- function() { + while ("renv:shims" %in% search()) + detach("renv:shims") +} + + +# snapshot-auto.R ------------------------------------------------------------ + + +# information about the project library; used to detect whether +# the library appears to have been modified or updated +the$library_info <- NULL + +# are we forcing automatic snapshots? +the$auto_snapshot_forced <- FALSE + +# did the last attempt at an automatic snapshot fail? +the$auto_snapshot_failed <- FALSE + +# are we currently running an automatic snapshot? +the$auto_snapshot_running <- FALSE + +# is the next automatic snapshot suppressed? +the$auto_snapshot_suppressed <- FALSE + +# nocov start +renv_snapshot_auto <- function(project) { + + # set some state so we know we're running + the$auto_snapshot_running <- TRUE + defer(the$auto_snapshot_running <- FALSE) + + # passed pre-flight checks; snapshot the library + updated <- withCallingHandlers( + + tryCatch( + renv_snapshot_auto_impl(project), + error = function(err) FALSE + ), + + cancel = function() FALSE + + ) + + if (updated) { + lockfile <- renv_path_aliased(renv_lockfile_path(project)) + writef("- Automatic snapshot has updated '%s'.", lockfile) + } + + invisible(updated) + +} + +renv_snapshot_auto_impl <- function(project) { + + # validation messages can be noisy; turn off for auto snapshot + renv_scope_options( + renv.config.snapshot.validate = FALSE, + renv.verbose = FALSE + ) + + # get current lockfile state + lockfile <- renv_paths_lockfile(project) + old <- file.info(lockfile, extra_cols = FALSE)$mtime + + # perform snapshot without prompting + snapshot(project = project, prompt = FALSE) + + # check for change in lockfile + new <- file.info(lockfile, extra_cols = FALSE)$mtime + old != new + +} + +renv_snapshot_auto_enabled <- function(project = renv_project_get()) { + + # respect override + if (the$auto_snapshot_forced) + return(TRUE) + + # respect config setting + enabled <- config$auto.snapshot(project = project) + if (!enabled) + return(FALSE) + + # only snapshot interactively + if (!interactive()) + return(FALSE) + + # only automatically snapshot the current project + if (!renv_project_loaded(project)) + return(FALSE) + + # don't auto-snapshot if the project hasn't been initialized + if (!renv_project_initialized(project = project)) + return(FALSE) + + # don't auto-snapshot if we don't have a library + library <- renv_paths_library(project = project) + if (!file.exists(library)) + return(FALSE) + + # don't auto-snapshot unless the active library is the project library + if (!renv_file_same(renv_libpaths_active(), library)) + return(FALSE) + + TRUE + +} + +renv_snapshot_auto_update <- function(project = renv_project_get() ) { + + # check for enabled + if (!renv_snapshot_auto_enabled(project = project)) + return(FALSE) + + # get path to project library + libpath <- renv_paths_library(project = project) + if (!file.exists(libpath)) + return(FALSE) + + # list files + get file info for files in project library + info <- renv_file_info(libpath) + + # only keep relevant fields + fields <- c("size", "mtime", "ctime") + new <- c(info[fields]) + + # update our cached info + old <- the$library_info + the$library_info <- new + + # if we've suppressed the next automatic snapshot, bail here + if (the$auto_snapshot_suppressed) { + the$auto_snapshot_suppressed <- FALSE + return(FALSE) + } + + # report if things have changed + !is.null(old) && !identical(old, new) + +} + +renv_snapshot_task <- function() { + + # if the previous snapshot attempt failed, do nothing + if (the$auto_snapshot_failed) + return(FALSE) + + # treat warnings as errors in this scope + renv_scope_options(warn = 2L) + + # attempt automatic snapshot, but disable on failure + tryCatch( + renv_snapshot_task_impl(), + error = function(cnd) { + caution("Error generating automatic snapshot: %s", conditionMessage(cnd)) + caution("Automatic snapshots will be disabled. Use `renv::snapshot()` to manually update the lockfile.") + the$auto_snapshot_failed <- TRUE + } + ) + +} + +renv_snapshot_task_impl <- function() { + + # check for active renv project + project <- renv_project_get() + if (is.null(project)) + return(invisible(FALSE)) + + # see if library state has updated + updated <- renv_snapshot_auto_update(project = project) + if (!updated) + return(invisible(FALSE)) + + # library has updated; perform auto snapshot + renv_snapshot_auto(project = project) + +} + +renv_snapshot_auto_suppress_next <- function() { + + # if we're currently running an automatic snapshot, then nothing to do + if (the$auto_snapshot_running) + return() + + # otherwise, set the suppressed flag + the$auto_snapshot_suppressed <- TRUE + +} + +# nocov end + + +# snapshot.R ----------------------------------------------------------------- + + +# controls whether hashes are computed when computing a snapshot +# can be scoped to FALSE when hashing is not necessary +the$auto_snapshot_hash <- TRUE + +#' Record current state of the project library in the lockfile +#' +#' @description +#' Call `renv::snapshot()` to update a [lockfile] with the current state of +#' dependencies in the project library. The lockfile can be used to later +#' [restore] these dependencies as required. +#' +#' It's also possible to call `renv::snapshot()` with a non-renv project, +#' in which case it will record the current state of dependencies in the +#' current library paths. This makes it possible to [restore] the current packages, +#' providing lightweight portability and reproducibility without isolation. +#' +#' If you want to automatically snapshot after each change, you can +#' set `config$config$auto.snapshot(TRUE)`, see `?config` for more details. +#' +#' # Snapshot types +#' +#' Depending on how you prefer to manage dependencies, you might prefer +#' selecting a different snapshot mode. The modes available are as follows: +#' +#' \describe{ +#' +#' \item{`"implicit"`}{ +#' (The default) Capture only packages which appear to be used in your project, +#' as determined by `renv::dependencies()`. This ensures that only the packages +#' actually required by your project will enter the lockfile; the downside +#' if it might be slow if your project contains a large number of files. +#' If speed becomes an issue, you might consider using `.renvignore` files to +#' limit which files renv uses for dependency discovery, or switching to +#' explicit mode, as described next. +#' } +#' +#' \item{`"explicit"`}{ +#' Only capture packages which are explicitly listed in the project +#' `DESCRIPTION` file. This workflow is recommended for users who wish to +#' manage their project's \R package dependencies directly. +#' } +#' +#' \item{`"all"`}{ +#' Capture all packages within the active \R libraries in the lockfile. +#' This is the quickest and simplest method, but may lead to undesired +#' packages (e.g. development dependencies) entering the lockfile. +#' } +#' +#' \item{`"custom"`}{ +#' Like `"implicit"`, but use a custom user-defined filter instead. The filter +#' should be specified by the \R option `renv.snapshot.filter`, and should +#' either be a character vector naming a function (e.g. `"package::method"`), +#' or be a function itself. The function should only accept one argument (the +#' project directory), and should return a vector of package names to include +#' in the lockfile. +#' } +#' +#' } +#' +#' You can change the snapshot type for the current project with [settings()]. +#' For example, the following code will switch to using `"explicit"` snapshots: +#' +#' ``` +#' renv::settings$snapshot.type("explicit") +#' ``` +#' +#' When the `packages` argument is set, `type` is ignored, and instead only the +#' requested set of packages, and their recursive dependencies, will be written +#' to the lockfile. +#' +#' @inherit renv-params +#' +#' @param library The \R libraries to snapshot. When `NULL`, the active \R +#' libraries (as reported by `.libPaths()`) are used. +#' +#' @param lockfile The location where the generated lockfile should be written. +#' By default, the lockfile is written to a file called `renv.lock` in the +#' project directory. When `NULL`, the lockfile (as an \R object) is returned +#' directly instead. +#' +#' @param type The type of snapshot to perform: +#' * `"implict"`, (the default), uses all packages captured by [dependencies()]. +#' * `"explicit"` uses packages recorded in `DESCRIPTION`. +#' * `"all"` uses all packages in the project library. +#' * `"custom"` uses a custom filter. +#' +#' See **Snapshot type** below for more details. +#' +#' @inheritParams dependencies +#' +#' @param repos The \R repositories to be recorded in the lockfile. Defaults +#' to the currently active package repositories, as retrieved by +#' `getOption("repos")`. +#' +#' +#' @param packages A vector of packages to be included in the lockfile. When +#' `NULL` (the default), all packages relevant for the type of snapshot being +#' performed will be included. When set, the `type` argument is ignored. +#' Recursive dependencies of the specified packages will be added to the +#' lockfile as well. +#' +#' @param exclude A vector of packages to be explicitly excluded from the lockfile. +#' Note that transitive package dependencies will always be included, to avoid +#' potentially creating an incomplete / non-functional lockfile. +#' +#' @param update Boolean; if the lockfile already exists, then attempt to update +#' that lockfile without removing any prior package records. +#' +#' @param force Boolean; force generation of a lockfile even when pre-flight +#' validation checks have failed? +#' +#' @param reprex Boolean; generate output appropriate for embedding the lockfile +#' as part of a [reprex](https://www.tidyverse.org/help/#reprex)? +#' +#' @return The generated lockfile, as an \R object (invisibly). Note that +#' this function is normally called for its side effects. +#' +#' +#' @seealso More on handling package [dependencies()] +#' @family reproducibility +#' +#' @export +#' +#' @example examples/examples-init.R +snapshot <- function(project = NULL, + ..., + library = NULL, + lockfile = paths$lockfile(project = project), + type = settings$snapshot.type(project = project), + dev = FALSE, + repos = getOption("repos"), + packages = NULL, + exclude = NULL, + prompt = interactive(), + update = FALSE, + force = FALSE, + reprex = FALSE) +{ + renv_consent_check() + renv_scope_error_handler() + renv_dots_check(...) + + renv_snapshot_auto_suppress_next() + + project <- renv_project_resolve(project) + renv_project_lock(project = project) + renv_scope_verbose_if(prompt) + + repos <- renv_repos_validate(repos) + renv_scope_options(repos = repos) + + if (!is.null(lockfile)) + renv_activate_prompt("snapshot", library, prompt, project) + + libpaths <- renv_path_normalize(library %||% renv_libpaths_all()) + if (config$snapshot.validate()) + renv_snapshot_preflight(project, libpaths) + + # when packages is set, we treat this as an 'all' type snapshot, but + # with explicit package filters turned on + if (!is.null(packages)) { + + if (!missing(type)) { + fmt <- "packages argument is set; type argument %s will be ignored" + warningf(fmt, stringify(type)) + } + + type <- "packages" + + } + + alt <- new <- renv_lockfile_create( + project = project, + type = type, + libpaths = libpaths, + packages = packages, + exclude = exclude, + prompt = prompt, + force = force, + dev = dev + ) + + if (is.null(lockfile)) + return(new) + + # if running as part of 'reprex', then render output inline + if (reprex) + return(renv_snapshot_reprex(new)) + + # check for missing dependencies and warn if any are discovered + # (note: use 'new' rather than 'alt' here as we don't want to attempt + # validation on uninstalled packages) + valid <- renv_snapshot_validate(project, new, libpaths) + renv_snapshot_validate_report(valid, prompt, force) + + # get prior lockfile state + old <- list() + if (file.exists(lockfile)) { + + # read a pre-existing lockfile (if any) + old <- renv_lockfile_read(lockfile) + + # preserve records from alternate OSes in lockfile + alt <- renv_snapshot_preserve(old, new) + + # check if there are any changes in the lockfile + diff <- renv_lockfile_diff(old, alt) + if (empty(diff)) { + writef("- The lockfile is already up to date.") + return(renv_snapshot_successful(alt, prompt, project)) + } + + } + + # update new reference + new <- alt + + # if we're only updating the lockfile, then merge any missing records + # from 'old' back into 'new' + if (update) + for (package in names(old$Packages)) + new$Packages[[package]] <- new$Packages[[package]] %||% old$Packages[[package]] + + # report actions to the user + actions <- renv_lockfile_diff_packages(old, new) + if (prompt || renv_verbose()) + renv_snapshot_report_actions(actions, old, new) + + # request user confirmation + cancel_if(length(actions) && file.exists(lockfile) && prompt && !proceed()) + + # write it out + ensure_parent_directory(lockfile) + renv_lockfile_write(new, file = lockfile) + + # ensure the lockfile is .Rbuildignore-d + renv_infrastructure_write_rbuildignore(project) + + # ensure the activate script is up-to-date + renv_infrastructure_write_activate(project, create = FALSE) + + # return new records + renv_snapshot_successful(new, prompt, project) +} + +renv_snapshot_preserve <- function(old, new) { + records <- filter(old$Packages, renv_snapshot_preserve_impl) + if (length(records)) + new$Packages[names(records)] <- records + new +} + +renv_snapshot_preserve_impl <- function(record) { + + ostype <- tolower(record[["OS_type"]] %||% "") + if (!nzchar(ostype)) + return(FALSE) + + altos <- if (renv_platform_unix()) "windows" else "unix" + identical(ostype, altos) + +} + +renv_snapshot_preflight <- function(project, libpaths) { + lapply(libpaths, renv_snapshot_preflight_impl, project = project) +} + +renv_snapshot_preflight_impl <- function(project, library) { + renv_snapshot_preflight_library_exists(project, library) +} + +renv_snapshot_preflight_library_exists <- function(project, library) { + + # check that we have a directory + type <- renv_file_type(library, symlinks = FALSE) + if (type == "directory") + return(TRUE) + + # if the file exists but isn't a directory, fail + if (nzchar(type)) { + fmt <- "library '%s' exists but is not a directory" + stopf(fmt, renv_path_aliased(library)) + } + + # the directory doesn't exist; perhaps the user hasn't called init + if (identical(library, renv_paths_library(project = project))) { + fmt <- "project '%s' has no private library -- have you called `renv::init()`?" + stopf(fmt, renv_path_aliased(project)) + } + + # user tried to snapshot arbitrary but missing path + fmt <- "library '%s' does not exist; cannot proceed" + stopf(fmt, renv_path_aliased(library)) + +} + +renv_snapshot_validate <- function(project, lockfile, libpaths) { + + # allow user to disable snapshot validation, just in case + enabled <- config$snapshot.validate() + if (!enabled) + return(TRUE) + + methods <- list( + renv_snapshot_validate_bioconductor, + renv_snapshot_validate_dependencies_available, + renv_snapshot_validate_dependencies_compatible, + renv_snapshot_validate_sources + ) + + ok <- map_lgl(methods, function(method) { + tryCatch( + method(project, lockfile, libpaths), + error = function(e) { warning(e); FALSE } + ) + }) + + all(ok) + +} + +renv_snapshot_validate_report <- function(valid, prompt, force) { + + # nothing to do if everything is valid + if (valid) { + dlog("snapshot", "passed pre-flight validation checks") + return(TRUE) + } + + # if we're forcing snapshot, ignore the failures + if (force) { + dlog("snapshot", "ignoring error in pre-flight validation checks as 'force = TRUE'") + return(TRUE) + } + + # in interactive sessions, if 'prompt' is set, then ask the user + # if they would like to proceed + if (interactive() && !testing() && prompt) { + cancel_if(!proceed()) + return(TRUE) + } + + # otherwise, bail on error (need to use 'force = TRUE') + stop("aborting snapshot due to pre-flight validation failure") + +} + +# nocov start +renv_snapshot_validate_bioconductor <- function(project, lockfile, libpaths) { + + ok <- TRUE + + # check whether any packages are installed from Bioconductor + records <- renv_lockfile_records(lockfile) + sources <- extract_chr(records, "Source") + if (!"Bioconductor" %in% sources) + return(ok) + + # check for BiocManager or BiocInstaller + package <- renv_bioconductor_manager() + if (!package %in% names(records)) { + + text <- c( + "One or more Bioconductor packages are used in your project,", + "but the %s package is not available.", + "", + "Consider installing %s before snapshot.", + "" + ) + caution(text, package) + + ok <- FALSE + } + + # check that Bioconductor packages are from correct release + version <- + lockfile$Bioconductor$Version %||% + renv_bioconductor_version(project = project) + + biocrepos <- renv_bioconductor_repos(version = version) + renv_scope_options(repos = biocrepos) + + # collect Bioconductor records + bioc <- records %>% + filter(function(record) renv_record_source(record) == "bioconductor") %>% + map(function(record) record[c("Package", "Version")]) %>% + bind() + + # collect latest versions of these packages + bioc$Latest <- vapply(bioc$Package, function(package) { + entry <- catch(renv_available_packages_latest(package)) + if (inherits(entry, "error")) + return("") + entry$Version + }, FUN.VALUE = character(1)) + + # check for version mismatches (allow mismatch in minor version) + bioc$Mismatch <- mapply(function(current, latest) { + + if (identical(latest, "")) + return(TRUE) + + current <- renv_version_maj_min(current) + latest <- renv_version_maj_min(latest) + current != latest + + }, bioc$Version, bioc$Latest) + + bad <- bioc[bioc$Mismatch, ] + if (nrow(bad)) { + + fmt <- "%s [installed %s != latest %s]" + msg <- sprintf(fmt, format(bad$Package), format(bad$Version), bad$Latest) + caution_bullets( + "The following Bioconductor packages appear to be from a separate Bioconductor release:", + msg, + c( + "renv may be unable to restore these packages.", + paste("Bioconductor version:", version) + ) + ) + + ok <- FALSE + } + + ok + +} +# nocov end + +renv_snapshot_validate_dependencies_available <- function(project, lockfile, libpaths) { + + # use library to collect package dependency versions + records <- renv_lockfile_records(lockfile) + packages <- extract_chr(records, "Package") + locs <- find.package(packages, lib.loc = libpaths, quiet = TRUE) + deps <- bapply(locs, renv_dependencies_discover_description) + if (empty(deps)) + return(TRUE) + + splat <- split(deps, deps$Package) + + # exclude base R packages + splat <- splat[renv_vector_diff(names(splat), renv_packages_base())] + + # check for required packages not currently installed + requested <- names(splat) + missing <- renv_vector_diff(requested, packages) + if (empty(missing)) + return(TRUE) + + # exclude ignored packages + missing <- renv_vector_diff(missing, settings$ignored.packages(project = project)) + if (empty(missing)) + return(TRUE) + + usedby <- map_chr(missing, function(package) { + + revdeps <- sort(unique(basename(deps$Source)[deps$Package == package])) + + items <- revdeps; limit <- 3L + if (length(revdeps) > limit) { + rest <- length(revdeps) - limit + suffix <- paste("and", length(revdeps) - 3L, plural("other", rest)) + items <- c(revdeps[seq_len(limit)], suffix) + } + + paste(items, collapse = ", ") + + }) + + caution_bullets( + "The following required packages are not installed:", + sprintf("%s [required by %s]", format(missing), usedby), + "Consider reinstalling these packages before snapshotting the lockfile." + ) + + FALSE + +} + +renv_snapshot_validate_dependencies_compatible <- function(project, lockfile, libpaths) { + + # use library to collect package dependency versions + records <- renv_lockfile_records(lockfile) + packages <- extract_chr(records, "Package") + locs <- find.package(packages, lib.loc = libpaths, quiet = TRUE) + deps <- bapply(locs, renv_dependencies_discover_description) + if (empty(deps)) + return(TRUE) + + splat <- split(deps, deps$Package) + + # exclude base R packages + splat <- splat[renv_vector_diff(names(splat), renv_packages_base())] + + # collapse requirements for each package + bad <- enumerate(splat, function(package, requirements) { + + # skip NULL records (should be handled above) + record <- records[[package]] + if (is.null(record)) + return(NULL) + + version <- record$Version + + # drop packages without explicit version requirement + requirements <- requirements[nzchar(requirements$Require), ] + if (nrow(requirements) == 0) + return(NULL) + + # add in requested version + requirements$Requested <- version + + # generate expressions to evaluate + fmt <- "package_version('%s') %s package_version('%s')" + code <- with(requirements, sprintf(fmt, Requested, Require, Version)) + parsed <- parse(text = code) + ok <- map_lgl(parsed, eval, envir = baseenv()) + + # return requirements that weren't satisfied + requirements[!ok, ] + + }) + + bad <- bind(bad) + if (empty(bad)) + return(TRUE) + + package <- basename(bad$Source) + requires <- sprintf("%s (%s %s)", bad$Package, bad$Require, bad$Version) + request <- bad$Requested + + fmt <- "%s requires %s, but version %s is installed" + txt <- sprintf(fmt, format(package), format(requires), format(request)) + caution_bullets( + "The following package(s) have unsatisfied dependencies:", + txt, + "Consider updating the required dependencies as appropriate." + ) + + FALSE + +} + +renv_snapshot_validate_sources <- function(project, lockfile, libpaths) { + records <- renv_lockfile_records(lockfile) + renv_check_unknown_source(records, project) +} + +# NOTE: if packages are found in multiple libraries, +# then the first package found in the library paths is +# kept and others are discarded +renv_snapshot_libpaths <- function(libpaths = NULL, + project = NULL) +{ + dynamic( + key = list(libpaths = libpaths, project = project), + value = renv_snapshot_libpaths_impl(libpaths, project) + ) +} + +renv_snapshot_libpaths_impl <- function(libpaths = NULL, + project = NULL) +{ + records <- uapply( + libpaths, + renv_snapshot_library, + project = project + ) + + dupes <- duplicated(names(records)) + records[!dupes] +} + +renv_snapshot_library <- function(library = NULL, + records = TRUE, + project = NULL) +{ + # list packages in the library + library <- renv_path_normalize(library %||% renv_libpaths_active()) + paths <- list.files(library, full.names = TRUE) + + # remove 'base' packages + paths <- paths[!basename(paths) %in% renv_packages_base()] + + # remove ignored packages + ignored <- renv_project_ignored_packages(project = project) + paths <- paths[!basename(paths) %in% ignored] + + # remove paths that are not valid package names + pattern <- sprintf("^%s$", .standard_regexps()$valid_package_name) + paths <- paths[grep(pattern, basename(paths))] + + # validate the remaining set of packages + valid <- renv_snapshot_library_diagnose(library, paths) + + # remove duplicates (so only first package entry discovered in library wins) + duplicated <- duplicated(basename(valid)) + packages <- valid[!duplicated] + + # early exit if we're just collecting the list of packages + if (!records) + return(basename(packages)) + + # snapshot description files + descriptions <- file.path(packages, "DESCRIPTION") + records <- lapply(descriptions, compose(catch, renv_snapshot_description)) + names(records) <- basename(packages) + + # report any snapshot failures + broken <- filter(records, inherits, what = "error") + if (length(broken)) { + + messages <- map_chr(broken, conditionMessage) + text <- sprintf("'%s': %s", names(broken), messages) + caution_bullets( + "renv was unable to snapshot the following packages:", + text, + "These packages will likely need to be repaired and / or reinstalled." + ) + + stopf("snapshot of library %s failed", renv_path_pretty(library)) + + } + + # name results and return + names(records) <- map_chr(records, `[[`, "Package") + records + +} + +renv_snapshot_library_diagnose <- function(library, paths) { + + paths <- grep("00LOCK", paths, invert = TRUE, value = TRUE) + paths <- renv_snapshot_library_diagnose_broken_link(library, paths) + paths <- renv_snapshot_library_diagnose_tempfile(library, paths) + paths <- renv_snapshot_library_diagnose_missing_description(library, paths) + paths + +} + +renv_snapshot_library_diagnose_broken_link <- function(library, paths) { + + broken <- !file.exists(paths) + if (!any(broken)) + return(paths) + + caution_bullets( + "The following package(s) have broken symlinks into the cache:", + basename(paths)[broken], + "Use `renv::repair()` to try and reinstall these packages." + ) + + paths[!broken] + +} + +renv_snapshot_library_diagnose_tempfile <- function(library, paths) { + + names <- basename(paths) + missing <- grepl("^file(?:\\w){12}", names) + if (!any(missing)) + return(paths) + + caution_bullets( + "The following folder(s) appear to be left-over temporary directories:", + map_chr(paths[missing], renv_path_pretty), + "Consider removing these folders from your R library." + ) + + paths[!missing] + +} + +renv_snapshot_library_diagnose_missing_description <- function(library, paths) { + + desc <- file.path(paths, "DESCRIPTION") + missing <- !file.exists(desc) + if (!any(missing)) + return(paths) + + caution_bullets( + "The following package(s) are missing their DESCRIPTION files:", + sprintf("%s [%s]", format(basename(paths[missing])), paths[missing]), + c( + "These may be left over from a prior, failed installation attempt.", + "Consider removing or reinstalling these packages." + ) + ) + + paths[!missing] + +} + +renv_snapshot_description <- function(path = NULL, package = NULL) { + + # resolve path + path <- path %||% { + path <- renv_package_find(package) + if (!nzchar(path)) + stopf("package '%s' is not installed", package) + } + + # read and snapshot DESCRIPTION file + dcf <- renv_description_read(path, package) + renv_snapshot_description_impl(dcf, path) + +} + +renv_snapshot_description_impl <- function(dcf, path = NULL) { + + # figure out the package source + source <- renv_snapshot_description_source(dcf) + dcf[names(source)] <- source + + # check for required fields + required <- c("Package", "Version", "Source") + missing <- renv_vector_diff(required, names(dcf)) + if (length(missing)) { + fmt <- "required fields %s missing from DESCRIPTION at path '%s'" + stopf(fmt, paste(shQuote(missing), collapse = ", "), path %||% "") + } + + # generate a hash if we can + dcf[["Hash"]] <- if (the$auto_snapshot_hash) { + if (is.null(path)) + renv_hash_description_impl(dcf) + else + renv_hash_description(path) + } + + # generate a Requirements field -- primarily for use by 'pak' + fields <- c("Depends", "Imports", "LinkingTo") + deps <- bind(map(dcf[fields], renv_description_parse_field)) + all <- unique(csort(unlist(deps$Package))) + dcf[["Requirements"]] <- all + + # get remotes fields + git <- grep("^git", names(dcf), value = TRUE) + remotes <- grep("^Remote", names(dcf), value = TRUE) + + is_repo <- + is.null(dcf[["RemoteType"]]) || + identical(dcf[["RemoteType"]], "standard") + + # only keep relevant fields + extra <- c("Repository", "OS_type") + all <- c( + required, extra, + if (!is_repo) c(remotes, git), + "Requirements", "Hash" + ) + keep <- renv_vector_intersect(all, names(dcf)) + + # return as list + as.list(dcf[keep]) + +} + +renv_snapshot_description_source <- function(dcf) { + + # first, check for a declared remote type + # treat 'standard' remotes as packages installed from a repository + # https://github.com/rstudio/renv/issues/998 + type <- dcf[["RemoteType"]] + repository <- dcf[["Repository"]] + if (identical(type, "standard") && !is.null(repository)) + return(list(Source = "Repository", Repository = repository)) + else if (!is.null(type)) + return(list(Source = alias(type))) + + # packages from Bioconductor are normally tagged with a 'biocViews' entry; + # use that to infer a Bioconductor source + if (!is.null(dcf[["biocViews"]])) + return(list(Source = "Bioconductor")) + + # check for a declared repository + if (!is.null(repository)) + return(list(Source = "Repository", Repository = repository)) + + # check for a valid package name + package <- dcf[["Package"]] + if (is.null(package)) + return(list(Source = "unknown")) + + # if this is running as part of the synchronization check, skip CRAN queries + # https://github.com/rstudio/renv/issues/812 + if (the$project_synchronized_check_running) + return(list(Source = "unknown")) + + # NOTE: this is sort of a hack that allows renv to declare packages which + # appear to be installed from sources, but are actually available on the + # active R package repositories, as though they were retrieved from that + # repository. however, this is often what users intend, especially if + # they haven't configured their repository to tag the packages it makes + # available with the 'Repository:' field in the DESCRIPTION file. + # + # still, this has the awkward side-effect of a package's source potentially + # depending on what repositories happen to be active at the time of snapshot, + # so it'd be nice to tighten up the logic here if possible + # + # NOTE: local sources are also searched here as part of finding the 'latest' + # available package, so we need to handle local packages discovered here + tryCatch( + renv_snapshot_description_source_hack(package, dcf), + error = function(e) list(Source = "unknown") + ) + +} + +renv_snapshot_description_source_hack <- function(package, dcf) { + + # check cellar + for (type in renv_package_pkgtypes()) { + cellar <- renv_available_packages_cellar(type) + if (package %in% cellar$Package) + return(list(Source = "Cellar")) + } + + # check available packages + latest <- catch(renv_available_packages_latest(package)) + if (is.null(latest) || inherits(latest, "error")) + return(list(Source = "unknown")) + + # check version; use unknown if it's too new + if (renv_version_gt(dcf[["Version"]], latest[["Version"]])) + return(list(Source = "unknown")) + + # ok, this package appears to be from a package repository + list(Source = "Repository", Repository = latest[["Repository"]]) + +} + + +# nocov start +renv_snapshot_report_actions <- function(actions, old, new) { + + if (!renv_verbose()) + return(invisible()) + + if (length(actions)) { + lhs <- renv_lockfile_records(old) + rhs <- renv_lockfile_records(new) + renv_pretty_print_records_pair( + "The following package(s) will be updated in the lockfile:", + lhs[names(lhs) %in% names(actions)], + rhs[names(rhs) %in% names(actions)] + ) + } + + oldr <- old$R$Version + newr <- new$R$Version + rdiff <- renv_version_compare(oldr %||% "0", newr %||% "0") + + if (rdiff != 0L) { + n <- max(nchar(names(actions)), 0) + fmt <- paste("-", format("R", width = n), " ", "[%s -> %s]") + msg <- sprintf(fmt, oldr %||% "*", newr %||% "*") + writef( + c("The version of R recorded in the lockfile will be updated:", msg, "") + ) + } + +} +# nocov end + +# compute the package dependencies inferred for a project, +# respecting the snapshot type selected (or currently configured) +# for the associated project +renv_snapshot_dependencies <- function(project, type = NULL, dev = FALSE) { + + type <- type %||% settings$snapshot.type(project = project) + + packages <- dynamic( + list(project = project, type = type, dev = dev), + renv_snapshot_dependencies_impl(project, type, dev) + ) + + if (!renv_tests_running()) + packages <- unique(c(packages, "renv")) + + packages + +} + +renv_snapshot_dependencies_impl <- function(project, type = NULL, dev = FALSE) { + + if (type %in% "all") { + packages <- installed_packages(field = "Package") + return(setdiff(packages, renv_packages_base())) + } + + if (type %in% "custom") { + filter <- renv_snapshot_filter_custom_resolve() + return(filter(project)) + } + + path <- case( + type %in% c("packrat", "implicit") ~ project, + type %in% "explicit" ~ file.path(project, "DESCRIPTION"), + ~ { + fmt <- "internal error: unhandled snapshot type '%s' in %s" + stopf(fmt, type, stringify(sys.call())) + } + ) + + # count the number of files in each directory, so we can report + # to the user if we scanned a folder containing many files + count <- integer() + + packages <- withCallingHandlers( + + renv_dependencies_impl( + path = path, + root = project, + field = "Package", + errors = config$dependency.errors(), + dev = dev + ), + + # require user confirmation to proceed if there's a reported error + renv.dependencies.problems = function(cnd) { + + if (identical(config$dependency.errors(), "ignored")) + return() + + if (interactive() && !proceed()) + cancel() + + }, + + # collect information about folders containing lots of files + renv.dependencies.count = function(cnd) { + count[[cnd$data$path]] <<- cnd$data$count + }, + + # notify the user if we took a long time to discover dependencies + renv.dependencies.elapsed_time = function(cnd) { + + # only relevant for implicit-type snapshots + if (!type %in% c("packrat", "implicit")) + return() + + # check for timeout + elapsed <- cnd$data + limit <- getOption("renv.dependencies.elapsed_time_threshold", default = 10L) + if (elapsed < limit) + return() + + # tally up directories with lots of files + count <- count[order(count)] + count <- count[count >= 200] + + # report to user + lines <- c( + "", + "NOTE: Dependency discovery took %s during snapshot.", + "Consider using .renvignore to ignore files, or switching to explicit snapshots.", + "See `?renv::dependencies` for more information.", + if (length(count)) c( + "", + sprintf("- %s: %s", format(names(count)), nplural("file", count)) + ), + "" + ) + + # force output in this scope + renv_scope_caution(TRUE) + caution(lines, renv_difftime_format(elapsed)) + + } + + ) + + unique(packages) + +} + +# compute package records from the provided library paths, +# normally to be included as part of an renv lockfile +renv_snapshot_packages <- function(packages, libpaths, project) { + + ignored <- c( + renv_packages_base(), + renv_project_ignored_packages(project = project), + if (renv_tests_running()) "renv" + ) + + callback <- function(package, location, project) { + if (nzchar(location) && !package %in% ignored) + return(location) + } + + # expand package dependency tree + paths <- renv_package_dependencies( + packages = packages, + libpaths = libpaths, + callback = callback, + project = project + ) + + # keep only packages with known locations + paths <- convert(filter(paths, is.character), "character") + + # diagnose issues with the scanned packages + paths <- uapply(libpaths, function(library) { + renv_snapshot_library_diagnose( + library = library, + paths = filter(paths, startswith, prefix = library)) + }) + + # now, snapshot the remaining packages + records <- map(paths, renv_snapshot_description) + +} + +renv_snapshot_report_missing <- function(missing, type) { + + missing <- setdiff(missing, "renv") + if (empty(missing)) + return(invisible()) + + preamble <- "The following required packages are not installed:" + + postamble <- c( + "Packages must first be installed before renv can snapshot them.", + if (type %in% "explicit") + "If these packages are no longer required, consider removing them from your DESCRIPTION file." + else + "Use `renv::dependencies()` to see where this package is used in your project." + ) + + caution_bullets( + preamble = preamble, + values = sort(unique(missing)), + postamble = postamble + ) + + # only prompt the user to install if a restart is available + restart <- findRestart("renv_recompute_records") + if (is.null(restart)) + return(invisible()) + + choices <- c( + snapshot = "Snapshot, just using the currently installed packages.", + install = "Install the packages, then snapshot.", + cancel = "Cancel, and resolve the situation on your own." + ) + + choice <- menu(choices, title = "What do you want to do?") + + if (choice == "snapshot") { + # do nothing + } else if (choice == "install") { + install(missing, prompt = FALSE) + invokeRestart(restart) + } else { + cancel() + } + + invisible() + +} + +renv_snapshot_filter_custom_resolve <- function() { + + # check for custom filter + filter <- getOption("renv.snapshot.filter", default = NULL) + if (is.null(filter)) { + fmt <- "snapshot of type '%s' requested, but '%s' is not registered" + stopf(fmt, "custom", "renv.snapshot.filter") + } + + # allow for filter naming a function to use + if (is.character(filter)) + filter <- eval(parse(text = filter), envir = baseenv()) + + # check we got a function + if (!is.function(filter)) { + fmt <- "snapshot of type '%s' requested, but '%s' is not a function" + stopf(fmt, "custom", "renv.snapshot.filter") + } + + # return resolved function + filter + +} + +renv_snapshot_fixup <- function(records) { + + records <- renv_snapshot_fixup_renv(records) + records + +} + +renv_snapshot_fixup_renv <- function(records) { + + # don't run when testing renv + if (renv_tests_running()) + return(records) + + # check for an existing valid record + record <- records$renv + if (is.null(record)) + return(records) + + source <- renv_record_source(record) + if (source != "unknown") + return(records) + + # no valid record available; construct a synthetic one + remote <- renv_metadata_remote() + + # add it to the set of records + records$renv <- renv_remotes_resolve(remote) + + # return it + records + +} + +renv_snapshot_reprex <- function(lockfile) { + + fmt <- "Lockfile generated by renv %s." + version <- sprintf(fmt, renv_metadata_version_friendly()) + + text <- c( + "
", + "Lockfile", + "```", + renv_lockfile_write(lockfile, file = NULL), + "```", + version, + "
" + ) + + output <- paste(text, collapse = "\n") + class(output) <- "knit_asis" + attr(output, "knit_cacheable") <- NA + + output + +} + +renv_snapshot_successful <- function(records, prompt, project) { + + # update snapshot flag + the$auto_snapshot_failed <- FALSE + + # perform python snapshot on success + renv_python_snapshot(project, prompt) + + # return generated records + invisible(records) + +} + + +# socket.R ------------------------------------------------------------------- + + +# avoid R CMD check errors with older R +if (getRversion() < "4.0") { + utils::globalVariables(c("serverSocket", "socketAccept")) +} + +renv_socket_server <- function(min = 49152, max = 65535) { + + # create the socket server + port <- socket <- NULL + for (i in 1:2000) catch({ + port <- sample(min:max, size = 1L) + socket <- serverSocket(port) + break + }) + + # if we still don't have a socket here, we failed + if (is.null(socket)) + stop("error creating socket server: couldn't find open port") + + # return information about the server + list( + socket = socket, + port = port, + pid = Sys.getpid() + ) +} + +renv_socket_connect <- function(port, open, timeout = getOption("timeout")) { + socketConnection( + host = "127.0.0.1", + port = port, + open = open, + blocking = TRUE, + encoding = "native.enc", + timeout = timeout + ) +} + +renv_socket_accept <- function(socket, open, timeout = getOption("timeout")) { + socketAccept( + socket = socket, + open = open, + blocking = TRUE, + encoding = "native.enc", + timeout = timeout + ) +} + + +# stack.R -------------------------------------------------------------------- + + +stack <- function(mode = "list") { + + .data <- list() + storage.mode(.data) <- mode + + list( + + push = function(...) { + dots <- list(...) + for (data in dots) { + if (is.null(data)) + .data[length(.data) + 1] <<- list(NULL) + else + .data[[length(.data) + 1]] <<- data + } + }, + + pop = function() { + item <- .data[[length(.data)]] + length(.data) <<- length(.data) - 1 + item + }, + + peek = function() { + .data[[length(.data)]] + }, + + contains = function(data) { + data %in% .data + }, + + empty = function() { + length(.data) == 0 + }, + + get = function(index) { + if (index <= length(.data)) .data[[index]] + }, + + set = function(index, value) { + .data[[index]] <<- value + }, + + clear = function() { + .data <<- list() + }, + + data = function() { + .data + } + + ) + +} + + +# status.R ------------------------------------------------------------------- + + +the$status_running <- FALSE + +#' Report inconsistencies between lockfile, library, and dependencies +#' +#' @description +#' `renv::status()` reports issues caused by inconsistencies across the project +#' lockfile, library, and [dependencies()]. In general, you should strive to +#' ensure that `status()` reports no issues, as this maximises your chances of +#' successfully `restore()`ing the project in the future or on another machine. +#' +#' `renv::load()` will report if any issues are detected when starting an +#' renv project; we recommend resolving these issues before doing any +#' further work on your project. +#' +#' See the headings below for specific advice on resolving any issues +#' revealed by `status()`. +#' +#' # Missing packages +#' +#' `status()` first checks that all packages used by the project are installed. +#' This must be done first because if any packages are missing we can't tell for +#' sure that a package isn't used; it might be a dependency that we don't know +#' about. Once you have resolve any installation issues, you'll need to run +#' `status()` again to reveal the next set of potential problems. +#' +#' There are four possibilities for an uninstalled package: +#' +#' * If it's used and recorded, call `renv::restore()` to install the version +#' specified in the lockfile. +#' * If it's used and not recorded, call `renv::install()` to install it +#' from CRAN or elsewhere. +#' * If it's not used and recorded, call `renv::snapshot()` to +#' remove it from the lockfile. +#' * If it's not used and not recorded, there's nothing to do. This the most +#' common state because you only use a small fraction of all available +#' packages in any one project. +#' +#' If you have multiple packages in an inconsistent state, we recommend +#' `renv::restore()`, then `renv::install()`, then `renv::snapshot()`, but +#' that also suggests you should be running status more frequently. +#' +#' # Lockfile vs `dependencies()` +#' +#' Next we need to ensure that packages are recorded in the lockfile if and +#' only if they are used by the project. Fixing issues of this nature only +#' requires calling `snapshot()` because there are four possibilities for +#' a package: +#' +#' * If it's used and recorded, it's ok. +#' * If it's used and not recorded, call `renv::snapshot()` to add it to the +#' lockfile. +#' * If it's not used but is recorded, call `renv::snapshot()` to remove +#' it from the lockfile. +#' * If it's not used and not recorded, it's also ok, as it may be a +#' development dependency. +#' +#' # Out-of-sync sources +#' +#' The final issue to resolve is any inconsistencies between the version of +#' the package recorded in the lockfile and the version installed in your +#' library. To fix these issues you'll need to either call `renv::restore()` +#' or `renv::snapshot()`: +#' +#' * Call `renv::snapshot()` if your project code is working. This implies that +#' the library is correct and you need to update your lockfile. +#' * Call `renv::restore()` if your project code isn't working. This probably +#' implies that you have the wrong package versions installed and you need +#' to restore from known good state in the lockfile. +#' +#' If you're not sure which case applies, it's generally safer to call +#' `renv::snapshot()`. If you want to rollback to an earlier known good +#' status, see [renv::history()] and [renv::revert()]. +#' +#' @inherit renv-params +#' +#' @param library The library paths. By default, the library paths associated +#' with the requested project are used. +#' +#' @param sources Boolean; check that each of the recorded packages have a +#' known installation source? If a package has an unknown source, renv +#' may be unable to restore it. +#' +#' @param cache Boolean; perform diagnostics on the global package cache? +#' When `TRUE`, renv will validate that the packages installed into the +#' cache are installed at the expected + proper locations, and validate the +#' hashes used for those storage locations. +#' +#' @inheritParams dependencies +#' +#' @return This function is normally called for its side effects, but +#' it invisibly returns a list containing the following components: +#' +#' * `library`: packages in your library. +#' * `lockfile`: packages in the lockfile. +#' * `synchronized`: are the library and lockfile in sync? +#' +#' @export +#' +#' @example examples/examples-init.R +status <- function(project = NULL, + ..., + library = NULL, + lockfile = NULL, + sources = TRUE, + cache = FALSE, + dev = FALSE) +{ + renv_scope_error_handler() + renv_dots_check(...) + + renv_snapshot_auto_suppress_next() + renv_scope_options(renv.prompt.enabled = FALSE) + + the$status_running <- TRUE + defer(the$status_running <- FALSE) + + project <- renv_project_resolve(project) + renv_project_lock(project = project) + + # check to see if we've initialized this project + if (!renv_status_check_initialized(project, library, lockfile)) { + result <- list( + library = list(Packages = named(list())), + lockfile = list(Packages = named(list())), + synchronized = FALSE + ) + return(invisible(result)) + } + + libpaths <- library %||% renv_libpaths_resolve() + lockpath <- lockfile %||% renv_paths_lockfile(project = project) + + # get all dependencies, including transitive + dependencies <- renv_snapshot_dependencies(project, dev = dev) + packages <- sort(union(dependencies, "renv")) + paths <- renv_package_dependencies(packages, libpaths = libpaths, project = project) + packages <- as.character(names(paths)) + + # read project lockfile + lockfile <- if (file.exists(lockpath)) + renv_lockfile_read(lockpath) + else + renv_lockfile_init(project = project) + + # get lockfile capturing current library state + library <- renv_lockfile_create( + libpaths = libpaths, + type = "all", + prompt = FALSE, + project = project + ) + + # remove ignored packages + ignored <- c( + renv_project_ignored_packages(project), + renv_packages_base(), + if (renv_tests_running()) "renv" + ) + + packages <- setdiff(packages, ignored) + renv_lockfile_records(lockfile) <- exclude(renv_lockfile_records(lockfile), ignored) + renv_lockfile_records(library) <- exclude(renv_lockfile_records(library), ignored) + + synchronized <- + renv_status_check_consistent(lockfile, library, packages) && + renv_status_check_synchronized(lockfile, library) + + if (sources) { + synchronized <- synchronized && + renv_status_check_unknown_sources(project, lockfile) + } + + if (cache) + renv_status_check_cache(project) + + if (synchronized) + writef("No issues found -- the project is in a consistent state.") + else + writef(c("", "See ?renv::status() for advice on resolving these issues.")) + + result <- list( + library = library, + lockfile = lockfile, + synchronized = synchronized + ) + + invisible(result) + +} + +renv_status_check_unknown_sources <- function(project, lockfile) { + renv_check_unknown_source(renv_lockfile_records(lockfile), project) +} + +renv_status_check_consistent <- function(lockfile, library, used) { + + lockfile <- renv_lockfile_records(lockfile) + library <- renv_lockfile_records(library) + + packages <- sort(unique(c(names(library), names(lockfile), used))) + + status <- data.frame( + package = packages, + installed = packages %in% names(library), + recorded = packages %in% names(lockfile), + used = packages %in% used + ) + + ok <- status$installed & (status$used == status$recorded) + if (all(ok)) + return(TRUE) + + if (renv_verbose()) { + # If any packages are not installed, we don't know for sure what's used + # because our dependency graph is incomplete + issues <- status[!ok, , drop = FALSE] + missing <- !issues$installed + issues$installed <- ifelse(issues$installed, "y", "n") + issues$recorded <- ifelse(issues$recorded, "y", "n") + issues$used <- ifelse(issues$used, "y", if (any(missing)) "?" else "n") + + if (any(missing)) { + msg <- "The following package(s) are missing:" + issues <- issues[missing, ] + } else { + msg <- "The following package(s) are in an inconsistent state:" + } + writef(msg) + writef() + print(issues, row.names = FALSE, right = FALSE) + } + + FALSE + +} + +renv_status_check_initialized <- function(project, library = NULL, lockfile = NULL) { + + # only done if library and lockfile are NULL; that is, if the user + # is calling `renv::status()` without arguments + if (!is.null(library) || !is.null(lockfile)) + return(TRUE) + + # resolve paths to lockfile, primary library path + library <- library %||% renv_paths_library(project = project) + lockfile <- lockfile %||% renv_paths_lockfile(project = project) + + # check whether the lockfile + library exist + haslib <- all(file.exists(library)) + haslock <- file.exists(lockfile) + if (haslib && haslock) + return(TRUE) + + # TODO: what about the case where the library exists but no packages are installed? + # TODO: should this check for an 'renv/activate.R' script? + # TODO: what if a different project is loaded? + if (haslib && !haslock) { + writef(c( + "This project does not contain a lockfile.", + "Use `renv::snapshot()` to create a lockfile." + )) + } else if (!haslib && haslock) { + writef(c( + "There are no packages installed in the project library.", + "Use `renv::restore()` to install the packages defined in lockfile." + )) + } else { + writef(c( + "This project does not appear to be using renv.", + "Use `renv::init()` to initialize the project." + )) + } + + FALSE + +} + +renv_status_check_synchronized <- function(lockfile, library) { + + lockfile <- renv_lockfile_records(lockfile) + library <- renv_lockfile_records(library) + + actions <- renv_lockfile_diff_packages(lockfile, library) + rest <- c("upgrade", "downgrade", "crossgrade") + + if (all(!rest %in% actions)) { + return(TRUE) + } + + pkgs <- names(actions[actions %in% rest]) + renv_pretty_print_records_pair( + preamble = "The following package(s) are out of sync [lockfile -> library]:", + lockfile[pkgs], + library[pkgs], + ) + + FALSE + +} + +renv_status_check_cache <- function(project) { + + if (renv_cache_config_enabled(project = project)) + renv_cache_diagnose() + +} + + + +# system.R ------------------------------------------------------------------- + + +renv_system_exec <- function(command, + args = NULL, + action = "executing command", + success = 0L, + stream = FALSE, + quiet = NULL) +{ + # be quiet when running tests by default + quiet <- quiet %||% renv_tests_running() + + # handle 'stream' specially + if (stream) { + + # form stdout, stderr + stdout <- stderr <- if (quiet) FALSE else "" + + # execute command + status <- suppressWarnings( + if (is.null(args)) + system(command, ignore.stdout = quiet, ignore.stderr = quiet) + else + system2(command, args, stdout = stdout, stderr = stderr) + ) + + # check for error + status <- status %||% 0L + if (!is.null(success) && !status %in% success) { + fmt <- "error %s [error code %i]" + stopf(fmt, action, status) + } + + # return status code + return(status) + + } + + # suppress warnings as some successful commands may return a non-zero exit + # code, whereas R will always warn on such error codes + output <- suppressWarnings( + if (is.null(args)) + system(command, intern = TRUE) + else + system2(command, args, stdout = TRUE, stderr = TRUE) + ) + + # extract status code from result + status <- attr(output, "status") %||% 0L + + # if this status matches an expected 'success' code, return output + if (is.null(success) || status %in% success) + return(output) + + # otherwise, notify the user that things went wrong + abort( + sprintf("error %s [error code %i]", action, status), + body = renv_system_exec_details(command, args, output) + ) + +} + +renv_system_exec_details <- function(command, args, output) { + + # get header, giving the command that was run + cmdline <- paste(command, paste(args, collapse = " ")) + underline <- paste(rep.int("=", min(80L, nchar(cmdline))), collapse = "") + header <- c(cmdline, underline) + + # truncate output (avoid overwhelming console) + body <- if (length(output) > 200L) + c(head(output, n = 100L), "< ... >", tail(output, n = 100L)) + else + output + + c(header, "", body) + +} + + +# tar.R ---------------------------------------------------------------------- + + +renv_tar_exe <- function() { + + # allow override + tar <- getOption("renv.tar.exe") + if (!is.null(tar)) + return(tar) + + # on unix, just use default + if (renv_platform_unix()) + return(Sys.which("tar")) + + # on Windows, use system tar.exe if available + root <- Sys.getenv("SystemRoot", unset = NA) + if (is.na(root)) + root <- "C:/Windows" + + # use tar if it exists + tarpath <- file.path(root, "System32/tar.exe") + if (file.exists(tarpath)) + return(tarpath) + + # otherwise, give up (don't trust the arbitrary tar on PATH) + "" + +} + +renv_tar_decompress <- function(tar, archive, files = NULL, exdir = ".", ...) { + + # build argument list + args <- c( + "xf", renv_shell_path(archive), + if (!identical(exdir, ".")) + c("-C", renv_shell_path(exdir)), + if (length(files)) + renv_shell_path(files) + ) + + # make sure exdir exists + ensure_directory(exdir) + + # perform decompress + return(renv_system_exec(tar, args, action = "decompressing archive")) + +} + + +# task.R --------------------------------------------------------------------- + + +renv_task_create <- function(callback, name = NULL) { + + # create name for task callback + name <- name %||% as.character(substitute(callback)) + name <- paste("renv", name, sep = ":::") + + # remove an already-existing task of the same name + removeTaskCallback(name) + + # otherwise, add our new task + addTaskCallback( + renv_task_callback(callback, name), + name = name + ) + +} + +renv_task_callback <- function(callback, name) { + + force(callback) + force(name) + + function(...) { + + status <- tryCatch(callback(), error = identity) + if (inherits(status, "error")) { + caution("Error in background task '%s': %s", name, conditionMessage(status)) + caution("Background task '%s' will be stopped.", name) + return(FALSE) + } + + TRUE + + } + +} + +renv_task_unload <- function() { + callbacks <- getTaskCallbackNames() + for (callback in callbacks) + for (prefix in c("renv_", "renv:::")) + if (startswith(callback, prefix)) + removeTaskCallback(callback) +} + + +# template.R ----------------------------------------------------------------- + + +renv_template_create <- function(template) { + gsub("^\\n+|\\n+$", "", template) +} + +renv_template_replace <- function(text, replacements, format = "${%s}") { + + enumerate(replacements, function(key, value) { + key <- sprintf(format, key) + text <<- gsub(key, value, text, fixed = TRUE) + }) + + text + +} + + +# tests.R -------------------------------------------------------------------- + + +the$tests_root <- NULL + +# NOTE: Prefer using 'testing()' to 'renv_tests_running()' for behavior +# that should apply regardless of the package currently being tested. +# +# renv_tests_running() is appropriate when running renv's own tests. +renv_tests_running <- function() { + getOption("renv.tests.running", default = FALSE) +} + +renv_test_code <- function(code, data = list(), fileext = ".R", scope = parent.frame()) { + code <- do.call(substitute, list(substitute(code), data)) + file <- renv_scope_tempfile("renv-code-", fileext = fileext, scope = scope) + + writeLines(deparse(code), con = file) + file +} + +renv_test_retrieve <- function(record) { + + renv_scope_error_handler() + + # avoid using cache + cache <- renv_scope_tempfile() + renv_scope_envvars(RENV_PATHS_CACHE = cache) + + # construct records + package <- record$Package + records <- list(record) + names(records) <- package + + # prepare dummy library + templib <- renv_scope_tempfile("renv-library-") + ensure_directory(templib) + renv_scope_libpaths(c(templib, .libPaths())) + + # attempt a restore into that library + renv_scope_restore( + project = getwd(), + library = templib, + records = records, + packages = package, + recursive = TRUE + ) + + records <- retrieve(record$Package) + renv_install_impl(records) + + descpath <- file.path(templib, package) + if (!file.exists(descpath)) + stopf("failed to retrieve package '%s'", package) + + desc <- renv_description_read(descpath) + fields <- grep("^Remote", names(record), value = TRUE) + + testthat::expect_identical( + as.list(desc[fields]), + as.list(record[fields]) + ) + +} + +renv_tests_diagnostics <- function() { + + # print library paths + caution_bullets( + "The following R libraries are set:", + paste("-", .libPaths()) + ) + + # print repositories + repos <- getOption("repos") + caution_bullets( + "The following repositories are set:", + paste(names(repos), repos, sep = ": ") + ) + + # print renv root + caution_bullets( + "The following renv root directory is being used:", + paste("-", paths$root()) + ) + + # print cache root + caution_bullets( + "The following renv cache directory is being used:", + paste("-", paths$cache()) + ) + + writeLines("The following packages are available in the test repositories:") + + dbs <- + available_packages(type = "source", quiet = TRUE) %>% + map(function(db) { + rownames(db) <- NULL + db[c("Package", "Version", "File")] + }) + + print(dbs) + + path <- Sys.getenv("PATH") + splat <- strsplit(path, .Platform$path.sep, fixed = TRUE)[[1]] + + caution_bullets( + "The following PATH is set:", + paste("-", splat) + ) + + envvars <- c( + grep("^_R_", names(Sys.getenv()), value = TRUE), + "HOME", + "R_ARCH", "R_HOME", + "R_LIBS", "R_LIBS_SITE", "R_LIBS_USER", "R_USER", + "R_ZIPCMD", + "TAR", "TEMP", "TMP", "TMPDIR" + ) + + keys <- format(envvars) + vals <- Sys.getenv(envvars, unset = "") + vals[vals != ""] <- renv_json_quote(vals[vals != ""]) + + caution_bullets( + "The following environment variables of interest are set:", + paste(keys, vals, sep = " : ") + ) + +} + +renv_tests_root <- function() { + the$tests_root <- the$tests_root %||% { + renv_path_normalize(testthat::test_path(".")) + } +} + +renv_tests_path <- function(path = NULL) { + + # special case for NULL path + if (is.null(path)) + return(renv_tests_root()) + + # otherwise, form path from root + file.path(renv_tests_root(), path) + +} + +renv_tests_supported <- function() { + + # supported when running locally + on CI + for (envvar in c("NOT_CRAN", "CI")) + if (renv_envvar_exists(envvar)) + return(TRUE) + + # disabled on older macOS releases (credentials fails to load) + if (renv_platform_macos() && getRversion() < "4.0.0") + return(FALSE) + + # disabled on Windows + if (renv_platform_windows()) + return(FALSE) + + # true otherwise + TRUE + +} + + +# testthat-helpers.R --------------------------------------------------------- + + +expect_same_elements <- function(lhs, rhs) { + + if (!requireNamespace("testthat", quietly = TRUE)) + stop("testthat not available for testing") + + if (is.list(lhs) && is.list(rhs)) { + lhs <- lhs[order(names(lhs))] + rhs <- rhs[order(names(rhs))] + return(testthat::expect_equal(!!lhs, !!rhs)) + } + + if (packageVersion("testthat") > "2.2.0") + testthat::expect_setequal(!!lhs, !!rhs) + else + testthat::expect_setequal(lhs, rhs) + +} + + +# truthy.R ------------------------------------------------------------------- + + +truthy <- function(value, default = FALSE) { + + # https://github.com/rstudio/renv/issues/1558 + if (is.call(value)) { + value <- tryCatch(renv_dependencies_eval(value), error = identity) + if (inherits(value, "error")) + return(default) + } + + if (length(value) == 0) + default + else if (is.character(value)) + value %in% c("TRUE", "True", "true", "T", "1") + else if (is.symbol(value)) + as.character(value) %in% c("TRUE", "True", "true", "T", "1") + else if (is.na(value)) + default + else + as.logical(value) +} + + +# type.R --------------------------------------------------------------------- + + +renv_type_check <- function(value, type) { + + # quietly convert NAs to requested type + if (is.null(value) || is.na(value)) + return(convert(value, type)) + + # if the value already matches the expected type, return success + if (inherits(value, type)) + return(value) + + # create error object + fmt <- "parameter '%s' is not of expected type '%s'" + msg <- sprintf(fmt, deparse(substitute(value)), type) + error <- simpleError(msg, sys.call(sys.parent())) + + # report error + stop(error) + +} + +renv_type_unexpected <- function(value) { + fmt <- "parameter '%s' has unexpected type '%s'" + msg <- sprintf(fmt, deparse(substitute(value)), typeof(value)) + error <- simpleError(msg, sys.call(sys.parent())) + stop(error) +} + + +# unload.R ------------------------------------------------------------------- + + +unload <- function(project = NULL, quiet = FALSE) { + + project <- renv_project_resolve(project) + renv_scope_error_handler() + + if (renv_tests_running()) + return() + + if (quiet) + renv_scope_options(renv.verbose = FALSE) + + renv_envvars_restore() + + renv_unload_shims(project) + renv_unload_project(project) + renv_unload_profile(project) + renv_unload_envvars(project) + renv_unload_sandbox(project) + renv_unload_libpaths(project) + +} + +renv_unload_shims <- function(project) { + renv_shims_deactivate() +} + +renv_unload_project <- function(project) { + renv_project_clear() +} + +renv_unload_profile <- function(project) { + Sys.unsetenv("RENV_PROFILE") +} + +renv_unload_envvars <- function(project) { + renv_envvars_restore() +} + +renv_unload_sandbox <- function(project) { + renv_sandbox_deactivate() +} + +renv_unload_libpaths <- function(project) { + renv_libpaths_restore() +} + +renv_unload_finalizer <- function(libpath) { + libpath <- dirname(renv_namespace_path(.packageName)) + .onUnload(libpath) +} + + +# update.R ------------------------------------------------------------------- + + +the$update_errors <- new.env(parent = emptyenv()) + +renv_update_find_repos <- function(records) { + + results <- lapply(records, function(record) { + catch(renv_update_find_repos_impl(record)) + }) + + failed <- map_lgl(results, inherits, "error") + if (any(failed)) + renv_update_errors_set("repos", results[failed]) + + results[!failed] + +} + +renv_update_find_repos_impl <- function(record) { + + # retrieve latest-available package + package <- record$Package + latest <- catch(renv_available_packages_latest(package)) + if (inherits(latest, "error")) + return(NULL) + + # validate our versions + if (empty(latest$Version) || empty(record$Version)) + return(NULL) + + # compare the versions; return NULL if the 'latest' version + # is older + compare <- renv_version_compare(latest$Version, record$Version) + if (compare != 1L) + return(NULL) + + latest + +} + +renv_update_find_git <- function(records) { + renv_parallel_exec(records, renv_update_find_git_impl) +} + +renv_update_find_git_impl <- function(record) { + + sha <- renv_remotes_resolve_git_sha_ref(record) + + # if sha is empty: + # `git remote-ls origin ref` expects ref to be a reference, not a sha + # it is empty if ref isn't a reference on the repo + # this may be due to record$RemoteRef actually being a sha + # or it may be because record$RemoteRef is not a real ref + # but we can't check, so we will try to fetch the ref & see what we get + oldsha <- record$RemoteSha %||% "" + if (nzchar(oldsha) && identical(sha, oldsha)) + return(NULL) + + current <- record + current$RemoteSha <- sha + + desc <- renv_remotes_resolve_git_description(current) + + current$Version <- desc$Version + current$Package <- desc$Package + + updated <- renv_version_ge(current$Version, record$Version) + if (updated) + return(current) + +} + +renv_update_find_github <- function(records) { + + # check for GITHUB_PAT + if (!renv_envvar_exists("GITHUB_PAT")) { + + msg <- paste( + "GITHUB_PAT is unset. Updates may fail due to GitHub's API rate limit.", + "", + "To increase your GitHub API rate limit:", + "- Use `usethis::browse_github_pat()` to create a Personal Access Token (PAT).", + "- Use `usethis::edit_r_environ()` and add the token as `GITHUB_PAT`.", + sep = "\n" + ) + + warning(msg, call. = FALSE) + + } + + names(records) <- map_chr(records, `[[`, "Package") + results <- renv_parallel_exec(records, function(record) { + catch(renv_update_find_github_impl(record)) + }) + + failed <- map_lgl(results, inherits, "error") + if (any(failed)) + renv_update_errors_set("github", results[failed]) + + results[!failed] + +} + +renv_update_find_github_impl <- function(record) { + + # construct and parse record entry + host <- record$RemoteHost %||% config$github.host() + user <- record$RemoteUsername + repo <- record$RemoteRepo + subdir <- record$RemoteSubdir + ref <- record$RemoteRef + + # check for changed sha + sha <- renv_remotes_resolve_github_sha_ref(host, user, repo, ref) + if (sha == record$RemoteSha) + return(NULL) + + # get updated record + desc <- renv_remotes_resolve_github_description(host, user, repo, subdir, sha) + current <- list( + Package = desc$Package, + Version = desc$Version, + Source = "GitHub", + RemoteUsername = user, + RemoteRepo = repo, + RemoteSubdir = subdir, + RemoteRef = ref, + RemoteSha = sha, + RemoteHost = host + ) + + # check that the version has actually updated + updated <- + current$RemoteSha != record$RemoteSha && + numeric_version(current$Version) >= numeric_version(record$Version) + + if (updated) + return(current) + +} + + +renv_update_find_remote <- function(records, type) { + + update <- switch(type, + "gitlab" = renv_remotes_resolve_gitlab, + "bitbucket" = renv_remotes_resolve_bitbucket, + stopf("Unsupported type %s", type) + ) + + names(records) <- map_chr(records, `[[`, "Package") + results <- renv_parallel_exec(records, function(record) { + catch(renv_update_find_remote_impl(record, update)) + }) + + failed <- map_lgl(results, inherits, "error") + if (any(failed)) + renv_update_errors_set(type, results[failed]) + + results[!failed] + +} + +renv_update_find_remote_impl <- function(record, update) { + + remote <- list( + host = record$RemoteHost, + user = record$RemoteUsername, + repo = record$RemoteRepo, + ref = record$RemoteRef + ) + current <- update(remote) + + # check that the version has actually updated + updated <- + current$RemoteSha != record$RemoteSha && + numeric_version(current$Version) >= numeric_version(record$Version) + + if (updated) + return(current) + +} + + +renv_update_find <- function(records) { + + sources <- extract_chr(records, "Source") + grouped <- split(records, sources) + + # retrieve updates + results <- enumerate(grouped, function(source, records) { + case( + source == "Bioconductor" ~ renv_update_find_repos(records), + source == "Repository" ~ renv_update_find_repos(records), + source == "GitHub" ~ renv_update_find_github(records), + source == "Git" ~ renv_update_find_git(records), + source == "GitLab" ~ renv_update_find_remote(records, "gitlab"), + source == "Bitbucket" ~ renv_update_find_remote(records, "bitbucket") + ) + }) + + # remove groupings + ungrouped <- unlist(results, recursive = FALSE, use.names = FALSE) + if (empty(ungrouped)) + return(list()) + + # keep non-null results + updates <- Filter(Negate(is.null), ungrouped) + if (empty(updates)) + return(list()) + + names(updates) <- extract_chr(updates, "Package") + renv_records_sort(updates) + +} + + + +#' Update packages +#' +#' @description +#' Update packages which are currently out-of-date. Currently supports CRAN, +#' Bioconductor, other CRAN-like repositories, GitHub, GitLab, Git, and +#' BitBucket. +#' +#' Updates will only be checked from the same source -- for example, +#' if a package was installed from GitHub, but a newer version is +#' available on CRAN, that updated version will not be seen. +#' +#' @inherit renv-params +#' +#' @param packages A character vector of \R packages to update. When `NULL` +#' (the default), all packages (apart from any listed in the `ignored.packages` +#' project setting) will be updated. +#' +#' @param check Boolean; check for package updates without actually +#' installing available updates? This is useful when you'd like to determine +#' what updates are available, without actually installing those updates. +#' +#' @param exclude A set of packages to explicitly exclude from updating. +#' Use `renv::update(exclude = <...>)` to update all packages except for +#' a specific set of excluded packages. +#' +#' @return A named list of package records which were installed by renv. +#' +#' @export +#' +#' @examples +#' \dontrun{ +#' +#' # update the 'dplyr' package +#' renv::update("dplyr") +#' +#' } +update <- function(packages = NULL, + ..., + exclude = NULL, + library = NULL, + rebuild = FALSE, + check = FALSE, + prompt = interactive(), + project = NULL) +{ + renv_consent_check() + renv_scope_error_handler() + renv_dots_check(...) + + project <- renv_project_resolve(project) + renv_project_lock(project = project) + renv_scope_verbose_if(prompt) + + # resolve library path + libpaths <- renv_libpaths_resolve(library) + library <- nth(libpaths, 1L) + renv_scope_libpaths(libpaths) + + # resolve exclusions + exclude <- c(exclude, settings$ignored.packages(project = project)) + + # if users have requested the use of pak, delegate there + if (config$pak.enabled() && !recursing()) { + packages <- setdiff(packages, exclude) + renv_pak_init() + return(renv_pak_install(packages, libpaths, project)) + } + + # get package records + renv_scope_binding(the, "snapshot_hash", FALSE) + records <- renv_snapshot_libpaths(libpaths = libpaths, project = project) + packages <- packages %||% names(records) + + # apply exclusions + packages <- setdiff(packages, exclude) + + # check if the user has requested update for packages not installed + missing <- renv_vector_diff(packages, names(records)) + if (!empty(missing)) { + + if (prompt || renv_verbose()) { + caution_bullets( + "The following package(s) are not currently installed:", + missing, + "The latest available versions of these packages will be installed instead." + ) + } + + cancel_if(prompt && !proceed()) + + } + + # select records + selected <- c( + records[renv_vector_intersect(packages, names(records))], + named(lapply(missing, renv_available_packages_latest), missing) + ) + + # check for usage of cran, bioc + repo <- FALSE + bioc <- FALSE + + for (record in selected) { + + source <- renv_record_source(record, normalize = TRUE) + + if (source %in% c("repository")) { + repo <- TRUE + next + } + + if (source %in% c("bioconductor")) { + repo <- bioc <- TRUE + next + } + + } + + # activate bioc repositories if needed + if (bioc) + renv_scope_bioconductor(project = project) + + # ensure database of available packages is current + if (repo) { + for (type in renv_package_pkgtypes()) { + available_packages(type = type) + } + } + + printf("- Checking for updated packages ... ") + + # remove records that appear to be from an R package repository, + # but are not actually available in the current repositories + selected <- filter(selected, function(record) { + + source <- renv_record_source(record, normalize = TRUE) + if (!source %in% c("bioconductor", "cran", "repository")) + return(TRUE) + + # check for available package + package <- record$Package + entry <- catch(renv_available_packages_latest(package)) + !inherits(entry, "error") + + }) + + updates <- renv_update_find(selected) + writef("Done!") + + renv_update_errors_emit() + + if (empty(updates)) { + writef("- All packages appear to be up-to-date.") + return(invisible(TRUE)) + } + + # perform a diff (for reporting to user) + old <- selected[names(updates)] + new <- updates + diff <- renv_lockfile_diff_packages(old, new) + + # if we're only checking for updates, just report and exit + if (check) { + + fmt <- case( + length(diff) == 1 ~ "- %i package has updates available.", + length(diff) != 1 ~ "- %i packages have updates available." + ) + + preamble <- sprintf(fmt, length(diff)) + renv_updates_report(preamble, diff, old, new) + return(invisible(renv_updates_create(diff, old, new))) + + } + + if (prompt || renv_verbose()) { + renv_restore_report_actions(diff, old, new) + cancel_if(prompt && !proceed()) + } + + # perform the install + install( + packages = updates, + library = libpaths, + rebuild = rebuild, + prompt = prompt, + project = project + ) + +} + +renv_update_errors_set <- function(key, errors) { + assign(key, errors, envir = the$update_errors) +} + +renv_update_errors_clear <- function() { + rm( + list = ls(envir = the$update_errors, all.names = TRUE), + envir = the$update_errors + ) +} + +renv_update_errors_emit <- function() { + + # clear errors when we're done + defer(renv_update_errors_clear()) + + # if we have any errors, start by emitting a single newline + all <- ls(envir = the$update_errors, all.names = TRUE) + if (!empty(all)) + writef() + + # then emit errors for each class + renv_update_errors_emit_repos() + renv_update_errors_emit_remote("github", "GitHub") + renv_update_errors_emit_remote("gitlab", "GitLab") + renv_update_errors_emit_remote("bitbucket", "BitBucket") + +} + +renv_update_errors_emit_impl <- function(key, preamble, postamble) { + + errors <- the$update_errors[[key]] + if (empty(errors)) + return() + + messages <- enumerate(errors, function(package, error) { + errmsg <- paste(conditionMessage(error), collapse = "; ") + sprintf("%s: %s", format(package), errmsg) + }) + + caution_bullets( + preamble = preamble, + values = messages, + postamble = postamble + ) + +} + +renv_update_errors_emit_repos <- function() { + + renv_update_errors_emit_impl( + key = "repos", + preamble = "One or more errors occurred while finding updates for the following packages:", + postamble = "Ensure that these packages are available from your active package repositories." + ) + +} + +renv_update_errors_emit_remote <- function(key, label) { + + renv_update_errors_emit_impl( + key = key, + preamble = sprintf("One or more errors occurred while finding updates for the following %s packages:", label), + postamble = sprintf("Ensure that these packages were installed from an accessible %s remote.", label) + ) + +} + + + +# updates.R ------------------------------------------------------------------ + + +renv_updates_create <- function(diff, old, new) { + structure( + list(diff = diff, old = old, new = new), + class = "renv_updates" + ) +} + +renv_updates_report <- function(preamble, diff, old, new) { + + lhs <- renv_lockfile_records(old) + rhs <- renv_lockfile_records(new) + renv_pretty_print_records_pair( + preamble, + lhs[names(lhs) %in% names(diff)], + rhs[names(rhs) %in% names(diff)] + ) + +} + + +# upgrade.R ------------------------------------------------------------------ + + +#' Upgrade renv +#' +#' @description +#' Upgrade the version of renv associated with a project, including using +#' a development version from GitHub. Automatically snapshots the update +#' renv, updates the activate script, and restarts R. +#' +#' If you want to update all packages (including renv) to their latest CRAN +#' versions, use [renv::update()]. +#' +#' @inherit renv-params +#' +#' @param version The version of renv to be installed. +#' +#' When `NULL` (the default), the latest version of renv will be installed as +#' available from CRAN (or whatever active package repositories are active) +#' Alternatively, you can install the latest development version with +#' `"main"`, or a specific commit with a SHA, e.g. `"5049cef8a"`. +#' +#' @param prompt Boolean; prompt upgrade before proceeding? +#' +#' @param reload Boolean; reload renv after install? When `NULL` (the +#' default), renv will be re-loaded only if updating renv for the +#' active project. Since it's not possible to guarantee a clean reload +#' in the current session, this will attempt to restart your R session. +#' +#' @return A boolean value, indicating whether the requested version of +#' renv was successfully installed. Note that this function is normally +#' called for its side effects. +#' +#' @export +#' +#' @examples +#' \dontrun{ +#' +#' # upgrade to the latest version of renv +#' renv::upgrade() +#' +#' # upgrade to the latest version of renv on GitHub (development version) +#' renv::upgrade(version = "main") +#' +#' } +upgrade <- function(project = NULL, + version = NULL, + reload = NULL, + prompt = interactive()) +{ + renv_scope_error_handler() + renv_scope_verbose_if(prompt) + invisible(renv_upgrade_impl(project, version, reload, prompt)) +} + +renv_upgrade_impl <- function(project, version, reload, prompt) { + + project <- renv_project_resolve(project) + renv_project_lock(project = project) + + reload <- reload %||% renv_project_loaded(project) + + lockfile <- renv_lockfile_load(project) + old <- lockfile$Packages$renv + new <- renv_upgrade_find_record(version) + + # check for some form of change + if (renv_records_equal(old, new)) { + fmt <- "- renv [%s] is already installed and active for this project." + writef(fmt, renv_metadata_version_friendly()) + return(FALSE) + } + + if (prompt || renv_verbose()) { + renv_pretty_print_records_pair( + "A new version of the renv package will be installed:", + list(renv = old), + list(renv = new), + "This project will use the newly-installed version of renv." + ) + } + + cancel_if(prompt && !proceed()) + + renv_scope_restore( + project = project, + library = renv_libpaths_active(), + records = list(renv = new), + packages = "renv", + recursive = FALSE + ) + + # retrieve and install renv + records <- retrieve("renv") + renv_install_impl(records) + + # update the lockfile + lockfile <- renv_lockfile_load(project = project) + records <- renv_lockfile_records(lockfile) %||% list() + records$renv <- new + renv_lockfile_records(lockfile) <- records + renv_lockfile_save(lockfile, project = project) + + # now update the infrastructure to use this version of renv. + # do this in a separate process to avoid issues that could arise + # if the old version of renv is still loaded + # + # https://github.com/rstudio/renv/issues/1546 + writef("- Updating activate script") + code <- substitute({ + renv <- asNamespace("renv"); renv$summon() + version <- renv_metadata_version_create(record) + renv_infrastructure_write(project, version = version) + }, list(project = project, record = records[["renv"]])) + + script <- renv_scope_tempfile("renv-activate-", fileext = ".R") + writeLines(deparse(code), con = script) + + args <- c("--vanilla", "-s", "-f", renv_shell_path(script)) + r(args, stdout = FALSE, stderr = FALSE) + + if (reload) { + renv_restart_request(project) + } + + invisible(TRUE) + +} + +renv_upgrade_find_record <- function(version) { + + if (is.null(version)) + renv_upgrade_find_record_default() + else + renv_upgrade_find_record_dev(version) + +} + +renv_upgrade_find_record_default <- function() { + + # check if the package is available on R repositories. + # if not, prefer GitHub + record <- catch(renv_available_packages_latest("renv")) + if (inherits(record, "error")) + return(renv_upgrade_find_record_dev()) + + # check the version reported by R repositories. + # if it's older than current renv, then prefer GitHub + version <- record$Version + if (package_version(version) < renv_package_version("renv")) + return(renv_upgrade_find_record_dev()) + + # ok -- install from repository + record + +} + +renv_upgrade_find_record_dev <- function(version = NULL) { + version <- version %||% renv_upgrade_find_record_dev_latest() + entry <- paste("rstudio/renv", version, sep = "@") + renv_remotes_resolve(entry) +} + + +renv_upgrade_find_record_dev_latest <- function() { + + # download tags + url <- "https://api.github.com/repos/rstudio/renv/tags" + destfile <- tempfile("renv-tags-", fileext = ".json") + download(url, destfile = destfile, quiet = TRUE) + json <- renv_json_read(destfile) + + # find latest version + names <- extract_chr(json, "name") + versions <- numeric_version(names, strict = FALSE) + latest <- sort(versions, decreasing = TRUE)[[1]] + names[versions %in% latest][[1L]] + +} + +renv_upgrade_reload <- function() { + + # we need to remove the task callbacks here, as otherwise + # we'll run into trouble trying to remove task callbacks + # within a task callback + renv_task_unload() + + # now define and add a callback to reload renv; use the base namespace + # to avoid carrying along any bits of the current renv environment + callback <- function(...) { + unloadNamespace("renv") + loadNamespace("renv") + invisible(FALSE) + } + + environment(callback) <- baseenv() + + # add the task callback; don't name it so that the renv infrastructure + # doesn't try to remove this callback (it'll resolve and remove itself) + addTaskCallback(callback) + + invisible(TRUE) + +} + + +# url.R ---------------------------------------------------------------------- + + +renv_url_parse <- function(url) { + + pattern <- paste0( + "^", + "([^:]+://)?", # protocol + "([^/?#]+)", # domain + "(?:(/[^?#]*))?", # path + "(?:[?]([^#]+))?", # parameters + "(?:#(.*))?", # fragment + "" + ) + + matches <- regmatches(url, regexec(pattern, url, perl = TRUE))[[1L]] + if (length(matches) != 6L) + stopf("couldn't parse url '%s'", url) + + matches <- as.list(matches) + names(matches) <- c("url", "protocol", "domain", "path", "parameters", "fragment") + + # parse parameters into named list + matches$parameters <- renv_properties_read( + text = chartr("&", "\n", matches$parameters), + delimiter = "=", + dequote = FALSE, + trim = FALSE + ) + + # return parsed URL + matches + +} + + + +# use-python.R --------------------------------------------------------------- + + +#' Use python +#' +#' Associate a version of Python with your project. +#' +#' When Python integration is active, renv will: +#' +#' - Save metadata about the requested version of Python in `renv.lock` -- in +#' particular, the Python version, and the Python type ("virtualenv", "conda", +#' "system"), +#' +#' - Capture the set of installed Python packages during `renv::snapshot()`, +#' +#' - Re-install the set of recorded Python packages during `renv::restore()`. +#' +#' In addition, when the project is loaded, the following actions will be taken: +#' +#' - The `RENV_PYTHON` environment variable will be set, indicating the version +#' of Python currently active for this sessions, +#' +#' - The `RETICULATE_PYTHON` environment variable will be set, so that the +#' reticulate package can automatically use the requested copy of Python +#' as appropriate, +#' +#' - The requested version of Python will be placed on the `PATH`, so that +#' attempts to invoke Python will resolve to the expected version of Python. +#' +#' You can override the version of Python used in a particular project by +#' setting the `RENV_PYTHON` environment variable; e.g. as part of the +#' project's `.Renviron` file. This can be useful if you find that renv +#' is unable to automatically discover a compatible version of Python to +#' be used in the project. +#' +#' @inherit renv-params +#' +#' @param ... Optional arguments; currently unused. +#' +#' @param python +#' The path to the version of Python to be used with this project. See +#' **Finding Python** for more details. +#' +#' @param type +#' The type of Python environment to use. When `"auto"` (the default), +#' virtual environments will be used. +#' +#' @param name +#' The name or path that should be used for the associated Python environment. +#' If `NULL` and `python` points to a Python executable living within a +#' pre-existing virtual environment, that environment will be used. Otherwise, +#' a project-local environment will be created instead, using a name +#' generated from the associated version of Python. +#' +#' @details +#' # Finding Python +#' +#' In interactive sessions, when `python = NULL`, renv will prompt for an +#' appropriate version of Python. renv will search a pre-defined set of +#' locations when attempting to find Python installations on the system: +#' +#' - `getOption("renv.python.root")`, +#' - `/opt/python`, +#' - `/opt/local/python`, +#' - `~/opt/python`, +#' - `/usr/local/opt` (for macOS Homebrew-installed copies of Python), +#' - `/opt/homebrew/opt` (for M1 macOS Homebrew-installed copies of Python), +#' - `~/.pyenv/versions`, +#' - Python instances available on the `PATH`. +#' +#' In non-interactive sessions, renv will first check the `RETICULATE_PYTHON` +#' environment variable; if that is unset, renv will look for Python on the +#' `PATH`. It is recommended that the version of Python to be used is explicitly +#' supplied for non-interactive usages of `use_python()`. +#' +#' +#' # Warning +#' +#' We strongly recommend using Python virtual environments, for a few reasons: +#' +#' 1. If something goes wrong with a local virtual environment, you can safely +#' delete that virtual environment, and then re-initialize it later, without +#' worry that doing so might impact other software on your system. +#' +#' 2. If you choose to use a "system" installation of Python, then any packages +#' you install or upgrade will be visible to any other application that +#' wants to use that same Python installation. Using a virtual environment +#' ensures that any changes made are isolated to that environment only. +#' +#' 3. Choosing to use Anaconda will likely invite extra frustration in the +#' future, as you may be required to upgrade and manage your Anaconda +#' installation as new versions of Anaconda are released. In addition, +#' Anaconda installations tend to work poorly with software not specifically +#' installed as part of that same Anaconda installation. +#' +#' In other words, we recommend selecting "system" or "conda" only if you are an +#' expert Python user who is already accustomed to managing Python / Anaconda +#' installations on your own. +#' +#' +#' @return +#' `TRUE`, indicating that the requested version of Python has been +#' successfully activated. Note that this function is normally called for its +#' side effects. +#' +#' +#' @export +#' +#' @examples +#' \dontrun{ +#' +#' # use python with a project +#' renv::use_python() +#' +#' # use python with a project; create the environment +#' # within the project directory in the '.venv' folder +#' renv::use_python(name = ".venv") +#' +#' # use python with a pre-existing virtual environment located elsewhere +#' renv::use_python(name = "~/.virtualenvs/env") +#' +#' # use virtualenv python with a project +#' renv::use_python(type = "virtualenv") +#' +#' # use conda python with a project +#' renv::use_python(type = "conda") +#' +#' } +use_python <- function(python = NULL, + ..., + type = c("auto", "virtualenv", "conda", "system"), + name = NULL, + project = NULL) +{ + renv_scope_error_handler() + renv_dots_check(...) + project <- renv_project_resolve(project) + + # deactivate python integration when FALSE + if (identical(python, FALSE)) + return(renv_python_deactivate(project)) + + # handle 'auto' type + type <- match.arg(type) + if (identical(type, "auto")) + type <- "virtualenv" + + case( + type == "system" ~ renv_use_python_system(python, name, project), + type == "virtualenv" ~ renv_use_python_virtualenv(python, name, project), + type == "conda" ~ renv_use_python_condaenv(python, name, project) + ) +} + +renv_use_python_system <- function(python, + name, + project) +{ + # retrieve python information + python <- renv_python_resolve(python) + version <- renv_python_version(python) + info <- renv_python_info(python) + + # if the user ended up selecting a virtualenv or conda python, then + # just activate those and ignore the 'system' request + if (identical(info$type, "virtualenv")) + return(renv_use_python_virtualenv(info$python, name, project)) + if (identical(info$type, "conda")) + return(renv_use_python_condaenv(info$python, name, project)) + + # for 'system' python usages, we just use the path to python + # (note that this may not be portable or useful for other machines) + renv_use_python_fini(info, python, version, project) +} + +renv_use_python_virtualenv <- function(python, + name, + project) +{ + # if name has been set, check and see if it refers to an already-existing + # virtual environment; if that exists, use it + if (is.null(python) && !is.null(name)) { + path <- renv_python_virtualenv_path(name) + if (file.exists(path)) + python <- renv_python_exe(name) + } + + python <- renv_python_resolve(python) + version <- renv_python_version(python) + info <- renv_python_info(python) + + # if name is unset, and 'python' doesn't already refer to an existing + # virtual environment, then we'll use a local virtual environment + local <- is.null(name) && identical(info$type, "virtualenv") + if (local) { + name <- renv_path_aliased(info$root) + if (renv_path_same(dirname(name), renv_python_virtualenv_home())) + name <- basename(name) + } else { + name <- name %||% renv_python_envpath(project, "virtualenv", version) + if (grepl("/", name, fixed = TRUE)) + name <- renv_path_canonicalize(name) + } + + # now, check to see if the python environment exists; + # if it does not exist, we'll create it now + vpython <- renv_use_python_virtualenv_impl(project, name, version, python) + vinfo <- renv_python_info(vpython) + + # finish up now + renv_use_python_fini(vinfo, name, version, project) + +} + +renv_use_python_condaenv <- function(python, + name, + project) +{ + # if python is set, see if it's already the path to a python interpreter + # living within a conda environment + while (!is.null(python)) { + + if (!is.null(name)) { + fmt <- "ignoring value of name %s as python was already set" + warningf(fmt, renv_path_pretty(name)) + } + + # validate that this is a conda python + info <- renv_python_info(python) + if (!identical(info$type, "conda")) { + fmt <- "%s does not appear to refer to a Conda instance of Python; ignoring" + warningf(fmt, renv_path_pretty(python)) + break + } + + # use this edition of python without further adieu + version <- renv_python_version(python) + return(renv_use_python_fini(info, name, version, project)) + + } + + # TODO: how do we select which version of python we want to use? + name <- name %||% renv_python_envpath(project, "conda") + python <- renv_use_python_condaenv_impl(project, name) + info <- renv_python_info(python) + version <- renv_python_version(python) + + renv_use_python_fini(info, name, version, project) + +} + +renv_use_python_fini <- function(info, + name, + version, + project) +{ + # ensure project-local names are treated as such + name <- if (!is.null(name)) path.expand(chartr("\\", "/", name)) + project <- if (!is.null(project)) path.expand(chartr("\\", "/", project)) + + if (!is.null(name) && startswith(name, project)) { + base <- substring(name, nchar(project) + 2L) + name <- if (grepl("^[.][^/]+$", base)) base else file.path(".", base) + } + + # form the lockfile fields we'll want to write + fields <- as.list(c(Version = version, Type = info$type, Name = name)) + + # update the lockfile + lockfile <- renv_lockfile_load(project) + if (!identical(fields, lockfile$Python)) { + lockfile$Python <- fields + renv_lockfile_save(lockfile, project) + } + + # re-initialize with these settings + renv_load_python(project, fields) + + # notify user + if (!renv_tests_running()) { + if (is.null(info$type)) { + fmt <- "- Activated Python %s (%s)." + writef(fmt, version, renv_path_aliased(info$python)) + } else { + fmt <- "- Activated Python %s [%s; %s]" + writef(fmt, version, info$type, renv_path_aliased(name)) + } + } + + # report to user + setwd(project) + activate(project = project) + + invisible(info$python) + +} + +# return the path to an existing python binary associated with the virtual +# environment having name 'name' and version 'version', or "" if no such +# python instance exists +renv_use_python_virtualenv_impl_existing <- function(project, + name = NULL, + version = NULL) +{ + # resolve environment path from name + name <- name %||% renv_python_envpath(project, "virtualenv", version) + path <- renv_python_virtualenv_path(name) + if (!file.exists(path)) + return("") + + # check that this appears to have a valid python executable + info <- catch(renv_python_info(path)) + if (inherits(info, "error")) { + warning(info) + return("") + } + + # validate version and return + renv_python_virtualenv_validate(path, version) +} + +# Internal helper for activating a Python virtual environment +# +# @param project +# The project directory. +# +# @param name +# The environment name, if any. If unset, it should be constructed +# based on the Python executable used (note: _not_ the version parameter) +# +# @param version +# The _requested_ version of Python (which may not be the actual version!) +# This version should be used as a hint for finding an appropriate version +# of Python, if the environment needs to be re-created. +# +# @param python +# The copy of Python to be used. When unset, an appropriate version of Python +# should be discovered based on the `version` parameter. +# +# @return +# The path to the Python binary in the associated virtual environment. +# +renv_use_python_virtualenv_impl <- function(project, + name = NULL, + version = NULL, + python = NULL) +{ + # first, look for an already-existing python installation + # associated with the requested version of python + exe <- renv_use_python_virtualenv_impl_existing(project, name, version) + if (file.exists(exe)) + return(exe) + + # couldn't resolve environment from requested version; try to find + # a compatible version of python and re-create that environment + python <- python %||% renv_python_find(version) + pyversion <- renv_python_version(python) + name <- name %||% renv_python_envpath(project, "virtualenv", pyversion) + path <- renv_python_virtualenv_path(name) + + # if the environment already exists, but is associated with a different + # version of Python, prompt the user to re-create that environment + if (file.exists(path)) { + exe <- renv_python_virtualenv_validate(path, version) + if (file.exists(exe)) + return(exe) + } + + printf("- Creating virtual environment '%s' ... ", basename(name)) + vpython <- renv_python_virtualenv_create(python, path) + writef("Done!") + + printf("- Updating Python packages ... ") + renv_python_virtualenv_update(vpython) + writef("Done!") + + renv_python_virtualenv_validate(path, version) + +} + +renv_use_python_condaenv_impl <- function(project, + name = NULL, + version = NULL, + python = NULL) +{ + # if we can't load reticulate, try installing if there is a version + # recorded in the lockfile + if (!requireNamespace("reticulate", quietly = TRUE)) { + + # retrieve reticulate record + lockfile <- renv_lockfile_load(project = project) + records <- renv_lockfile_records(lockfile) + reticulate <- records[["reticulate"]] + + # if we have a reticulate record, then attempt to restore + if (!is.null(reticulate)) { + restore(packages = "reticulate", + prompt = FALSE, + project = project) + } else { + install(packages = "reticulate", + prompt = FALSE, + project = project) + } + + } + + # try once more to load reticulate + if (!requireNamespace("reticulate", quietly = TRUE)) + stopf("use of conda environments requires the 'reticulate' package") + + # TODO: how to handle things like a requested Python version here? + name <- name %||% renv_python_envpath(project, "conda", version) + renv_python_conda_select(name, version) +} + +renv_python_deactivate <- function(project) { + + file <- renv_lockfile_path(project) + if (!file.exists(file)) + return(TRUE) + + lockfile <- renv_lockfile_read(file) + if (is.null(lockfile$Python)) + return(TRUE) + + lockfile$Python <- NULL + renv_lockfile_write(lockfile, file = file) + writef("- Deactived Python -- the lockfile has been updated.") + TRUE + +} + + +# use.R ---------------------------------------------------------------------- + + +the$use_libpath <- NULL + +#' @rdname embed +#' +#' @param ... +#' The \R packages to be used with this script. Ignored if `lockfile` is +#' non-`NULL`. +#' +#' @param lockfile +#' The lockfile to use. When supplied, renv will use the packages as +#' declared in the lockfile. +#' +#' @param library +#' The library path into which the requested packages should be installed. +#' When `NULL` (the default), a library path within the \R temporary +#' directory will be generated and used. Note that this same library path +#' will be re-used on future calls to `renv::use()`, allowing `renv::use()` +#' to be used multiple times within a single script. +#' +#' @param isolate +#' Boolean; should the active library paths be included in the set of library +#' paths activated for this script? Set this to `TRUE` if you only want the +#' packages provided to `renv::use()` to be visible on the library paths. +#' +#' @param sandbox +#' Should the system library be sandboxed? See the sandbox documentation in +#' [renv::config] for more details. You can also provide an explicit sandbox +#' path if you want to configure where `renv::use()` generates its sandbox. +#' By default, the sandbox is generated within the \R temporary directory. +#' +#' @param attach +#' Boolean; should the set of requested packages be automatically attached? +#' If `TRUE`, packages will be loaded and attached via a call +#' to [library()] after install. Ignored if `lockfile` is non-`NULL`. +#' +#' @param verbose +#' Boolean; be verbose while installing packages? +#' +#' @return +#' This function is normally called for its side effects. +#' +#' @export +use <- function(..., + lockfile = NULL, + library = NULL, + isolate = sandbox, + sandbox = TRUE, + attach = FALSE, + verbose = TRUE) +{ + + # allow use of the cache in this context + renv_scope_options(renv.cache.linkable = TRUE) + + # set up sandbox if requested + renv_use_sandbox(sandbox) + + # prepare library and activate library + library <- library %||% renv_use_libpath() + ensure_directory(library) + + # set library paths + libpaths <- c(library, if (!isolate) .libPaths()) + renv_libpaths_set(libpaths) + + # if we were supplied a lockfile, use it + if (!is.null(lockfile)) { + renv_scope_options(renv.verbose = verbose) + records <- restore(lockfile = lockfile, clean = FALSE, prompt = FALSE) + return(invisible(records)) + } + + dots <- list(...) + if (empty(dots)) + return(invisible()) + + # resolve the provided remotes + remotes <- lapply(dots, renv_remotes_resolve) + names(remotes) <- map_chr(remotes, `[[`, "Package") + + # install packages + records <- local({ + renv_scope_options(renv.verbose = verbose) + install(packages = remotes, library = library, prompt = FALSE) + }) + + # automatically load the requested remotes + if (attach) { + enumerate(remotes, function(package, remote) { + library(package, character.only = TRUE) + }) + } + + # return set of installed packages + invisible(records) + +} + +renv_use_libpath <- function() { + (the$use_libpath <- the$use_libpath %||% tempfile("renv-use-libpath-")) +} + +renv_use_sandbox <- function(sandbox) { + + if (identical(sandbox, FALSE)) + return(FALSE) + + if (renv_sandbox_activated()) + return(TRUE) + + sandbox <- if (is.character(sandbox)) + sandbox + else + file.path(tempdir(), "renv-sandbox") + + renv_scope_options(renv.config.sandbox.enabled = TRUE) + renv_sandbox_activate_impl(sandbox = sandbox) + +} + + +# utils-connections.R -------------------------------------------------------- + + +textfile <- function(description, open = "wt") { + file(description, open = open, encoding = "native.enc") +} + + +# utils-format.R ------------------------------------------------------------- + + +stopf <- function(fmt = "", ..., call. = FALSE) { + stop(sprintf(fmt, ...), call. = call.) +} + +warningf <- function(fmt = "", ..., call. = FALSE, immediate. = FALSE) { + warning(sprintf(fmt, ...), call. = call., immediate. = immediate.) +} + +printf <- function(fmt = "", ..., file = stdout(), sep = "") { + if (!is.null(fmt) && renv_verbose()) + cat(sprintf(fmt, ...), file = file, sep = sep) +} + +writef <- function(fmt = "", ..., con = stdout()) { + if (!is.null(fmt) && renv_verbose()) + writeLines(sprintf(fmt, ...), con = con) +} + +info_bullet <- function() { + if (l10n_info()$`UTF-8`) "\u2139" else "i" +} + + +# utils-map.R ---------------------------------------------------------------- + + +bapply <- function(x, f, ..., index = "Index") { + result <- lapply(x, f, ...) + bind(result, index = index) +} + +enumerate <- function(x, f, ..., FUN.VALUE = NULL) { + + n <- names(x) + idx <- named(seq_along(x), n) + callback <- function(i) f(n[[i]], x[[i]], ...) + + if (is.environment(x)) + x <- as.list(x, all.names = TRUE) + + if (is.null(FUN.VALUE)) + lapply(idx, callback) + else + vapply(idx, callback, FUN.VALUE = FUN.VALUE) + +} + +enum_chr <- function(x, f, ...) { + enumerate(x, f, ..., FUN.VALUE = character(1)) +} + +enum_int <- function(x, f, ...) { + enumerate(x, f, ..., FUN.VALUE = integer(1)) +} + +enum_dbl <- function(x, f, ...) { + enumerate(x, f, ..., FUN.VALUE = double(1)) +} + +enum_lgl <- function(x, f, ...) { + enumerate(x, f, ..., FUN.VALUE = logical(1)) +} + + +uapply <- function(x, f, ...) { + f <- match.fun(f) + unlist(lapply(x, f, ...), recursive = FALSE) +} + +filter <- function(x, f, ...) { + f <- match.fun(f) + x[map_lgl(x, f, ...)] +} + +reject <- function(x, f, ...) { + f <- match.fun(f) + x[!map_lgl(x, f, ...)] +} + +map <- function(x, f, ...) { + f <- match.fun(f) + lapply(x, f, ...) +} + +map_chr <- function(x, f, ...) { + f <- match.fun(f) + vapply(x, f, ..., FUN.VALUE = character(1)) +} + +map_dbl <- function(x, f, ...) { + f <- match.fun(f) + vapply(x, f, ..., FUN.VALUE = numeric(1)) +} + +map_int <- function(x, f, ...) { + f <- match.fun(f) + vapply(x, f, ..., FUN.VALUE = integer(1)) +} + +map_lgl <- function(x, f, ...) { + f <- match.fun(f) + vapply(x, f, ..., FUN.VALUE = logical(1)) +} + + +extract <- function(x, ...) { + lapply(x, `[[`, ...) +} + +extract_chr <- function(x, ...) { + vapply(x, `[[`, ..., FUN.VALUE = character(1)) +} + +extract_dbl <- function(x, ...) { + vapply(x, `[[`, ..., FUN.VALUE = numeric(1)) +} + +extract_int <- function(x, ...) { + vapply(x, `[[`, ..., FUN.VALUE = integer(1)) +} + +extract_lgl <- function(x, ...) { + vapply(x, `[[`, ..., FUN.VALUE = logical(1)) +} + + +# utils.R -------------------------------------------------------------------- + + +`%>%` <- function(...) { + + dots <- eval(substitute(alist(...))) + if (length(dots) != 2L) + stopf("`%>%` called with invalid number of arguments") + + lhs <- dots[[1L]]; rhs <- dots[[2L]] + if (!is.call(rhs)) + stopf("right-hand side of rhs is not a call") + + data <- c(rhs[[1L]], lhs, as.list(rhs[-1L])) + call <- as.call(data) + + nm <- names(rhs) + if (length(nm)) + names(call) <- c("", "", nm[-1L]) + + eval(call, envir = parent.frame()) + +} + +`%NA%` <- function(x, y) { + if (length(x) && is.na(x)) y else x +} + +`%&&%` <- function(x, y) { + if (length(x)) y +} + +lines <- function(...) { + paste(..., sep = "\n") +} + +is_named <- function(x) { + nm <- names(x) + !is.null(nm) && all(nzchar(nm)) +} + +named <- function(object, names = object) { + names(object) <- names + object +} + +empty <- function(x) { + length(x) == 0L +} + +zlength <- function(x) { + length(x) != 0L +} + +trim <- function(x) { + gsub("^\\s+|\\s+$", "", x, perl = TRUE) +} + +trimws <- function(x) { + gsub("^\\s+|\\s+$", "", x, perl = TRUE) +} + +case <- function(...) { + + dots <- eval(substitute(alist(...))) + for (i in seq_along(dots)) { + + if (identical(dots[[i]], quote(expr = ))) + next + + dot <- eval(dots[[i]], envir = parent.frame()) + if (!inherits(dot, "formula")) + return(dot) + + # Silence R CMD check note + expr <- NULL + cond <- NULL + + # use delayed assignments below so we can allow return statements to + # be handled in the lexical scope where they were defined + if (length(dot) == 2L) { + do.call(delayedAssign, list("expr", dot[[2L]], eval.env = environment(dot))) + return(expr) + } + + do.call(delayedAssign, list("cond", dot[[2L]], eval.env = environment(dot))) + do.call(delayedAssign, list("expr", dot[[3L]], eval.env = environment(dot))) + if (cond) return(expr) + + } + +} + +compose <- function(wrapper, callback) { + function(...) wrapper(callback(...)) +} + +catch <- function(expr) { + tryCatch( + withCallingHandlers(expr, error = renv_error_capture), + error = renv_error_tag + ) +} + +catchall <- function(expr) { + tryCatch( + withCallingHandlers(expr, condition = renv_error_capture), + condition = renv_error_tag + ) +} + +# nocov start + +ask <- function(question, default = FALSE) { + + if (renv_tests_running()) + return(TRUE) + + enabled <- getOption("renv.prompt.enabled", default = TRUE) + if (!enabled) + return(default) + + if (!interactive()) + return(default) + + # be verbose in this scope, as we're asking the user for input + renv_scope_options(renv.verbose = TRUE) + + repeat { + + # solicit user's answer + selection <- if (default) "[Y/n]" else "[y/N]" + prompt <- sprintf("%s %s: ", question, selection) + response <- tryCatch( + tolower(trimws(readline(prompt))), + interrupt = identity + ) + + # check for interrupts; treat as abort request + cancel_if(inherits(response, "interrupt")) + + # use default when no response + if (!nzchar(response)) + return(default) + + # check for 'yes' responses + if (response %in% c("y", "yes")) { + writef("") + return(TRUE) + } + + # check for 'no' responses + if (response %in% c("n", "no")) { + writef("") + return(FALSE) + } + + # ask the user again + writef("- Unrecognized response: please enter 'y' or 'n', or type Ctrl + C to cancel.") + + } + +} + +proceed <- function(default = TRUE) { + ask("Do you want to proceed?", default = default) +} + +menu <- function(choices, title, default = 1L) { + + testing <- getOption("renv.menu.choice", integer()) + if (length(testing)) { + selected <- testing[[1]] + options(renv.menu.choice = testing[-1]) + } else if (testing()) { + selected <- default + } else { + selected <- NULL + } + + if (!is.null(selected)) { + title <- paste(title, collapse = "\n") + body <- paste(sprintf("%i: %s", seq_along(choices), choices), collapse = "\n") + footer <- sprintf("Selection: %s\n", selected) + writef(paste(c(title, body, footer), collapse = "\n\n")) + return(names(choices)[selected]) + } + + if (!interactive()) { + value <- if (is.numeric(default)) names(choices)[default] else default + return(value) + } + + idx <- tryCatch( + utils::menu(choices, paste(title, collapse = "\n"), graphics = FALSE), + interrupt = function(cnd) 0L + ) + + if (idx == 0L) + return("cancel") + + names(choices)[idx] + +} + +# nocov end + +inject <- function(contents, + pattern, + replacement, + anchor = NULL, + fixed = FALSE) +{ + # first, check to see if the pattern matches a line + index <- grep(pattern, contents, perl = !fixed, fixed = fixed) + if (length(index)) { + contents[index] <- replacement + return(contents) + } + + # otherwise, check for the anchor, and insert after + index <- if (!is.null(anchor)) + grep(anchor, contents, perl = !fixed, fixed = fixed) + + if (!length(index)) + return(c(contents, replacement)) + + c( + head(contents, n = index), + replacement, + tail(contents, n = -index) + ) +} + +deparsed <- function(value, width = 60L) { + paste(deparse(value, width.cutoff = width), collapse = "\n") +} + +read <- function(file) { + renv_scope_options(warn = -1L) + contents <- readLines(file, warn = FALSE) + paste(contents, collapse = "\n") +} + +plural <- function(word, n) { + if (n == 1) word else paste(word, "s", sep = "") +} + +nplural <- function(word, n) { + paste(n, plural(word, n)) +} + +trunc <- function(text, n = 78) { + long <- nchar(text) > n + text[long] <- sprintf("%s <...>", substring(text[long], 1, n - 6)) + text +} + +endswith <- function(string, suffix) { + substring(string, nchar(string) - nchar(suffix) + 1) == suffix +} + +# like tools::file_ext, but includes leading '.', and preserves +# '.tar.gz', '.tar.bz' and so on +fileext <- function(path, default = "") { + indices <- regexpr("[.]((?:tar[.])?[[:alnum:]]+)$", path, perl = TRUE) + ifelse(indices > -1L, substring(path, indices), default) +} + +visited <- function(name, envir) { + value <- envir[[name]] %||% FALSE + envir[[name]] <- TRUE + value +} + +rowapply <- function(X, FUN, ...) { + lapply(seq_len(NROW(X)), function(I) { + FUN(X[I, , drop = FALSE], ...) + }) +} + +comspec <- function() { + Sys.getenv("COMSPEC", unset = Sys.which("cmd.exe")) +} + +nullfile <- function() { + if (renv_platform_windows()) "NUL" else "/dev/null" +} + +quietly <- function(expr, sink = TRUE) { + + if (sink) { + sink(file = nullfile()) + defer(sink(NULL)) + } + + withCallingHandlers( + expr, + warning = function(c) invokeRestart("muffleWarning"), + message = function(c) invokeRestart("muffleMessage"), + packageStartupMessage = function(c) invokeRestart("muffleMessage") + ) + +} + +# NOTE: This function can be used in preference to `as.*()` if you'd like +# to preserve attributes on the incoming object 'x'. +convert <- function(x, type) { + storage.mode(x) <- type + x +} + +remap <- function(x, map) { + + # TODO: use match? + remapped <- x + enumerate(map, function(key, val) { + remapped[remapped == key] <<- val + }) + remapped + +} + +keep <- function(x, keys) { + x[intersect(keys, names(x))] +} + +exclude <- function(x, keys) { + x[setdiff(names(x), keys)] +} + +invoke <- function(callback, ...) { + callback(...) +} + +dequote <- function(strings) { + + for (quote in c("'", '"')) { + + # find strings matching pattern + pattern <- paste0(quote, "(.*)", quote) + matches <- grep(pattern, strings, perl = TRUE) + if (empty(matches)) + next + + # remove outer quotes + strings[matches] <- gsub(pattern, "\\1", strings[matches], perl = TRUE) + + # un-escape inner quotes + pattern <- paste0("\\", quote) + strings[matches] <- gsub(pattern, quote, strings[matches], fixed = TRUE) + } + + strings + +} + +nth <- function(x, i) { + x[[i]] +} + +heredoc <- function(text, leave = 0) { + + # remove leading, trailing whitespace + trimmed <- gsub("^\\s*\\n|\\n\\s*$", "", text) + + # split into lines + lines <- strsplit(trimmed, "\n", fixed = TRUE)[[1L]] + + # compute common indent + indent <- regexpr("[^[:space:]]", lines) + common <- min(setdiff(indent, -1L)) - leave + paste(substring(lines, common), collapse = "\n") + +} + +find <- function(x, f, ...) { + for (i in seq_along(x)) + if (!is.null(value <- f(x[[i]], ...))) + return(value) +} + +recursing <- function() { + + nf <- sys.nframe() + if (nf < 2L) + return(FALSE) + + np <- sys.parent() + fn <- sys.function(np) + for (i in seq_len(np - 1L)) + if (identical(fn, sys.function(i))) + return(TRUE) + + FALSE + +} + +csort <- function(x, decreasing = FALSE, ...) { + renv_scope_locale("LC_COLLATE", "C") + sort(x, decreasing, ...) +} + +fsub <- function(pattern, replacement, x, ignore.case = FALSE, useBytes = FALSE) { + sub(pattern, replacement, x, ignore.case = ignore.case, useBytes = useBytes, fixed = TRUE) +} + +rows <- function(data, indices) { + + # convert logical values + if (is.logical(indices)) { + if (length(indices) < nrow(data)) + indices <- rep(indices, length.out = nrow(data)) + indices <- which(indices, useNames = FALSE) + } + + # build output list + output <- vector("list", length(data)) + for (i in seq_along(data)) + output[[i]] <- .subset2(data, i)[indices] + + # copy relevant attributes + attrs <- attributes(data) + attrs[["row.names"]] <- .set_row_names(length(indices)) + attributes(output) <- attrs + + # return new data.frame + output + +} + +cols <- function(data, indices) { + + # perform subset + output <- .subset(data, indices) + + # copy relevant attributes + attrs <- attributes(data) + attrs[["names"]] <- attr(output, "names", exact = TRUE) + attributes(output) <- attrs + + # return output + output + +} + +stringify <- function(object, collapse = " ") { + + if (is.symbol(object)) + return(as.character(object)) + + paste( + deparse(object, width.cutoff = 500L), + collapse = collapse + ) + +} + +env <- function(...) { + list2env(list(...), envir = new.env(parent = emptyenv())) +} + +env2list <- function(env) { + as.list.environment(env, all.names = TRUE) +} + +chop <- function(x, split = "\n", fixed = TRUE, perl = FALSE, useBytes = FALSE) { + strsplit(x, split, !perl, perl, useBytes)[[1L]] +} + +prof <- function(expr, ...) { + + profile <- tempfile("renv-profile-", fileext = ".Rprof") + + Rprof(profile, ...) + result <- expr + Rprof(NULL) + print(summaryRprof(profile)) + + invisible(result) + +} + +recycle <- function(data) { + + # compute number of columns + n <- lengths(data, use.names = FALSE) + nrow <- max(n) + + # start recycling + for (i in seq_along(data)) { + if (n[[i]] == 0L) { + length(data[[i]]) <- nrow + } else if (n[[i]] != nrow) { + data[[i]] <- rep.int(data[[i]], nrow / n[[i]]) + } + } + + data + +} + +take <- function(data, index = NULL) { + if (is.null(index)) data else .subset2(data, index) +} + +cancel <- function() { + + renv_snapshot_auto_suppress_next() + if (testing()) + stop("Operation canceled", call. = FALSE) + + message("- Operation canceled.") + invokeRestart("abort") + +} + +cancel_if <- function(cnd) { + if (cnd) cancel() +} + +rep_named <- function(names, x) { + values <- rep_len(x, length(names)) + names(values) <- names + values +} + +wait_until <- function(callback, ...) { + repeat if (callback(...)) return(TRUE) +} + +timer <- function(units = "secs") { + + .time <- Sys.time() + .units <- units + + list( + + now = function() { + Sys.time() + }, + + elapsed = function() { + difftime(Sys.time(), .time, units = .units) + } + ) + +} + +summon <- function() { + envir <- do.call(attach, list(what = NULL, name = "renv")) + renv <- renv_envir_self() + list2env(as.list(renv), envir = envir) +} + +assert <- function(...) stopifnot(...) + +overlay <- function(lhs, rhs) { + modifyList(as.list(lhs), as.list(rhs)) +} + +# the 'top' renv function in the call stack +topfun <- function() { + + self <- renv_envir_self() + frames <- sys.frames() + + for (i in seq_along(frames)) + if (identical(self, parent.env(frames[[i]]))) + return(sys.function(i)) + +} + +warnify <- function(cnd) { + class(cnd) <- c("warning", "condition") + warning(cnd) +} + + +# vector.R ------------------------------------------------------------------- + + +# these functions are like the base R equivalents, but preserve names +renv_vector_diff <- function(x, y) { + x[match(x, y, 0L) == 0L] +} + +renv_vector_intersect <- function(x, y) { + y[match(x, y, 0L)] +} + +renv_vector_unique <- function(x) { + x[!duplicated(x)] +} + + +# vendor.R ------------------------------------------------------------------- + + +#' Vendor renv in an R package +#' +#' @description +#' Calling `renv:::vendor()` will: +#' +#' - Compile a vendored copy of renv to `inst/vendor/renv.R`, +#' - Generate an renv auto-loader at `R/renv.R`. +#' +#' Using this, projects can take a dependency on renv, and use renv +#' internals, in a CRAN-compliant way. After vendoring renv, you can +#' use renv APIs in your package via the embedded renv environment; +#' for example, you could call the [renv::dependencies()] function with: +#' +#' ``` +#' renv$dependencies() +#' ``` +#' +#' Be aware that renv internals might change in future releases, so if you +#' need to rely on renv internal functions, we strongly recommend testing +#' your usages of these functions to avoid potential breakage. +#' +#' @param version The version of renv to vendor. `renv` sources will be pulled +#' from GitHub, and so `version` should refer to either a commit hash or a +#' branch name. +#' +#' @param project The project in which renv should be vendored. +#' +#' @keywords internal +#' +vendor <- function(version = "main", project = getwd()) { + renv_scope_error_handler() + + # validate project is a package + descpath <- file.path(project, "DESCRIPTION") + if (!file.exists(descpath)) { + fmt <- "%s does not contain a DESCRIPTION file; cannot proceed" + stopf(fmt, renv_path_pretty(project)) + } + + # retrieve package sources + sources <- renv_vendor_sources(version) + + # compute package remote + spec <- sprintf("rstudio/renv@%s", version) + remote <- renv_remotes_resolve(spec) + + # build script header + header <- renv_vendor_header(remote) + + # create the renv script itself + embed <- renv_vendor_create( + project = project, + sources = sources, + header = header + ) + + # create the loader + loader <- renv_vendor_loader(project, remote, header) + + # let the user know what just happened + template <- heredoc(" + # + # A vendored copy of renv was created at: %s + # The renv auto-loader was generated at: %s + # + # Please add `renv$initialize()` to your package's `.onLoad()` + # to ensure that renv is initialized on package load. + # + ") + + writef(template, renv_path_pretty(embed), renv_path_pretty(loader)) + + invisible(TRUE) +} + +renv_vendor_create <- function(project, sources, header) { + + # find all the renv R source scripts + scripts <- list.files(file.path(sources, "R"), full.names = TRUE) + + # read into a single file + contents <- map_chr(scripts, function(script) { + header <- header(basename(script), n = 78L) + contents <- readLines(script) + parts <- c(header, "", contents, "", "") + paste(parts, collapse = "\n") + }) + + # paste into single script + bundle <- paste(contents, collapse = "\n") + all <- c(header, "", bundle) + + # write to file + target <- file.path(project, "inst/vendor/renv.R") + ensure_parent_directory(target) + writeLines(all, con = target) + + # return generated bundle + invisible(target) + +} + +renv_vendor_loader <- function(project, remote, header) { + + source <- system.file("resources/vendor/renv.R", package = "renv") + template <- readLines(source, warn = FALSE) + + # replace '..imports..' with the imports we use + imports <- renv_vendor_imports() + + # create metadata for the embedded version + version <- renv_metadata_version_create(remote) + metadata <- renv_metadata_create(embedded = TRUE, version = version) + + # format metadata for template insertion + lines <- enum_chr(metadata, function(key, value) { + sprintf(" %s = %s", key, deparse(value)) + }) + + inner <- paste(lines, collapse = ",\n") + + replacements <- list( + imports = imports, + metadata = paste(c("list(", inner, " )"), collapse = "\n") + ) + contents <- renv_template_replace(template, replacements, format = "..%s..") + + all <- c("", header, "", contents) + target <- file.path(project, "R/renv.R") + ensure_parent_directory(target) + writeLines(all, con = target) + + invisible(target) + +} + +renv_vendor_imports <- function() { + + imports <- getNamespaceImports("renv") + + # collect into sane format + packages <- setdiff(unique(names(imports)), c("base", "")) + names(packages) <- packages + table <- map(packages, function(package) { + unlist(imports[names(imports) == package], use.names = FALSE) + }) + + # format nicely + entries <- enum_chr(table, function(package, functions) { + lines <- sprintf(" \"%s\"", functions) + body <- paste(lines, collapse = ",\n") + parts <- c(sprintf(" %s = c(", package), body, " )") + paste(parts, collapse = "\n") + }) + + paste(c("list(", paste(entries, collapse = ",\n"), " )"), collapse = "\n") + +} + +renv_vendor_sources <- function(version) { + + # retrieve renv + tarball <- renv_bootstrap_download_github(version = version) + + # extract downloaded sources + untarred <- tempfile("renv-vendor-") + untar(tarball, exdir = untarred) + + # the package itself will exist as a folder within 'exdir' + list.files(untarred, full.names = TRUE)[[1L]] + +} + +renv_vendor_header <- function(remote) { + + template <- heredoc(" + # + # renv %s [rstudio/renv#%s]: A dependency management toolkit for R. + # Generated using `renv:::vendor()` at %s. + # + ") + + version <- remote$Version + hash <- substring(remote$RemoteSha, 1L, 7L) + sprintf(template, version, hash, Sys.time()) + +} + + +# verbose.R ------------------------------------------------------------------ + + +renv_verbose <- function() { + + verbose <- getOption("renv.verbose") + if (!is.null(verbose)) + return(as.logical(verbose)) + + verbose <- Sys.getenv("RENV_VERBOSE", unset = NA) + if (!is.na(verbose)) + return(as.logical(verbose)) + + if (testing()) + return(FALSE) + + interactive() || !renv_tests_running() + +} + + +# version.R ------------------------------------------------------------------ + + +renv_version_compare <- function(lhs, rhs, n = NULL) { + + # retrieve versions as integer vector + lhs <- unlist(unclass(numeric_version(lhs))) + rhs <- unlist(unclass(numeric_version(rhs))) + + # compute number of components to compare + n <- n %||% max(length(lhs), length(rhs)) + + # pad each vector with zeroes up to the requested length + lhs <- c(lhs, rep.int(0L, max(0L, n - length(lhs)))) + rhs <- c(rhs, rep.int(0L, max(0L, n - length(rhs)))) + + # iterate through each component and compare + for (i in seq_len(n)) { + if (lhs[[i]] < rhs[[i]]) + return(-1L) + else if (lhs[[i]] > rhs[[i]]) + return(+1L) + } + + # if we got here, then all components compared equal + 0L + +} + +renv_version_le <- function(lhs, rhs, n = NULL) { + renv_version_compare(lhs, rhs, n) <= 0L +} + +renv_version_lt <- function(lhs, rhs, n = NULL) { + renv_version_compare(lhs, rhs, n) < 0L +} + +renv_version_eq <- function(lhs, rhs, n = NULL) { + renv_version_compare(lhs, rhs, n) == 0L +} + +renv_version_gt <- function(lhs, rhs, n = NULL) { + renv_version_compare(lhs, rhs, n) > 0L +} + +renv_version_ge <- function(lhs, rhs, n = NULL) { + renv_version_compare(lhs, rhs, n) >= 0L +} + +renv_version_match <- function(versions, request) { + + nrequest <- unclass(numeric_version(request))[[1L]] + for (i in rev(seq_along(nrequest))) { + + matches <- which(map_lgl(versions, function(version) { + renv_version_eq(version, request, n = i) + })) + + if (!length(matches)) + next + + # TODO: should '3.1' match the closest match (e.g. '3.2') or + # highest match (e.g. '3.6')? + sorted <- matches[sort(names(matches), decreasing = TRUE)] + return(names(sorted)[[1L]]) + + } + + versions[[1L]] + +} + +renv_version_parts <- function(version, n) { + + # split version into parts + parts <- unclass(as.numeric_version(version))[[1L]] + + # extend parts to size of n + diff <- max(n) - length(parts) + if (diff > 0) + parts <- c(parts, rep.int(0L, diff)) + + # retrieve possibly-extended parts + parts[1:n] + +} + +renv_version_maj_min <- function(version) { + parts <- renv_version_parts(version, 2L) + paste(parts, collapse = ".") +} + +renv_version_length <- function(version) { + nv <- as.numeric_version(version) + length(unclass(nv)[[1L]]) +} + + +# virtualization.R ----------------------------------------------------------- + + +the$virtualization_type <- NULL + +renv_virtualization_init <- function() { + + type <- tryCatch( + renv_virtualization_type_impl(), + error = function(e) "unknown" + ) + + the$virtualization_type <- type + +} + +renv_virtualization_type <- function() { + the$virtualization_type +} + +renv_virtualization_type_impl <- function() { + + # only done on linux for now + if (!renv_platform_linux()) + return("native") + + # check for cgroup + if (file.exists("/proc/1/cgroup")) { + contents <- readLines("/proc/1/cgroup") + if (any(grepl("/docker/", contents))) + return("docker") + } + + # assume native otherwise + "native" + +} + + +# warnings.R ----------------------------------------------------------------- + + +renv_warnings_unknown_sources <- function(records) { + + if (empty(records)) + return(FALSE) + + # TODO: Should this be documented? + enabled <- renv_config_get( + name = "unknown.sources", + scope = "warnings", + type = "logical[1]", + default = TRUE + ) + + if (!enabled) + return(FALSE) + + renv_scope_options(renv.verbose = TRUE) + renv_pretty_print_records( + "The following package(s) were installed from an unknown source:", + records, + c( + "renv may be unable to restore these packages in the future.", + "Consider reinstalling these packages from a known source (e.g. CRAN)." + ) + ) + + return(TRUE) + +} + + +# watchdog-server.R ---------------------------------------------------------- + + +renv_watchdog_server_start <- function(client) { + + # initialize logging + renv_log_init() + + # create socket server + server <- renv_socket_server() + dlog("watchdog-server", "Listening on port %i.", server$port) + + # communicate information back to client + dlog("watchdog-server", "Waiting for client...") + metadata <- list(port = server$port, pid = server$pid) + conn <- renv_socket_connect(port = client$port, open = "wb") + serialize(metadata, connection = conn) + close(conn) + dlog("watchdog-server", "Synchronized with client.") + + # initialize locks + lockenv <- new.env(parent = emptyenv()) + + # start listening for connections + repeat tryCatch( + renv_watchdog_server_run(server, client, lockenv), + error = function(e) { + dlog("watchdog-server", "Error: %s", conditionMessage(e)) + } + ) + +} + +renv_watchdog_server_run <- function(server, client, lockenv) { + + # check for parent exit + if (!renv_process_exists(client$pid)) { + dlog("watchdog-server", "Client process has exited; shutting down.") + renv_watchdog_server_exit(server, client, lockenv) + } + + # set file time on owned locks, so we can see they're not orphaned + dlog("watchdog-server", "Refreshing lock times.") + locks <- ls(envir = lockenv, all.names = TRUE) + renv_lock_refresh(locks) + + # wait for connection + dlog("watchdog-server", "Waiting for connection...") + conn <- renv_socket_accept(server$socket, open = "rb", timeout = 1) + defer(close(conn)) + + # read the request + dlog("watchdog-server", "Received connection; reading data.") + request <- unserialize(conn) + + dlog("watchdog-server", "Received request.") + str(request) + + # handle the request + switch( + + request$method %||% "", + + ListLocks = { + dlog("watchdog-server", "Executing 'ListLocks' request.") + conn <- renv_socket_connect(port = request$port, open = "watchdog-server", "b") + defer(close(conn)) + locks <- ls(envir = lockenv, all.names = TRUE) + serialize(locks, connection = conn) + }, + + LockAcquired = { + dlog("watchdog-server", "Acquired lock on path '%s'.", request$data$path) + assign(request$data$path, TRUE, envir = lockenv) + }, + + LockReleased = { + dlog("watchdog-server", "Released lock on path '%s'.", request$data$path) + rm(list = request$data$path, envir = lockenv) + }, + + Shutdown = { + dlog("watchdog-server", "Received shutdown request; shutting down.") + renv_watchdog_server_exit(server, client, lockenv) + }, + + "" = { + dlog("watchdog-server", "Received request with no method field available.") + }, + + { + dlog("watchdog-server", "Unknown method '%s'", request$method) + } + + ) + +} + +renv_watchdog_server_exit <- function(server, client, lockenv) { + + # remove any existing locks + locks <- ls(envir = lockenv, all.names = TRUE) + unlink(locks, recursive = TRUE, force = TRUE) + + # shut down the socket server + close(server$socket) + + # quit + quit(status = 0) + +} + + +# watchdog.R ----------------------------------------------------------------- + + +# whether or not the user has enabled the renv watchdog in this session +the$watchdog_enabled <- FALSE + +# metadata related to the running watchdog process, if any +the$watchdog_process <- NULL + +renv_watchdog_init <- function() { + the$watchdog_enabled <- renv_watchdog_enabled_impl() +} + +renv_watchdog_enabled <- function() { + the$watchdog_enabled +} + +renv_watchdog_check <- function() { + + if (!renv_watchdog_enabled()) + return(FALSE) + + if (renv_watchdog_running()) + return(TRUE) + + renv_watchdog_start() + +} + +renv_watchdog_enabled_impl <- function() { + + # skip in older versions of R; we require newer APIs + if (getRversion() < "4.0.0") + return(FALSE) + + # skip if explicitly disabled via envvar + enabled <- Sys.getenv("RENV_WATCHDOG_ENABLED", unset = NA) + if (!is.na(enabled)) + return(truthy(enabled)) + + # disable on Windows; need to understand CI test failures + # https://github.com/rstudio/renv/actions/runs/5273668333/jobs/9537353788#step:6:242 + if (renv_platform_windows()) + return(FALSE) + + # skip during R CMD check (but not when running tests) + checking <- renv_envvar_exists("_R_CHECK_PACKAGE_NAME_") + if (checking && !testing()) + return(FALSE) + + # skip during R CMD build or R CMD INSTALL + # ... unless we are running tests on CI + building <- + renv_envvar_exists("R_PACKAGE_NAME") || + renv_envvar_exists("R_PACKAGE_DIR") + + if (building) { + ci <- Sys.getenv("CI", unset = "FALSE") + if (!truthy(ci)) + return(FALSE) + } + + # ok, we're enabled + TRUE + +} + +renv_watchdog_start <- function() { + + the$watchdog_enabled <- tryCatch( + renv_watchdog_start_impl(), + error = function(e) { + warning(conditionMessage(e)) + FALSE + } + ) + +} + +renv_watchdog_start_impl <- function() { + + # create a socket server -- this is used so the watchdog process + # can communicate what port it'll be listening on for messages + dlog("watchdog", "launching watchdog") + server <- renv_socket_server() + socket <- server$socket; port <- server$port + defer(close(socket)) + + # generate script to invoke watchdog + script <- renv_scope_tempfile("renv-watchdog-", fileext = ".R") + + # figure out library path -- need to dodge devtools::load_all() + nspath <- renv_namespace_path(.packageName) + library <- if (file.exists(file.path(nspath, "Meta/package.rds"))) + dirname(nspath) + else + renv_libpaths_default() + + # for R CMD check + name <- .packageName + pid <- Sys.getpid() + + env <- list( + name = name, + library = library, + pid = pid, + port = port + ) + + code <- substitute(env = env, { + client <- list(pid = pid, port = port) + host <- loadNamespace(name, lib.loc = library) + renv <- if (!is.null(host$renv)) host$renv else host + renv$renv_watchdog_server_start(client) + }) + + writeLines(deparse(code), con = script) + + # debug logging + debugging <- Sys.getenv("RENV_WATCHDOG_DEBUG", unset = "FALSE") + stdout <- stderr <- if (truthy(debugging)) "" else FALSE + + # launch the watchdog + local({ + renv_scope_envvars(RENV_PROCESS_TYPE = "watchdog-server") + system2( + command = R(), + args = c("--vanilla", "-s", "-f", renv_shell_path(script)), + stdout = stdout, + stderr = stderr, + wait = FALSE + ) + }) + + # wait for connection from watchdog server + dlog("watchdog", "watchdog process launched; waiting for message") + conn <- catch(renv_socket_accept(socket, open = "rb", timeout = 10L)) + if (inherits(conn, "error")) { + dlog("watchdog", paste("error connecting to watchdog:", conditionMessage(conn))) + return(FALSE) + } + + # store information about the running process + the$watchdog_process <- unserialize(conn) + close(conn) + + # return TRUE to indicate process was started + dlog("watchdog", "watchdog message received [pid == %i]", the$watchdog_process$pid) + TRUE + +} + +renv_watchdog_notify <- function(method, data = list()) { + + tryCatch( + renv_watchdog_notify_impl(method, data), + error = warnify + ) + +} + +renv_watchdog_notify_impl <- function(method, data = list()) { + + # make sure the watchdog is running + if (!renv_watchdog_check()) + return(FALSE) + + # connect to the running server + port <- renv_watchdog_port() + conn <- renv_socket_connect(port, open = "wb") + + # close the connection on exit + defer(close(conn)) + + # write message + message <- list(method = method, data = data) + serialize(message, connection = conn) + + # TRUE indicates message was written + TRUE + +} + +renv_watchdog_request <- function(method, data = list()) { + tryCatch( + renv_watchdog_request_impl(method, data), + error = warnify + ) +} + +renv_watchdog_request_impl <- function(method, data = list()) { + + # make sure the watchdog is running + if (!renv_watchdog_check()) + return(FALSE) + + # connect to the running server + port <- renv_watchdog_port() + outgoing <- renv_socket_connect(port, open = "wb") + defer(close(outgoing)) + + # create our own socket server + server <- renv_socket_server() + defer(close(server$socket)) + + # write message + message <- list(method = method, data = data, port = server$port) + serialize(message, connection = outgoing) + + # now, open a new connection to get the response + incoming <- renv_socket_accept(server$socket, open = "rb") + defer(close(incoming)) + + # read the response + unserialize(connection = incoming) + +} + +renv_watchdog_pid <- function() { + the$watchdog_process$pid +} + +renv_watchdog_port <- function() { + the$watchdog_process$port +} + +renv_watchdog_running <- function() { + pid <- renv_watchdog_pid() + !is.null(pid) && renv_process_exists(pid) +} + +renv_watchdog_unload <- function() { + renv_watchdog_shutdown() +} + +renv_watchdog_terminate <- function() { + pid <- renv_watchdog_pid() + renv_process_kill(pid) +} + +renv_watchdog_shutdown <- function() { + + # nothing to do if watchdog isn't running + if (!renv_watchdog_running()) + return(TRUE) + + # tell watchdog to shutdown + renv_watchdog_notify("Shutdown") + + # wait for process to exit (avoid RStudio bomb) + clock <- timer() + wait_until(function() { + !renv_watchdog_running() || clock$elapsed() > 1 + }) + + if (!renv_watchdog_running()) + return(TRUE) + + # if it's still running, explicitly terminate it + renv_watchdog_terminate() + + # wait for process to exit (avoid RStudio bomb) + clock <- timer() + wait_until(function() { + !renv_watchdog_running() || clock$elapsed() > 1 + }) + +} + + +# xcode.R -------------------------------------------------------------------- + + +renv_xcode_available <- function() { + + # allow bypass if required + check <- getOption("renv.xcode.available", default = NULL) + if (!is.null(check)) + return(check) + + # otherwise, check via xcode-select + status <- suppressWarnings( + system2("/usr/bin/xcode-select", "-p", stdout = FALSE, stderr = FALSE) + ) + + identical(status, 0L) + +} + +renv_xcode_check <- function() { + + # allow bypass of xcode check if required + check <- getOption("renv.xcode.check", default = TRUE) + if (identical(check, FALSE)) + return() + + # only run on macOS + if (!renv_platform_macos()) + return() + + # only run check once per session + if (once()) + return() + + cmd <- "/usr/bin/xcrun --find --show-sdk-path" + status <- system(cmd, ignore.stdout = TRUE, ignore.stderr = TRUE) + if (identical(status, 0L)) + return() + + if (identical(status, 69L)) { + + msg <- " +macOS is reporting that you have not yet agreed to the Xcode license. +You must accept the Xcode license before R packages can be installed from source. +Please run: + + sudo xcodebuild -license accept + +in the Terminal to accept the Xcode license. +Set options(renv.xcode.check = FALSE) to disable this warning. +" + warning(msg) + + } + + fmt <- "%s returned exit code %i" + warningf(fmt, cmd, status) + +} + + +# yaml.R --------------------------------------------------------------------- + + +renv_yaml_load <- function(text) { + + yaml::yaml.load( + string = text, + eval.expr = FALSE, + handlers = list( + r = function(yaml) { + attr(yaml, "type") <- "r" + yaml + } + ) + ) + +} + + +# zzz.R ---------------------------------------------------------------------- + + +.onLoad <- function(libname, pkgname) { + renv_zzz_load() +} + +.onAttach <- function(libname, pkgname) { + renv_zzz_attach() +} + +.onUnload <- function(libpath) { + + renv_lock_unload() + renv_task_unload() + renv_watchdog_unload() + + # do some extra cleanup when running R CMD check + if (renv_platform_unix() && checking() && !ci()) + cleanse() + + # flush the help db to avoid errors on reload + # https://github.com/rstudio/renv/issues/1294 + helpdb <- system.file(package = "renv", "help/renv.rdb") + .Internal <- .Internal + lazyLoadDBflush <- function(...) {} + + tryCatch( + .Internal(lazyLoadDBflush(helpdb)), + error = function(e) NULL + ) + +} + +# NOTE: required for devtools::load_all() +.onDetach <- function(libpath) { + package <- Sys.getenv("DEVTOOLS_LOAD", unset = NA) + if (identical(package, .packageName)) + .onUnload(libpath) +} + +renv_zzz_load <- function() { + + # NOTE: needs to be visible to embedded instances of renv as well + the$envir_self <<- renv_envir_self() + + # make sure renv (and packages using renv!!!) use tempdir for storage + # when running tests, or R CMD check + if (checking() || testing()) { + + # set root directory + root <- Sys.getenv("RENV_PATHS_ROOT", unset = tempfile("renv-root-")) + Sys.setenv(RENV_PATHS_ROOT = root) + + # set up sandbox -- only done on non-Windows due to strange intermittent + # test failures that seemed to occur there? + if (renv_platform_unix()) { + sandbox <- Sys.getenv("RENV_PATHS_SANDBOX", unset = tempfile("renv-sandbox-")) + Sys.setenv(RENV_PATHS_SANDBOX = sandbox) + } + + # don't lock sandbox while testing / checking + options(renv.sandbox.locking_enabled = FALSE) + + } + + renv_metadata_init() + renv_platform_init() + renv_virtualization_init() + renv_envvars_init() + renv_log_init() + renv_methods_init() + renv_libpaths_init() + renv_patch_init() + renv_sandbox_init() + renv_sdkroot_init() + renv_watchdog_init() + + if (!renv_metadata_embedded()) { + + # TODO: It's not clear if these callbacks are safe to use when renv is + # embedded, but it's unlikely that clients would want them anyhow. + renv_task_create(renv_sandbox_task) + renv_task_create(renv_snapshot_task) + } + + # if an renv project already appears to be loaded, then re-activate + # the sandbox now -- this is primarily done to support suspend and + # resume with RStudio where the user profile might not be run + if (renv_rstudio_available()) { + project <- getOption("renv.project.path") + if (!is.null(project)) + renv_sandbox_activate(project = project) + } + + # make sure renv is unloaded on exit, so locks etc. are released + # we previously tried to orchestrate this via unloadNamespace(), + # but this fails when a package importing renv is already loaded + # https://github.com/rstudio/renv/issues/1621 + reg.finalizer(renv_envir_self(), renv_unload_finalizer, onexit = TRUE) + +} + +renv_zzz_attach <- function() { + renv_rstudio_fixup() +} + +renv_zzz_run <- function() { + + # check if we're in pkgload::load_all() + # if so, then create some files + if (renv_envvar_exists("DEVTOOLS_LOAD")) { + renv_zzz_bootstrap_activate() + renv_zzz_bootstrap_config() + } + + # check if we're running as part of R CMD build + # if so, build our local repository with a copy of ourselves + if (building()) + renv_zzz_repos() + +} + +renv_zzz_bootstrap_activate <- function() { + + source <- "templates/template-activate.R" + target <- "inst/resources/activate.R" + scripts <- c("R/bootstrap.R", "R/json-read.R") + + # Do we need an update + source_mtime <- max(renv_file_info(c(source, scripts))$mtime) + target_mtime <- renv_file_info(target)$mtime + + if (!is.na(target_mtime) && target_mtime > source_mtime) + return() + + # read the necessary bootstrap scripts + contents <- map(scripts, readLines) + bootstrap <- unlist(contents) + + # format nicely for insertion + bootstrap <- paste(" ", bootstrap) + bootstrap <- paste(bootstrap, collapse = "\n") + + # replace template with bootstrap code + template <- renv_file_read(source) + replaced <- renv_template_replace(template, list(BOOTSTRAP = bootstrap)) + + # write to resources + printf("- Generating 'inst/resources/activate.R' ... ") + writeLines(replaced, con = target) + writef("Done!") + +} + +renv_zzz_bootstrap_config <- function() { + + source <- "inst/config.yml" + target <- "R/config-defaults.R" + + source_mtime <- renv_file_info(source)$mtime + target_mtime <- renv_file_info(target)$mtime + + if (target_mtime > source_mtime) + return() + + template <- renv_template_create(heredoc(leave = 2, ' + ${NAME} = function(..., default = ${DEFAULT}) { + renv_config_get( + name = "${NAME}", + type = "${TYPE}", + default = default, + args = list(...) + ) + } + ')) + + template <- gsub("^\\n+|\\n+$", "", template) + + generate <- function(entry) { + + name <- entry$name + type <- entry$type + default <- entry$default + code <- entry$code + + default <- if (length(code)) trimws(code) else deparse(default) + + replacements <- list( + NAME = name, + TYPE = type, + DEFAULT = default + ) + + renv_template_replace(template, replacements) + + } + + config <- yaml::read_yaml("inst/config.yml") + code <- map_chr(config, generate) + all <- c( + "", + "# Auto-generated by renv_zzz_bootstrap_config()", + "", + "#' @rdname config", + "#' @export", + "#' @format NULL", + "config <- list(", + "", + paste(code, collapse = ",\n\n"), + "", + ")" + ) + + printf("- Generating 'R/config-defaults.R' ... ") + writeLines(all, con = target) + writef("Done!") + +} + +renv_zzz_repos <- function() { + + # don't run if we're running tests + if (checking()) + return() + + # prevent recursion + installing <- Sys.getenv("RENV_INSTALLING_REPOS", unset = NA) + if (!is.na(installing)) + return() + + renv_scope_envvars(RENV_INSTALLING_REPOS = "TRUE") + writeLines("** installing renv to package-local repository") + + # get package directory + pkgdir <- getwd() + + # move to build directory + tdir <- tempfile("renv-build-") + ensure_directory(tdir) + renv_scope_wd(tdir) + + # build renv again + r_cmd_build("renv", path = pkgdir, "--no-build-vignettes") + + # copy built tarball to inst folder + src <- list.files(tdir, full.names = TRUE) + tgt <- file.path(pkgdir, "inst/repos/src/contrib") + + ensure_directory(tgt) + file.copy(src, tgt) + + # write PACKAGES + renv_scope_envvars(R_DEFAULT_SERIALIZE_VERSION = "2") + write_PACKAGES(tgt, type = "source") + +} + +if (identical(.packageName, "renv")) { + renv_zzz_run() +} + + diff --git a/man/dock_from_renv.Rd b/man/dock_from_renv.Rd index f0f05b1..0b78bc6 100644 --- a/man/dock_from_renv.Rd +++ b/man/dock_from_renv.Rd @@ -13,7 +13,7 @@ dock_from_renv( repos = c(CRAN = "https://cran.rstudio.com/"), expand = FALSE, extra_sysreqs = NULL, - fix_renv_version = FALSE + renv_version ) } \arguments{ @@ -38,8 +38,9 @@ will contain sysreq installation.} \item{extra_sysreqs}{character vector. Extra debian system requirements. Will be installed with apt-get install.} -\item{fix_renv_version}{boolean. If `TRUE` the version of renv in the lockfile -will be used for the `renv::restore()` command} +\item{renv_version}{character. The {renv} version to use in the generated Dockerfile. +By default, it is set to the version specified in the `renv.lock` file. +If the `renv.lock` file does not specify a {renv} version, the version of {renv} bundled with {dockerfiler}, specifically `dockerfiler::renv$the$metadata$version`, will be used. If you set it to NULL, the latest available version of {renv} will be used.} } \value{ A R6 object of class `Dockerfile`. diff --git a/man/renv.Rd b/man/renv.Rd new file mode 100644 index 0000000..e71f9d1 --- /dev/null +++ b/man/renv.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/renv.R +\docType{data} +\name{renv} +\alias{renv} +\title{Internalised {renv}} +\format{ +An object of class \code{environment} of length 1. +} +\usage{ +renv +} +\description{ +https://rstudio.github.io/renv/reference/vendor.html?q=vendor +} +\keyword{datasets} diff --git a/tests/testthat/test-dock_from_renv.R b/tests/testthat/test-dock_from_renv.R index 805172c..2b9759b 100644 --- a/tests/testthat/test-dock_from_renv.R +++ b/tests/testthat/test-dock_from_renv.R @@ -1,5 +1,6 @@ # WARNING - Generated by {fusen} from dev/flat_dock_from_renv.Rmd: do not edit by hand +# A temporary directory dir_build <- tempfile(pattern = "renv") dir.create(dir_build) @@ -8,7 +9,6 @@ the_lockfile <- file.path(dir_build, "renv.lock") custom_packages <- c( # attachment::att_from_description(), - "renv", "cli", "glue", # "golem", "shiny", @@ -17,7 +17,8 @@ custom_packages <- c( "testthat", "knitr" ) -renv::snapshot( +try(dockerfiler::renv$initialize(),silent=TRUE) +dockerfiler::renv$snapshot( packages = custom_packages, lockfile = the_lockfile, prompt = FALSE @@ -67,16 +68,13 @@ test_that("dock_from_renv works", { "FROM rocker/verse:4.1.2" ) - expect_length( - grep("install.packages\\(c\\(\"renv\",\"remotes\"", dock_created), - 1 - ) expect_length( grep("RUN R -e 'renv::restore\\(\\)'", dock_created), 1 ) # System dependencies are different when build in interactive environment? + # yes. strange. skip_if_not(interactive()) dir.create( file.path( @@ -142,56 +140,53 @@ test_that("gen_base_image works", { -test_that("dock_from_renv works with old renv", { - out_true <- dock_from_renv( - lockfile = the_lockfile, - distro = "focal", - FROM = "rocker/verse", - fix_renv_version = TRUE - ) +test_that("dock_from_renv works with specific renv", { + +the_lockfile1.0.0 <- system.file("renv_with_1.0.0.lock",package = "dockerfiler") - out_true$write( - file.path( - dir_build, - "Dockerfile_keep_true" - ) - ) +for (lf in list(the_lockfile,the_lockfile1.0.0)){ +for (renv_version in list(NULL,"banana","missing")){ - dock_created_true <- readLines( - file.path( - dir_build, - "Dockerfile_keep_true" - ) - ) - out_false <- dock_from_renv( - lockfile = the_lockfile, - distro = "focal", - FROM = "rocker/verse", - fix_renv_version = FALSE - ) - - out_false$write( - file.path( - dir_build, - "Dockerfile_keep_false" - ) - ) - dock_created_false <- readLines( - file.path( - dir_build, - "Dockerfile_keep_false" + if (!is.null(renv_version) && renv_version == "missing") { + out <- dock_from_renv(lockfile = lf, + distro = "focal", + FROM = "rocker/verse") + } else{ + out <- dock_from_renv( + lockfile = lf, + distro = "focal", + FROM = "rocker/verse", + renv_version = renv_version ) - ) - dock_created_false - dock_created_true - - packageVersion("renv") - test_string <- paste0("remotes::install_version\\(\"renv\", version = ", packageVersion("renv") ,"\\)") - expect_true( any( grepl(test_string , dock_created_true) )) - dock_created_false - test_string <- 'install.packages\\(c\\(\"renv\",\"remotes\"))' - expect_true( any( grepl(test_string , dock_created_false) )) + } +socle_install_version <- "remotes::install_version\\(\"renv\", version = \"" + if (lf == the_lockfile & is.null(renv_version)) { + test_string <- 'install.packages\\(c\\(\"renv\",\"remotes\"))' + } else if (lf == the_lockfile1.0.0 & is.null(renv_version)) { + test_string <- 'install.packages\\(c\\(\"renv\",\"remotes\"))' + } else if (lf == the_lockfile & renv_version == "banana") { + test_string <- paste0(socle_install_version,"banana" ,"\"\\)") + } else if (lf == the_lockfile1.0.0 & renv_version == "banana") { + test_string <- paste0(socle_install_version,"banana","\"\\)") + } else if (lf == the_lockfile & renv_version == "missing") { + test_string <- + paste0( + socle_install_version,dockerfiler::renv$the$metadata$version,"\"\\)" + ) + } else if (lf == the_lockfile1.0.0 & renv_version == "missing") { + test_string <-paste0(socle_install_version,"1.0.0","\"\\)") + } + + expect_true( any( grepl(test_string , out$Dockerfile) ), + info = paste(lf," & ",renv_version)) + + +}} + + + }) + diff --git a/vignettes/dockerfile-from-renv-lock.Rmd b/vignettes/dockerfile-from-renv-lock.Rmd index 78b70a3..9eaa756 100644 --- a/vignettes/dockerfile-from-renv-lock.Rmd +++ b/vignettes/dockerfile-from-renv-lock.Rmd @@ -50,33 +50,3 @@ library(dockerfiler) -```{r dock_from_renv, eval = FALSE} -# A temporary directory -dir_build <- tempfile(pattern = "renv") -dir.create(dir_build) - -# Create a lockfile -the_lockfile <- file.path(dir_build, "renv.lock") -custom_packages <- c( - # attachment::att_from_description(), # build from a DESCRIPTION file - "renv", - "cli", "glue", "golem", "shiny", "stats", "utils", - "testthat", - "knitr" -) -renv::snapshot( - packages = custom_packages, - lockfile = the_lockfile, - prompt = FALSE) - -# Create Dockerfile -dock_from_renv(lockfile = the_lockfile, - distro = "focal", - FROM = "rstudio/verse", - out_dir = dir_build - ) - -# rstudioapi::navigateToFile(file.path(dir_build, "Dockerfile")) -unlink(dir_build) -``` -