R/dependencies.R

Defines functions fileDependencies.tangle fileDependencies.evaluate knitrHasEvaluateHook isShinyApp isRPackage readDESCRIPTION expressionDependencies identifyPackagesUsed recursiveWalk allOf anyOf fileDependencies.R fileDependencies.Rnw fileDependencies.Rpres fileDependencies.knitr fileDependencies.Markdown fileDependencies.Rmd fileDependencies.Qmd stripAltEngines yamlDeps hasYamlFrontMatter fileDependencies dirDependenciesBuiltIn dirDependenciesRenv ignoresForRenv dirDependencies appDependencies

Documented in appDependencies

#' Detect Application Dependencies
#'
#' Recursively detect all package dependencies for an application. This function
#' parses all \R files in the application directory to determine what packages
#' the application depends directly.
#'
#' Only direct dependencies are detected (i.e. no recursion is done to find the
#' dependencies of the dependencies).
#'
#' @param project Directory containing application. Defaults to current working
#'   directory.
#' @param implicit.packrat.dependency Include \code{packrat} as an implicit
#'   dependency of this project, if not otherwise discovered? This should be
#'   \code{FALSE} only if you can guarantee that \code{packrat} will be available
#'   via other means when attempting to load this project.
#'
#' @details Dependencies are determined by parsing application source code and
#'   looking for calls to \code{library}, \code{require}, \code{::}, and
#'   \code{:::}.
#'
#' @return Returns a list of the names of the packages on which R code in the
#'   application depends.
#'
#' @examples
#'
#' \dontrun{
#'
#' # dependencies for the app in the current working dir
#' appDependencies()
#'
#' # dependencies for an app in another directory
#' appDependencies("~/projects/shiny/app1")
#'
#' }
#' @keywords internal
appDependencies <- function(project = NULL,
                            available.packages = NULL,
                            fields = opts$snapshot.fields(),
                            implicit.packrat.dependency = TRUE) {

  if (is.null(available.packages))
    available.packages <- availablePackages()

  project <- getProjectDir(project)

  ## We want to search both local and global library paths for DESCRIPTION files
  ## in the recursive dependency lookup; hence we take a large (ordered) union
  ## of library paths. The ordering ensures that we search the private library first,
  ## and fall back to the local / global library (necessary for `packrat::init`)
  libPaths <- c(
    libDir(project),
    .libPaths(),
    .packrat_mutables$origLibPaths
  )

  ignores <- packrat::opts$ignored.packages()

  ## For R packages, we only use the DESCRIPTION file
  if (isRPackage(project)) {

    ## Make sure we get records recursively from the packages in DESCRIPTION
    parentDeps <-
      pkgDescriptionDependencies(file.path(project, "DESCRIPTION"))$Package

    # Strip out any dependencies the user has requested we do not track.
    parentDeps <- setdiff(parentDeps, ignores)

    ## For downstream dependencies, we don't grab their Suggests:
    ## Presumedly, we can build child dependencies without vignettes, and hence
    ## do not need suggests -- for the package itself, we should make sure
    ## we grab suggests, however
    childDeps <- recursivePackageDependencies(parentDeps,
                                              ignores,
                                              libPaths,
                                              available.packages,
                                              fields)
  } else {
    parentDeps <- setdiff(unique(c(dirDependencies(project))), "packrat")
    parentDeps <- setdiff(parentDeps, ignores)
    childDeps <- recursivePackageDependencies(parentDeps,
                                              ignores,
                                              libPaths,
                                              available.packages,
                                              fields)
  }

  result <- unique(c(parentDeps, childDeps))

  # should packrat be included as automatic dependency?
  if (implicit.packrat.dependency) {
    result <- unique(c(result, "packrat"))
  }

  # If this project is implicitly a shiny application, then
  # add that in as the previously run expression dependency lookup
  # won't have found it.
  if (!("shiny" %in% result) && isShinyApp(project))
    result <- c(result, "shiny")

  if (is.null(result))
    return(character())

  sorted <- sort_c(result)

  # some users have seen empty package names discovered here
  # although we don't know the underlying cause, we should
  # just filter these out as we know they can't be valid
  setdiff(sorted, "")
}

