move @id, @warnings and @message to attributes of code and fix rest of the codebase #70

Author: m7pr

R/qenv-concat.R

@@ -32,10 +32,7 @@
 setGeneric("concat", function(x, y) standardGeneric("concat"))
 
 setMethod("concat", signature = c("qenv", "qenv"), function(x, y) {
-  y@id <- c(x@id, y@id)
   y@code <- c(x@code, y@code)
-  y@warnings <- c(x@warnings, y@warnings)
-  y@messages <- c(x@messages, y@messages)
 
   # insert (and overwrite) objects from y to x
   y@env <- rlang::env_clone(y@env, parent = parent.env(.GlobalEnv))

R/qenv-eval_code.R

@@ -39,7 +39,6 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code
   for (i in seq_along(code_split)) {
     current_code <- code_split[[i]]
     current_call <- parse(text = current_code, keep.source = FALSE)
-    new_object_code <- c(object@code, list(current_code))
 
     # Using withCallingHandlers to capture warnings and messages.
     # Using tryCatch to capture the error and abort further evaluation.
@@ -62,7 +61,7 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code
               deparse1(current_call)
             ),
             class = c("qenv.error", "try-error", "simpleError"),
-            trace = unlist(new_object_code)
+            trace = unlist(c(object@code, list(current_code)))
           )
         }
       ),
@@ -81,7 +80,7 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code
     }
 
     attr(current_code, "id") <- sample.int(.Machine$integer.max, size = 1)
-    object@code <- new_object_code
+    object@code <- c(object@code, list(current_code))
   }
 
   lockEnvironment(object@env, bindings = TRUE)
@@ -109,3 +108,8 @@ setMethod("eval_code", signature = c("qenv.error", "ANY"), function(object, code
     chr
   }
 }
+
+get_code_attr <- function(qenv, attr){
+  #unlist(lapply(qenv@code, attr, attr)) # somehow doesn't work
+  unlist(lapply(qenv@code, function(x) attr(x, attr)))
+}

R/qenv-get_code.R

