fixes #217

Author: gogonzo

DESCRIPTION

@@ -61,6 +61,7 @@ Collate:
     '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

@@ -9,6 +9,7 @@ export(dev_suppress)
 export(eval_code)
 export(get_code)
 export(get_env)
+export(get_messages)
 export(get_var)
 export(get_warnings)
 export(join)

R/qenv-get_code.R

@@ -9,8 +9,8 @@
 #'
 #'
 #' @section Extracting dataset-specific code:
-#' When `names` for `get_code` is specified, the code returned will be limited  to the lines needed to _create_
-#' the requested objects. The code stored in the `@code` slot is analyzed statically to determine
+#' When `names` for `get_code` is specified, the code returned will be limited to the lines needed to _create_
+#' the requested objects. The code stored in the `qenv` is analyzed statically to determine
 #' which lines the objects of interest depend upon. The analysis works well when objects are created
 #' with standard infix assignment operators (see `?assignOps`) but it can fail in some situations.
 #'
@@ -74,7 +74,7 @@
 #' - creating and evaluating language objects, _e.g._ `eval(<call>)`
 #'
 #' @return
-#' `get_code` returns the traced code (from `@code` slot) in the form specified by `deparse`.
+#' `get_code` returns the traced code in the form specified by `deparse`.
 #'
 #' @examples
 #' # retrieve code
@@ -97,12 +97,7 @@
 #'
 #' @export
 setGeneric("get_code", function(object, deparse = TRUE, names = NULL, ...) {
-  # this line forces evaluation of object before passing to the generic
-  # needed for error handling to work properly
-  grDevices::pdf(nullfile())
-  on.exit(grDevices::dev.off())
-  object
-
+  dev_suppress(object)
   standardGeneric("get_code")
 })
 

R/qenv-get_env.R

@@ -1,10 +1,10 @@
 #' Access environment included in `qenv`
 #'
-#' The access of environment included in `qenv@env` allows to e.g. list object names included in `qenv@env` slot.
+#' The access of environment included in the `qenv` that contains all data objects.
 #'
-#' @param object (`qenv`)
+#' @param object (`qenv`).
 #'
-#' @return An `environment` stored in `qenv@env` slot.
+#' @return An `environment` stored in `qenv` with all data objects.
 #'
 #' @examples
 #' q <- qenv()

R/qenv-get_messages.r

@@ -0,0 +1,60 @@
+#' Get messages from `qenv` object
+#'
+#' Retrieve all messages raised during code evaluation in a `qenv`.
+#'
+#' @param object (`qenv`)
+#'
+#' @return `character` containing warning information or `NULL` if no messages.
+#'
+#' @examples
+#' data_q <- qenv()
+#' data_q <- eval_code(data_q, "iris_data <- iris")
+#' warning_qenv <- eval_code(
+#'   data_q,
+#'   bquote(p <- hist(iris_data[, .("Sepal.Length")], ff = ""))
+#' )
+#' cat(get_messages(warning_qenv))
+#'
+#' @name get_messages
+#' @rdname get_messages
+#' @aliases get_messages,qenv-method
+#' @aliases get_messages,qenv.error-method
+#' @aliases get_messages,NULL-method
+#'
+#' @export
+setGeneric("get_messages", function(object) {
+  dev_suppress(object)
+  standardGeneric("get_messages")
+})
+
+setMethod("get_messages", signature = "qenv", function(object) {
+  messages <- lapply(object@code, "attr", "message")
+  idx_warn <- which(sapply(messages, function(x) !is.null(x) && !identical(x, "")))
+  if (!any(idx_warn)) {
+    return(NULL)
+  }
+  messages <- messages[idx_warn]
+  code <- object@code[idx_warn]
+
+  lines <- mapply(
+    function(warn, expr) {
+      sprintf("%swhen running code:\n%s", warn, expr)
+    },
+    warn = messages,
+    expr = code
+  )
+
+  sprintf(
+    "~~~ messages ~~~\n\n%s\n\n~~~ Trace ~~~\n\n%s",
+    paste(lines, collapse = "\n\n"),
+    paste(get_code(object), collapse = "\n")
+  )
+})
+
+setMethod("get_messages", signature = "qenv.error", function(object) {
+  NULL
+})
+
+setMethod("get_messages", "NULL", function(object) {
+  NULL
+})

R/qenv-get_var.R

@@ -21,8 +21,7 @@
 #'
 #' @export
 setGeneric("get_var", function(object, var) {
-  grDevices::pdf(nullfile())
-  on.exit(grDevices::dev.off())
+  dev_suppress(object)
   standardGeneric("get_var")
 })
 

