alternative to #231

Author: gogonzo

R/qenv-c.R

@@ -24,8 +24,8 @@
     )
   }
 
-  x_id <- get_code_attr(x, "id")
-  y_id <- get_code_attr(y, "id")
+  x_id <- names(x@code)
+  y_id <- names(y@code)
 
   shared_ids <- intersect(x_id, y_id)
   if (length(shared_ids) == 0) {
@@ -89,7 +89,7 @@ c.qenv <- function(...) {
         stop(join_validation)
       }
 
-      x@code <- union(x@code, y@code)
+      x@code <- modifyList(x@code, y@code)
 
       # insert (and overwrite) objects from y to x
       x@.xData <- rlang::env_clone(x@.xData, parent = parent.env(.GlobalEnv))

R/qenv-class.R

@@ -4,18 +4,18 @@
 #' @name qenv-class
 #' @rdname qenv-class
 #' @slot .xData (`environment`) environment with content was generated by the evaluation
-#' @slot code (`list` of `character`) representing code necessary to reproduce the environment.
+#' @slot code (`named list` of `character`) representing code necessary to reproduce the environment.
 #' Read more in Code section.
 #'  of the `code` slot.
 #'
 #' @section Code:
 #'
-#' Each code element is a character representing one call. Each element has possible attributes:
-#' - `warnings` (`character`) the warnings output when evaluating the code element
-#' - `messages` (`character`) the messages output when evaluating the code element
-#' - `id (`integer`) random identifier of the code element to make sure uniqueness when joining
+#' Each code element is a character representing one call. Each element is named with the random
+#' identifier to make sure uniqueness when joining. Each element has possible attributes:
+#' - `warnings` (`character`) the warnings output when evaluating the code element.
+#' - `messages` (`character`) the messages output when evaluating the code element.
 #' - `dependency` (`character`) names of objects that appear in this call and gets affected by this call,
-#' separated by `<-` (objects on LHS of `<-` are affected by this line, and objects on RHS are affecting this line)
+#' separated by `<-` (objects on LHS of `<-` are affected by this line, and objects on RHS are affecting this line).
 #'
 #' @keywords internal
 #' @exportClass qenv
@@ -54,10 +54,7 @@ setMethod(
 #' @name qenv-class
 #' @keywords internal
 setValidity("qenv", function(object) {
-  ids <- lapply(object@code, "attr", "id")
-  if (any(sapply(ids, is.null))) {
-    "All @code slots must have an 'id' attribute"
-  } else if (any(duplicated(unlist(ids)))) {
+  if (any(duplicated(names(object@code)))) {
     "@code contains duplicated 'id' attributes."
   } else if (!environmentIsLocked(object@.xData)) {
     "@.xData must be locked."

R/qenv-eval_code.R

@@ -35,9 +35,8 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code
   object@.xData <- rlang::env_clone(object@.xData, parent = parent.env(.GlobalEnv))
   if (length(parsed_code) == 0) {
     # empty code, or just comments
-    attr(code, "id") <- sample.int(.Machine$integer.max, size = 1)
     attr(code, "dependency") <- extract_dependency(parsed_code) # in case comment contains @linksto tag
-    object@code <- c(object@code, list(code))
+    object@code <- c(object@code, setNames(list(code), sample.int(.Machine$integer.max, size = 1)))
     return(object)
   }
   code_split <- split_code(paste(code, collapse = "\n"))
@@ -84,10 +83,8 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code
     if (!is.null(x)) {
       return(x)
     }
-
-    attr(current_code, "id") <- sample.int(.Machine$integer.max, size = 1)
     attr(current_code, "dependency") <- extract_dependency(current_call)
-    object@code <- c(object@code, list(current_code))
+    object@code <- c(object@code, setNames(list(current_code), sample.int(.Machine$integer.max, size = 1)))
   }
 
   lockEnvironment(object@.xData, bindings = TRUE)

man/qenv-class.Rd

@@ -6,10 +6,7 @@ testthat::test_that("Concatenate two identical qenvs outputs", {
   q12 <- concat(q1, q2)
 
   testthat::expect_equal(q12@.xData, q1@.xData)
-  testthat::expect_identical(
-    unlist(q12@code),
-    c("iris1 <- iris", "iris1 <- iris")
-  )
+  testthat::expect_identical(get_code(q12), "iris1 <- iris\niris1 <- iris")
 })
 
 testthat::test_that("Concatenate two independent qenvs results in object having combined code and environments", {
@@ -22,13 +19,8 @@ testthat::test_that("Concatenate two independent qenvs results in object having
   q12 <- concat(q1, q2)
 
   testthat::expect_equal(q12@.xData, list2env(list(iris1 = iris, mtcars1 = mtcars)))
-  testthat::expect_identical(
-    unlist(q12@code),
-    c("iris1 <- iris", "mtcars1 <- mtcars")
-  )
-  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::expect_identical(get_code(q12), "iris1 <- iris\nmtcars1 <- mtcars")
+  testthat::expect_identical(names(q12@code), c(names(q1@code), names(q2@code)))
 })
 
 testthat::test_that("Concatenate qenvs results with the same variable, the RHS has priority", {
@@ -59,7 +51,7 @@ testthat::test_that("Concatenate two independent qenvs with warnings results in
   q12 <- concat(q1, q2)
 
   testthat::expect_equal(
-    unlist(lapply(q12@code, attr, "warning")),
+    unlist(lapply(q12@code, attr, "warning"), use.names = FALSE),
     c(
       "> This is warning 1\n",
       "> This is warning 2\n"
@@ -74,7 +66,7 @@ testthat::test_that("Concatenate two independent qenvs with messages results in
   q12 <- concat(q1, q2)
 
   testthat::expect_equal(
-    unlist(lapply(q12@code, attr, "message")),
+    unlist(lapply(q12@code, attr, "message"), use.names = FALSE),
     c(
       "> This is message 1\n",
       "> This is message 2\n"

tests/testthat/test-qenv_concat.R

@@ -127,7 +127,7 @@ testthat::test_that("comments alone are pasted to the next/following call elemen
   code <- c("x <- 5", "# comment", "y <- 6")
   q <- eval_code(qenv(), code)
   testthat::expect_identical(
-    unlist(q@code)[2],
+    as.character(q@code)[[2]],
     paste(code[2:3], collapse = "\n")
   )
   testthat::expect_identical(
@@ -140,7 +140,7 @@ testthat::test_that("comments at the end of src are added to the previous call e
   code <- c("x <- 5", "# comment")
   q <- eval_code(qenv(), code)
   testthat::expect_identical(
-    unlist(q@code),
+    as.character(q@code),
     paste(code[1:2], collapse = "\n")
   )
   testthat::expect_identical(
@@ -153,7 +153,7 @@ testthat::test_that("comments from the same line are associated with it's call",
   code <- c("x <- 5", " y <- 4 # comment", "z <- 5")
   q <- eval_code(qenv(), code)
   testthat::expect_identical(
-    unlist(q@code)[2],
+    as.character(q@code)[2],
     paste0(code[2], "\n")
   )
 })
@@ -163,7 +163,7 @@ testthat::test_that("alone comments at the end of the source are considered as c
   code <- c("x <- 5\ny <- 10\n# comment")
   q <- eval_code(eval_code(qenv(), code[1]), code[2])
   testthat::expect_identical(
-    unlist(q@code)[2],
+    as.character(q@code)[2],
     "y <- 10\n# comment"
   )
 })

tests/testthat/test-qenv_eval_code.R

@@ -41,27 +41,30 @@ testthat::test_that("`[.` warns and subsets to existing if some names not presen
   )
 })
 
-testthat::test_that("`[.` warns if name is in code but not in env", {
+testthat::test_that("`[.` warns if name is not in code but is present in env", {
   data <- within(qenv(), {
     a <- 1
     b <- 2
     c <- 3
     d <- 4
   })
   data@code <- data@code[1]
-  testthat::expect_warning(data[c("a", "b", "c")])
+  testthat::expect_warning(data[c("a", "b", "c")], "Object\\(s\\) not found in code: b, c.")
 })
 
-testthat::test_that("`[.` doesn't warn if name is in code but not in env (secret feature for unverified teal_data)", {
-  data <- within(qenv(), {
-    a <- 1
-    b <- 2
-    c <- 3
-    d <- 4
-  })
-  data@code <- data@code[1]
-  testthat::expect_silent(data[c("a", "b", "c"), check_code_names = FALSE])
-})
+testthat::test_that(
+  "`[.` doesn't warn if name is not in code but is present in env (secret feature for unverified teal_data)",
+  {
+    data <- within(qenv(), {
+      a <- 1
+      b <- 2
+      c <- 3
+      d <- 4
+    })
+    data@code <- data@code[1]
+    testthat::expect_silent(data[c("a", "b", "c"), check_code_names = FALSE])
+  }
+)
 
 testthat::test_that("`[.` subsets environment and code to specified object names", {
   q <- qenv()
@@ -78,19 +81,13 @@ testthat::test_that("`[.` extracts the code only needed to recreate objects pass
   q <- eval_code(q, code)
   object_names <- c("x", "a")
   qs <- q[object_names]
-  testthat::expect_identical(
-    unlist(qs@code),
-    c("x<-1\n", "a<-1;")
-  )
+  testthat::expect_identical(get_code(qs), c("x<-1\na<-1;"))
 })
 
 testthat::test_that("`[.` comments are preserved in the code and associated with the following call", {
   q <- qenv()
   code <- c("x<-1 #comment", "a<-1;b<-2")
   q <- eval_code(q, code)
   qs <- q[c("x", "a")]
-  testthat::expect_identical(
-    unlist(qs@code),
-    c("x<-1 #comment\n", "a<-1;")
-  )
+  testthat::expect_identical(get_code(qs), c("x<-1 #comment\na<-1;"))
 })

tests/testthat/test-qenv_extract.R

@@ -131,7 +131,7 @@ testthat::test_that("Joining two independent qenvs with warnings results in obje
   q <- c(q1, q2)
 
   testthat::expect_equal(
-    get_code_attr(q, "warning"),
+    unname(get_code_attr(q, "warning")),
     c(
       "> This is warning 1\n",
       "> This is warning 2\n"
@@ -146,7 +146,7 @@ testthat::test_that("Joining two independent qenvs with messages results in obje
   q <- c(q1, q2)
 
   testthat::expect_equal(
-    get_code_attr(q, "message"),
+    unname(get_code_attr(q, "message")),
     c(
       "> This is message 1\n",
       "> This is message 2\n"