Fixes bug in execution with multiple assignments inside expression (#250)

# Pull Request

<!--- Replace `#nnn` with your issue link for reference. -->

Fixes #249

# Changes description

- Detects expression blocks and handles them one by one
    - Any co-occurence is tracked to the single line

---------

Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com>

Author: averissimo

NEWS.md

@@ -1,5 +1,9 @@
 # teal.code 0.6.1.9001
 
+### Bug fixes
+
+* Fix a problem detecting co-occurrences when expression has multiple lines.
+
 # teal.code 0.6.1
 
 ### Bug fixes

R/utils-get_code_dependency.R

@@ -340,15 +340,72 @@ extract_side_effects <- function(pd) {
 #' @keywords internal
 #' @noRd
 extract_dependency <- function(parsed_code) {
-  pd <- normalize_pd(utils::getParseData(parsed_code))
-  reordered_pd <- extract_calls(pd)
-  if (length(reordered_pd) > 0) {
-    # extract_calls is needed to reorder the pd so that assignment operator comes before symbol names
-    # extract_calls is needed also to substitute assignment operators into specific format with fix_arrows
-    # extract_calls is needed to omit empty calls that contain only one token `"';'"`
-    # This cleaning is needed as extract_occurrence assumes arrows are fixed, and order is different than in original pd
-    c(extract_side_effects(reordered_pd[[1]]), extract_occurrence(reordered_pd[[1]]))
+  full_pd <- normalize_pd(utils::getParseData(parsed_code))
+  reordered_full_pd <- extract_calls(full_pd)
+
+  # Early return on empty code
+  if (length(reordered_full_pd) == 0L) {
+    return(NULL)
+  }
+
+  if (length(parsed_code) == 0L) {
+    return(extract_side_effects(reordered_full_pd[[1]]))
+  }
+  expr_ix <- lapply(parsed_code[[1]], class) == "{"
+
+  # Build queue of expressions to parse individually
+  queue <- list()
+  parsed_code_list <- if (all(!expr_ix)) {
+    list(parsed_code)
+  } else {
+    queue <- as.list(parsed_code[[1]][expr_ix])
+    new_list <- parsed_code[[1]]
+    new_list[expr_ix] <- NULL
+    list(parse(text = as.expression(new_list), keep.source = TRUE))
+  }
+
+  while (length(queue) > 0) {
+    current <- queue[[1]]
+    queue <- queue[-1]
+    if (identical(current[[1L]], as.name("{"))) {
+      queue <- append(queue, as.list(current)[-1L])
+    } else {
+      parsed_code_list[[length(parsed_code_list) + 1]] <- parse(text = as.expression(current), keep.source = TRUE)
+    }
   }
+
+  parsed_occurences <- lapply(
+    parsed_code_list,
+    function(parsed_code) {
+      pd <- normalize_pd(utils::getParseData(parsed_code))
+      reordered_pd <- extract_calls(pd)
+      if (length(reordered_pd) > 0) {
+        # extract_calls is needed to reorder the pd so that assignment operator comes before symbol names
+        # extract_calls is needed also to substitute assignment operators into specific format with fix_arrows
+        # extract_calls is needed to omit empty calls that contain only one token `"';'"`
+        # This cleaning is needed as extract_occurrence assumes arrows are fixed, and order is different
+        # than in original pd
+        extract_occurrence(reordered_pd[[1]])
+      }
+    }
+  )
+
+  # Merge results together
+  result <- Reduce(
+    function(u, v) {
+      ix <- if ("<-" %in% v) min(which(v == "<-")) else 0
+      u$left_side <- c(u$left_side, v[seq_len(max(0, ix - 1))])
+      u$right_side <- c(
+        u$right_side,
+        if (ix == length(v)) character(0L) else v[seq(ix + 1, max(ix + 1, length(v)))]
+      )
+      u
+    },
+    init = list(left_side = character(0L), right_side = character(0L)),
+    x = parsed_occurences
+  )
+
+  c(extract_side_effects(reordered_full_pd[[1]]), result$left_side, "<-", result$right_side)
 }
 
 # graph_parser ----

teal.code.Rproj

@@ -1,4 +1,5 @@
 Version: 1.0
+ProjectId: 97c2c74b-5d15-476b-a5df-d94d70687438
 
 RestoreWorkspace: No
 SaveWorkspace: No

tests/testthat/test-utils-get_code_dependency.R

@@ -0,0 +1,88 @@
+testthat::describe("get_code with single assignments inside an expression", {
+  testthat::it("detects assign() function", {
+    td <- qenv() |>
+      within({
+        for (i in 1:10) {
+          assign("var1", iris)
+        }
+      })
+
+    code_source <- "for (i in 1:10) {\n    assign(\"var1\", iris)\n}"
+
+    testthat::expect_equal(get_code(td, names = "var1"), code_source)
+  })
+
+  testthat::it("detects <-", {
+    td <- qenv() |>
+      within({
+        for (i in 1:10) {
+          var1 <- iris
+        }
+      })
+
+    code_source <- "for (i in 1:10) {\n    var1 <- iris\n}"
+
+    testthat::expect_equal(get_code(td, names = "var1"), code_source)
+  })
+
+  testthat::it("detects ->", {
+    td <- qenv() |>
+      within({
+        for (i in 1:10) {
+          iris -> var1 # nolint: assignment.
+        }
+      })
+
+    # Reversed order of operation
+    code_source <- "for (i in 1:10) {\n    var1 <- iris\n}"
+
+    testthat::expect_equal(get_code(td, names = "var1"), code_source)
+  })
+})
+
+testthat::describe("get_code with multiple assignments inside an expression", {
+  testthat::it("detects assign() function", {
+    td <- qenv() |>
+      within({
+        for (i in 1:10) {
+          assign("var1", iris)
+          assign("var2", mtcars)
+        }
+      })
+
+    code_source <- "for (i in 1:10) {\n    assign(\"var1\", iris)\n    assign(\"var2\", mtcars)\n}"
+
+    testthat::expect_equal(get_code(td, names = "var1"), code_source)
+    testthat::expect_equal(get_code(td, names = "var2"), code_source)
+  })
+
+  testthat::it("detects <- function", {
+    td <- qenv() |>
+      within({
+        for (i in 1:10) {
+          var1 <- iris
+          var2 <- mtcars
+        }
+      })
+
+    code_source <- "for (i in 1:10) {\n    var1 <- iris\n    var2 <- mtcars\n}"
+
+    testthat::expect_equal(get_code(td, names = "var1"), code_source)
+    testthat::expect_equal(get_code(td, names = "var2"), code_source)
+  })
+
+  testthat::it("detects -> function", {
+    td <- qenv() |>
+      within({
+        for (i in 1:10) {
+          iris -> var1 # nolint: assignment.
+          mtcars -> var2 # nolint: assignment.
+        }
+      })
+
+    code_source <- "for (i in 1:10) {\n    var1 <- iris\n    var2 <- mtcars\n}"
+
+    testthat::expect_equal(get_code(td, names = "var1"), code_source)
+    testthat::expect_equal(get_code(td, names = "var2"), code_source)
+  })
+})