Merged origin/main into 224_magrittr@main

Author: llrs-roche

.pre-commit-config.yaml

@@ -6,7 +6,7 @@ default_language_version:
   python: python3
 repos:
   - repo: https://github.com/lorenzwalthert/precommit
-    rev: v0.4.3.9001
+    rev: v0.4.3.9003
     hooks:
       - id: style-files
         name: Style code with `styler`

DESCRIPTION

@@ -1,8 +1,8 @@
 Type: Package
 Package: teal.code
 Title: Code Storage and Execution Class for 'teal' Applications
-Version: 0.5.0.9012
-Date: 2024-10-29
+Version: 0.5.0.9013
+Date: 2024-11-08
 Authors@R: c(
     person("Dawid", "Kaledkowski", , "[email protected]", role = c("aut", "cre")),
     person("Aleksander", "Chlebowski", , "[email protected]", role = "aut"),
@@ -52,6 +52,7 @@ Language: en-US
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.3.2
 Collate:
+    'qenv-c.R'
     'qenv-class.R'
     'qenv-errors.R'
     'qenv-concat.R'
@@ -62,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,6 +1,13 @@
 # Generated by roxygen2: do not edit by hand
 
+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(names,qenv.error)
 S3method(within,qenv)
 S3method(within,qenv.error)
 export(concat)

NEWS.md

@@ -1,9 +1,12 @@
-# teal.code 0.5.0.9012
+# teal.code 0.5.0.9013
 
 ### Enhancements
 
 * `get_code()` was extended with `names` parameter and allows the code extraction to be limited to objects stored in
 `qenv` but limited to `names`.
+* `qenv` inherits from the `environment` class, allowing to use `ls()`, `names()`, `as.environment()` and other functions on `qenv` objects.
+* `join()` method is deprecated, please use `c()` instead
+* `get_var()` method is deprecated, please use `get`, `[[` or `$` instead.
 
 # teal.code 0.5.0
 

R/qenv-c.R

@@ -0,0 +1,107 @@
+#' If two `qenv` can be joined
+#'
+#' Checks if two `qenv` objects can be combined.
+#' For more information, please see [`join`]
+#' @param x (`qenv`)
+#' @param y (`qenv`)
+#' @return `TRUE` if able to join or `character` used to print error message.
+#' @keywords internal
+.check_joinable <- function(x, y) {
+  checkmate::assert_class(x, "qenv")
+  checkmate::assert_class(y, "qenv")
+
+  common_names <- intersect(rlang::env_names(x@.xData), rlang::env_names(y@.xData))
+  is_overwritten <- vapply(common_names, function(el) {
+    !identical(get(el, x@.xData), get(el, y@.xData))
+  }, logical(1))
+  if (any(is_overwritten)) {
+    return(
+      paste(
+        "Not possible to join qenv objects if anything in their environment has been modified.\n",
+        "Following object(s) have been modified:\n - ",
+        paste(common_names[is_overwritten], collapse = "\n - ")
+      )
+    )
+  }
+
+  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)
+
+  # 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))) {
+    TRUE
+  } else if (!identical(shared_in_x, shared_in_y)) {
+    paste(
+      "The common shared code of the qenvs does not occur in the same position in both qenv objects",
+      "so they cannot be joined together as it's impossible to determine the evaluation's order.",
+      collapse = ""
+    )
+  } else {
+    paste(
+      "There is code in the qenv objects before their common shared code",
+      "which means these objects cannot be joined.",
+      collapse = ""
+    )
+  }
+}
+
+#' @rdname join
+#' @param ... (`qenv` or `qenv.error`).
+#' @examples
+#' q <- qenv()
+#' q1 <- within(q, {
+#'   iris1 <- iris
+#'   mtcars1 <- mtcars
+#' })
+#' q1 <- within(q1, iris2 <- iris)
+#' q2 <- within(q1, mtcars2 <- mtcars)
+#' qq <- c(q1, q2)
+#' cat(get_code(qq))
+#'
+#' @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
+    }
+  )
+}
+
+#' @rdname join
+#' @export
+c.qenv.error <- function(...) {
+  rlang::list2(...)[[1]]
+}

R/qenv-class.R

@@ -4,7 +4,7 @@
 #' @name qenv-class
 #' @rdname qenv-class
 #' @slot code (`character`) representing code necessary to reproduce the environment
-#' @slot env (`environment`) environment which content was generated by the evaluation
+#' @slot .xData (`environment`) environment with content was generated by the evaluation
 #'  of the `code` slot.
 #' @slot id (`integer`) random identifier of the code element to make sure uniqueness
 #'  when joining.
