feat: expand on compatibility with an environment

Author: averissimo

DESCRIPTION

@@ -63,6 +63,7 @@ Collate:
     'qenv-get_var.R'
     'qenv-get_warnings.R'
     'qenv-join.R'
+    'qenv-length.R'
     'qenv-show.R'
     'qenv-within.R'
     'teal.code-package.R'

NAMESPACE

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

R/qenv-class.R

@@ -20,14 +20,21 @@ setClass(
     warnings = "character",
     messages = "character"
   ),
-  contains = "environment",
-  prototype = list(
-    .xData = new.env(parent = parent.env(.GlobalEnv)),
-    code = character(0),
-    id = integer(0),
-    warnings = character(0),
-    messages = character(0)
-  )
+  contains = "environment"
+)
+
+setMethod(
+  "initialize",
+  "qenv",
+  function(.Object, .xData = new.env(parent = parent.env(.GlobalEnv)), ...) { # nolint: object_name.
+    .Object <- callNextMethod(.Object, ...) # nolint: object_name.
+
+    checkmate::assert_environment(.xData)
+    lockEnvironment(.xData)
+    .Object@.xData <- .xData # nolint: object_name.
+
+    .Object
+  }
 )
 
 #' It takes a `qenv` class and returns `TRUE` if the input is valid

R/qenv-errors.R

@@ -1,2 +1,10 @@
 # needed to handle try-error
 setOldClass("qenv.error")
+
+#' @export
+as.list.qenv.error <- function(x, ...) {
+  stop(errorCondition(
+    list(message = conditionMessage(x)),
+    class = c("validation", "try-error", "simpleError")
+  ))
+}

R/qenv-get_var.R

@@ -70,14 +70,3 @@ setMethod("[[", signature = c("qenv", "ANY"), function(x, i) {
     class = c("validation", "try-error", "simpleError")
   ))
 }
-
-#' @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

@@ -136,30 +136,17 @@
 setGeneric("join", function(x, y) standardGeneric("join"))
 
 setMethod("join", signature = c("qenv", "qenv"), function(x, y) {
-  join_validation <- .check_joinable(x, y)
-
-  # join expressions
-  if (!isTRUE(join_validation)) {
-    stop(join_validation)
-  }
-
-  id_unique <- !y@id %in% x@id
-  x@id <- c(x@id, y@id[id_unique])
-  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@.xData <- rlang::env_clone(x@.xData, parent = parent.env(.GlobalEnv))
-  rlang::env_coalesce(env = x@.xData, from = y@.xData)
-  x
+  lifecycle::deprecate_soft("0.5.1", "join()", details = "Please use `c()` instead")
+  c(x, y)
 })
 
 setMethod("join", signature = c("qenv", "qenv.error"), function(x, y) {
+  lifecycle::deprecate_soft("0.5.1", "join()", details = "Please use `c()` instead")
   y
 })
 
 setMethod("join", signature = c("qenv.error", "ANY"), function(x, y) {
+  lifecycle::deprecate_soft("0.5.1", "join()", details = "Please use `c()` instead")
   x
 })
 
@@ -214,3 +201,45 @@ setMethod("join", signature = c("qenv.error", "ANY"), function(x, y) {
     )
   }
 }
+
+#' @export
+c.qenv.error <- function(...) {
+  rlang::list2(...)[[1]]
+}
+
+#' @export
+c.qenv <- function(...) {
+  dots <- rlang::list2(...)
+  if (!checkmate::test_list(dots[-1], types = c("qenv", "qenv.error"))) {
+    return(NextMethod(c, dots[[1]]))
+  }
+
+  first_non_qenv_ix <- which.min(vapply(dots, inherits, what = "qenv", logical(1)))
+  if (first_non_qenv_ix > 1) {
+    return(dots[[first_non_qenv_ix]])
+  }
+
+  Reduce(
+    x = dots[-1],
+    init = dots[[1]],
+    f = function(x, y) {
+      join_validation <- .check_joinable(x, y)
+
+      # join expressions
+      if (!isTRUE(join_validation)) {
+        stop(join_validation)
+      }
+
+      id_unique <- !y@id %in% x@id
+      x@id <- c(x@id, y@id[id_unique])
+      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@.xData <- rlang::env_clone(x@.xData, parent = parent.env(.GlobalEnv))
+      rlang::env_coalesce(env = x@.xData, from = y@.xData)
+      x
+    }
+  )
+}

R/qenv-length.R

@@ -0,0 +1,5 @@
+#' @export
+length.qenv <- function(x) length(x@.xData)
+
+#' @export
+length.qenv.error <- function(x) 0

tests/testthat/test-qenv-class.R

@@ -0,0 +1,13 @@
+testthat::describe("methods::new(qenv)", {
+  testthat::it("creates a locked environment", {
+    expect_true(is.environment(methods::new("qenv")))
+  })
+
+  testthat::it("throws error when id and code length doesn't match", {
+    expect_error(is.environment(methods::new("qenv", id = 1)))
+  })
+
+  testthat::it("throws error when .xData is not an environment", {
+    expect_true(is.environment(methods::new("qenv")))
+  })
+})

tests/testthat/test-qenv_get_var.R

@@ -53,11 +53,3 @@ testthat::test_that("get_var, `$` and `[[` only returns objects from qenv, not .
   testthat::expect_null(q[["iris"]])
   testthat::expect_null(q$iris)
 })
-
-testthat::test_that("`$<-` and `[[<-` always return error", {
-  q <- eval_code(qenv(), quote(x <- 1))
-  q <- eval_code(q, quote(y <- w * x))
-
-  testthat::expect_error(q[["x2"]] <- 3, "when evaluating qenv code")
-  testthat::expect_error(q$x2 <- 3, "when evaluating qenv code")
-})