improve record => remote transformation for pak (#1883)

NEWS.md

@@ -1,6 +1,10 @@
 
 # renv (development version)
 
+* Fixed an issue with `renv`'s `pak` integration where `renv` could install the
+  wrong version of a GitHub package during restore if
+  `options(renv.config.pak.enabled = TRUE)` was set. (#1883)
+
 * Fixed an issue where `renv` could silently prompt the user for input
   when running the autoloader inside an RStudio R session. (#1879)
 

R/pak.R

@@ -124,7 +124,7 @@ renv_pak_restore <- function(lockfile,
   }
 
   # convert into specs compatible with pak, and install
-  remotes <- map_chr(records, renv_record_format_remote)
+  remotes <- map_chr(records, renv_record_format_remote, pak = TRUE)
 
   # TODO: We previously tried converting version-ed remotes into "plain" remotes
   # if the package version happened to be current, but then 'pak' would choose

R/records.R

@@ -93,13 +93,88 @@ renv_record_validate <- function(package, record) {
 
 }
 
-renv_record_format_remote <- function(record) {
+renv_record_format_remote <- function(record, compact = FALSE, pak = FALSE) {
 
-  remotes <- c("RemoteUsername", "RemoteRepo")
-  if (all(remotes %in% names(record)))
-    return(renv_record_format_short_remote(record))
+  # extract some of the commonly used fields up-front
+  source <- renv_record_source(record, normalize = TRUE)
+  package <- record[["Package"]]
+  version <- record[["Version"]]
+
+  # handle repository remotes
+  if (source %in% c("cran", "repository", "standard")) {
+    remote <- paste(package, version, sep = "@")
+    return(remote)
+  }
+
+  # handle bioconductor remotes
+  if (source %in% "bioconductor") {
+    remote <- sprintf("bioc::%s@%s", package, version)
+    return(remote)
+  }
+
+  # handle git, svn remotes
+  if (source %in% c("git", "svn")) {
+    url <- record[["RemoteUrl"]]
+    remote <- sprintf("%s::%s", source, url)
+    return(remote)
+  }
+
+  # handle local, url remotes
+  if (source %in% c("local", "url")) {
+    url <- record[["RemoteUrl"]] %||% sub("[^:]+::", "", record[["RemotePkgRef"]])
+    remote <- sprintf("%s=%s::%s", package, source, url)
+    return(remote)
+  }
+
+  # handle other remotes; assumed to be a github-like remote
+  user   <- record[["RemoteUsername"]]
+  repo   <- record[["RemoteRepo"]]
+  type   <- record[["RemoteType"]]
+  ref    <- record[["RemoteRef"]]
+  sha    <- record[["RemoteSha"]]
+  subdir <- record[["RemoteSubdir"]]
+
+  # generate the remote base
+  remote <- paste(user, repo, sep = "/")
+
+  # include type prefix if we're not github
+  if (!identical(type %||% "github", "github"))
+    remote <- paste(type, remote, sep = "::")
+
+  # include package name if it differs from the repo name
+  if (!identical(package, repo))
+    remote <- paste(package, remote, sep = "=")
+
+  # include subdir if available -- note that renv and pak use slightly
+  # different syntax for declaring a subdir
+  if (!is.null(subdir)) {
+    sep <- if (pak) "/" else ":"
+    remote <- paste(remote, subdir, sep = sep)
+  }
+
+  # prefer using 'sha' for pak remotes
+  if (pak) {
+    remote <- paste(remote, sha %||% ref %||% "HEAD", sep = "@")
+    return(remote)
+  }
+
+  # prefer using 'ref' for compact display
+  if (compact && length(ref)) {
+    ref <- if (ref %in% c("main", "master")) NULL else ref
+    remote <- paste(c(remote, ref), collapse = "@")
+    return(remote)
+  }
+
+  # use sha if available
+  if (length(sha)) {
+    sha <- if (compact) substring(sha, 1L, 8L) else sha
+    remote <- paste(c(remote, sha), collapse = "@")
+    return(remote)
+  }
 
-  paste(record$Package, record$Version, sep = "@")
+  # fall back to using ref
+  remote <- paste(c(remote, ref), collapse = "@")
+  return(remote)
 
 }
 
@@ -110,7 +185,7 @@ 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)
+    remote <- renv_record_format_remote(record, compact = TRUE)
     if (versioned)
       remote <- sprintf("%s  [%s]", record$Version %||% "<NA>", remote)
     return(remote)
@@ -120,27 +195,6 @@ renv_record_format_short <- function(record, versioned = FALSE) {
 
 }
 
-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, separator = "->") {
 
   placeholder <- renv_record_placeholder()

R/retrieve.R

@@ -661,7 +661,8 @@ renv_retrieve_repos <- function(record) {
       warning(error)
   })
 
-  stopf("failed to retrieve package '%s'", renv_record_format_remote(record))
+  remote <- renv_record_format_remote(record, compact = TRUE)
+  stopf("failed to retrieve package '%s'", remote)
 
 }
 

tests/testthat/test-records.R

@@ -137,3 +137,27 @@ test_that("pak's cran remotes are considered cranlike", {
   expect_identical(!!actual, !!expected)
 
 })
+
+test_that("we format github remotes appropriately", {
+
+  record <- list(
+    Package        = "skeleton",
+    Version        = "1.1.0",
+    RemoteType     = "github",
+    RemoteUsername = "kevinushey",
+    RemoteRepo     = "skeleton",
+    RemoteRef      = "main",
+    RemoteSha      = "e4aafb92b86ba7eba3b7036d9d96fdfb6c32761a",
+    RemoteSubdir   = "subdir"
+  )
+
+  remote <- renv_record_format_remote(record, compact = FALSE)
+  expect_equal(remote, "kevinushey/skeleton:subdir@e4aafb92b86ba7eba3b7036d9d96fdfb6c32761a")
+
+  remote <- renv_record_format_remote(record, compact = TRUE)
+  expect_equal(remote, "kevinushey/skeleton:subdir")
+
+  remote <- renv_record_format_remote(record, pak = TRUE)
+  expect_equal(remote, "kevinushey/skeleton/subdir@e4aafb92b86ba7eba3b7036d9d96fdfb6c32761a")
+
+})