# detect all package dependencies for a directory of files
dirDependencies <- function(dir) {
  if (as.logical(getOption("packrat.dependency.discovery.disabled", default = FALSE))) {
    character()
  } else if (as.logical(getOption("packrat.dependency.discovery.renv", default = TRUE))) {
    dirDependenciesRenv(dir)
  } else {
    dirDependenciesBuiltIn(dir)
  }
}

# Return renv ignore patterns based on the packrat ignored.directories option.
# Each directory is returned as a rooted pattern for renv, meaning that it
# should only apply at the root directory of the project.
#
# Note: The "/data/" and "/inst/" directories are ignored by default.
#
# See: https://github.com/rstudio/renv/pull/866
#
# See: renv:::renv_renvignore_parse_impl
ignoresForRenv <- function(dir, ignoredDirectories) {
  ignores <- NULL
  if (length(ignoredDirectories) > 0) {
    ignores <- ignoredDirectories
    # Make sure all the directories end with a slash.
    ignores <- ifelse(
        substr(ignores, nchar(ignores), nchar(ignores)) != "/",
        paste0(ignores, "/"),
        ignores
    )
    # Make sure all the directories begin with a slash.
    ignores <- ifelse(
        substr(ignores, 1, 1) != "/",
        paste0("/", ignores),
        ignores
    )
    # Prepend the project root and quote.
    ignores <- paste0('^\\Q', dir, '\\E\\Q', ignores, '\\E$')
    # Tell renv that these rules do not need additional parsing.
    attr(ignores, "asis") <- TRUE
  }
  ignores
}

dirDependenciesRenv <- function(dir) {
  old_filebacked_cache <- options(renv.config.filebacked.cache = FALSE)
  on.exit(do.call(options, old_filebacked_cache), add = TRUE)

  project <- Sys.getenv("RENV_PROJECT", unset = NA)
  if (!is.na(project)) {
    Sys.unsetenv("RENV_PROJECT")
    on.exit(Sys.setenv(RENV_PROJECT = project), add = TRUE)
  }

  profile <- Sys.getenv("RENV_PROFILE", unset = NA)
  if (!is.na(profile)) {
    Sys.unsetenv("RENV_PROFILE")
    on.exit(Sys.setenv(RENV_PROFILE = profile), add = TRUE)
  }

  absDir <- normalizePath(dir, winslash = "/")

  old_ignored_packages <- options("renv.settings.ignored.packages" = opts$ignored.packages())
  on.exit(do.call(options, old_ignored_packages), add = TRUE)

  old_renv_exclude <- options("renv.renvignore.exclude" = ignoresForRenv(absDir, opts$ignored.directories()))
  on.exit(do.call(options, old_renv_exclude), add = TRUE)

  # TODO: add rsconnect as an ignored directory? May not be an issue for
  # bundling, since we don't include the rsconnect directory.

  deps <- renv$dependencies(path = absDir, root = absDir, progress = FALSE, errors = "ignored")
  pkgs <- unique(deps$Package)
  ## Exclude recommended packages (and the artifical "R" package) if there is
  ## no package installed locally this places an implicit dependency on the
  ## system-installed version of a package
  pkgs <- dropSystemPackages(pkgs)
  pkgs
}

