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))
+
+})