R/library-support.R

In rstudio/packrat: A Dependency Management System for Projects and their R Package Dependencies

## System packages == installed packages with a non-NA priority
## Returns TRUE/FALSE, indicating whether the symlinking was successful
symlinkSystemPackages <- function(project = NULL) {
  project <- getProjectDir(project)

  # skip symlinking if requested by user
  if (identical(opts$symlink.system.packages(), FALSE))
    return(FALSE)

  # Get the path to the base R library installation
  sysLibPath <- normalizePath(R.home("library"), winslash = "/", mustWork = TRUE)

  ## Get the system packages
  sysPkgs <- utils::installed.packages(sysLibPath)
  sysPkgsBase <- sysPkgs[!is.na(sysPkgs[, "Priority"]), ]
  sysPkgNames <- rownames(sysPkgsBase)

  ## Make a directory where we can symlink these libraries
  libRdir <- libRdir(project = project)
  if (!file.exists(libRdir))
    if (!dir.create(libRdir, recursive = TRUE))
      return(FALSE)

  ## Generate symlinks for each package
  for (pkg in sysPkgNames) {
    source <- file.path(sysLibPath, pkg)
    target <- file.path(libRdir, pkg)
    if (!ensurePackageSymlink(source, target))
      return(FALSE)
  }

  TRUE
}

isPathToSamePackage <- function(source, target) {

  # When not on Windows, we can just check that the normalized
  # paths resolve to the same location.
  if (!is.windows())
    return(normalizePath(source) == normalizePath(target))

  # On Windows, junction points are not resolved by 'normalizePath()',
  # so we need an alternate strategy for determining if the junction
  # point is up to date. We ensure that the 'DESCRIPTION' files at
  # both locations are equivalent.
  lhsPath <- file.path(source, "DESCRIPTION")
  rhsPath <- file.path(target, "DESCRIPTION")

  # If either of these files do not exist, bail
  if (!(file.exists(lhsPath) && file.exists(rhsPath)))
    return(FALSE)

  lhsContents <- readChar(lhsPath, file.info(lhsPath)$size, TRUE)
  rhsContents <- readChar(rhsPath, file.info(rhsPath)$size, TRUE)

  identical(lhsContents, rhsContents)
}

# Clean up recursive symlinks erroneously generated by
# older versions of packrat. This code can probably be
# removed in a future release of packrat.
cleanRecursivePackageSymlinks <- function(source) {
  target <- file.path(source, basename(source))
  if (file.exists(target)) {
    sourceFiles <- list.files(source)
    targetFiles <- list.files(target)
    if (identical(sourceFiles, targetFiles))
      unlink(target)
  }
}

ensurePackageSymlink <- function(source, target) {

  cleanRecursivePackageSymlinks(source)

  # If we have a symlink already active in the
  # target location, check that it points to the
  # library corresponding to the current running
  # R session.
  if (file.exists(target)) {

    if (isPathToSamePackage(source, target))
      return(TRUE)

    # Remove the old symlink target (swallowing errors)
    tryCatch(
      unlink(target, recursive = !is.symlink(target)),
      error = identity
    )

    # Check if the file still exists and warn if so
    if (file.exists(target)) {

      # request information on the existing file
      info <- paste(capture.output(print(file.info(target))), collapse = "\n")
      msg <- c(
        sprintf("Packrat failed to remove a pre-existing file at '%s'.", target),
        "Please report this issue at 'https://github.com/rstudio/packrat/issues'.",
        "File info:",
        info
      )

      warning(paste(msg, collapse = "\n"))
    }
  }

  # If, for some reason, the target directory
  # still exists, bail as otherwise symlinking
  # will not work as desired.
  if (file.exists(target))
    stop("Target '", target, "' already exists and is not a symlink")

  # Perform the symlink.
  symlink(source, target)

  # Success if the file now exists
  file.exists(file.path(target, "DESCRIPTION"))
}

symlinkExternalPackages <- function(project = NULL) {

  external.packages <- opts$external.packages()
  if (!length(external.packages))
    return(invisible(NULL))

  project <- getProjectDir(project)
  if (!file.exists(libExtDir(project)))
    if (!dir.create(libExtDir(project), recursive = TRUE))
      stop("Failed to create 'lib-ext' packrat directory")

  # Get the default (non-packrat) library paths
  lib.loc <- getDefaultLibPaths()
  pkgDeps <- recursivePackageDependencies(
    external.packages,
    ignores = NULL,
    lib.loc = lib.loc,
    available.packages = NULL
  )
  allPkgs <- union(external.packages, pkgDeps)

  # Get the locations of these packages within the supplied lib.loc
  loc <- lapply(allPkgs, function(x) {
    find.package(x, lib.loc = lib.loc, quiet = TRUE)
  })
  names(loc) <- allPkgs

  # Warn about missing packages
  notFound <- loc[sapply(loc, function(x) {
    !length(x)
  })]

  if (length(notFound)) {
    warning("The following external packages could not be located:\n- ",
            paste(shQuote(names(notFound)), collapse = ", "))
  }

  # Symlink the packages that were found
  loc <- loc[sapply(loc, function(x) length(x) > 0)]
  results <- lapply(loc, function(x) {
    source <- x
    target <- file.path(libExtDir(project), basename(x))
    ensurePackageSymlink(source, target)
  })

  failedSymlinks <- results[sapply(results, Negate(isTRUE))]
  if (length(failedSymlinks)) {
    warning("The following external packages could not be linked into ",
            "the packrat private library:\n- ",
            paste(shQuote(names(failedSymlinks)), collapse = ", "))
  }
}

is.symlink <- function(path) {

  ## Strip trailing '/'
  path <- gsub("/*$", "", path)

  ## Sys.readlink returns NA for error, "" for 'not a symlink', and <path> for symlink
  ## return false for first two cases, true for second
  result <- Sys.readlink(path)
  if (is.na(result)) FALSE
  else nzchar(result)

}

useSymlinkedSystemLibrary <- function(project = NULL) {
  project <- getProjectDir(project)
  replaceLibrary(".Library", libRdir(project = project))
}