211 [.qenv S3 method + replacement of @id, @warnings, and @messages fields (#216)

Signed-off-by: go_gonzo <[email protected]>
Co-authored-by: Marcin <[email protected]>
Co-authored-by: André Veríssimo <[email protected]>

Author: m7pr

DESCRIPTION

@@ -59,8 +59,10 @@ Collate:
     'qenv-concat.R'
     'qenv-constructor.R'
     'qenv-eval_code.R'
+    'qenv-extract.R'
     'qenv-get_code.R'
     'qenv-get_env.R'
+    'qenv-get_messages.r'
     'qenv-get_var.R'
     'qenv-get_warnings.R'
     'qenv-join.R'

NAMESPACE

@@ -1,6 +1,7 @@
 # Generated by roxygen2: do not edit by hand
 
 S3method("$",qenv.error)
+S3method("[",qenv)
 S3method("[[",qenv.error)
 S3method(as.list,qenv.error)
 S3method(c,qenv)
@@ -15,6 +16,7 @@ export(dev_suppress)
 export(eval_code)
 export(get_code)
 export(get_env)
+export(get_messages)
 export(get_var)
 export(get_warnings)
 export(join)

NEWS.md

@@ -2,8 +2,11 @@
 
 ### Enhancements
 
+* Introduced `[.qenv` function to subset `qenv` object (code and environment) to specified object names. #211
 * `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` but limited to `names`. #210
+* Introduced `get_messages()` to get messages produced during code evaluation. #217
+* `get_code()` returns original code formatting (white spaces and comments) passed to `eval_code()`. #212
 * `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.

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

@@ -3,23 +3,25 @@
 #' Reproducible class with environment and code.
 #' @name qenv-class
 #' @rdname qenv-class
-#' @slot code (`character`) representing code necessary to reproduce the environment
 #' @slot .xData (`environment`) environment with content was generated by the evaluation
+#' @slot code (`list` of `character`) representing code necessary to reproduce the environment.
+#' Read more in Code section.
 #'  of the `code` slot.
-#' @slot id (`integer`) random identifier of the code element to make sure uniqueness
-#'  when joining.
-#' @slot warnings (`character`) the warnings output when evaluating the code
-#' @slot messages (`character`) the messages output when evaluating the code
+#'
+#' @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
+#' - `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)
+#'
 #' @keywords internal
 #' @exportClass qenv
 setClass(
   "qenv",
-  slots = c(
-    code = "character",
-    id = "integer",
-    warnings = "character",
-    messages = "character"
-  ),
+  slots = c(code = "list"),
   contains = "environment"
 )
 
@@ -28,27 +30,7 @@ setClass(
 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))
-    }
-
+  function(.Object, .xData, code = list(), ...) { # nolint: object_name.
     new_xdata <- if (rlang::is_missing(.xData)) {
       new.env(parent = parent.env(.GlobalEnv))
     } else {
@@ -60,28 +42,23 @@ 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.
-      # Mandatory use of `xData` to build a correct .Object@.xData
-      .Object, new_xdata,
-      code = code, messages = messages, warnings = warnings, id = id, ...
+    methods::callNextMethod(
+      .Object,
+      new_xdata, # Mandatory use of unnamed environment arg
+      code = code, ...
     )
-
-    .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-concat.R

@@ -32,10 +32,7 @@
 setGeneric("concat", function(x, y) standardGeneric("concat"))
 
 setMethod("concat", signature = c("qenv", "qenv"), function(x, y) {
-  y@id <- c(x@id, y@id)
   y@code <- c(x@code, y@code)
-  y@warnings <- c(x@warnings, y@warnings)
-  y@messages <- c(x@messages, y@messages)
 
   # insert (and overwrite) objects from y to x
   y@.xData <- rlang::env_clone(y@.xData, parent = parent.env(.GlobalEnv))

R/qenv-constructor.R

@@ -5,6 +5,10 @@
 #'
 #' Create a `qenv` object and evaluate code in it to track code history.
 #'
+#' @param names (`character`) for `x[names]`, names of objects included in `qenv` to subset. Names not present in `qenv`
+#' are skipped. For `get_code` `r lifecycle::badge("experimental")` vector of object names to return the code for.
+#' For more details see the "Extracting dataset-specific code" section.
+#'
 #' @details
 #'
 #' `qenv()` instantiates a `qenv` with an empty environment.

R/qenv-eval_code.R

@@ -28,24 +28,27 @@
 setGeneric("eval_code", function(object, code) standardGeneric("eval_code"))
 
 setMethod("eval_code", signature = c("qenv", "character"), function(object, code) {
-  id <- sample.int(.Machine$integer.max, size = 1)
-
-  object@id <- c(object@id, id)
+  parsed_code <- parse(text = code, keep.source = TRUE)
   object@.xData <- rlang::env_clone(object@.xData, parent = parent.env(.GlobalEnv))
-  code <- paste(code, collapse = "\n")
-  object@code <- c(object@code, code)
+  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))
+    return(object)
+  }
+  code_split <- split_code(paste(code, collapse = "\n"))
 
-  current_warnings <- ""
-  current_messages <- ""
+  for (i in seq_along(code_split)) {
+    current_code <- code_split[[i]]
+    current_call <- parse(text = current_code, keep.source = TRUE)
 
-  parsed_code <- parse(text = code, keep.source = TRUE)
-  for (single_call in parsed_code) {
     # Using withCallingHandlers to capture warnings and messages.
     # Using tryCatch to capture the error and abort further evaluation.
     x <- withCallingHandlers(
       tryCatch(
         {
-          eval(single_call, envir = object@.xData)
+          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)
@@ -58,30 +61,31 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code
             message = sprintf(
               "%s \n when evaluating qenv code:\n%s",
               .ansi_strip(conditionMessage(e)),
-              deparse1(single_call)
+              current_code
             ),
             class = c("qenv.error", "try-error", "simpleError"),
-            trace = object@code
+            trace = unlist(c(object@code, list(current_code)))
           )
         }
       ),
       warning = function(w) {
-        current_warnings <<- paste0(current_warnings, .ansi_strip(sprintf("> %s\n", conditionMessage(w))))
+        attr(current_code, "warning") <<- .ansi_strip(sprintf("> %s\n", conditionMessage(w)))
         invokeRestart("muffleWarning")
       },
       message = function(m) {
-        current_messages <<- paste0(current_messages, .ansi_strip(sprintf("> %s", conditionMessage(m))))
+        attr(current_code, "message") <<- .ansi_strip(sprintf("> %s", conditionMessage(m)))
         invokeRestart("muffleMessage")
       }
     )
 
     if (!is.null(x)) {
       return(x)
     }
-  }
 
-  object@warnings <- c(object@warnings, current_warnings)
-  object@messages <- c(object@messages, current_messages)
+    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))
+  }
 
   lockEnvironment(object@.xData, bindings = TRUE)
   object
