From 146ddd29ddc2f733e8a205b1665f5be752d20790 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= <csardi.gabor@gmail.com>
Date: Mon, 4 Nov 2024 15:43:16 +0100
Subject: [PATCH] Scan deps: support ragg from knitr device

---
 R/scan-deps-queries.R | 25 +++++++++++++++++++
 R/scan-deps.R         | 56 ++++++++++++++++++++++++++++++++++++-------
 2 files changed, 72 insertions(+), 9 deletions(-)

diff --git a/R/scan-deps-queries.R b/R/scan-deps-queries.R
index a491a470..1126745a 100644
--- a/R/scan-deps-queries.R
+++ b/R/scan-deps-queries.R
@@ -92,12 +92,37 @@ q_junit_reporter <- function() {
   ), 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))
+}
+
 q_deps <- function() {
   c(
     q_library_0(),
     q_colon(),
     q_methods(),
     q_junit_reporter(),
+    q_knitr_dev(),
     NULL
   )
 }
diff --git a/R/scan-deps.R b/R/scan-deps.R
index dee95876..8595baa5 100644
--- a/R/scan-deps.R
+++ b/R/scan-deps.R
@@ -41,11 +41,12 @@ re_r_dep <- paste0(collapse = "|", c(
   "p_load",
   "module",
   "import",
-  "box",
+  "box::",
   "tar_option_set",
   "glue",
   "ggsave",
-  "set_engine"
+  "set_engine",
+  "opts_chunk"
 ))
 
 scan_path_deps <- function(path) {
@@ -122,12 +123,18 @@ scan_path_deps_do_r <- function(code, path, ranges = NULL) {
   jr_pat <- hits$patterns$id[hits$patterns$name %in% jr_patterns]
   jr_hits <- mct[mct$pattern %in% jr_pat, ]
 
-  pkg_hits <- mct[! mct$pattern %in% c(gen_pat, fn_pat, jr_pat), ]
+  # knit ragg_png device needs ragg
+  ragg_patterns <- "knitr_dev"
+  ragg_pat <- hits$patterns$id[hits$patterns$name %in% ragg_patterns]
+  ragg_hits <- mct[mct$pattern %in% ragg_pat, ]
+
+  pkg_hits <- mct[! mct$pattern %in% c(gen_pat, fn_pat, jr_pat, ragg_pat), ]
   rbind(
     if (nrow(pkg_hits) > 0) scan_path_deps_do_pkg_hits(pkg_hits, path),
     if (nrow(fn_hits) > 0) scan_path_deps_do_fn_hits(fn_hits, path),
     if (nrow(gen_hits) > 0) scan_path_deps_do_gen_hits(gen_hits, path),
-    if (nrow(jr_hits) > 0) scan_path_deps_do_jr_hits(jr_hits, path)
+    if (nrow(jr_hits) > 0) scan_path_deps_do_jr_hits(jr_hits, path),
+    if (nrow(ragg_hits) > 0) scan_pat_deps_do_ragg_hits(ragg_hits, path)
   )
 }
 
@@ -195,11 +202,38 @@ scan_path_deps_do_jr_hits <- function(hits, path) {
   )
 }
 
+scan_pat_deps_do_ragg_hits <- function(hits, path) {
+  wcodes <- which(hits$name == "dep-code")
+  for (wc in wcodes) {
+    expr <- parse(text = hits$code[wc], keep.source = FALSE)
+    matched <- match.call(function(...) { }, expr, expand.dots=FALSE)
+    args <- matched[["..."]]
+    if ("dev" %in% names(args) && args[["dev"]] == "ragg_png") {
+      return(data_frame(
+        path = path,
+        package = "ragg",
+        type = get_dep_type_from_path(path),
+        code = hits$code[wc],
+        start_row = hits$start_row[wc],
+        start_column = hits$start_column[wc],
+        start_byte = hits$start_byte[wc]
+      ))
+    }
+  }
+  NULL
+}
+
 prot_xfun_pkg_attach <- function(..., install, message) { }
 prot_xfun_pkg_attach2 <- function(...) { }
-prot_pacman_p_load <- function(..., char, install, update, character.only) { }
-prot_modules_import <- function(from, ..., attach = TRUE, where = parent.frame()) { }
-prot_modules_module <- function(expr = {}, topEncl = NULL, envir = parent.frame()) { }
+prot_pacman_p_load <- function(
+  ..., char, install, update, character.only) {
+}
+prot_modules_import <- function(
+  from, ..., attach = TRUE, where = parent.frame()) {
+}
+prot_modules_module <- function(
+  expr = {}, topEncl = NULL, envir = parent.frame()) {
+}
 prot_import_from <- function(.from, ..., .character_only = FALSE) { }
 prot_import_here <- function(.from, ..., .character_only = FALSE) { }
 prot_import_into <- function(
@@ -208,7 +242,9 @@ prot_import_into <- function(
   .S3 = FALSE) {
 }
 prot_box_use <- function(...) { }
-prot_targets_tar_option_set <- function(tidy_eval = NULL, packages = NULL, ...) { }
+prot_targets_tar_option_set <- function(
+  tidy_eval = NULL, packages = NULL, ...) {
+}
 prot_glue_glue <- function(
   ..., .sep = "", .envir = parent.frame(), .open = "{", .close = "}") {
 }
@@ -218,7 +254,9 @@ prot_r6_r6class <- function(
   classname = NULL, public = list(), private = NULL, active = NULL,
   inherit = NULL, ...) { }
 prot_testthat_test_package <- function(package, reporter = NULL, ...) { }
-prot_testthat_test_dir <- function(path, filter = NULL, reporter = NULL, ...) { }
+prot_testthat_test_dir <- function(
+  path, filter = NULL, reporter = NULL, ...) {
+}
 prot_testthat_test_file <- function(path, reporter = NULL, ...) { }
 
 safe_parse_pkg_from_call <- function(ns, fn, code) {