Merge pull request #388 from r-lib/feature/deps

Search for package dependencies in R code files

DESCRIPTION

@@ -68,6 +68,8 @@ Config/Needs/website:
     r-lib/asciicast,
     pkgdown (>= 2.0.2),
     tidyverse/tidytemplate
+Remotes:
+    r-lib/cli
 Config/testthat/edition: 3
 Encoding: UTF-8
-RoxygenNote: 7.3.1.9000
+RoxygenNote: 7.3.2

NAMESPACE

@@ -54,6 +54,7 @@ export(pkg_installation_proposal)
 export(pkg_name_check)
 export(pkg_rx)
 export(repo)
+export(scan_deps)
 export(sysreqs_check_installed)
 export(sysreqs_db_list)
 export(sysreqs_db_match)
@@ -66,3 +67,4 @@ export(sysreqs_platforms)
 importFrom(stats,na.omit)
 importFrom(utils,modifyList)
 importFrom(utils,untar)
+useDynLib(pkgdepends, .registration = TRUE, .fixes = "c_")

NEWS.md

@@ -1,5 +1,9 @@
 # pkgdepends (development version)
 
+* New function `scan_deps()` to auto-detect package dependencies from
+  R code. `deps::.` automatically uses detected dependencies now if no
+  `DESCRIPTION` file is found.
+
 # pkgdepends 0.8.0
 
 * pkgdepends now supports `gitlab::` package sources better, by adding

R/cleancall.R

@@ -0,0 +1,4 @@
+
+call_with_cleanup <- function(ptr, ...) {
+  .Call(c_cleancall_call, pairlist(ptr, ...), parent.frame())
+}

R/find-package-root.R

