install now finds packages in local sources when possible

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: renv
 Type: Package
 Title: Project Environments
-Version: 0.12.3-61
+Version: 0.12.3-62
 Authors@R: c(
     person("Kevin", "Ushey", role = c("aut", "cre"), email = "[email protected]"),
     person("RStudio", role = c("cph"))

NEWS.md

@@ -1,6 +1,10 @@
 
 # renv 0.13.0 (UNRELEASED)
 
+* `renv::install("package")` will now install the latest-available version of
+  that package from local sources, if that package is available and newer than
+  any package available on the active package repositories. (#591)
+
 * The configuration option `startup.quiet` has been added, allowing one to
   control whether `renv` will display the typical startup banner when a
   project is loaded.

R/available-packages.R

@@ -217,7 +217,14 @@ renv_available_packages_record <- function(entry, type) {
 
 renv_available_packages_latest_impl <- function(package, type) {
 
+  # get available packages
   dbs <- renv_available_packages(type = type, quiet = TRUE)
+
+  # prepend local sources if available
+  local <- renv_available_packages_local(type = type)
+  if (!is.null(local))
+    dbs <- c(list(Local = local), dbs)
+
   fields <- c("Package", "Version", "OS_type", "NeedsCompilation", "Repository")
   entries <- bapply(dbs, function(db) {
 
@@ -268,39 +275,14 @@ renv_available_packages_latest_impl <- function(package, type) {
 
   }, index = "Name")
 
-  if (is.null(entries)) {
-
-    # for diagnostics on CI
-    if (renv_tests_running() && renv_tests_verbose()) {
-
-      # write error message
-      fmt <- "internal error: package '%s' not available on test repositories"
-      writef(fmt, package)
-
-      # dump some (hopefully) helpful information
-      repos <- getOption("repos")
-      str(repos)
-
-      dbs %>% map(`[`, c("Package", "Version")) %>% print()
-
-      repopath <- gsub("^file:/+", "", repos)
-      files <- list.files(
-        path       = repopath,
-        all.files  = TRUE,
-        full.names = TRUE,
-        recursive  = TRUE
-      )
-
-      writeLines(files)
-
-    }
-
+  if (is.null(entries))
     return(NULL)
-  }
 
   # sort based on version
   version <- numeric_version(entries$Version)
   ordered <- order(version, decreasing = TRUE)
+
+  # return newest-available version
   entries[ordered[[1]], ]
 
 }
@@ -385,3 +367,60 @@ renv_available_packages_latest_select <- function(src, bin) {
   renv_available_packages_record(src, "source")
 
 }
+
+renv_available_packages_local <- function(type, project = NULL) {
+
+  project <- renv_project_resolve(project)
+
+  # list files recursively in the local sources paths
+  roots <- c(
+    renv_paths_project("renv/local", project = project),
+    renv_paths_local()
+  )
+
+  # find all files used in the locals folder
+  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]
+
+  # read the DESCRIPTION files within the archive
+  descs <- lapply(keep, function(path) {
+
+    # read the DESCRIPTION
+    desc <- renv_description_read(path)
+
+    # set the Repository field
+    prefix <- if (renv_platform_windows()) "file:///" else "file://"
+    uri <- paste0(prefix, dirname(path))
+    desc[["Repository"]] <- uri
+
+    # return it
+    desc
+
+  })
+
+  # extract DESCRIPTION fields of interest
+  fields <- c("Package", "Version", "OS_type", "NeedsCompilation", "Repository")
+  records <- map(descs, function(desc) {
+
+    # ensure missing fields are set as NA
+    missing <- setdiff(fields, names(desc))
+    desc[missing] <- NA
+
+    # return record with requested fields
+    desc[fields]
+
+  })
+
+  # bind into data.frame for lookup
+  bind_list(records)
+
+}

R/retrieve.R

@@ -343,10 +343,8 @@ renv_retrieve_local_report <- function(record) {
   if (source == "local")
     return(record)
 
-  record$Source <- "Local"
-  rather <- if (source == "unknown") "" else paste(" rather than", renv_alias(source))
-  fmt <- "* Package %s [%s] will be installed from local sources%s."
-  with(record, vwritef(fmt, Package, Version, rather))
+  fmt <- "* Package %s [%s] will be installed from local sources."
+  with(record, vwritef(fmt, Package, Version))
 
   record
 

R/scope.R

@@ -327,3 +327,9 @@ renv_scope_lock <- function(path = NULL,
   defer(callback(), envir = parent.frame())
 
 }
+
+renv_scope_trace <- function(what, tracer, ..., .envir = NULL) {
+  .envir <- .envir %||% parent.frame()
+  trace(what = substitute(what), tracer = tracer, print = FALSE, ...)
+  defer(untrace(what), envir = .envir)
+}

R/snapshot.R

@@ -675,8 +675,17 @@ renv_snapshot_description_source <- function(dcf) {
     catch(renv_available_packages_latest(package, type = "source"))
   })
 
-  if (!inherits(entry, "error"))
-    return(list(Source = "Repository", Repository = entry[["Repository"]]))
+  if (!inherits(entry, "error")) {
+
+    # check for and handle local repositories
+    repos <- entry[["Repository"]]
+    if (identical(repos, "Local"))
+      return(list(Source = "Local"))
+
+    # otherwise, treat as regular entry
+    return(list(Source = "Repository", Repository = repos))
+
+  }
 
   location <- catch(renv_retrieve_local_find(dcf))
   if (!inherits(location, "error"))

tests/testthat/test-available-packages.R

@@ -68,3 +68,17 @@ test_that("renv_available_packages_latest() respects pkgType option", {
   expect_error(renv_available_packages_latest("breakfast"))
 
 })
+
+test_that("local sources are preferred when available", {
+
+  skip_on_cran()
+  renv_tests_scope()
+
+  root <- renv_tests_root()
+  renv_scope_envvars(RENV_PATHS_LOCAL = file.path(root, "local"))
+
+  record <- renv_available_packages_latest(package = "skeleton", type = "source")
+  expect_identical(record$Source, "Repository")
+  expect_identical(record$Repository, "Local")
+
+})

tests/testthat/test-install.R

@@ -304,3 +304,22 @@ test_that("install() installs inferred dependencies", {
   expect_length(records, 0L)
 
 })
+
+test_that("install() prefers local sources when available", {
+
+  skip_on_cran()
+  renv_tests_scope()
+
+  root <- renv_tests_root()
+  renv_scope_envvars(RENV_PATHS_LOCAL = file.path(root, "local"))
+
+  records <- install("skeleton")
+
+  record <- records$skeleton
+  expect_equal(record$Repository, "Local")
+
+  prefix <- if (renv_platform_windows()) "file:///" else "file://"
+  uri <- paste0(prefix, root, "/local/skeleton")
+  expect_equal(attr(record, "url"), uri)
+
+})

tests/testthat/test-snapshot.R

@@ -228,8 +228,14 @@ test_that("snapshot records packages discovered in local sources", {
   init(bare = TRUE)
 
   record <- list(Package = "skeleton", Version = "1.0.1", Source = "Local")
-  install(list(record))
+  records <- install(list(record))
 
+  # validate the record reported by install
+  skeleton <- records[["skeleton"]]
+  expect_equal(skeleton$Version, "1.0.1")
+  expect_equal(skeleton$Source, "Local")
+
+  # validate the record in the lockfile
   lockfile <- snapshot(lockfile = NULL)
   records <- renv_records(lockfile)
   skeleton <- records[["skeleton"]]