Fix ‘sym_cond > ass_cond’: longer object (#236)

Fixes #235

There was a warning thrown by the `get_code_dependency` that is now not
visible + the code extraction works for `for` loops.

Added 2 tests to prove that.

No warning shown during

```r
devtools::load_all("../teal.code")
devtools::load_all("../teal")
devtools::load_all(".")
footnote_regression <- teal_transform_module(
  server = make_teal_transform_server(expression(
    plot <- plot + labs(caption = deparse(summary(fit)[[1]]))
  ))
)

data <- teal_data()
data <- within(data, {
  require(nestcolor)
  ADSL <- rADSL
})
join_keys(data) <- default_cdisc_join_keys[names(data)]

app <- init(
  data = data,
  modules = modules(
    tm_a_regression(
      label = "Regression",
      response = data_extract_spec(
        dataname = "ADSL",
        select = select_spec(
          label = "Select variable:",
          choices = "BMRKR1",
          selected = "BMRKR1",
          multiple = FALSE,
          fixed = TRUE
        )
      ),
      regressor = data_extract_spec(
        dataname = "ADSL",
        select = select_spec(
          label = "Select variables:",
          choices = variable_choices(data[["ADSL"]], c("AGE", "SEX", "RACE")),
          selected = "AGE",
          multiple = TRUE,
          fixed = FALSE
        )
      ),
      decorators = list(footnote_regression)
    )
  )
)
if (interactive()) {
  shinyApp(app$ui, app$server)
}


```

---------

Signed-off-by: Marcin <[email protected]>
Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com>
Co-authored-by: André Veríssimo <[email protected]>

Author: 3 people

R/utils-get_code_dependency.R

@@ -274,6 +274,7 @@ extract_occurrence <- function(pd) {
   # What occurs in a function body is not tracked.
   x <- pd[!is_in_function(pd), ]
   sym_cond <- which(x$token %in% c("SPECIAL", "SYMBOL", "SYMBOL_FUNCTION_CALL"))
+  sym_fc_cond <- which(x$token == "SYMBOL_FUNCTION_CALL")
 
   if (length(sym_cond) == 0) {
     return(character(0L))
@@ -287,28 +288,27 @@ extract_occurrence <- function(pd) {
     sym_cond <- setdiff(sym_cond, which(x$id %in% after_dollar))
   }
 
-  ass_cond <- grep("ASSIGN", x$token)
-  if (!length(ass_cond)) {
+  assign_cond <- grep("ASSIGN", x$token)
+  if (!length(assign_cond)) {
     return(c("<-", unique(x[sym_cond, "text"])))
   }
 
-  sym_cond <- sym_cond[sym_cond > ass_cond] # NOTE 1
+  # For cases like 'eval(expression(c <- b + 2))' removes 'eval(expression('.
+  sym_cond <- sym_cond[!(sym_cond < min(assign_cond) & sym_cond %in% sym_fc_cond)]
+
   # If there was an assignment operation detect direction of it.
-  if (unique(x$text[ass_cond]) == "->") { # NOTE 2
+  if (unique(x$text[assign_cond]) == "->") { # What if there are 2 assignments: e.g. a <- b -> c.
     sym_cond <- rev(sym_cond)
   }
 
-  after <- match(min(x$id[ass_cond]), sort(x$id[c(min(ass_cond), sym_cond)])) - 1
+  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))
   roll <- in_parenthesis(pd)
   if (length(roll)) {
     c(setdiff(ans, roll), roll)
   } else {
     ans
   }
-
-  ### NOTE 2: What if there are 2 assignments: e.g. a <- b -> c.
-  ### NOTE 1: For cases like 'eval(expression(b <- b + 2))' removes 'eval(expression('.
 }
 
 #' Extract side effects

tests/testthat/test-qenv_get_code.R

@@ -596,6 +596,54 @@ testthat::test_that("detects occurrence of a function definition with a @linksto
     pasten(code[1:2])
   )
 })
+
+
+# for loop --------------------------------------------------------------------------------------------------------
+
+testthat::test_that("objects in for loop are extracted if passed as one character", {
+  code <- "
+    some_other_dataset <- mtcars
+    original_dataset <- iris[, 1:4]
+    count <- 1
+    for (x in colnames(original_dataset)) {
+      original_dataset[, x] <- original_dataset[, x] * 2
+      count <- count + 1
+    }
+    output <- rlang::list2(x = original_dataset)
+  "
+  q <- eval_code(qenv(), code)
+  testthat::expect_identical(
+    get_code(q, names = "output"),
+    gsub("\n    some_other_dataset <- mtcars\n", "", code, fixed = TRUE)
+  )
+})
+
+testthat::test_that("objects in for loop are extracted if passed as separate calls", {
+  q <- within(qenv(), {
+    a <- 1
+    b <- 2
+  }) |> within({
+    for (x in c(1, 2)) {
+      b <- a
+      b <- b + a + 1
+      b + 3 -> b # nolint: assignment.
+    }
+  })
+
+  testthat::expect_setequal(
+    strsplit(get_code(q, names = "b"), "\n")[[1]],
+    c(
+      "a <- 1",
+      "b <- 2",
+      "for (x in c(1, 2)) {",
+      "    b <- a",
+      "    b <- b + a + 1",
+      "    b <- b + 3", # ORDER IS CHANGED IN HERE, but we can live with it
+      "}"
+    )
+  )
+})
+
 # $ ---------------------------------------------------------------------------------------------------------------
 
 testthat::test_that("understands $ usage and do not treat rhs of $ as objects (only lhs)", {