# detect all package dependencies for a directory of files
dirDependenciesBuiltIn <- function(dir) {
  dir <- normalizePath(dir, winslash = '/')

  # first get the packages referred to in source code
  pattern <- "[.](?:r|rmd|qmd|rnw|rpres)$"
  pkgs <- character()
  R_files <- list.files(dir,
                        pattern = pattern,
                        ignore.case = TRUE,
                        recursive = TRUE
  )

  ## Avoid anything within the packrat directory itself -- all inference
  ## should be done on user code
  packratDirRegex <- "(?:^|/)packrat"
  R_files <- grep(packratDirRegex, R_files, invert = TRUE, value = TRUE)

  ## Avoid anything on the list of ignored directories
  ignoredDir <- get_opts("ignored.directories")
  if (length(ignoredDir) > 0) {
    # Make sure all the directories end with a slash...
    ignoredDir <- ifelse(
      substr(ignoredDir, nchar(ignoredDir), nchar(ignoredDir)) != "/",
      paste0(ignoredDir, "/"),
      ignoredDir
    )

    # Make a regex to match any of them.
    ignoredDirRegex <- paste0(
      "(?:^",
      paste0(
        ignoredDir,
        collapse = ")|(?:^"
      ),
      ")"
    )
    R_files <- grep(ignoredDirRegex, R_files, invert = TRUE, value = TRUE)
  }

  sapply(R_files, function(file) {
    filePath <- file.path(dir, file)
    pkgs <<- append(pkgs, fileDependencies(file.path(dir, file)))

  })

  ## Exclude recommended packages if there is no package installed locally
  ## this places an implicit dependency on the system-installed version of a package
  dropSystemPackages(pkgs)

}

# detect all package dependencies for a source file (parses the file and then
# recursively examines all expressions in the file)

# ad-hoc dispatch based on the file extension
fileDependencies <- function(file) {
  file <- normalizePath(file, winslash = "/", mustWork = TRUE)
  fileext <- tolower(gsub(".*\\.", "", file))
  switch(fileext,
         r = fileDependencies.R(file),
         rmd = fileDependencies.Rmd(file),
         qmd = fileDependencies.Qmd(file),
         rnw = fileDependencies.Rnw(file),
         rpres = fileDependencies.Rpres(file),
         stop("Unrecognized file type '", file, "'")
  )
}

hasYamlFrontMatter <- function(content) {
  lines <- grep("^(---|\\.\\.\\.)\\s*$", content, perl = TRUE)
  1 %in% lines && length(lines) >= 2 && grepl("^---\\s*$", content[1], perl = TRUE)
}

yamlDeps <- function(yaml) {
  unique(c(
    "shiny"[any(grepl("runtime:[[:space:]]*shiny", yaml, perl = TRUE))],
    "shiny"[any(grepl("server:[[:space:]]*shiny", yaml, perl = TRUE))],
    "shiny"[any(grepl("[[:space:]]+type:[[:space:]]*shiny", yaml, perl = TRUE))],
    "rticles"[any(grepl("rticles::", yaml, perl = TRUE))]
  ))
}

stripAltEngines <- function(file, encoding) {
  contents <- readLines(file, encoding = encoding)

  # generate a list of all the headers
  engineHeaders <- which(grepl("^## --.*engine=", contents))
  allHeaders <- c(which(grepl("^## --", contents)), length(contents))

  # calculate the end of each alternate engine code block (the beginning of the
  # very next code block)
  engineEnds <- vapply(engineHeaders, function(x) {
    allHeaders[min(which(allHeaders > x))] - 1
  }, 0)

  # exclude the alternate engine code block lines
  regions <- rep.int(TRUE, length(contents))
  for (h in seq_along(engineHeaders)) {
    regions[engineHeaders[[h]]:engineEnds[[h]]] <- FALSE
  }

  writeLines(contents[regions], file)
}

# compute package dependencies for an *.qmd file. not all Quarto documents
# require R/rmarkdown.
#
# Quarto/rsconnect may independently indicate that this file needs the knitr
# engine and will communicate an implicit dependency on rmarkdown
fileDependencies.Qmd <- function(file) {
  fileDependencies.Markdown(file, implicit = NULL)
}

# compute package dependencies for an *.Rmd file. rmarkdown is an automatic,
# implicit dependency.
fileDependencies.Rmd <- function(file) {
  fileDependencies.Markdown(file, implicit = c("rmarkdown"))
}

