commit changes from https://github.com/insightsengineering/teal.data/pull/340/files

Author: m7pr

R/qenv-get_code.R

@@ -112,6 +112,11 @@ setMethod("get_code", signature = "qenv", function(object, deparse = TRUE, names
   checkmate::assert_flag(deparse)
   checkmate::assert_character(names, min.len = 1L, null.ok = TRUE)
 
+  # Normalize in case special it is backticked
+  if (!is.null(names)) {
+    names <- gsub("^`(.*)`$", "\\1", names)
+  }
+
   code <- if (!is.null(names)) {
     get_code_dependency(object@code, names, ...)
   } else {

R/utils-get_code_dependency.R

@@ -42,6 +42,7 @@ get_code_dependency <- function(code, names, check_names = TRUE) {
 
   code <- parse(text = code, keep.source = TRUE)
   pd <- utils::getParseData(code)
+  pd <- normalize_pd(pd)
   calls_pd <- extract_calls(pd)
 
   if (check_names) {
@@ -175,7 +176,7 @@ fix_arrows <- function(calls) {
 sub_arrows <- function(call) {
   checkmate::assert_data_frame(call)
   map <- data.frame(
-    row.names = c("`<-`", "`<<-`", "`=`"),
+    row.names = c("<-", "<<-", "="),
     token = rep("LEFT_ASSIGN", 3),
     text = rep("<-", 3)
   )
@@ -297,7 +298,7 @@ extract_occurrence <- function(calls_pd) {
 
       # What occurs in a function body is not tracked.
       x <- call_pd[!is_in_function(call_pd), ]
-      sym_cond <- which(x$token %in% c("SYMBOL", "SYMBOL_FUNCTION_CALL"))
+      sym_cond <- which(x$token %in% c("SPECIAL", "SYMBOL", "SYMBOL_FUNCTION_CALL"))
 
       if (length(sym_cond) == 0) {
         return(character(0L))
@@ -434,3 +435,19 @@ detect_libraries <- function(calls_pd) {
     )
   )
 }
+
+#' Normalize parsed data removing backticks from symbols
+#'
+#' @param pd `data.frame` resulting from `utils::getParseData()` call.
+#'
+#' @return `data.frame` with backticks removed from `text` column for `SYMBOL` tokens.
+#'
+#' @keywords internal
+#' @noRd
+normalize_pd <- function(pd) {
+  # Remove backticks from SYMBOL tokens
+  symbol_index <- grepl("^SYMBOL.*$", pd$token)
+  pd[symbol_index, "text"] <- gsub("^`(.*)`$", "\\1", pd[symbol_index, "text"])
+
+  pd
+}

tests/testthat/test-qenv_get_code.R

@@ -740,3 +740,135 @@ testthat::test_that("data() call is returned when data name is provided as a cha
     )
   )
 })
+
+
+testthat::describe("Backticked symbol", {
+  testthat::it("code can be retrieved with get_code", {
+    td <- within(
+      teal_data(),
+      {
+        `%cbind%` <- function(lhs, rhs) cbind(lhs, rhs) # nolint: object_name.
+        iris_ds <- iris %cbind% data.frame(new_col = "new column")
+      }
+    )
+
+    testthat::expect_identical(
+      get_code(td, datanames = "%cbind%"),
+      "`%cbind%` <- function(lhs, rhs) cbind(lhs, rhs)"
+    )
+  })
+
+  testthat::it("code can be retrieved with get_code", {
+    td <- within(
+      teal_data(),
+      {
+        `%cbind%` <- function(lhs, rhs) cbind(lhs, rhs) # nolint: object_name.
+        iris_ds <- iris %cbind% data.frame(new_col = "new column")
+      }
+    )
+
+    testthat::expect_identical(
+      get_code(td, datanames = "`%cbind%`"),
+      "`%cbind%` <- function(lhs, rhs) cbind(lhs, rhs)"
+    )
+  })
+
+  testthat::it("starting with underscore is detected in code dependency", {
+    td <- within(
+      teal_data(),
+      {
+        `_add_column_` <- function(lhs, rhs) cbind(lhs, rhs) # nolint: object_name.
+        iris_ds <- `_add_column_`(iris, data.frame(new_col = "new column"))
+      }
+    )
+
+    testthat::expect_identical(
+      get_code(td, datanames = "iris_ds"),
+      paste(
+        sep = "\n",
+        "`_add_column_` <- function(lhs, rhs) cbind(lhs, rhs)",
+        "iris_ds <- `_add_column_`(iris, data.frame(new_col = \"new column\"))"
+      )
+    )
+  })
+
+  testthat::it("with space character is detected in code dependency", {
+    td <- within(
+      teal_data(),
+      {
+        `add column` <- function(lhs, rhs) cbind(lhs, rhs) # nolint: object_name.
+        iris_ds <- `add column`(iris, data.frame(new_col = "new column"))
+      }
+    )
+
+    testthat::expect_identical(
+      get_code(td, datanames = "iris_ds"),
+      paste(
+        sep = "\n",
+        "`add column` <- function(lhs, rhs) cbind(lhs, rhs)",
+        "iris_ds <- `add column`(iris, data.frame(new_col = \"new column\"))"
+      )
+    )
+  })
+
+  testthat::it("without special characters is cleaned and detected in code dependency", {
+    td <- within(
+      teal_data(),
+      {
+        `add_column` <- function(lhs, rhs) cbind(lhs, rhs)
+        iris_ds <- `add_column`(iris, data.frame(new_col = "new column"))
+      }
+    )
+
+    testthat::expect_identical(
+      get_code(td, datanames = "iris_ds"),
+      paste(
+        sep = "\n",
+        "add_column <- function(lhs, rhs) cbind(lhs, rhs)",
+        "iris_ds <- add_column(iris, data.frame(new_col = \"new column\"))"
+      )
+    )
+  })
+
+  testthat::it("with non-native pipe used as function is detected code dependency", {
+    td <- within(
+      teal_data(),
+      {
+        `%add_column%` <- function(lhs, rhs) cbind(lhs, rhs)
+        iris_ds <- `%add_column%`(iris, data.frame(new_col = "new column"))
+      }
+    )
+
+    # Note that the original code is changed to use the non-native pipe operator
+    # correctly.
+    testthat::expect_identical(
+      get_code(td, datanames = "iris_ds"),
+      paste(
+        sep = "\n",
+        "`%add_column%` <- function(lhs, rhs) cbind(lhs, rhs)",
+        "iris_ds <- iris %add_column% data.frame(new_col = \"new column\")"
+      )
+    )
+  })
+
+  testthat::it("with non-native pipe is detected code dependency", {
+    td <- within(
+      teal_data(),
+      {
+        `%add_column%` <- function(lhs, rhs) cbind(lhs, rhs)
+        iris_ds <- iris %add_column% data.frame(new_col = "new column")
+      }
+    )
+
+    # Note that the original code is changed to use the non-native pipe operator
+    # correctly.
+    testthat::expect_identical(
+      get_code(td, datanames = "iris_ds"),
+      paste(
+        sep = "\n",
+        "`%add_column%` <- function(lhs, rhs) cbind(lhs, rhs)",
+        "iris_ds <- iris %add_column% data.frame(new_col = \"new column\")"
+      )
+    )
+  })
+})