R/bundlePackageRenv.R

In rsconnect: Deploy Docs, Apps, and APIs to 'Posit Connect', 'shinyapps.io', and 'RPubs'

snapshotRenvDependencies <- function(
  bundleDir,
  extraPackages = character(),
  quiet = FALSE,
  verbose = FALSE
) {
  recordExtraDependencies(bundleDir, extraPackages)

  old <- options(
    renv.verbose = FALSE,
    renv.consent = TRUE
  )
  defer(options(old))

  dependenciesLimit <- getOption("renv.config.dependencies.limit")
  if (is.null(dependenciesLimit)) {
    maxFiles <- getOption("rsconnect.max.bundle.files", 10000)
    oldlim <- options(
      renv.config.dependencies.limit = maxFiles
    )
    defer(options(oldlim))
  }

  # analyze code dependencies ourselves rather than relying on the scan during renv::snapshot, as
  # that will add renv to renv.lock as a dependency.
  deps <- renv::dependencies(
    bundleDir,
    root = bundleDir,
    quiet = if (quiet) TRUE else NULL,
    progress = FALSE
  )
  renv::snapshot(bundleDir, packages = deps$Package, prompt = FALSE)
  # renv::snapshot() respects RENV_PATHS_LOCKFILE and renv profiles, so the
  # lockfile may have been written to a non-standard location.
  lockfile <- resolveRenvLockFile(bundleDir)
  if (is.null(lockfile)) {
    cli::cli_abort("renv::snapshot() did not produce a lockfile")
  }
  defer(removeRenv(bundleDir))

  parseRenvDependencies(lockfile, bundleDir, snapshot = TRUE)
}

parseRenvDependencies <- function(lockfile, bundleDir, snapshot = FALSE) {
  renvLock <- jsonlite::read_json(lockfile)
  repos <- setNames(
    vapply(renvLock$R$Repositories, "[[", "URL", FUN.VALUE = character(1)),
    vapply(renvLock$R$Repositories, "[[", "Name", FUN.VALUE = character(1))
  )
  deps <- standardizeRenvPackages(
    renvLock$Packages,
    repos,
    biocPackages = biocPackages(bundleDir)
  )
  if (nrow(deps) == 0) {
    return(data.frame())
  }
  deps$description <- lapply(deps$Package, package_record)
  if (!snapshot) {
    lib_versions <- unlist(lapply(deps$description, "[[", "Version"))

    if (any(deps$Version != lib_versions)) {
      cli::cli_abort(c(
        "Library and lockfile are out of sync",
        i = "Use renv::restore() or renv::snapshot() to synchronise",
        i = "Or ignore the lockfile by adding to your .rscignore"
      ))
    }
  }

  deps
}

standardizeRenvPackages <- function(packages, repos, biocPackages = NULL) {
  repos <- standardizeRepos(repos)
  availablePackages <- availablePackages(repos)

  names(packages) <- NULL
  out <- lapply(
    packages,
    standardizeRenvPackage,
    availablePackages = availablePackages,
    biocPackages = biocPackages,
    repos = repos
  )
  out <- compact(out)
  out <- lapply(out, as.data.frame, stringsAsFactors = FALSE)
  rbind_fill(out)
}

standardizeRenvPackage <- function(
  pkg,
  availablePackages,
  biocPackages = NULL,
  repos = character(),
  bioc
) {
  # Convert renv source to manifest source/repository
  # https://github.com/rstudio/renv/blob/0.17.2/R/snapshot.R#L730-L773

  if (
    is.null(pkg$Repository) &&
      !is.null(pkg$RemoteRepos) &&
      grepl("bioconductor.org", pkg$RemoteRepos)
  ) {
    # Work around bug where renv fails to detect BioC package installed by pak
    # https://github.com/rstudio/renv/issues/1202
    pkg$Source <- "Bioconductor"
  }

  if (pkg$Source == "Repository") {
    if (identical(pkg$Repository, "CRAN")) {
      if (isDevVersion(pkg, availablePackages)) {
        pkg$Source <- NA_character_
        pkg$Repository <- NA_character_
      } else {
        pkg$Source <- "CRAN"
        pkg$Repository <- findRepoUrl(pkg$Package, availablePackages)
      }
    } else {
      # $Repository comes from DESCRIPTION and is set by repo, so can be
      # anything. First check if it matches a known repository name,
      # otherwise look up from the package name in availablePackages
      # Note: our terminology is confusing: the name of the repsoitory is
      # we call "Source" even though renv uses "Repository" and the URL of
      # the repository we call "Repository"
      originalRepository <- pkg$Repository

      if (
        !is.null(originalRepository) && originalRepository %in% names(repos)
      ) {
        # Use the repository specified in renv.lock
        pkg$Repository <- repos[[originalRepository]]
        pkg$Source <- originalRepository
      } else {
        # Fall back to looking up from availablePackages
        pkg$Repository <- findRepoUrl(pkg$Package, availablePackages)
        pkg$Source <- findRepoName(pkg$Repository, repos)
        if (is.na(pkg$Source)) {
          # Archived packages are not publicized by available.packages(). Use
          # the renv.lock repository as source, expecting that the package is
          # available through one of the repository URLs.
          pkg$Source <- originalRepository
        }
      }
    }
  } else if (pkg$Source == "Bioconductor") {
    pkg$Repository <- findRepoUrl(pkg$Package, availablePackages)
    if (is.na(pkg$Repository)) {
      # Try packages defined from default bioC repos
      pkg$Repository <- findRepoUrl(pkg$Package, biocPackages)
    }
  } else if (pkg$Source %in% c("Bitbucket", "GitHub", "GitLab")) {
    pkg$Source <- tolower(pkg$Source)
  } else if (pkg$Source == "Local") {
    # A locally-installed package (e.g. via pak "local::") may still be
    # available from a configured repository. Make a best effort to locate
    # it, the same way we handle packages installed from source.
    pkg$Repository <- findRepoUrl(pkg$Package, availablePackages)
    pkg$Source <- findRepoName(pkg$Repository, repos)
    if (is.na(pkg$Source)) {
      pkg$Source <- NA_character_
      pkg$Repository <- NA_character_
    }
  } else if (pkg$Source == "unknown") {
    pkg$Source <- NA_character_
    pkg$Repository <- NA_character_
  }

  # Remove Remote fields that pak adds for "standard" installs from CRAN
  if (identical(pkg$RemoteType, "standard")) {
    pkg <- pkg[!grepl("^Remote", names(pkg))]
  }

  pkg[manifestPackageColumns(pkg)]
}

biocPackages <- function(bundleDir) {
  signal("evaluating", class = "rsconnect_biocRepos") # used for testing
  availablePackages(biocRepos(bundleDir))
}
biocRepos <- function(bundleDir) {
  repos <- getFromNamespace("renv_bioconductor_repos", "renv")(bundleDir)
  repos[setdiff(names(repos), "CRAN")]
}

# Find the renv lockfile, checking both the renv-resolved path and the
# standard location. Returns the path if found, NULL otherwise.
resolveRenvLockFile <- function(bundleDir) {
  resolved <- renv::paths$lockfile(project = bundleDir)
  if (file.exists(resolved)) {
    return(resolved)
  }

  standard <- file.path(bundleDir, "renv.lock")
  if (file.exists(standard)) {
    return(standard)
  }

  NULL
}

removeRenv <- function(path, lockfile = TRUE) {
  if (lockfile) {
    unlink(resolveRenvLockFile(path))
  }
  unlink(file.path(path, "renv"), recursive = TRUE)
}