fileDependencies.Markdown <- function(file, implicit = NULL) {

  deps <- c()
  if (!is.null(implicit)) {
    deps <- c(deps, implicit)
  }

  # try using an evaluate-based approach for dependencies
  if (knitrHasEvaluateHook()) {

    # attempt to load rmarkdown
    isRmarkdownLoaded <- "rmarkdown" %in% loadedNamespaces()
    if (requireNamespace("rmarkdown", quietly = TRUE)) {

      # unload rmarkdown after we're done with it if it
      # wasn't already loaded
      if (!isRmarkdownLoaded) {
        on.exit(
          try(unloadNamespace("rmarkdown"), silent = TRUE),
          add = TRUE
        )
      }

      # render with a custom evaluate hook to discover dependencies
      deps <- c(deps, fileDependencies.evaluate(file))
    }
  }

  # we don't know this file's encoding, so presume the default encoding
  encoding <- getOption("encoding")
  format <- NULL

  # check whether the default output format references a package
  if (requireNamespace("rmarkdown", quietly = TRUE)) {
    tryCatch({
      format <- rmarkdown::default_output_format(file)
    }, error = function(e) {
      # if we can't parse the YAML header with the default encoding, try UTF-8
      encoding <<- "UTF-8"
      format <<- rmarkdown::default_output_format(file, encoding)
    })
    components <- strsplit(format$name, "::")[[1]]
    if (length(components) == 2) {
      deps <- c(deps, components[[1]])
    }
  }

  # We need to check for and parse YAML frontmatter if necessary
  yamlDeps <- NULL
  content <- readLines(file, encoding = encoding, warn = FALSE)
  if (hasYamlFrontMatter(content)) {

    # Extract the YAML frontmatter.
    tripleDashesDots <- grep("^(---|\\.\\.\\.)\\s*$", content, perl = TRUE)
    start <- tripleDashesDots[[1]]
    end <- tripleDashesDots[[2]]
    yaml <- paste(content[(start + 1):(end - 1)], collapse = "\n")

    # Populate 'deps'.
    yamlDeps <- yamlDeps(yaml)
    deps <- c(deps, yamlDeps)

    # Extract additional dependencies from YAML parameters.
    if (requireNamespace("knitr", quietly = TRUE) &&
        packageVersion("knitr") >= "1.10.18")
    {
      # attempt to extract knitr params from yaml
      knitParams <- tryCatch(
        knitr::knit_params_yaml(yaml, evaluate = FALSE),
        error = function(e) {
          warning(e)
          NULL
        }
      )

      if (length(knitParams)) {
        deps <- c(deps, "shiny")
        for (param in knitParams) {
          if (!is.null(param$expr)) {
            parsed <- quietly(parse(text = param$expr))
            if (!inherits(parsed, "error"))
              deps <- c(deps, expressionDependencies(parsed))
          }
        }
      }

    }
  }

  # Escape hatch for empty .Rmd files
  if (!length(content) || identical(unique(gsub("[[:space:]]", "", content, perl = TRUE)), "")) {
    return(deps)
  }

  ## Unload knitr if needed only for the duration of this function call
  ## This prevents errors with e.g. `packrat::restore` performed after
  ## a `fileDependencies.Rmd` call on Windows, where having knitr loaded
  ## would prevent an installation of knitr to succeed
  knitrIsLoaded <- "knitr" %in% loadedNamespaces()
  on.exit({
    if (!knitrIsLoaded && "knitr" %in% loadedNamespaces()) {
      try(unloadNamespace("knitr"), silent = TRUE)
    }
  }, add = TRUE)

  if (requireNamespace("knitr", quietly = TRUE)) {
    deps <- c(
      deps,
      fileDependencies.tangle(file, encoding = encoding)
    )
  } else {
    warning("knitr is required to parse dependencies but is not available")
  }

  unique(deps)
}

fileDependencies.knitr <- function(...) {
  fileDependencies.Rmd(...)
}

fileDependencies.Rpres <- function(...) {
  fileDependencies.Rmd(...)
}

fileDependencies.Rnw <- function(file) {
  tempfile <- tempfile()
  on.exit(unlink(tempfile))
  tryCatch(silent({
    utils::Stangle(file, output = tempfile)
    fileDependencies.R(tempfile)
  }), error = function(e) {
    fileDependencies.knitr(file)
  })
}

