diff --git a/R/utils-get_code_dependency.R b/R/utils-get_code_dependency.R index 8596ae420..42e0650ad 100644 --- a/R/utils-get_code_dependency.R +++ b/R/utils-get_code_dependency.R @@ -303,6 +303,7 @@ extract_occurrence <- function(pd) { after <- match(min(x$id[assign_cond]), sort(x$id[c(min(assign_cond), sym_cond)])) - 1 ans <- append(x[sym_cond, "text"], "<-", after = max(1, after)) + ans <- move_functions_after_arrow(ans, unique(x[sym_fc_cond, "text"])) roll <- in_parenthesis(pd) if (length(roll)) { c(setdiff(ans, roll), roll) @@ -311,6 +312,29 @@ extract_occurrence <- function(pd) { } } +#' Moves function names to the right side of dependency graph +#' +#' Changes status of the function call from dependent to dependency if occurs in the lhs. +#' Technically, it means to move function names after the dependency operator. +#' For example, for `attributes(a) <- b` the dependency graph should look like `c("a", "<-", "b", "attributes")`. +#' +#' @param ans `character` vector of object names in dependency graph. +#' @param functions `character` vector of function names. +#' +#' @return +#' A character vector. +#' @keywords internal +#' @noRd +move_functions_after_arrow <- function(ans, functions) { + arrow_pos <- which(ans == "<-") + if (length(arrow_pos) == 0) { + return(ans) + } + before_arrow <- setdiff(ans[1:arrow_pos], functions) + after_arrow <- ans[(arrow_pos + 1):length(ans)] + c(before_arrow, unique(c(intersect(ans[1:arrow_pos], functions), after_arrow))) +} + #' Extract side effects #' #' Extracts all object names from the code that are marked with `@linksto` tag. diff --git a/tests/testthat/test-qenv_get_code.R b/tests/testthat/test-qenv_get_code.R index a5dc2975f..282c72869 100644 --- a/tests/testthat/test-qenv_get_code.R +++ b/tests/testthat/test-qenv_get_code.R @@ -290,6 +290,20 @@ testthat::describe("get_code for specific names", { ) } ) + testthat::it( + "doesn't consider function called on the lhs as a dependent in this call (dependency in further calls)", + { + code <- c( + "object_list <- list(x = iris, y = iris)", + "object_list_2 <- list(x = mtcars, y = mtcars)", + "object_list_2[c('x')] <- c('string')", + "object_list[c('x')] <- c('string')" + ) + q <- eval_code(qenv(), code = code) + result <- get_code(q, names = "object_list") + testthat::expect_identical(result, paste(code[c(1, 4)], collapse = "\n")) + } + ) })