@@ -1,4 +1,11 @@
+project_root_anchors <-
+  c("DESCRIPTION", ".git", ".Rproj.user", "renv.lock", "renv")
+
 find_package_root <- function(path = ".") {
+  find_project_root(path = path, anchors = "DESCRIPTION")
+}
+
+find_project_root <- function(path = ".", anchors = project_root_anchors) {
   is_root <- function(path) {
     identical(
       normalizePath(path, winslash = "/"),
@@ -17,7 +24,7 @@ find_package_root <- function(path = ".") {
   )
   max_depth <- 100
   for (i in 1:max_depth) {
-    if (file.exists(file.path(cur_path, "DESCRIPTION"))) {
+    if (any(file.exists(file.path(cur_path, anchors)))) {
       return(cur_path)
     } else if (is_root(cur_path)) {
       stop(errmsg)

R/pkgdepends.R

@@ -6,6 +6,7 @@
 #' installations, to be used in other packages. If you are looking for a
 #' package manager, see [pak](https://github.com/r-lib/pak).
 #'
+#' @useDynLib pkgdepends, .registration = TRUE, .fixes = "c_"
 #' @includeRmd tools/doc/README-body.Rmd
 "_PACKAGE"
 

R/scan-deps-dep-types.R

@@ -0,0 +1,6 @@
+get_dep_type_from_path <- function(paths) {
+  type <- rep("prod", length(paths))
+  type[paths == "man/roxygen/meta.R"] <- "dev"
+  type[startsWith(paths, "tests/") | startsWith(paths, "test/")] <- "test"
+  type
+}

R/scan-deps-queries.R

@@ -0,0 +1,168 @@
+# match any library(), require(), base::library(), base::require(), etc. calls
+# we use these as fallbacks. If a call is not identified some other way
+# we parse it with R and match the call.
+q_library_0 <- function() {
+  structure(c(
+    '((call function: (identifier) @fn-name) @dep-code
+      (#any-of? @fn-name
+       "library" "require" "loadNamespace" "requireNamespace"
+       "pkg_attach" "pkg_attach2"
+       "p_load"
+       "module"
+       "tar_option_set"
+       "glue"
+       "ggsave"
+       "set_engine"
+       "R6Class" "test_package" "test_dir" "test_file"))',
+    '((call function:
+       (namespace_operator
+        lhs: (identifier) @ns-name
+        rhs: (identifier) @fn-name
+       )
+      ) @dep-code
+      (#any-of? @ns-name
+       "base" "xfun" "pacman" "modules" "import" "box" "targets" "glue"
+       "ggplot2" "parsnip" "R6" "testthat")
+      (#any-of? @fn-name
+       "library" "require" "loadNamespace" "requireNamespace"
+       "pkg_attach" "pkg_attach2"
+       "p_load"
+       "module" "import"
+       "from" "here" "into"
+       "use"
+       "tar_option_set"
+       "glue"
+       "ggsave"
+       "set_engine"
+       "R6Class" "test_package" "test_dir" "test_file"))'
+  ), names = rep("q_library_0", 2))
+}
+
+q_module_import <- function() {
+  c(
+    '((call function: (identifier) @fn-name) @dep-code
+      (#any-of? @fn-name "import"))',
+    '((call function:
+       (namespace_operator
+        lhs: (identifier) @ns-name
+        rhs: (identifier) @fn-name
+       )
+      ) @dep-code
+      (#any-of? @ns-name "modules")
+      (#any-of? @fn-name "import"))'
+  )
+}
+
+# pkg::fun, pkg:::fun
+q_colon <- function() {
+  '((namespace_operator lhs: (identifier) @pkg-name) @dep-code
+    (#not-eq? @pkg-name "base")
+  )'
+}
+
+q_methods <- function() {
+  structure(
+    '((call function: (identifier) @fn-name) @dep-code
+      (#any-of? @fn-name "setClass" "setGeneric"))',
+    names = "methods"
+  )
+}
+
+q_junit_reporter <- function() {
+  structure(c(
+    '((call function:
+      (extract_operator
+       lhs: (identifier) @class-name
+       rhs: (identifier) @method-name
+      )
+     ) @dep-code
+     (#eq? @class-name "JunitReporter")
+     (#eq? @method-name "new"))',
+    '((call function:
+      (extract_operator
+       lhs: (namespace_operator
+             lhs: (identifier) @pkg-name
+             rhs: (identifier) @class-name)
+       rhs: (identifier) @method-name
+      )
+     ) @dep-code
+     (#eq? @pkg-name "testthat")
+     (#eq? @class-name "JunitReporter")
+     (#eq? @method-name "new"))'
+  ), names = rep("junit_reporter", 2))
+}
+
+q_knitr_dev <- function() {
+  structure(c(
+    '((call function:
+      (extract_operator
+       lhs: (identifier) @object-name
+       rhs: (identifier) @method-name
+      )
+     ) @dep-code
+     (#eq? @object-name "opts_chunk")
+     (#eq? @method-name "set"))',
+    '((call function:
+      (extract_operator
+       lhs: (namespace_operator
+             lhs: (identifier) @pkg-name
+             rhs: (identifier) @object-name)
+       rhs: (identifier) @method-name
+      )
+     ) @dep-code
+     (#eq? @pkg-name "knitr")
+     (#eq? @object-name "opts_chunk")
+     (#eq? @method-name "set"))'
+  ), names = rep("knitr_dev", 2))
+}
+
+renv_dependencies_database <- function() {
+  db <- getOption("renv.dependencies.database", default = list())
+  db$ggplot2$geom_hex <- "hexbin"
+  db$testthat$JunitReporter <- "xml2"
+  db
+}
+
+q_database <- function() {
+  db <- renv_dependencies_database()
+  fns <- unlist(lapply(db, names))
+  if (length(fns) == 0) return(NULL)
+  structure(sprintf(
+    '((identifier) @id
+      (#any-of? @id %s))',
+    paste0('"', fns, '"', collapse = " ")
+  ), names = "database")
+}
+
+q_deps <- function() {
+  c(
+    q_library_0(),
+    q_colon(),
+    q_methods(),
+    q_junit_reporter(),
+    q_knitr_dev(),
+    q_database(),
+    NULL
+  )
+}
+
+q_deps_rmd <- function() {
+  c(block =
+    '(fenced_code_block
+      (fenced_code_block_delimiter)
+      (info_string (language) @language) @header
+      (code_fence_content) @content
+      (#any-of? @language "r" "R" "rscript" "Rscript")
+      (#match? @header "^[{]")
+    )',
+    inline =
+      '(inline) @inline'
+  )
+}
+
+q_deps_rmd_inline <- function() {
+  '(code_span
+    (code_span_delimiter) @csd1
+    (code_span_delimiter) @csd2
+  ) @code'
+}