[skip style] [skip vbump] Restyle files

Author: github-actions[bot]

R/utils-get_code_dependency.R

@@ -211,86 +211,86 @@ extract_occurrence <- function(pd) {
     }
   }
 
-      # Handle data(object)/data("object")/data(object, envir = ) independently.
-      data_call <- find_call(pd, "data")
-      if (data_call) {
-        sym <- pd[data_call + 1, "text"]
-        return(c(gsub("^['\"]|['\"]$", "", sym), "<-"))
-      }
-      # Handle assign(x = ).
-      assign_call <- find_call(pd, "assign")
-      if (assign_call) {
-        # Check if parameters were named.
-        # "','" is for unnamed parameters, where "SYMBOL_SUB" is for named.
-        # "EQ_SUB" is for `=` appearing after the name of the named parameter.
-        if (any(pd$token == "SYMBOL_SUB")) {
-          params <- pd[pd$token %in% c("SYMBOL_SUB", "','", "EQ_SUB"), "text"]
-          # Remove sequence of "=", ",".
-          if (length(params > 1)) {
-            remove <- integer(0)
-            for (i in 2:length(params)) {
-              if (params[i - 1] == "=" & params[i] == ",") {
-                remove <- c(remove, i - 1, i)
-              }
-            }
-            if (length(remove)) params <- params[-remove]
-          }
-          pos <- match("x", setdiff(params, ","), nomatch = match(",", params, nomatch = 0))
-          if (!pos) {
-            return(character(0L))
+  # Handle data(object)/data("object")/data(object, envir = ) independently.
+  data_call <- find_call(pd, "data")
+  if (data_call) {
+    sym <- pd[data_call + 1, "text"]
+    return(c(gsub("^['\"]|['\"]$", "", sym), "<-"))
+  }
+  # Handle assign(x = ).
+  assign_call <- find_call(pd, "assign")
+  if (assign_call) {
+    # Check if parameters were named.
+    # "','" is for unnamed parameters, where "SYMBOL_SUB" is for named.
+    # "EQ_SUB" is for `=` appearing after the name of the named parameter.
+    if (any(pd$token == "SYMBOL_SUB")) {
+      params <- pd[pd$token %in% c("SYMBOL_SUB", "','", "EQ_SUB"), "text"]
+      # Remove sequence of "=", ",".
+      if (length(params > 1)) {
+        remove <- integer(0)
+        for (i in 2:length(params)) {
+          if (params[i - 1] == "=" & params[i] == ",") {
+            remove <- c(remove, i - 1, i)
           }
-          # pos is indicator of the place of 'x'
-          # 1. All parameters are named, but none is 'x' - return(character(0L))
-          # 2. Some parameters are named, 'x' is in named parameters: match("x", setdiff(params, ","))
-          # - check "x" in params being just a vector of named parameters.
-          # 3. Some parameters are named, 'x' is not in named parameters
-          # - check first appearance of "," (unnamed parameter) in vector parameters.
-        } else {
-          # Object is the first entry after 'assign'.
-          pos <- 1
         }
-        sym <- pd[assign_call + pos, "text"]
-        return(c(gsub("^['\"]|['\"]$", "", sym), "<-"))
+        if (length(remove)) params <- params[-remove]
       }
-
-      # 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"))
-
-      if (length(sym_cond) == 0) {
+      pos <- match("x", setdiff(params, ","), nomatch = match(",", params, nomatch = 0))
+      if (!pos) {
         return(character(0L))
       }
-      # Watch out for SYMBOLS after $ and @. For x$a x@a: x is object, a is not.
-      # For x$a, a's ID is $'s ID-2 so we need to remove all IDs that have ID = $ID - 2.
-      dollar_ids <- x[x$token %in% c("'$'", "'@'"), "id"]
-      if (length(dollar_ids)) {
-        object_ids <- x[sym_cond, "id"]
-        after_dollar <- object_ids[(object_ids - 2) %in% dollar_ids]
-        sym_cond <- setdiff(sym_cond, which(x$id %in% after_dollar))
-      }
+      # pos is indicator of the place of 'x'
+      # 1. All parameters are named, but none is 'x' - return(character(0L))
+      # 2. Some parameters are named, 'x' is in named parameters: match("x", setdiff(params, ","))
+      # - check "x" in params being just a vector of named parameters.
+      # 3. Some parameters are named, 'x' is not in named parameters
+      # - check first appearance of "," (unnamed parameter) in vector parameters.
+    } else {
+      # Object is the first entry after 'assign'.
+      pos <- 1
+    }
+    sym <- pd[assign_call + pos, "text"]
+    return(c(gsub("^['\"]|['\"]$", "", sym), "<-"))
+  }
 
-      ass_cond <- grep("ASSIGN", x$token)
-      if (!length(ass_cond)) {
-        return(c("<-", unique(x[sym_cond, "text"])))
-      }
+  # 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_cond <- sym_cond[sym_cond > ass_cond] # NOTE 1
-      # If there was an assignment operation detect direction of it.
-      if (unique(x$text[ass_cond]) == "->") { # NOTE 2
-        sym_cond <- rev(sym_cond)
-      }
+  if (length(sym_cond) == 0) {
+    return(character(0L))
+  }
+  # Watch out for SYMBOLS after $ and @. For x$a x@a: x is object, a is not.
+  # For x$a, a's ID is $'s ID-2 so we need to remove all IDs that have ID = $ID - 2.
+  dollar_ids <- x[x$token %in% c("'$'", "'@'"), "id"]
+  if (length(dollar_ids)) {
+    object_ids <- x[sym_cond, "id"]
+    after_dollar <- object_ids[(object_ids - 2) %in% dollar_ids]
+    sym_cond <- setdiff(sym_cond, which(x$id %in% after_dollar))
+  }
 
-      after <- match(min(x$id[ass_cond]), sort(x$id[c(min(ass_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
-      }
+  ass_cond <- grep("ASSIGN", x$token)
+  if (!length(ass_cond)) {
+    return(c("<-", unique(x[sym_cond, "text"])))
+  }
+
+  sym_cond <- sym_cond[sym_cond > ass_cond] # NOTE 1
+  # If there was an assignment operation detect direction of it.
+  if (unique(x$text[ass_cond]) == "->") { # NOTE 2
+    sym_cond <- rev(sym_cond)
+  }
 
-      ### 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('.
+  after <- match(min(x$id[ass_cond]), sort(x$id[c(min(ass_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
@@ -389,7 +389,7 @@ detect_libraries <- function(graph) {
   which(
     unlist(
       lapply(
-        graph, function(x){
+        graph, function(x) {
           any(grepl(pattern = paste(defaults, collapse = "|"), x = x))
         }
       )
@@ -478,4 +478,3 @@ split_code <- function(code) {
   #  semicolon is treated by R parser as a separate call.
   gsub("^([[:space:]])*;(.+)$", "\\1\\2", new_code, perl = TRUE)
 }
-

tests/testthat/test-qenv_eval_code.R

@@ -92,47 +92,55 @@ testthat::test_that("an error when calling eval_code returns a qenv.error object
 })
 
 testthat::test_that(
-  "a warning when calling eval_code returns a qenv object which has warnings as attributes of code", {
-  q <- eval_code(qenv(), quote("iris_data <- iris"))
-  q <- eval_code(q, quote("p <- hist(iris_data[, 'Sepal.Length'], ff = '')"))
-  testthat::expect_s4_class(q, "qenv")
-  testthat::expect_equal(
-    lapply(q@code, attr, "warning"),
-    list(NULL, "> \"ff\" is not a graphical parameter\n")
-  )
-})
+  "a warning when calling eval_code returns a qenv object which has warnings as attributes of code",
+  {
+    q <- eval_code(qenv(), quote("iris_data <- iris"))
+    q <- eval_code(q, quote("p <- hist(iris_data[, 'Sepal.Length'], ff = '')"))
+    testthat::expect_s4_class(q, "qenv")
+    testthat::expect_equal(
+      lapply(q@code, attr, "warning"),
+      list(NULL, "> \"ff\" is not a graphical parameter\n")
+    )
+  }
+)
 
 testthat::test_that(
-  "eval_code associates warnings with call by adding attribute to code element", {
-  q <- eval_code(qenv(), c("x <- 1", "y <- 1", "warning('warn1')"))
-  testthat::expect_equal(
-    lapply(q@code, attr, "warning"),
-    list(NULL, NULL, "> warn1\n")
-  )
-})
+  "eval_code associates warnings with call by adding attribute to code element",
+  {
+    q <- eval_code(qenv(), c("x <- 1", "y <- 1", "warning('warn1')"))
+    testthat::expect_equal(
+      lapply(q@code, attr, "warning"),
+      list(NULL, NULL, "> warn1\n")
+    )
+  }
+)
 
 
 testthat::test_that(
-  "eval_code associates messages with call by adding attribute to code element", {
-  q <- eval_code(qenv(), quote("iris_data <- head(iris)"))
-  q <- eval_code(q, quote("message('This is a message')"))
-  testthat::expect_s4_class(q, "qenv")
-  testthat::expect_equal(
-    lapply(q@code, attr, "message"),
-    list(
-      NULL,
-      "> This is a message\n"
+  "eval_code associates messages with call by adding attribute to code element",
+  {
+    q <- eval_code(qenv(), quote("iris_data <- head(iris)"))
+    q <- eval_code(q, quote("message('This is a message')"))
+    testthat::expect_s4_class(q, "qenv")
+    testthat::expect_equal(
+      lapply(q@code, attr, "message"),
+      list(
+        NULL,
+        "> This is a message\n"
+      )
     )
-  )
-})
+  }
+)
 
 testthat::test_that(
-  "eval_code returns a qenv object with empty messages and warnings as code attributes, when none are returned", {
-  q <- eval_code(qenv(), quote("iris_data <- head(iris)"))
-  testthat::expect_s4_class(q, "qenv")
-  testthat::expect_null(attr(q@code, "message"))
-  testthat::expect_null(attr(q@code, "warning"))
-})
+  "eval_code returns a qenv object with empty messages and warnings as code attributes, when none are returned",
+  {
+    q <- eval_code(qenv(), quote("iris_data <- head(iris)"))
+    testthat::expect_s4_class(q, "qenv")
+    testthat::expect_null(attr(q@code, "message"))
+    testthat::expect_null(attr(q@code, "warning"))
+  }
+)
 
 testthat::test_that("eval_code returns a qenv object with dependency attribute", {
   q <- eval_code(qenv(), "iris_data <- head(iris)")
@@ -150,13 +158,15 @@ testthat::test_that("eval_code returns a qenv object with dependency attribute t
   )
 })
 testthat::test_that(
-  "eval_code returns a qenv object with dependency attribute that extracts functions after '<-' part", {
-  q3 <- eval_code(qenv(), c("library(survival)", "head(iris)"))
-  testthat::expect_identical(
-    lapply(q3@code, attr, "dependency"),
-    list(
-      c("<-", "library", "survival"),
-      c("<-", "head", "iris")
+  "eval_code returns a qenv object with dependency attribute that extracts functions after '<-' part",
+  {
+    q3 <- eval_code(qenv(), c("library(survival)", "head(iris)"))
+    testthat::expect_identical(
+      lapply(q3@code, attr, "dependency"),
+      list(
+        c("<-", "library", "survival"),
+        c("<-", "head", "iris")
+      )
     )
-  )
-})
+  }
+)

tests/testthat/test-qenv_extract.R

@@ -1,4 +1,3 @@
-
 testthat::test_that("`[.` returns empty qenv for names not in qenv", {
   data <- within(qenv(), {
     x <- 1
@@ -65,4 +64,3 @@ testthat::test_that("`[.` extract proper elements of @id, @warnings and @message
   testthat::expect_null(get_code_attr(qs, "warning"))
   testthat::expect_null(get_code_attr(qs, "message"))
 })
-

tests/testthat/test-qenv_get_code.R

@@ -1,4 +1,4 @@
-get_code_g <- function(qenv, ...){
+get_code_g <- function(qenv, ...) {
   gsub("\n", "", get_code(qenv, ...), fixed = TRUE)
 }
 
@@ -393,7 +393,7 @@ testthat::test_that("get_code does not break if @linksto is put in the last line
 
 testthat::test_that("@linksto makes a line being returned for an affected binding", {
   code <-
-  "a <- 1 # @linksto b
+    "a <- 1 # @linksto b
   b <- 2"
   q <- eval_code(qenv(), code)
   testthat::expect_identical(
@@ -475,7 +475,8 @@ testthat::test_that("comments fall into proper calls", {
   q <- eval_code(qenv(), code)
   testthat::expect_identical(
     get_code(q),
-    c("\n    # initial comment\n    a <- 1\n",
+    c(
+      "\n    # initial comment\n    a <- 1\n",
       "    b <- 2 # inline comment\n",
       "    c <- 3\n",
       "    # inbetween comment\n    d <- 4\n    # finishing comment\n  "
@@ -500,7 +501,8 @@ testthat::test_that("comments get pasted when they fall into calls", {
   q <- qenv() |> eval_code(code)
   testthat::expect_identical(
     get_code(q),
-    c("\n    # initial comment\n    a <- 1 # A comment\n",
+    c(
+      "\n    # initial comment\n    a <- 1 # A comment\n",
       "    b <- 2 # inline comment\n",
       "    c <- 3 # C comment\n",
       "    # inbetween comment\n    d <- 4\n    # finishing comment\n  "
@@ -646,8 +648,10 @@ testthat::test_that("detects occurrence of a function definition with a @linksto
   q <- eval_code(qenv(), code)
   testthat::expect_identical(
     get_code(q, names = "x"),
-    c("\n        foo <- function() {\n          env <- parent.frame()\n          env$x <- 0\n        }\n",
-      "foo() # @linksto x\n")
+    c(
+      "\n        foo <- function() {\n          env <- parent.frame()\n          env$x <- 0\n        }\n",
+      "foo() # @linksto x\n"
+    )
   )
 })
 # $ ---------------------------------------------------------------------------------------------------------------
@@ -892,6 +896,6 @@ testthat::describe("Backticked symbol", {
 
 testthat::test_that("get_code raises warning for missing names", {
   q <- eval_code(qenv(), code = c("a<-1;b<-2"))
-  testthat::expect_null(get_code(q, names = 'c'))
-  testthat::expect_warning(get_code(q, names = 'c'), " not found in code: c")
+  testthat::expect_null(get_code(q, names = "c"))
+  testthat::expect_warning(get_code(q, names = "c"), " not found in code: c")
 })