Change qenv as environment "type" -- adds names(qenv/qenv.error), get() and $ S3 methods

NAMESPACE

@@ -1,6 +1,9 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method("$",qenv.error)
+S3method("$<-",qenv.error)
 S3method("[[",qenv.error)
+S3method("[[<-",qenv.error)
 S3method(within,qenv)
 S3method(within,qenv.error)
 export(concat)

NEWS.md

@@ -4,6 +4,7 @@
 
 * `get_code()` was extended with `names` parameter and allows the code extraction to be limited to objects stored in
 `qenv` but limited to `names`.
+* Added `names()` function for `qenv` objects, which dynamically determines the visible objects in the environment.
 
 # teal.code 0.5.0
 

R/qenv-class.R

@@ -14,10 +14,19 @@
 #' @exportClass qenv
 setClass(
   "qenv",
-  slots = c(env = "environment", code = "character", id = "integer", warnings = "character", messages = "character"),
+  slots = c(
+    code = "character",
+    id = "integer",
+    warnings = "character",
+    messages = "character"
+  ),
+  contains = "environment",
   prototype = list(
-    env = new.env(parent = parent.env(.GlobalEnv)), code = character(0), id = integer(0),
-    warnings = character(0), messages = character(0)
+    .xData = new.env(parent = parent.env(.GlobalEnv)),
+    code = character(0),
+    id = integer(0),
+    warnings = character(0),
+    messages = character(0)
   )
 )
 

R/qenv-concat.R

@@ -38,8 +38,8 @@ setMethod("concat", signature = c("qenv", "qenv"), function(x, y) {
   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))
-  rlang::env_coalesce(env = y@env, from = x@env)
+  y@.xData <- rlang::env_clone(y@.xData, parent = parent.env(.GlobalEnv))
+  rlang::env_coalesce(env = y@.xData, from = x@.xData)
   y
 })
 

R/qenv-constructor.R

@@ -25,7 +25,7 @@
 qenv <- function() {
   q_env <- new.env(parent = parent.env(.GlobalEnv))
   lockEnvironment(q_env, bindings = TRUE)
-  methods::new("qenv", env = q_env)
+  methods::new("qenv", .xData = q_env)
 }
 
 
@@ -73,7 +73,11 @@ setMethod(
     id <- sample.int(.Machine$integer.max, size = length(code))
     methods::new(
       "qenv",
-      env = new_env, code = code, warnings = rep("", length(code)), messages = rep("", length(code)), id = id
+      .xData = new_env,
+      code = code,
+      warnings = rep("", length(code)),
+      messages = rep("", length(code)),
+      id = id
     )
   }
 )

R/qenv-eval_code.R

@@ -31,7 +31,7 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code
   id <- sample.int(.Machine$integer.max, size = 1)
 
   object@id <- c(object@id, id)
-  object@env <- rlang::env_clone(object@env, parent = parent.env(.GlobalEnv))
+  object@.xData <- rlang::env_clone(object@.xData, parent = parent.env(.GlobalEnv))
   code <- paste(code, collapse = "\n")
   object@code <- c(object@code, code)
 
@@ -45,11 +45,11 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code
     x <- withCallingHandlers(
       tryCatch(
         {
-          eval(single_call, envir = object@env)
-          if (!identical(parent.env(object@env), parent.env(.GlobalEnv))) {
+          eval(single_call, envir = object@.xData)
+          if (!identical(parent.env(object@.xData), parent.env(.GlobalEnv))) {
             # needed to make sure that @env is always a sibling of .GlobalEnv
             # could be changed when any new package is added to search path (through library or require call)
-            parent.env(object@env) <- parent.env(.GlobalEnv)
+            parent.env(object@.xData) <- parent.env(.GlobalEnv)
           }
           NULL
         },
@@ -80,11 +80,10 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code
     }
   }
 
-
   object@warnings <- c(object@warnings, current_warnings)
   object@messages <- c(object@messages, current_messages)
 
-  lockEnvironment(object@env, bindings = TRUE)
+  lockEnvironment(object@.xData, bindings = TRUE)
   object
 })
 

R/qenv-get_env.R