@@ -92,7 +96,12 @@ setMethod("eval_code", signature = c("qenv", "language"), function(object, code)
 })
 
 setMethod("eval_code", signature = c("qenv", "expression"), function(object, code) {
-  eval_code(object, code = paste(vapply(lang2calls(code), deparse1, collapse = "\n", character(1L)), collapse = "\n"))
+  srcref <- attr(code, "wholeSrcref")
+  if (length(srcref)) {
+    eval_code(object, code = paste(attr(code, "wholeSrcref"), collapse = "\n"))
+  } else {
+    eval_code(object, code = paste(lang2calls(code), collapse = "\n"))
+  }
 })
 
 setMethod("eval_code", signature = c("qenv.error", "ANY"), function(object, code) {
@@ -108,3 +117,7 @@ setMethod("eval_code", signature = c("qenv.error", "ANY"), function(object, code
     chr
   }
 }
+
+get_code_attr <- function(qenv, attr) {
+  unlist(lapply(qenv@code, function(x) attr(x, attr)))
+}

R/qenv-extract.R

@@ -0,0 +1,52 @@
+#'
+#' @section Subsetting:
+#' `x[names]` subsets objects in `qenv` environment and limit the code to the necessary needed to build limited objects.
+#' `...` passes parameters to further methods.
+#'
+#' @param x (`qenv`)
+#'
+#' @examples
+#'
+#' # Subsetting
+#' q <- qenv()
+#' q <- eval_code(q, "a <- 1;b<-2")
+#' q["a"]
+#' q[c("a", "b")]
+#'
+#' @rdname qenv
+#'
+#' @export
+`[.qenv` <- function(x, names, ...) {
+  checkmate::assert_character(names, any.missing = FALSE)
+  possible_names <- ls(get_env(x), all.names = TRUE)
+  names_corrected <- intersect(names, possible_names)
+  env <- if (length(names_corrected)) {
+    names_missing <- setdiff(names, possible_names)
+    if (length(names_missing)) {
+      warning(
+        sprintf(
+          "Some 'names' do not exist in the environment of the '%s'. Skipping those: %s.",
+          class(x)[1],
+          paste(names_missing, collapse = ", ")
+        )
+      )
+    }
+    list2env(as.list(x, all.names = TRUE)[names_corrected], parent = parent.env(.GlobalEnv))
+  } else {
+    warning(
+      sprintf(
+        "None of 'names' exist in the environment of the '%1$s'. Returning empty '%1$s'.",
+        class(x)[1]
+      ),
+      call. = FALSE
+    )
+    new.env(parent = parent.env(.GlobalEnv))
+  }
+  lockEnvironment(env)
+  x@.xData <- env
+
+  normalized_names <- gsub("^`(.*)`$", "\\1", names)
+  x@code <- get_code_dependency(x@code, names = normalized_names, ...)
+
+  x
+}