@@ -125,7 +125,7 @@ setMethod("get_code", signature = "qenv", function(object, deparse = TRUE, names
   }
 
   if (deparse) {
-    unlist(code)
+    code
   } else {
     parse(text = paste(c("{", unlist(code), "}"), collapse = "\n"), keep.source = TRUE)
   }

R/qenv-get_warnings.R

@@ -33,7 +33,9 @@ setGeneric("get_warnings", function(object) {
 })
 
 setMethod("get_warnings", signature = c("qenv"), function(object) {
-  if (all(object@warnings == "")) {
+  warnings <- lapply(object@code, "attr", "warning")
+  code <- object@code[unlist(lapply(warnings, Negate(is.null)))]
+  if (length(unlist(warnings)) == 0) {
     return(NULL)
   }
 
@@ -44,8 +46,8 @@ setMethod("get_warnings", signature = c("qenv"), function(object) {
       }
       sprintf("%swhen running code:\n%s", warn, paste(lang2calls(expr), collapse = "\n"))
     },
-    warn = as.list(object@warnings),
-    expr = as.list(as.character(object@code))
+    warn = as.list(unlist(warnings)),
+    expr = as.list(unlist(code))
   )
   lines <- Filter(Negate(is.null), lines)
 

R/qenv-join.R

@@ -143,11 +143,8 @@ setMethod("join", signature = c("qenv", "qenv"), function(x, y) {
     stop(join_validation)
   }
 
-  id_unique <- !y@id %in% x@id
-  x@id <- c(x@id, y@id[id_unique])
+  id_unique <- !get_code_attr(y, "id") %in% get_code_attr(x, "id")
   x@code <- c(x@code, y@code[id_unique])
-  x@warnings <- c(x@warnings, y@warnings[id_unique])
-  x@messages <- c(x@messages, y@messages[id_unique])
 
   # insert (and overwrite) objects from y to x
   x@env <- rlang::env_clone(x@env, parent = parent.env(.GlobalEnv))
@@ -188,14 +185,16 @@ setMethod("join", signature = c("qenv.error", "ANY"), function(x, y) {
       )
     )
   }
+  x_id <- get_code_attr(x, "id")
+  y_id <- get_code_attr(y, "id")
 
-  shared_ids <- intersect(x@id, y@id)
+  shared_ids <- intersect(x_id, y_id)
   if (length(shared_ids) == 0) {
     return(TRUE)
   }
 
-  shared_in_x <- match(shared_ids, x@id)
-  shared_in_y <- match(shared_ids, y@id)
+  shared_in_x <- match(shared_ids, x_id)
+  shared_in_y <- match(shared_ids, y_id)
 
   # indices of shared ids should be 1:n in both slots
   if (identical(shared_in_x, shared_in_y) && identical(shared_in_x, seq_along(shared_ids))) {

R/utils-get_code_dependency.R

@@ -37,10 +37,10 @@ get_code_dependency <- function(code, names, check_names = TRUE) {
   # TODO: rethink if this is still needed when code is divided by calls?
   tcode <- trimws(code)
   if (any(grepl("^\\{.*\\}$", tcode))) {
-    code <- sub("^\\{(.*)\\}$", "\\1", tcode)
+    tcode <- sub("^\\{(.*)\\}$", "\\1", tcode)
   }
 
-  parsed_code <- parse(text = code, keep.source = TRUE)
+  parsed_code <- parse(text = tcode, keep.source = TRUE)
 
   pd <- utils::getParseData(parsed_code)
   pd <- normalize_pd(pd)

tests/testthat/test-qenv_concat.R

@@ -7,7 +7,7 @@ testthat::test_that("Concatenate two identical qenvs outputs", {
 
   testthat::expect_equal(q12@env, q1@env)
   testthat::expect_identical(
-    q12@code,
+    unlist(q12@code),
     c("iris1 <- iris", "iris1 <- iris")
   )
 })
@@ -23,10 +23,12 @@ testthat::test_that("Concatenate two independent qenvs results in object having
 
   testthat::expect_equal(q12@env, list2env(list(iris1 = iris, mtcars1 = mtcars)))
   testthat::expect_identical(
-    q12@code,
+    unlist(q12@code),
     c("iris1 <- iris", "mtcars1 <- mtcars")
   )
-  testthat::expect_identical(q12@id, c(q1@id, q2@id))
+  q12_ids <- unlist(lapply(q12@code, "attr", "id"))
+  q1_q2_ids <- c(attr(q1@code[[1]], "id"), attr(q2@code[[1]], "id"))
+  testthat::expect_identical(q12_ids, q1_q2_ids)
 })
 
 testthat::test_that("Concatenate qenvs results with the same variable, the RHS has priority", {
@@ -57,7 +59,7 @@ testthat::test_that("Concatenate two independent qenvs with warnings results in
   q12 <- concat(q1, q2)
 
   testthat::expect_equal(
-    q12@warnings,
+    unlist(lapply(q12@code, attr, "warning")),
     c(
       "> This is warning 1\n",
       "> This is warning 2\n"
@@ -72,7 +74,7 @@ testthat::test_that("Concatenate two independent qenvs with messages results in
   q12 <- concat(q1, q2)
 
   testthat::expect_equal(
-    q12@messages,
+    unlist(lapply(q12@code, attr, "message")),
     c(
       "> This is message 1\n",
       "> This is message 2\n"

tests/testthat/test-qenv_constructor.R

@@ -2,10 +2,10 @@ testthat::test_that("constructor returns qenv", {
   q <- qenv()
   testthat::expect_s4_class(q, "qenv")
   testthat::expect_identical(ls(q@env), character(0))
-  testthat::expect_identical(q@code, character(0))
-  testthat::expect_identical(q@id, integer(0))
-  testthat::expect_identical(q@warnings, character(0))
-  testthat::expect_identical(q@messages, character(0))
+  testthat::expect_null(unlist(q@code), NULL)
+  testthat::expect_null(attr(q@code, "id"))
+  testthat::expect_null(attr(q@code, "warning"))
+  testthat::expect_null(attr(q@code, "message"))
 })
 
 testthat::test_that("parent of qenv environment is the parent of .GlobalEnv", {

tests/testthat/test-qenv_eval_code.R

@@ -41,21 +41,21 @@ testthat::test_that("getting object from the package namespace works even if lib
 testthat::test_that("eval_code works with character", {
   q1 <- eval_code(qenv(), "a <- 1")
 
-  testthat::expect_identical(q1@code, "a <- 1")
+  testthat::expect_identical(unlist(q1@code), "a <- 1")
   testthat::expect_equal(q1@env, list2env(list(a = 1)))
 })
 
 testthat::test_that("eval_code works with expression", {
   q1 <- eval_code(qenv(), as.expression(quote(a <- 1)))
 
-  testthat::expect_identical(q1@code, "a <- 1")
+  testthat::expect_identical(unlist(q1@code), "a <- 1")
   testthat::expect_equal(q1@env, list2env(list(a = 1)))
 })
 
 testthat::test_that("eval_code works with quoted", {
   q1 <- eval_code(qenv(), quote(a <- 1))
 
-  testthat::expect_identical(q1@code, "a <- 1")
+  testthat::expect_identical(unlist(q1@code), "a <- 1")
   testthat::expect_equal(q1@env, list2env(list(a = 1)))
 })
 
@@ -69,7 +69,7 @@ testthat::test_that("eval_code works with quoted code block", {
   )
 
   testthat::expect_equal(
-    q1@code,
+    unlist(q1@code),
     c("a <- 1", "b <- 2")
   )
   testthat::expect_equal(q1@env, list2env(list(a = 1, b = 2)))
@@ -96,14 +96,17 @@ testthat::test_that("a warning when calling eval_code returns a qenv object whic
   q <- eval_code(q, quote("p <- hist(iris_data[, 'Sepal.Length'], ff = '')"))
   testthat::expect_s4_class(q, "qenv")
   testthat::expect_equal(
-    q@warnings,
-    c("", "> \"ff\" is not a graphical parameter\n")
+    lapply(q@code, attr, "warning"),
+    list(NULL, "> \"ff\" is not a graphical parameter\n")
   )
 })
 
 testthat::test_that("eval_code with a vector of code produces one warning element per code element", {
   q <- eval_code(qenv(), c("x <- 1", "y <- 1", "warning('warn1')"))
-  testthat::expect_equal(c("", "", "> warn1\n"), q@warnings)
+  testthat::expect_equal(
+    lapply(q@code, attr, "warning"),
+    list(NULL, NULL, "> warn1\n")
+  )
 })
 
 
@@ -112,9 +115,9 @@ testthat::test_that("a message when calling eval_code returns a qenv object whic
   q <- eval_code(q, quote("message('This is a message')"))
   testthat::expect_s4_class(q, "qenv")
   testthat::expect_equal(
-    q@messages,
-    c(
-      "",
+    lapply(q@code, attr, "message"),
+    list(
+      NULL,
       "> This is a message\n"
     )
   )
@@ -123,6 +126,6 @@ testthat::test_that("a message when calling eval_code returns a qenv object whic
 testthat::test_that("eval_code returns a qenv object with empty messages and warnings when none are returned", {
   q <- eval_code(qenv(), quote("iris_data <- head(iris)"))
   testthat::expect_s4_class(q, "qenv")
-  testthat::expect_equal(q@messages, "")
-  testthat::expect_equal(q@warnings, "")
+  testthat::expect_null(attr(q@code, "message"))
+  testthat::expect_null(attr(q@code, "warning"))
 })

tests/testthat/test-qenv_extract.R

@@ -1,3 +1,4 @@
+
 testthat::test_that("`[.` returns empty qenv for names not in qenv", {
   data <- within(qenv(), {
     x <- 1
@@ -36,7 +37,7 @@ testthat::test_that("`[.` extract proper code", {
   object_names <- c("x", "a")
   qs <- q[object_names]
   testthat::expect_identical(
-    qs@code,
+    unlist(qs@code),
     c("x<-1", "a<-1")
   )
 })
@@ -47,7 +48,7 @@ testthat::test_that("`[.` preservers comments in the code", {
   q <- eval_code(q, code)
   qs <- q[c("x", "a")]
   testthat::expect_identical(
-    qs@code,
+    unlist(qs@code),
     c("x<-1 #comment", "a<-1")
   )
 })
@@ -59,8 +60,9 @@ testthat::test_that("`[.` extract proper elements of @id, @warnings and @message
   q <- eval_code(q, code)
   qs <- q[c("x", "a")]
 
-  testthat::expect_identical(qs@id, q@id[c(1, 3)])
-  testthat::expect_identical(qs@code, q@code[c(1, 3)])
-  testthat::expect_identical(qs@warnings, q@warnings[c(1, 3)])
-  testthat::expect_identical(qs@messages, q@messages[c(1, 3)])
+  testthat::expect_identical(get_code_attr(qs, "id"), get_code_attr(q, "id")[c(1, 3)])
+  testthat::expect_identical(unlist(qs@code), unlist(q@code[c(1, 3)]))
+  testthat::expect_null(get_code_attr(qs, "warning"))
+  testthat::expect_null(get_code_attr(qs, "message"))
 })
+