Skip to content

Commit fcad956

Browse files
averissimodependabot-preview[bot]
averissimo
and
dependabot-preview[bot]
authored
Allow non-standard datanames in code dependency (#340)
# Pull Request <!--- Replace `#nnn` with your issue link for reference. --> Fixes insightsengineering/teal#1366 Related: - insightsengineering/teal#1382 - insightsengineering/teal.slice#622 - #340 ### Changes description - [x] Adds support for non-standard names in code dependency - [x] Support backtick symbols in code dependency <details> <summary>Reproducible code for backtick support in code parser</summary> `%add_column%` definition is not detected ```r pkgload::load_all("teal.data") #> ℹ Loading teal.data #> Loading required package: teal.code td <- teal_data() |> within({ IRIS <- iris IRIS2 <- iris MTCARS <- mtcars `%add_column%` <- function(lhs, rhs) dplyr::bind_cols(lhs, rhs) # @ add_column <- function(lhs, rhs) dplyr::bind_cols(lhs, rhs) IRIS <- IRIS %add_column% dplyr::tibble(yada = IRIS2$Species) IRIS <- add_column(IRIS, dplyr::tibble(yada2 = IRIS2$Species)) }) td |> get_code(datanames = "IRIS") |> cat() #> IRIS <- iris #> IRIS2 <- iris #> add_column <- function(lhs, rhs) dplyr::bind_cols(lhs, rhs) #> IRIS <- IRIS %add_column% dplyr::tibble(yada = IRIS2$Species) #> IRIS <- add_column(IRIS, dplyr::tibble(yada2 = IRIS2$Species)) td2 <- td |> within({ IRIS <- `%add_column%`(IRIS, dplyr::tibble(yada2 = IRIS2$Species)) }) td2 |> get_code(datanames = "IRIS") |> cat() #> IRIS <- iris #> IRIS2 <- iris #> add_column <- function(lhs, rhs) dplyr::bind_cols(lhs, rhs) #> IRIS <- IRIS %add_column% dplyr::tibble(yada = IRIS2$Species) #> IRIS <- add_column(IRIS, dplyr::tibble(yada2 = IRIS2$Species)) #> IRIS <- IRIS %add_column% dplyr::tibble(yada2 = IRIS2$Species) ``` <sup>Created on 2024-10-15 with [reprex v2.1.1](https://reprex.tidyverse.org)</sup> </details> --------- Co-authored-by: 27856297+dependabot-preview[bot]@users.noreply.github.com <27856297+dependabot-preview[bot]@users.noreply.github.com>
1 parent b5ccb1d commit fcad956

File tree

3 files changed

+158
-3
lines changed

3 files changed

+158
-3
lines changed

‎R/teal_data-get_code.R‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -107,6 +107,11 @@ setMethod("get_code", signature = "teal_data", definition = function(object, dep
107107
checkmate::assert_character(datanames, min.len = 1L, null.ok = TRUE)
108108
checkmate::assert_flag(deparse)
109109

110+
# Normalize in case special it is backticked
111+
if (!is.null(datanames)) {
112+
datanames <- gsub("^`(.*)`$", "\\1", datanames)
113+
}
114+
110115
code <- if (!is.null(datanames)) {
111116
get_code_dependency(object@code, datanames, ...)
112117
} else {

‎R/utils-get_code_dependency.R‎

Lines changed: 22 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -42,8 +42,10 @@ get_code_dependency <- function(code, names, check_names = TRUE) {
4242

4343
code <- parse(text = code, keep.source = TRUE)
4444
pd <- utils::getParseData(code)
45+
pd <- normalize_pd(pd)
4546
calls_pd <- extract_calls(pd)
4647

48+
4749
if (check_names) {
4850
# Detect if names are actually in code.
4951
symbols <- unlist(lapply(calls_pd, function(call) call[call$token == "SYMBOL", "text"]))
@@ -175,7 +177,7 @@ fix_arrows <- function(calls) {
175177
sub_arrows <- function(call) {
176178
checkmate::assert_data_frame(call)
177179
map <- data.frame(
178-
row.names = c("`<-`", "`<<-`", "`=`"),
180+
row.names = c("<-", "<<-", "="),
179181
token = rep("LEFT_ASSIGN", 3),
180182
text = rep("<-", 3)
181183
)
@@ -297,7 +299,7 @@ extract_occurrence <- function(calls_pd) {
297299

298300
# What occurs in a function body is not tracked.
299301
x <- call_pd[!is_in_function(call_pd), ]
300-
sym_cond <- which(x$token %in% c("SYMBOL", "SYMBOL_FUNCTION_CALL"))
302+
sym_cond <- which(x$token %in% c("SPECIAL", "SYMBOL", "SYMBOL_FUNCTION_CALL"))
301303

302304
if (length(sym_cond) == 0) {
303305
return(character(0L))
@@ -381,7 +383,8 @@ extract_side_effects <- function(calls_pd) {
381383
#' @noRd
382384
graph_parser <- function(x, graph) {
383385
occurrence <- vapply(
384-
graph, function(call) {
386+
graph,
387+
function(call) {
385388
ind <- match("<-", call, nomatch = length(call) + 1L)
386389
x %in% call[seq_len(ind - 1L)]
387390
},
@@ -434,3 +437,19 @@ detect_libraries <- function(calls_pd) {
434437
)
435438
)
436439
}
440+
441+
#' Normalize parsed data removing backticks from symbols
442+
#'
443+
#' @param pd `data.frame` resulting from `utils::getParseData()` call.
444+
#'
445+
#' @return `data.frame` with backticks removed from `text` column for `SYMBOL` tokens.
446+
#'
447+
#' @keywords internal
448+
#' @noRd
449+
normalize_pd <- function(pd) {
450+
# Remove backticks from SYMBOL tokens
451+
symbol_index <- grepl("^SYMBOL.*$", pd$token)
452+
pd[symbol_index, "text"] <- gsub("^`(.*)`$", "\\1", pd[symbol_index, "text"])
453+
454+
pd
455+
}

‎tests/testthat/test-get_code.R‎

Lines changed: 131 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -695,3 +695,134 @@ testthat::test_that("data() call is returned when data name is provided as a cha
695695
)
696696
)
697697
})
698+
699+
testthat::describe("Backticked symbol", {
700+
testthat::it("code can be retrieved with get_code", {
701+
td <- within(
702+
teal_data(),
703+
{
704+
`%cbind%` <- function(lhs, rhs) cbind(lhs, rhs) # nolint: object_name.
705+
iris_ds <- iris %cbind% data.frame(new_col = "new column")
706+
}
707+
)
708+
709+
testthat::expect_identical(
710+
get_code(td, datanames = "%cbind%"),
711+
"`%cbind%` <- function(lhs, rhs) cbind(lhs, rhs)"
712+
)
713+
})
714+
715+
testthat::it("code can be retrieved with get_code", {
716+
td <- within(
717+
teal_data(),
718+
{
719+
`%cbind%` <- function(lhs, rhs) cbind(lhs, rhs) # nolint: object_name.
720+
iris_ds <- iris %cbind% data.frame(new_col = "new column")
721+
}
722+
)
723+
724+
testthat::expect_identical(
725+
get_code(td, datanames = "`%cbind%`"),
726+
"`%cbind%` <- function(lhs, rhs) cbind(lhs, rhs)"
727+
)
728+
})
729+
730+
testthat::it("starting with underscore is detected in code dependency", {
731+
td <- within(
732+
teal_data(),
733+
{
734+
`_add_column_` <- function(lhs, rhs) cbind(lhs, rhs) # nolint: object_name.
735+
iris_ds <- `_add_column_`(iris, data.frame(new_col = "new column"))
736+
}
737+
)
738+
739+
testthat::expect_identical(
740+
get_code(td, datanames = "iris_ds"),
741+
paste(
742+
sep = "\n",
743+
"`_add_column_` <- function(lhs, rhs) cbind(lhs, rhs)",
744+
"iris_ds <- `_add_column_`(iris, data.frame(new_col = \"new column\"))"
745+
)
746+
)
747+
})
748+
749+
testthat::it("with space character is detected in code dependency", {
750+
td <- within(
751+
teal_data(),
752+
{
753+
`add column` <- function(lhs, rhs) cbind(lhs, rhs) # nolint: object_name.
754+
iris_ds <- `add column`(iris, data.frame(new_col = "new column"))
755+
}
756+
)
757+
758+
testthat::expect_identical(
759+
get_code(td, datanames = "iris_ds"),
760+
paste(
761+
sep = "\n",
762+
"`add column` <- function(lhs, rhs) cbind(lhs, rhs)",
763+
"iris_ds <- `add column`(iris, data.frame(new_col = \"new column\"))"
764+
)
765+
)
766+
})
767+
768+
testthat::it("without special characters is cleaned and detected in code dependency", {
769+
td <- within(
770+
teal_data(),
771+
{
772+
`add_column` <- function(lhs, rhs) cbind(lhs, rhs)
773+
iris_ds <- `add_column`(iris, data.frame(new_col = "new column"))
774+
}
775+
)
776+
777+
testthat::expect_identical(
778+
get_code(td, datanames = "iris_ds"),
779+
paste(
780+
sep = "\n",
781+
"add_column <- function(lhs, rhs) cbind(lhs, rhs)",
782+
"iris_ds <- add_column(iris, data.frame(new_col = \"new column\"))"
783+
)
784+
)
785+
})
786+
787+
testthat::it("with non-native pipe used as function is detected code dependency", {
788+
td <- within(
789+
teal_data(),
790+
{
791+
`%add_column%` <- function(lhs, rhs) cbind(lhs, rhs)
792+
iris_ds <- `%add_column%`(iris, data.frame(new_col = "new column"))
793+
}
794+
)
795+
796+
# Note that the original code is changed to use the non-native pipe operator
797+
# correctly.
798+
testthat::expect_identical(
799+
get_code(td, datanames = "iris_ds"),
800+
paste(
801+
sep = "\n",
802+
"`%add_column%` <- function(lhs, rhs) cbind(lhs, rhs)",
803+
"iris_ds <- iris %add_column% data.frame(new_col = \"new column\")"
804+
)
805+
)
806+
})
807+
808+
testthat::it("with non-native pipe is detected code dependency", {
809+
td <- within(
810+
teal_data(),
811+
{
812+
`%add_column%` <- function(lhs, rhs) cbind(lhs, rhs)
813+
iris_ds <- iris %add_column% data.frame(new_col = "new column")
814+
}
815+
)
816+
817+
# Note that the original code is changed to use the non-native pipe operator
818+
# correctly.
819+
testthat::expect_identical(
820+
get_code(td, datanames = "iris_ds"),
821+
paste(
822+
sep = "\n",
823+
"`%add_column%` <- function(lhs, rhs) cbind(lhs, rhs)",
824+
"iris_ds <- iris %add_column% data.frame(new_col = \"new column\")"
825+
)
826+
)
827+
})
828+
})

0 commit comments

Comments
 (0)