fileDependencies.R <- function(file) {

  if (!file.exists(file)) {
    warning("No file at path '", file, "'.")
    return(character())
  }

  # build a list of package dependencies to return
  pkgs <- character()

  # parse file and examine expressions -- first attempt to
  # parse in system encoding, then try again with UTF-8
  exprs <- quietly(parse(file, n = -1L))
  if (inherits(exprs, "error"))
    exprs <- quietly(parse(file, n = -1L, encoding = "UTF-8"))

  # report parse errors to the user
  if (inherits(exprs, "error")) {
    warning(paste("Failed to parse", file, "; dependencies in this file will",
                  "not be discovered."))
    exprs <- NULL
  }

  # extract expression dependencies
  for (i in seq_along(exprs))
    pkgs <- append(pkgs, expressionDependencies(exprs[[i]]))

  # return packages
  setdiff(unique(pkgs), "")
}

anyOf <- function(object, ...) {
  predicates <- list(...)
  for (predicate in predicates)
    if (predicate(object))
      return(TRUE)
  FALSE
}

allOf <- function(object, ...) {
  predicates <- list(...)
  for (predicate in predicates)
    if (!predicate(object))
      return(FALSE)
  TRUE
}

recursiveWalk <- function(`_node`, fn, ...) {
  fn(`_node`, ...)
  if (is.recursive(`_node`)) {
    for (i in seq_along(`_node`)) {
      recursiveWalk(`_node`[[i]], fn, ...)
    }
  }
}

# Fills 'env' as a side effect
identifyPackagesUsed <- function(call, env) {

  if (!is.call(call))
    return()

  fn <- call[[1]]
  if (!anyOf(fn, is.character, is.symbol))
    return()

  fnString <- as.character(fn)

  # Check for '::', ':::'
  if (fnString %in% c("::", ":::")) {
    if (anyOf(call[[2]], is.character, is.symbol)) {
      pkg <- as.character(call[[2]])
      env[[pkg]] <- TRUE
      return()
    }
  }

  # Check for S4-related function calls (implying a dependency on methods)
  if (fnString %in% c("setClass", "setMethod", "setRefClass", "setGeneric", "setGroupGeneric")) {
    env[["methods"]] <- TRUE
    return()
  }

  # Check for package loaders.
  #
  # The library() and require() calls accept symbols directly as package
  # names, while loadNamespace() and requireNamespace() do not.
  liberalLoaders <- c("library", "require")
  strictLoaders <- c("loadNamespace", "requireNamespace")
  pkgLoaders <- c(strictLoaders, liberalLoaders)
  if (!fnString %in% pkgLoaders)
    return()

  # Try matching the call.
  loader <- tryCatch(
    get(fnString, envir = asNamespace("base")),
    error = function(e) NULL
  )

  if (!is.function(loader))
    return()

  matched <- match.call(loader, call)
  if (!"package" %in% names(matched))
    return()

  if (fnString %in% liberalLoaders) {
    # Protect against 'character.only = TRUE' + symbols.
    # This defends us against a construct like:
    #
    #    for (x in pkgs)
    #        library(x, character.only = TRUE)
    #
    if (!"character.only" %in% names(matched)) {
      if (anyOf(matched[["package"]], is.character, is.symbol)) {
        pkg <- as.character(matched[["package"]])
        env[[pkg]] <- TRUE
        return()
      }
    }
  }

  if (anyOf(matched[["package"]], is.character)) {
    pkg <- as.character(matched[["package"]])
    env[[pkg]] <- TRUE
    return()
  }
}

expressionDependencies <- function(e) {
  if (is.expression(e)) {
    return(unlist(lapply(e, function(call) {
      expressionDependencies(call)
    })))
  }

  else if (is.call(e)) {
    env <- new.env(parent = emptyenv())
    recursiveWalk(e, identifyPackagesUsed, env)
    return(ls(env, all.names = TRUE))
  }

  else character()

}