R/qenv-get_warnings.R

@@ -23,43 +23,35 @@
 #'
 #' @export
 setGeneric("get_warnings", function(object) {
-  # this line forces evaluation of object before passing to the generic
-  # needed for error handling to work properly
-  grDevices::pdf(nullfile())
-  on.exit(grDevices::dev.off())
-  object
-
+  dev_suppress(object)
   standardGeneric("get_warnings")
 })
 
-setMethod("get_warnings", signature = c("qenv"), function(object) {
+setMethod("get_warnings", signature = "qenv", function(object) {
   warnings <- lapply(object@code, "attr", "warning")
-  idx_warn <- which(sapply(warnings, Negate(is.null)))
-  warnings <- warnings[idx_warn]
-  code <- object@code[idx_warn]
-  if (length(warnings) == 0) {
+  idx_warn <- which(sapply(warnings, function(x) !is.null(x) && !identical(x, "")))
+  if (!any(idx_warn)) {
     return(NULL)
   }
+  warnings <- warnings[idx_warn]
+  code <- object@code[idx_warn]
 
   lines <- mapply(
     function(warn, expr) {
-      if (warn == "") {
-        return(NULL)
-      }
-      sprintf("%swhen running code:\n%s", warn, paste(lang2calls(expr), collapse = "\n"))
+      sprintf("%swhen running code:\n%s", warn, expr)
     },
     warn = warnings,
     expr = code
   )
-  lines <- Filter(Negate(is.null), lines)
 
-  paste0(
-    sprintf("~~~ Warnings ~~~\n\n%s\n\n", paste(lines, collapse = "\n\n")),
-    sprintf("~~~ Trace ~~~\n\n%s", paste(get_code(object), collapse = "\n"))
+  sprintf(
+    "~~~ Warnings ~~~\n\n%s\n\n~~~ Trace ~~~\n\n%s",
+    paste(lines, collapse = "\n\n"),
+    paste(get_code(object), collapse = "\n")
   )
 })
 
-setMethod("get_warnings", signature = c("qenv.error"), function(object) {
+setMethod("get_warnings", signature = "qenv.error", function(object) {
   NULL
 })
 

R/qenv-join.R

@@ -21,8 +21,8 @@
 #'    In this example, `mtcars1` object exists in both `x` and `y` objects but the content are not identical.
 #'    `mtcars1` in the `x qenv` object has more columns than `mtcars1` in the `y qenv` object (only has one column).
 #'
-#' 2. `join()` will look for identical `@id` values in both `qenv` objects.
-#'    The index position of these `@id`s must be the same to determine the evaluation order.
+#' 2. `join()` will look for identical code elements in both `qenv` objects.
+#'    The index position of these code elements must be the same to determine the evaluation order.
 #'    Otherwise, `join()` will throw an error message.
 #'
 #'    Example:
@@ -45,11 +45,8 @@
 #'    # Error message will occur
 #'
 #'    # Check the order of evaluation based on the id slot
-#'    shared_ids <- intersect(q@id, z@id)
-#'    match(shared_ids, q@id) # Output: 1 3
-#'    match(shared_ids, z@id) # Output: 1 2
 #'    ```
-#'    The error occurs because the index position of identical `@id` between the two objects is not the same.
+#'    The error occurs because the index position of common code elements in the two objects is not the same.
 #'
 #' 3. The usage of temporary variable in the code expression could cause `join()` to fail.
 #'
@@ -72,10 +69,6 @@
 #'    )
 #'    q <- join(x,y)
 #'    # Error message will occur
-#'
-#'    # Check the value of temporary variable i in both objects
-#'    x@env$i # Output: 2
-#'    y@env$i # Output: 3
 #'    ```
 #'    `join()` fails to provide a proper result because of the temporary variable `i` exists
 #'    in both objects but has different value.

R/utils-get_code_dependency.R

@@ -29,10 +29,6 @@ get_code_dependency <- function(code, names, check_names = TRUE) {
   checkmate::assert_list(code, "character")
   checkmate::assert_character(names, any.missing = FALSE)
 
-  if (length(code) == 0) {
-    return(code)
-  }
-
   graph <- lapply(code, attr, "dependency")
 
   if (check_names) {
@@ -46,6 +42,10 @@ get_code_dependency <- function(code, names, check_names = TRUE) {
     }
   }
 
+  if (length(code) == 0) {
+    return(code)
+  }
+
   ind <- unlist(lapply(names, function(x) graph_parser(x, graph)))
 
   lib_ind <- detect_libraries(graph)