optimise get_messages/get_warnings

fix pkgdown
fix NEWS

NEWS.md

@@ -2,10 +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`.
-* `eval_code(qenv, code)` analyzes code by single calls and returns `@id`, `@code`, `@messages`, `@warnings` fields of
-the length of calls included in `code`.
+`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
 
 # teal.code 0.5.0
 

R/qenv-get_messages.r

@@ -28,27 +28,7 @@ setGeneric("get_messages", function(object) {
 })
 
 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")
-  )
+  get_warn_message_util(object, "message")
 })
 
 setMethod("get_messages", signature = "qenv.error", function(object) {

R/qenv-get_warnings.R

@@ -28,27 +28,7 @@ setGeneric("get_warnings", function(object) {
 })
 
 setMethod("get_warnings", signature = "qenv", function(object) {
-  warnings <- lapply(object@code, "attr", "warning")
-  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) {
-      sprintf("%swhen running code:\n%s", warn, expr)
-    },
-    warn = warnings,
-    expr = code
-  )
-
-  sprintf(
-    "~~~ Warnings ~~~\n\n%s\n\n~~~ Trace ~~~\n\n%s",
-    paste(lines, collapse = "\n\n"),
-    paste(get_code(object), collapse = "\n")
-  )
+  get_warn_message_util(object, "warning")
 })
 
 setMethod("get_warnings", signature = "qenv.error", function(object) {

R/utils.R

@@ -53,3 +53,33 @@ lang2calls <- function(x) {
     unlist(lapply(x, lang2calls), recursive = FALSE)
   }
 }
+
+#' Obtain warnings or messages from code slot
+#'
+#' @param object (`qenv`)
+#' @param what (``
+get_warn_message_util <- function(object, what) {
+  checkmate::matchArg(what, choices = c("warning", "message"))
+  messages <- lapply(object@code, "attr", what)
+  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(
+    warn = messages,
+    expr = code,
+    function(warn, expr) {
+      sprintf("%swhen running code:\n%s", warn, expr)
+    }
+  )
+
+  sprintf(
+    "~~~ %ss ~~~\n\n%s\n\n~~~ Trace ~~~\n\n%s",
+    tools::toTitleCase(what),
+    paste(lines, collapse = "\n\n"),
+    paste(get_code(object), collapse = "\n")
+  )
+}

_pkgdown.yml

@@ -32,6 +32,7 @@ reference:
       - get_code
       - get_env
       - get_var
+      - get_messages
       - get_warnings
       - join
       - qenv

tests/testthat/test-qenv_eval_code.R

@@ -171,8 +171,6 @@ testthat::test_that(
   }
 )
 
-
-
 # comments --------------------------------------------------------------------------------------------------------
 
 testthat::test_that("comments fall into proper calls", {

tests/testthat/test-qenv_get_messages.R

@@ -3,7 +3,7 @@ testthat::test_that("get_messages accepts a qenv object and returns character",
   testthat::expect_identical(
     get_messages(q),
     paste0(
-      "~~~ messages ~~~\n\n> This is a message!\nwhen running code:\nmessage(\"This is a message!\")\n\n",
+      "~~~ Messages ~~~\n\n> This is a message!\nwhen running code:\nmessage(\"This is a message!\")\n\n",
       "~~~ Trace ~~~\n\nmessage(\"This is a message!\")"
     )
   )
@@ -30,7 +30,7 @@ testthat::test_that("get_messages accepts a qenv object with 2 messages", {
   testthat::expect_identical(
     get_messages(q),
     paste0(
-      "~~~ messages ~~~\n\n> This is a message 1!\nwhen running code:\nmessage(\"This is a message 1!\")",
+      "~~~ Messages ~~~\n\n> This is a message 1!\nwhen running code:\nmessage(\"This is a message 1!\")",
       "\n\n> This is a message 2!\nwhen running code:\nmessage(\"This is a message 2!\")\n\n",
       "~~~ Trace ~~~\n\nmessage(\"This is a message 1!\")\nmessage(\"This is a message 2!\")"
     )
@@ -46,7 +46,7 @@ testthat::test_that("get_messages accepts a qenv object with a single eval_code
     get_messages(q),
     paste(
       c(
-        "~~~ messages ~~~\n",
+        "~~~ Messages ~~~\n",
         "> This is a message 1!",
         "when running code:",
         "message(\"This is a message 1!\")\n\n",
@@ -69,7 +69,7 @@ testthat::test_that("get_messages accepts a qenv object with 1 message eval_code
   testthat::expect_identical(
     get_messages(q),
     paste0(
-      "~~~ messages ~~~\n\n> This is a message 2!\nwhen running code:\nmessage(\"This is a message 2!\")\n\n",
+      "~~~ Messages ~~~\n\n> This is a message 2!\nwhen running code:\nmessage(\"This is a message 2!\")\n\n",
       "~~~ Trace ~~~\n\nx <- 1\nmessage(\"This is a message 2!\")"
     )
   )