# Read a DESCRIPTION file into a data.frame
readDESCRIPTION <- function(path) {

  if (!file.exists(path))
    stop("No DESCRIPTION file at path '", path, "'")

  tryCatch(
    readDcf(file = path, all = TRUE),
    error = function(e) {
      return(data.frame())
    }
  )
}

isRPackage <- function(project) {

  descriptionPath <- file.path(project, "DESCRIPTION")
  if (!file.exists(descriptionPath))
    return(FALSE)

  DESCRIPTION <- readDESCRIPTION(descriptionPath)

  # If 'Type' is in the DESCRIPTION, ensure it's equal to 'Package'.
  if ("Type" %in% names(DESCRIPTION))
    return(identical(DESCRIPTION$Type, "Package"))

  # Some packages will have a DESCRIPTION file without the 'Type' field.
  # Check that these still declare themselves with the 'Package' field.
  if ("Package" %in% names(DESCRIPTION))
    return(TRUE)

  # DESCRIPTION for a non-R package (e.g. Shiny application?)
  FALSE

}

# Infer whether a project is (implicitly) a Shiny application,
# in the absence of explicit `library()` statements.
isShinyApp <- function(project) {

  # Check for a DESCRIPTION file with 'Type: Shiny'
  descriptionPath <- file.path(project, "DESCRIPTION")
  if (file.exists(descriptionPath)) {
    DESCRIPTION <- readDESCRIPTION(descriptionPath)
    if (length(DESCRIPTION$Type) && tolower(DESCRIPTION$Type) == "shiny")
      return(TRUE)
  }

  # Check for a server.r with a 'shinyServer' call
  serverPath <- file.path(project, "server.R")
  if (file.exists(file.path(project, "server.R"))) {
    contents <- paste(readLines(serverPath), collapse = "\n")
    if (grepl("shinyServer\\s*\\(", contents, perl = TRUE))
      return(TRUE)
  }

  # Check for a single-file application with 'app.R'
  appPath <- file.path(project, "app.R")
  if (file.exists(appPath)) {
    contents <- paste(readLines(appPath), collapse = "\n")
    if (grepl("shinyApp\\s*\\(", contents, perl = TRUE))
      return(TRUE)
  }

  return(FALSE)
}

knitrHasEvaluateHook <- function() {
  isKnitrLoaded <- "knitr" %in% loadedNamespaces()
  if (!requireNamespace("knitr", quietly = TRUE))
    return(FALSE)

  if (!isKnitrLoaded) {
    on.exit(
      try(unloadNamespace("knitr"), silent = TRUE),
      add = TRUE
    )
  }

  hooks <- knitr::knit_hooks$get()
  "evaluate" %in% names(hooks)
}


