Merge pull request #543 from yjunechoe/agent-report-eval-text-fmt

Clean up evaluation error tooltips in agent report

NEWS.md

@@ -8,6 +8,8 @@
 
 - Warnings/errors arising from comparing `columns` to a `value` of different class (for example, comparing a datetime column to a date value `Sys.Date()` instead of another datetime value `Sys.time()`) are now signalled appropriately at `interrogate()`.
 
+- Improved readability of error and warning messages rendered as tooltip to the agent report.
+
 # pointblank 0.12.1
 
 - Ensured that the column string is a symbol before constructing the expression for the `col_vals_*()` functions.

R/get_agent_report.R

@@ -1329,6 +1329,16 @@ get_agent_report <- function(
       FUN.VALUE = character(1),
       USE.NAMES = FALSE,
       FUN = function(x) {
+
+        # Reformat error/warning to string
+        msg_error <- pointblank_cnd_to_string(
+          cnd = agent$validation_set$capture_stack[[x]]$error,
+          pb_call = agent$validation_set$capture_stack[[x]]$pb_call
+        )
+        msg_warning <- pointblank_cnd_to_string(
+          cnd = agent$validation_set$capture_stack[[x]]$warning,
+          pb_call = agent$validation_set$capture_stack[[x]]$pb_call
+        )
 
         if (is.na(eval[x])) {
 
@@ -1352,7 +1362,7 @@ get_agent_report <- function(
 
           text <- 
             htmltools::htmlEscape(
-              agent$validation_set$capture_stack[[x]]$error %>%
+              msg_error %>%
                 tidy_gsub("\"", "'")
             )
 
@@ -1378,7 +1388,7 @@ get_agent_report <- function(
 
           text <- 
             htmltools::htmlEscape(
-              agent$validation_set$capture_stack[[x]]$warning %>%
+              msg_warning %>%
                 tidy_gsub("\"", "'")
             )
 
@@ -1404,7 +1414,7 @@ get_agent_report <- function(
 
           text <-
             htmltools::htmlEscape(
-              agent$validation_set$capture_stack[[x]]$error %>%
+              msg_error %>%
                 tidy_gsub("\"", "'")
             )
 
@@ -2451,3 +2461,17 @@ store_footnote <- function(
     )
   )
 }
+
+# Function for formatting error in `$capture_stack`
+pointblank_cnd_to_string <- function(cnd, pb_call) {
+  if (is.null(cnd)) return(character(0))
+  # Reformatting not yet implemented for warnings 
+  if (rlang::is_warning(cnd)) return(cnd)
+  # Reconstruct trimmed down error and rethrow without cli
+  new <- rlang::error_cnd(
+    call = rlang::call2(":::", quote(pointblank), pb_call[1]),
+    message = cnd$parent$message %||% cnd$message,
+    use_cli_format = FALSE
+  )
+  as.character(try(rlang::cnd_signal(new), silent = TRUE))
+}

R/interrogate.R

@@ -2924,6 +2924,8 @@ column_validity_checks_ib_nb <- function(
 
 pointblank_try_catch <- function(expr) {
 
+  call <- rlang::enexpr(expr)
+
   warn <- err <- NULL
 
   value <- 
@@ -2936,7 +2938,7 @@ pointblank_try_catch <- function(expr) {
         invokeRestart("muffleWarning")
       })
 
-  eval_list <- list(value = value, warning = warn, error = err)
+  eval_list <- list(value = value, warning = warn, error = err, pb_call = call)
 
   class(eval_list) <- "table_eval"
   eval_list
@@ -2956,7 +2958,7 @@ add_reporting_data <- function(
   has_warnings <- !is.null(tbl_checked$warning)
   has_error <- !is.null(tbl_checked$error)
 
-  capture_stack <- tbl_checked[c("warning", "error")]
+  capture_stack <- tbl_checked[c("warning", "error", "pb_call")]
 
   agent$validation_set$eval_warning[idx] <- has_warnings
   agent$validation_set$eval_error[idx] <- has_error

tests/testthat/test-x_list.R

@@ -152,11 +152,11 @@ test_that("An x-list for a step is structurally correct", {
   expect_is(x_list_after$capture_stack, "list")
   expect_equal(
     length(x_list_after$capture_stack %>% unlist(recursive = FALSE)),
-    2
+    3
   )
   expect_equal(
     names(x_list_after$capture_stack %>% unlist(recursive = FALSE)),
-    c("warning", "error")
+    c("warning", "error", "pb_call")
   )
   expect_is(x_list_after$n, "numeric")
   expect_equal(x_list_after$n, 13)