WIP - postmerge

Author: gogonzo

NAMESPACE

@@ -1,7 +1,7 @@
 # Generated by roxygen2: do not edit by hand
 
-S3method("[",qenv)
 S3method("$",qenv.error)
+S3method("[",qenv)
 S3method("[[",qenv.error)
 S3method(as.list,qenv.error)
 S3method(c,qenv)

R/qenv-c.R

@@ -24,13 +24,16 @@
     )
   }
 
-  shared_ids <- intersect(x@id, y@id)
+  x_id <- get_code_attr(x, "id")
+  y_id <- get_code_attr(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))) {
@@ -86,11 +89,7 @@ c.qenv <- function(...) {
         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])
+      x@code <- union(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

@@ -21,12 +21,7 @@
 #' @exportClass qenv
 setClass(
   "qenv",
-  slots = c(
-    code = "character",
-    id = "integer",
-    warnings = "character",
-    messages = "character"
-  ),
+  slots = c(code = "list"),
   contains = "environment"
 )
 
@@ -37,25 +32,7 @@ setMethod(
   "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 {
@@ -67,28 +44,22 @@ setMethod(
     # .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.
+    methods::callNextMethod(
       # Mandatory use of `xData` to build a correct [email protected]
-      .Object, new_xdata,
-      code = code, messages = messages, warnings = warnings, id = id, ...
+      .Object, new_xdata, ...
     )
-
-    .Object
   }
 )
 
 #' It takes a `qenv` class and returns `TRUE` if the input is valid
 #' @name qenv-class
 #' @keywords internal
 setValidity("qenv", function(object) {
-  if (length(object@code) != length(object@id)) {
-    "@code and @id slots must have the same length."
-  } else if (length(object@code) != length(object@warnings)) {
-    "@code and @warnings slots must have the same length"
-  } else if (length(object@code) != length(object@messages)) {
-    "@code and @messages slots must have the same length"
-  } else if (any(duplicated(object@id))) {
-    "@id contains duplicated values."
+  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)))) {
+    "@code contains duplicated 'id' attributes."
   } else if (!environmentIsLocked(object@.xData)) {
     "@.xData must be locked."
   } else {

R/qenv-eval_code.R

@@ -29,7 +29,7 @@ setGeneric("eval_code", function(object, code) standardGeneric("eval_code"))
 
 setMethod("eval_code", signature = c("qenv", "character"), function(object, code) {
   parsed_code <- parse(text = code, keep.source = TRUE)
-  object@env <- rlang::env_clone(object@env, parent = parent.env(.GlobalEnv))
+  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)
@@ -48,9 +48,9 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code
     x <- withCallingHandlers(
       tryCatch(
         {
-          eval(current_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(current_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@.xData) <- parent.env(.GlobalEnv)
           }
@@ -87,7 +87,7 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code
     object@code <- c(object@code, list(current_code))
   }
 
-  lockEnvironment(object@env, bindings = TRUE)
+  lockEnvironment(object@.xData, bindings = TRUE)
   object
 })
 

R/qenv-extract.R

@@ -42,7 +42,7 @@
     )
   }
 
-  x@env <- list2env(mget(x = names, envir = get_env(x)))
+  x@.xData <- list2env(as.list(x)[names])
   names <- gsub("^`(.*)`$", "\\1", names)
   x@code <- get_code_dependency(x@code, names = names, ...)
 

R/qenv-join.R

@@ -139,20 +139,6 @@ setGeneric("join", function(x, y) standardGeneric("join"))
 setMethod("join", signature = c("qenv", "qenv"), function(x, y) {
   lifecycle::deprecate_soft("0.5.1", "join()", "c()")
   c(x, y)
-  join_validation <- .check_joinable(x, y)
-
-  # join expressions
-  if (!isTRUE(join_validation)) {
-    stop(join_validation)
-  }
-
-  id_unique <- !get_code_attr(y, "id") %in% get_code_attr(x, "id")
-  x@code <- c(x@code, y@code[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
 })
 
 setMethod("join", signature = c("qenv", "qenv.error"), function(x, y) {
@@ -164,57 +150,3 @@ setMethod("join", signature = c("qenv.error", "ANY"), function(x, y) {
   lifecycle::deprecate_soft("0.5.1", "join()", "c()")
   x
 })
-
-#' 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@env), rlang::env_names(y@env))
-  is_overwritten <- vapply(common_names, function(el) {
-    !identical(get(el, x@env), get(el, y@env))
-  }, 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 - ")
-      )
-    )
-  }
-  x_id <- get_code_attr(x, "id")
-  y_id <- get_code_attr(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)
-
-  # 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 = ""
-    )
-  }
-}

man/get_env.Rd

@@ -51,10 +51,7 @@ testthat::test_that("constructor returns qenv", {
   q <- qenv()
   testthat::expect_s4_class(q, "qenv")
   testthat::expect_identical(names(q), 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_identical(q@code, list())
 })
 
 testthat::describe("parent of qenv environment is the parent of .GlobalEnv", {