Merge pull request #568 from yjunechoe/rollback-pb_call-tracking

Roll-back tracking full language objects for internal calls

R/create_agent.R

@@ -394,7 +394,7 @@
 #' ```r
 #' agent <-
 #'   agent %>% 
-#'   col_exists(columns = date, date_time) %>%
+#'   col_exists(columns = c(date, date_time)) %>%
 #'   col_vals_regex(
 #'     columns = b,
 #'     regex = "[0-9]-[a-z]{3}-[0-9]{3}"

R/get_agent_report.R

@@ -2473,7 +2473,7 @@ pointblank_cnd_to_string <- function(cnd, pb_call) {
   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]),
+    call = rlang::call2(":::", quote(pointblank), rlang::sym(pb_call)),
     message = cnd$parent$message %||% cnd$message,
     use_cli_format = FALSE
   )

R/interrogate.R

@@ -2940,6 +2940,11 @@ column_validity_checks_ib_nb <- function(
 pointblank_try_catch <- function(expr) {
 
   call <- rlang::enexpr(expr)
+  call_fn <- if (rlang::is_call_simple(call)) {
+    deparse(call[[1]]) # ex: "tbl_val_comparison"
+  } else {
+    "<internal>"
+  }
 
   warn <- err <- NULL
 
@@ -2953,7 +2958,8 @@ pointblank_try_catch <- function(expr) {
         invokeRestart("muffleWarning")
       })
 
-  eval_list <- list(value = value, warning = warn, error = err, pb_call = call)
+  eval_list <- list(value = value, warning = warn, error = err,
+                    pb_call = call_fn)
 
   class(eval_list) <- "table_eval"
   eval_list

tests/manual_tests/test_quarto_render.R

@@ -0,0 +1,16 @@
+# Ensure that rendering reports in Quarto do not produce `data-qmd` attributes
+# since the reports are not *data* tables
+
+quarto::quarto_render("tests/manual_tests/test_quarto_render.qmd")
+stopifnot(file.exists("tests/manual_tests/test_quarto_render.html"))
+utils::browseURL("tests/manual_tests/test_quarto_render.html")
+
+test_qmd <- xml2::read_html("tests/manual_tests/test_quarto_render.html")
+
+data_qmd_divs <- xml2::xml_find_all(test_qmd, "//div[@data-qmd]")
+data_qmd_divs
+
+stopifnot(length(data_qmd_divs) == 0)
+
+unlink("tests/manual_tests/test_quarto_render.html")
+unlink("tests/manual_tests/test_quarto_render_files/*", recursive = TRUE)

tests/manual_tests/tests_agent_serialization_size.R

@@ -0,0 +1,30 @@
+# Setup
+library(pointblank)
+agent <- create_agent(data.frame(x = 1)) |> 
+  col_vals_equal(x, 1) |> 
+  interrogate()
+show_size <- function(x) {
+  size <- if (is.character(x) && file.exists(x)) file.size(x) else object.size(x)
+  scales::label_bytes()(as.integer(size))
+}
+
+# Assign something large to env
+largeobj <- replicate(100, mtcars[sample(nrow(mtcars), 1e4, replace = TRUE),])
+show_size(largeobj)
+
+# Serialize
+f <- tempfile(fileext = ".rds")
+saveRDS(agent, f)
+
+# Should be equivalent
+stopifnot(identical(agent, readRDS(f)))
+
+# File size check
+show_size(agent)
+show_size(f)
+
+# Should be uninfluenced by size of objects in env
+stopifnot(file.size(f) < as.integer(object.size(largeobj)))
+
+# Cleanup
+file.remove(f)

tests/testthat/test-get_agent_report.R

@@ -302,3 +302,19 @@ test_that("col_vals_expr() shows used columns", {
   expect_equal(report_columns[4], "a")
 
 })
+
+test_that("report shows informative error tooltips", {
+
+  df <- data.frame(date = "invalid date")
+  agent <- create_agent(df) |> 
+    col_vals_equal(date, Sys.Date()) |> 
+    interrogate(progress = TRUE)
+  report <- get_agent_report(agent)
+
+  error_source <- agent$validation_set$capture_stack[[1]]$pb_call
+  error_tooltip <- report$`_data`$eval_sym
+
+  expect_equal(error_source, "tbl_val_comparison")
+  expect_true(grepl(error_source, error_tooltip))
+
+})