@@ -14,11 +14,60 @@
 #' @exportClass qenv
 setClass(
   "qenv",
-  slots = c(env = "environment", code = "character", id = "integer", warnings = "character", messages = "character"),
-  prototype = list(
-    env = new.env(parent = parent.env(.GlobalEnv)), code = character(0), id = integer(0),
-    warnings = character(0), messages = character(0)
-  )
+  slots = c(
+    code = "character",
+    id = "integer",
+    warnings = "character",
+    messages = "character"
+  ),
+  contains = "environment"
+)
+
+#' It initializes the `qenv` class
+#' @noRd
+setMethod(
+  "initialize",
+  "qenv",
+  function(.Object, # nolint: object_name.
+           .xData, # nolint: object_name.
+           code = character(0L),
+           warnings = rep("", length(code)),
+           messages = rep("", length(code)),
+           id = integer(0L),
+           ...) {
+    # # Pre-process parameters to ensure they are ready to be used by parent constructors
+    stopifnot("`code` must be a character or language object." = any(is.language(code), is.character(code)))
+
+    if (is.language(code)) {
+      code <- paste(lang2calls(code), collapse = "\n")
+    }
+    if (length(code)) {
+      code <- paste(code, collapse = "\n")
+    }
+
+    if (length(id) == 0L) {
+      id <- sample.int(.Machine$integer.max, size = length(code))
+    }
+
+    new_xdata <- if (rlang::is_missing(.xData)) {
+      new.env(parent = parent.env(.GlobalEnv))
+    } else {
+      checkmate::assert_environment(.xData)
+      rlang::env_clone(.xData, parent = parent.env(.GlobalEnv))
+    }
+    lockEnvironment(new_xdata, bindings = TRUE)
+
+    # .xData needs to be unnamed as the `.environment` constructor allows at
+    # most 1 unnamed formal argument of class `environment`.
+    # See methods::findMethods("initialize")$.environment
+    .Object <- methods::callNextMethod( # nolint: object_name.
+      # Mandatory use of `xData` to build a correct [email protected]
+      .Object, new_xdata,
+      code = code, messages = messages, warnings = warnings, id = id, ...
+    )
+
+    .Object
+  }
 )
 
 #' It takes a `qenv` class and returns `TRUE` if the input is valid
@@ -33,6 +82,8 @@ setValidity("qenv", function(object) {
     "@code and @messages slots must have the same length"
   } else if (any(duplicated(object@id))) {
     "@id contains duplicated values."
+  } else if (!environmentIsLocked(object@.xData)) {
+    "@.xData must be locked."
   } else {
     TRUE
   }

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

@@ -12,7 +12,7 @@
 #'
 #' @name qenv
 #'
-#' @return Returns a `qenv` object.
+#' @return `qenv` returns a `qenv` object.
 #'
 #' @seealso [`base::within()`], [`get_var()`], [`get_env()`], [`get_warnings()`], [`join()`], [`concat()`]
 #' @examples
@@ -21,7 +21,5 @@
 #'
 #' @export
 qenv <- function() {
-  q_env <- new.env(parent = parent.env(.GlobalEnv))
-  lockEnvironment(q_env, bindings = TRUE)
-  methods::new("qenv", env = q_env)
+  methods::new("qenv")
 }

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-eval_code.R

@@ -1,7 +1,7 @@
 #' Evaluate code in `qenv`
 #'
 #' @details
-#' `eval_code` evaluates given code in the `qenv` environment and appends it to the `code` slot.
+#' `eval_code()` evaluates given code in the `qenv` environment and appends it to the `code` slot.
 #' Thus, if the `qenv` had been instantiated empty, contents of the environment are always a result of the stored code.
 #'
 #' @param object (`qenv`)
@@ -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))) {
-            # needed to make sure that @env is always a sibling of .GlobalEnv
+          eval(single_call, envir = object@.xData)
+          if (!identical(parent.env(object@.xData), parent.env(.GlobalEnv))) {
+            # needed to make sure that @.xData 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,20 +80,19 @@ 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
 })
 
 setMethod("eval_code", signature = c("qenv", "language"), function(object, code) {
-  eval_code(object, code = paste(lang2calls(code), collapse = "\n"))
+  eval_code(object, code = paste(vapply(lang2calls(code), deparse1, collapse = "\n", character(1L)), collapse = "\n"))
 })
 
 setMethod("eval_code", signature = c("qenv", "expression"), function(object, code) {
-  eval_code(object, code = paste(lang2calls(code), collapse = "\n"))
+  eval_code(object, code = paste(vapply(lang2calls(code), deparse1, collapse = "\n", character(1L)), collapse = "\n"))
 })
 
 setMethod("eval_code", signature = c("qenv.error", "ANY"), function(object, code) {