fileDependencies.evaluate <- function(file) {

  # discovered packages (to be updated by evaluate hook)
  deps <- list()

  # override any existing engines -- we don't want dependency discovery
  # to, say, run arbitrary bash scripts contained in the document!
  engines <- knitr::knit_engines$get()
  on.exit(knitr::knit_engines$restore(engines), add = TRUE)

  # generate overrides
  overrides <- replicate(length(engines), function(options) {}, FALSE)
  names(overrides) <- names(engines)

  # retain the regular R knitr hook, and treat Rscript chunks
  # the same way as "regular" R chunks
  overrides$R <- overrides$Rscript <- engines$R
  knitr::knit_engines$set(overrides)

  # save old hook and install our custom hook
  evaluate_hook <- knitr::knit_hooks$get("evaluate")
  on.exit(knitr::knit_hooks$set(evaluate = evaluate_hook), add = TRUE)
  knitr::knit_hooks$set(evaluate = function(code, ...) {
    try(silent = TRUE, {
      parsed <- parse(text = code, encoding = "UTF-8")
      deps <<- c(deps, expressionDependencies(parsed))
    })
  })

  # keep going on error
  chunkOptions <- knitr::opts_chunk$get()
  on.exit(knitr::opts_chunk$restore(chunkOptions), add = TRUE)
  knitr::opts_chunk$set(error = TRUE)

  # rudely override knitr's 'inline_exec' function so
  # that we can detect dependencies within inline chunks
  knitr <- asNamespace("knitr")
  if (exists("inline_exec", envir = knitr)) {

    inline_exec <- yoink("knitr", "inline_exec")
    do.call("unlockBinding", list("inline_exec", knitr))
    assign("inline_exec", function(block, ...) {

      # do our own special stuff
      try(silent = TRUE, {
        code <- paste(block$code, collapse = "\n")
        parsed <- parse(text = code, encoding = "UTF-8")
        deps <<- c(deps, expressionDependencies(parsed))
      })

      # return block input without evaluating anything
      block$input

    }, envir = knitr)

    on.exit({
      assign("inline_exec", inline_exec, envir = knitr)
      do.call("lockBinding", list("inline_exec", knitr))
    }, add = TRUE)

  }

  # attempt to render document with our custom hook active
  # TODO: do we want to report errors here? right now we're just
  # capturing and silently discarding render errors
  outfile <- tempfile()
  on.exit(unlink(outfile), add = TRUE)

  tryCatch(
    withCallingHandlers(
      rmarkdown::render(file, output_file = outfile, quiet = TRUE),
      warning = function(w) {

        # ignore warnings emitted by knitr::get_engine()
        get_engine <- yoink("knitr", "get_engine")
        for (i in seq_len(sys.nframe())) {
          fn <- sys.function(i)
          if (identical(fn, get_engine))
            invokeRestart("muffleWarning")
        }

      }
    ),
    error = identity
  )

  unique(unlist(deps, recursive = TRUE))
}




# Extract dependencies per chunk rather than per file.
# Packages like learnr have special R code chunks that are not evaluated at run time.
# While the .Rmd file can be rendered with rmarkdown, a raw tangled R file may not be able to be processed.
fileDependencies.tangle <- function(file, encoding = "UTF-8") {

  # discovered packages
  deps <- list()

  # unique key (line) to split R code with
  key <- paste0("###--packrat-", paste0(sample(letters, 10, replace = TRUE), collapse = ""), "\n")

  # rudely override knitr's 'label_code' function so
  # that we can detect dependencies within inline chunks
  knitr <- asNamespace("knitr")
  if (exists("label_code", envir = knitr)) {
    label_code <- yoink("knitr", "label_code")
    do.call("unlockBinding", list("label_code", knitr))
    assign("label_code", function(...) {
      # paste a known key to split the code chunks by
      paste0(key, label_code(...))
    }, envir = knitr)

    on.exit({
      assign("label_code", label_code, envir = knitr)
      do.call("lockBinding", list("label_code", knitr))
    }, add = TRUE)
  }

  # tangle out file
  outfile <- tempfile()
  on.exit({
    unlink(outfile)
  }, add = TRUE)

  # attempt to tangle document with our custom hook active
  tryCatch(silent(
    knitr::purl(
      file,
      output = outfile, # tangled file location
      quiet = TRUE,

      # `An integer specifying the level of documentation to add
      # to the tangled script. 1L (the default) means to add
      # the chunk headers to the code`
      documentation = 1L,
      encoding = encoding
    )
 ), error = function(e) {
   message("Unable to tangle file '", file, "'; cannot parse dependencies")
   character()
 })

  if (!file.exists(outfile)) {
    # nothing was created
    return(NULL)
  }

  stripAltEngines(outfile, encoding)

  # parse each r chunk independently to retrieve dependencies
  # allows for some chunks to be _broken_ but not stop retrieving dependencies
  r_chunks <- strsplit(paste0(readLines(outfile), collapse = "\n"), key)[[1]]
  for (r_chunk in r_chunks) {
    try(silent = TRUE, {
      parsed <- parse(text = r_chunk, encoding = encoding)
      deps <- c(deps, expressionDependencies(parsed))
    })
  }

  unique(unlist(deps, recursive = TRUE))
}
rstudio/packrat documentation built on Feb. 5, 2024, 9:17 p.m.