@@ -24,7 +24,7 @@ setGeneric("get_env", function(object) {
 })
 
 setMethod("get_env", "qenv", function(object) {
-  object@env
+  object@.xData
 })
 
 setMethod("get_env", "qenv.error", function(object) {

R/qenv-get_var.R

@@ -28,7 +28,7 @@ setGeneric("get_var", function(object, var) {
 
 setMethod("get_var", signature = c("qenv", "character"), function(object, var) {
   tryCatch(
-    get(var, envir = object@env, inherits = FALSE),
+    get(var, envir = object@.xData, inherits = FALSE),
     error = function(e) {
       message(conditionMessage(e))
       NULL
@@ -55,3 +55,29 @@ setMethod("[[", signature = c("qenv", "ANY"), function(x, i) {
     class = c("validation", "try-error", "simpleError")
   ))
 }
+
+#' @export
+`$.qenv.error` <- function(x, name) {
+  # Must allow access of elements in qenv.error object (message, call, trace, ...)
+  # Otherwise, it will enter an infinite recursion with the `conditionMessage(x)` call.
+  result <- NextMethod("$", x)
+  if (is.null(result)) {
+    class(x) <- setdiff(class(x), "qenv.error")
+    stop(errorCondition(
+      list(message = conditionMessage(x)),
+      class = c("validation", "try-error", "simpleError")
+    ))
+  }
+  result
+}
+
+#' @export
+`[[<-.qenv.error` <- function(x, name, value) {
+  stop(errorCondition(
+    list(message = conditionMessage(x)),
+    class = c("validation", "try-error", "simpleError")
+  ))
+}
+
+#' @export
+`$<-.qenv.error` <- `[[<-.qenv.error`

R/qenv-join.R

@@ -150,8 +150,8 @@ setMethod("join", signature = c("qenv", "qenv"), function(x, y) {
   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))
-  rlang::env_coalesce(env = x@env, from = y@env)
+  x@.xData <- rlang::env_clone(x@.xData, parent = parent.env(.GlobalEnv))
+  rlang::env_coalesce(env = x@.xData, from = y@.xData)
   x
 })
 
@@ -175,9 +175,9 @@ setMethod("join", signature = c("qenv.error", "ANY"), function(x, y) {
   checkmate::assert_class(x, "qenv")
   checkmate::assert_class(y, "qenv")
 
-  common_names <- intersect(rlang::env_names(x@env), rlang::env_names(y@env))
+  common_names <- intersect(rlang::env_names(x@.xData), rlang::env_names(y@.xData))
   is_overwritten <- vapply(common_names, function(el) {
-    !identical(get(el, x@env), get(el, y@env))
+    !identical(get(el, x@.xData), get(el, y@.xData))
   }, logical(1))
   if (any(is_overwritten)) {
     return(

R/qenv-show.R

@@ -16,5 +16,5 @@
 #' @importFrom methods show
 #' @export
 setMethod("show", "qenv", function(object) {
-  rlang::env_print(object@env)
+  rlang::env_print(object@.xData)
 })

_pkgdown.yml

@@ -34,6 +34,7 @@ reference:
       - get_var
       - get_warnings
       - join
+      - names.qenv
       - new_qenv
       - qenv
       - show,qenv-method

inst/WORDLIST

@@ -1,7 +1,7 @@
 Forkers
-Hoffmann
-Reproducibility
 funder
+Hoffmann
 qenv
 repo
+Reproducibility
 reproducibility

tests/testthat/test-qenv_concat.R

@@ -5,7 +5,7 @@ testthat::test_that("Concatenate two identical qenvs outputs", {
 
   q12 <- concat(q1, q2)
 
-  testthat::expect_equal(q12@env, q1@env)
+  testthat::expect_equal(q12@.xData, q1@.xData)
   testthat::expect_identical(
     q12@code,
     c("iris1 <- iris", "iris1 <- iris")
@@ -21,7 +21,7 @@ testthat::test_that("Concatenate two independent qenvs results in object having
 
   q12 <- concat(q1, q2)
 
-  testthat::expect_equal(q12@env, list2env(list(iris1 = iris, mtcars1 = mtcars)))
+  testthat::expect_equal(q12@.xData, list2env(list(iris1 = iris, mtcars1 = mtcars)))
   testthat::expect_identical(
     q12@code,
     c("iris1 <- iris", "mtcars1 <- mtcars")

tests/testthat/test-qenv_constructor.R

@@ -1,19 +1,67 @@
+testthat::describe("qenv inherits from environment: ", {
+  testthat::it("is an environment", {
+    testthat::expect_true(is.environment(qenv()))
+  })
+
+  testthat::it("ls() shows nothing on empty environment", {
+    testthat::expect_identical(ls(qenv(), all.names = TRUE), character(0))
+  })
+
+  testthat::it("ls() shows available objets", {
+    q <- within(qenv(), iris <- iris)
+    testthat::expect_setequal(ls(q), "iris")
+  })
+
+  testthat::it("ls() does not show hidden objects", {
+    q <- within(qenv(), {
+      iris <- iris
+      .hidden <- 2
+    })
+    testthat::expect_setequal(ls(q), "iris")
+  })
+
+  testthat::it("names() show all objects", {
+    q <- eval_code(qenv(), "
+      iris <- iris
+      .hidden <- 2
+    ")
+    testthat::expect_setequal(names(q), c("iris", ".hidden"))
+  })
+
+  testthat::it("does not allow binding to be added", {
+    q <- qenv()
+    testthat::expect_error(q$x <- 1, "cannot add bindings to a locked environment")
+  })
+
+  testthat::it("does not allow binding to be modified", {
+    q <- within(qenv(), obj <- 1)
+    testthat::expect_error(q$obj <- 2, "cannot change value of locked binding for 'obj'")
+  })
+})
+
 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(ls(q@.xData, all.names = TRUE), 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::test_that("parent of qenv environment is the parent of .GlobalEnv", {
-  q <- qenv()
-  testthat::expect_identical(parent.env(q@env), parent.env(.GlobalEnv))
+testthat::describe("parent of qenv environment is the parent of .GlobalEnv", {
+  testthat::it("via slot", {
+    q <- qenv()
+    testthat::expect_identical(parent.env(q@.xData), parent.env(.GlobalEnv))
+  })
+
+  testthat::it("via qenv directly", {
+    q <- qenv()
+    testthat::expect_identical(parent.env(q), parent.env(.GlobalEnv))
+  })
 })
 
-testthat::test_that("parent of qenv environment is locked", {
+testthat::test_that("qenv environment is locked", {
   q <- qenv()
-  testthat::expect_error(q@env$x <- 1, "cannot add bindings to a locked environment")
+  testthat::expect_error(q@.xData$x <- 1, "cannot add bindings to a locked environment")
 })

tests/testthat/test-qenv_eval_code.R

@@ -15,14 +15,14 @@
   )
 })
 
-testthat::test_that("@env in qenv is always a sibling of .GlobalEnv", {
+testthat::test_that("@.xData in qenv is always a sibling of .GlobalEnv", {
   q1 <- qenv()
-  testthat::expect_identical(parent.env(q1@env), parent.env(.GlobalEnv))
+  testthat::expect_identical(parent.env(q1@.xData), parent.env(.GlobalEnv))
 
   q2 <- eval_code(q1, quote(a <- 1L))
-  testthat::expect_identical(parent.env(q2@env), parent.env(.GlobalEnv))
+  testthat::expect_identical(parent.env(q2@.xData), parent.env(.GlobalEnv))
   q3 <- eval_code(q2, quote(b <- 2L))
-  testthat::expect_identical(parent.env(q3@env), parent.env(.GlobalEnv))
+  testthat::expect_identical(parent.env(q3@.xData), parent.env(.GlobalEnv))
 })
 
 testthat::test_that("getting object from the package namespace works even if library in the same call", {
@@ -42,21 +42,21 @@
   q1 <- eval_code(qenv(), "a <- 1")
 
   testthat::expect_identical(q1@code, "a <- 1")
-  testthat::expect_equal(q1@env, list2env(list(a = 1)))
+  testthat::expect_equal(q1@.xData, 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_equal(q1@env, list2env(list(a = 1)))
+  testthat::expect_equal(q1@.xData, 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_equal(q1@env, list2env(list(a = 1)))
+  testthat::expect_equal(q1@.xData, list2env(list(a = 1)))
 })
 
 testthat::test_that("eval_code works with quoted code block", {
@@ -72,11 +72,12 @@
     q1@code,
     "a <- 1\nb <- 2"
   )
-  testthat::expect_equal(q1@env, list2env(list(a = 1, b = 2)))
+  testthat::expect_equal(q1@.xData, list2env(list(a = 1, b = 2)))
 })
 
 testthat::test_that("eval_code fails with unquoted expression", {
-  testthat::expect_error(eval_code(qenv(), a <- b), "object 'b' not found")
+  b <- 3
+  testthat::expect_error(eval_code(qenv(), a <- b), "unable to find an inherited method for function .eval_code. for signature")
 })
 
 testthat::test_that("an error when calling eval_code returns a qenv.error object which has message and trace", {

tests/testthat/test-qenv_get_code.R

@@ -120,7 +120,7 @@ testthat::test_that("extracts the code without downstream usage", {
   )
 })
 
-testthat::test_that("works for datanames of length > 1", {
+testthat::test_that("works for names of length > 1", {
   code <- c(
     "a <- 1",
     "b <- 2"