diff --git a/DESCRIPTION b/DESCRIPTION index 74200b457..4b068d46f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -53,7 +53,7 @@ Config/Needs/website: insightsengineering/nesttemplate Encoding: UTF-8 Language: en-US Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.2 +RoxygenNote: 7.3.3 Collate: 'qenv-c.R' 'qenv-class.R' diff --git a/R/utils-get_code_dependency.R b/R/utils-get_code_dependency.R index 42e0650ad..954448d31 100644 --- a/R/utils-get_code_dependency.R +++ b/R/utils-get_code_dependency.R @@ -306,7 +306,17 @@ extract_occurrence <- function(pd) { ans <- move_functions_after_arrow(ans, unique(x[sym_fc_cond, "text"])) roll <- in_parenthesis(pd) if (length(roll)) { - c(setdiff(ans, roll), roll) + # detect elements appeared in parenthesis and move them on RHS + # but only their first appearance + # as the same object can appear as regular object and the one used in parenthesis + result <- ans + for (elem in roll) { + idx <- which(result == elem)[1] + if (!is.na(idx)) { + result <- result[-idx] + } + } + c(result, roll) } else { ans } @@ -330,9 +340,21 @@ move_functions_after_arrow <- function(ans, functions) { 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))) + if (length(functions) == 0) { + return(ans) + } + ans_pre <- ans[1:arrow_pos] + # it's setdiff but without the removal of duplicates + # do not use setdiff(ans_pre, functions) + # as it removes duplicates from ans_pre even if they do not appear in functions + # check setdiff(c("A", "A"), "B") - gives "A", where we want to keep c("A", "A") + for (fun in functions) { + if (any(ans_pre == fun)) ans_pre <- ans_pre[-match(fun, ans_pre)] + } + after_arrow <- if (arrow_pos < length(ans)) { + ans[(arrow_pos + 1):length(ans)] + } + c(ans_pre, after_arrow) } #' Extract side effects diff --git a/tests/testthat/test-utils-get_code_dependency.R b/tests/testthat/test-utils-get_code_dependency.R index 2cd4c40cd..a9f18f0e8 100644 --- a/tests/testthat/test-utils-get_code_dependency.R +++ b/tests/testthat/test-utils-get_code_dependency.R @@ -86,3 +86,162 @@ testthat::describe("get_code with multiple assignments inside an expression", { testthat::expect_equal(get_code(td, names = "var2"), code_source) }) }) + +testthat::describe("get_code with subassignments", { + it("tracks [ subassignment as producing the base object", { + td <- qenv() |> + within({ + x <- 1:10 + x[1:3] <- c(10, 20, 30) + }) + + code_source <- "x <- 1:10\nx[1:3] <- c(10, 20, 30)" + + testthat::expect_equal(get_code(td, names = "x"), code_source) + }) + + it("tracks [[ subassignment as producing the base object", { + td <- qenv() |> + within({ + lst <- list(a = 1, b = 2) + lst[["c"]] <- 3 + }) + + code_source <- "lst <- list(a = 1, b = 2)\nlst[[\"c\"]] <- 3" + + testthat::expect_equal(get_code(td, names = "lst"), code_source) + }) + + it("tracks nested subassignments", { + td <- qenv() |> + within({ + df <- data.frame(x = 1:5, y = 6:10) + df$x[df$y > 8] <- 99 + }) + + code_source <- "df <- data.frame(x = 1:5, y = 6:10)\ndf$x[df$y > 8] <- 99" + + testthat::expect_equal(get_code(td, names = "df"), code_source) + }) + + it("tracks multiple subassignments to same object", { + td <- qenv() |> + within({ + iris <- iris + iris$Species[sample.int(nrow(iris), 10)] <- NA + iris$Sepal.Length[1:5] <- 0 + }) + + code_source <- "iris <- iris\niris$Species[sample.int(nrow(iris), 10)] <- NA\niris$Sepal.Length[1:5] <- 0" + + testthat::expect_equal(get_code(td, names = "iris"), code_source) + }) + + it("tracks subassignments with complex expressions", { + td <- qenv() |> + within({ + mat <- matrix(1:12, nrow = 3) + mat[mat > 5 & mat < 10] <- 0 + }) + + code_source <- "mat <- matrix(1:12, nrow = 3)\nmat[mat > 5 & mat < 10] <- 0" + + testthat::expect_equal(get_code(td, names = "mat"), code_source) + }) + + it("tracks subassignments with function calls on LHS", { + td <- qenv() |> + within({ + lst <- list(a = 1, b = 2) + names(lst)[1] <- "first" + }) + + code_source <- "lst <- list(a = 1, b = 2)\nnames(lst)[1] <- \"first\"" + + testthat::expect_equal(get_code(td, names = "lst"), code_source) + }) + + it("tracks -> operator with subassignments", { + td <- qenv() |> + within({ + x <- 1:10 + c(10, 20, 30) -> x[1:3] # nolint: assignment. + }) + + code_source <- "x <- 1:10\nx[1:3] <- c(10, 20, 30)" + + testthat::expect_equal(get_code(td, names = "x"), code_source) + }) + + it("tracks attributes() function with subassignments", { + td <- qenv() |> + within({ + x <- 1:5 + attributes(x)$names <- letters[1:5] + }) + + code_source <- "x <- 1:5\nattributes(x)$names <- letters[1:5]" + + testthat::expect_equal(get_code(td, names = "x"), code_source) + }) + + it("handles complex nested subassignments", { + td <- qenv() |> + within({ + df <- data.frame(x = 1:5, y = 6:10) + df[df$x > 2, "y"][1:2] <- c(99, 100) + }) + + code_source <- "df <- data.frame(x = 1:5, y = 6:10)\ndf[df$x > 2, \"y\"][1:2] <- c(99, 100)" + + testthat::expect_equal(get_code(td, names = "df"), code_source) + }) + + it("handles subassignments with multiple operators", { + td <- qenv() |> + within({ + lst <- list(a = list(b = 1, c = 2)) + lst$a$b[2] <- 99 + }) + + code_source <- "lst <- list(a = list(b = 1, c = 2))\nlst$a$b[2] <- 99" + + testthat::expect_equal(get_code(td, names = "lst"), code_source) + }) + + it("handles subassignments with data frame column creation", { + td <- qenv() |> + within({ + df <- data.frame(x = 1:3) + df$new_col <- c("a", "b", "c") + }) + + code_source <- "df <- data.frame(x = 1:3)\ndf$new_col <- c(\"a\", \"b\", \"c\")" + + testthat::expect_equal(get_code(td, names = "df"), code_source) + }) + + it("handles subassignments with matrix indexing", { + td <- qenv() |> + within({ + mat <- matrix(1:9, nrow = 3) + mat[1:2, 2:3] <- matrix(0, nrow = 2, ncol = 2) + }) + + code_source <- "mat <- matrix(1:9, nrow = 3)\nmat[1:2, 2:3] <- matrix(0, nrow = 2, ncol = 2)" + + testthat::expect_equal(get_code(td, names = "mat"), code_source) + }) + + it("handles subassignments with logical indexing", { + td <- qenv() |> + within({ + vec <- 1:10 + vec[vec %% 2 == 0] <- vec[vec %% 2 == 0] * 2 + }) + + code_source <- "vec <- 1:10\nvec[vec%%2 == 0] <- vec[vec%%2 == 0] * 2" + + testthat::expect_equal(get_code(td, names = "vec"), code_source) + }) +})