handle subassignemnts with the same object

Author: m7pr

R/utils-get_code_dependency.R

@@ -306,7 +306,18 @@ 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 appread 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,6 +341,9 @@ move_functions_after_arrow <- function(ans, functions) {
   if (length(arrow_pos) == 0) {
     return(ans)
   }
+  if (length(functions) == 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)))

tests/testthat/test-utils-get_code_dependency.R

@@ -86,3 +86,174 @@ 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", {
+  testthat::it("tracks $ subassignment as producing the base object", {
+    td <- qenv() |>
+      within({
+        iris <- iris
+        iris$Species[sample.int(nrow(iris), 50)] <- NA
+      })
+
+    code_source <- "iris <- iris\niris$Species[sample.int(nrow(iris), 50)] <- NA"
+
+    testthat::expect_equal(get_code(td, names = "iris"), code_source)
+  })
+
+  testthat::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)
+  })
+
+  testthat::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)
+  })
+
+  testthat::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)
+  })
+
+  testthat::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)
+  })
+
+  testthat::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)
+  })
+
+  testthat::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)
+  })
+
+  testthat::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)
+  })
+
+  testthat::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)
+  })
+
+  testthat::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)
+  })
+
+  testthat::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)
+  })
+
+  testthat::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)
+  })
+
+  testthat::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)
+  })
+
+  testthat::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)
+  })
+})