prepare for 0.1.2

CRAN-SUBMISSION

@@ -1,3 +1,3 @@
-Version: 0.1.0
-Date: 2025-04-22 11:50:32 UTC
-SHA: 8f6cff765c5088e0f5c350edcac00f80e456a452
+Version: 0.1.1
+Date: 2025-05-08 12:27:18 UTC
+SHA: e103f495638785f96e5673ab3747e4e95f05ac26

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: schematic
 Title: Tidy Schema Validation for Data Frames
-Version: 0.1.1
+Version: 0.1.2
 Authors@R: person("Will", "Hipson", email = "will.e.hipson@gmail.com", role = c("aut", "cre", "cph"), comment = c(ORCID = "0000-0002-3931-2189"))
 Description: Validate data.frames against schemas to ensure that data matches expectations. Define schemas using 'tidyselect' and predicate functions for type consistency, nullability, and more. Schema failure messages can be tailored for non-technical users and are ideal for user-facing applications such as in 'shiny' or 'plumber'.  
 Maintainer: Will Hipson <will.e.hipson@gmail.com>

NAMESPACE

@@ -8,6 +8,7 @@ export(is_non_null)
 export(is_positive_integer)
 export(is_text)
 export(is_whole_number)
+export(last_check_errors)
 export(mod_infinitable)
 export(mod_nullable)
 export(schema)

NEWS.md

@@ -1,3 +1,13 @@
+# schematic 0.1.2
+
+### Minor changes
+
+- Check run time errors can be inspected using `last_check_errors()`.
+
+### Bug fixes
+
+- Predicates that produce errors are now distinguished between predicates that fail.
+
 # schematic 0.1.1
 
 ### Bug fixes

R/check_schema.R

@@ -21,24 +21,37 @@ check_schema <- function(data, schema) {
   pred_names <- ifelse(trimws(pred_names) == "", NA, pred_names)
 
   missing_cols_vec <- c()
-  invalid_preds_list <- list(
-    col = character(),
-    pred = character()
-  )
+  invalid_preds_list <- list()
+  errored_preds_list <- list()
+  check_errors <- list()
 
   withCallingHandlers(
     results <- purrr::map(schema, ~{
 
       selector <- rlang::f_lhs(.x)
       predicate_fm <- rlang::f_rhs(.x)
+      predicate_label <- rlang::as_label(predicate_fm)
+
+      # Initialize some containers
+      invalid_preds_list <<- append(
+        invalid_preds_list,
+        list(character()) |>
+          purrr::set_names(predicate_label)
+      )
+
+      errored_preds_list <<- append(
+        errored_preds_list,
+        list(character()) |>
+          purrr::set_names(predicate_label)
+      )
 
       tryCatch({
         predicate <- predicate_fm |>
           rlang::eval_tidy() |>
           rlang::as_function()
       }, error = function(e) {
         cli::cli_abort(
-          glue::glue("Error in predicate `{rlang::as_label(predicate_fm)}`"),
+          glue::glue("Error in predicate `{predicate_label}`"),
           call = rlang::caller_env(n = 7)
         )
       })
@@ -61,10 +74,15 @@ check_schema <- function(data, schema) {
       purrr::map(cols, ~{
         actual_class <- class(data[[.x]])
         result <- tryCatch({
-          check_pass <- predicate(data[[.x]])
+          check_pass <- tryCatch({
+            predicate(data[[.x]])
+          }, error = function(e) {
+            errored_preds_list[[predicate_label]] <<- c(errored_preds_list[[predicate_label]], .x)
+            check_errors <<- append(check_errors, purrr::set_names(e$message, predicate_label))
+            FALSE
+          })
           if (!is.logical(check_pass)) {
-            invalid_preds_list$col <<- c(invalid_preds_list$col, .x)
-            invalid_preds_list$pred <<- c(invalid_preds_list$pred, rlang::as_label(predicate_fm))
+            invalid_preds_list[[predicate_label]] <<- c(invalid_preds_list[[predicate_label]], .x)
             FALSE
           }
           stopifnot(check_pass)
@@ -76,7 +94,7 @@ check_schema <- function(data, schema) {
         data.frame(
           col = .x,
           class = actual_class,
-          predicate = rlang::as_label(predicate_fm)
+          predicate = predicate_label
         )
       }) |>
         purrr::list_rbind()
@@ -87,19 +105,57 @@ check_schema <- function(data, schema) {
     }
   )
 
+  schematic_pkgenv$check_errors <- check_errors
+
   fail_idx <- which(purrr::map_lgl(results, ~nrow(.x) > 0))
   pred_names <- pred_names[fail_idx]
 
   if (length(fail_idx) == 0 && length(missing_cols_vec) == 0) return(invisible())
 
   out_c <- c()
 
-  if (length(invalid_preds_list[[1]]) > 0) {
-    cols_ticked <- paste0("`", invalid_preds_list$col, "`")
-    plural_prefix <- glue::glue(cli::pluralize("Column{?s} {cols_ticked}"))
-    msg <- glue::glue("{plural_prefix} invalid predicate `{invalid_preds_list$pred[[1]]}`")
+  # Warn on errored predicates
+  errored_preds_list <- purrr::discard(errored_preds_list, ~length(.x) == 0)
+  if (length(errored_preds_list) > 0) {
+    out_err <- c()
+    purrr::iwalk(errored_preds_list, ~{
+      cols_ticked <- paste0("`", .x, "`")
+      plural_prefix <- glue::glue(cli::pluralize("column{?s} {cols_ticked}"))
+      msg <- glue::glue("`{.y}` on {plural_prefix}")
+      out_err <<- c(out_err, msg)
+    })
+    plural_pred <- ""
+    if (length(out_err) > 1) {
+      plural_pred <- "s"
+    }
+    cli::cli_warn(
+      c(
+        glue::glue("Error in predicate{plural_pred}:\n"),
+        paste("-", out_err),
+        "i" = "Run {.fn schematic::last_check_errors} to see where the error{plural_pred} occurred."
+      )
+    )
+  }
+
+  # Warn on invalid predicates (non TRUE/FALSE)
+  invalid_preds_list <- purrr::discard(invalid_preds_list, ~length(.x) == 0)
+  if (length(invalid_preds_list) > 0) {
+    out_inv <- c()
+    purrr::iwalk(invalid_preds_list, ~{
+      cols_ticked <- paste0("`", .x, "`")
+      plural_prefix <- glue::glue(cli::pluralize("column{?s} {cols_ticked}"))
+      msg <- glue::glue("`{.y}` on {plural_prefix}")
+      out_inv <<- c(out_inv, msg)
+    })
+    plural_pred <- ""
+    if (length(out_inv) > 1) {
+      plural_pred <- "s"
+    }
     cli::cli_warn(
-      c(msg, "i" = "All predicate functions must return a single TRUE/FALSE")
+      c(
+        glue::glue("Invalid predicate{plural_pred}:\n"), paste("-", out_inv),
+        "i" = "All predicate functions must return a single TRUE/FALSE"
+      )
     )
   }
 
@@ -119,7 +175,7 @@ check_schema <- function(data, schema) {
     out_c <<- c(out_c, msg)
   })
 
-  cli::cli_abort(c("Schema Error:\n", paste("-", out_c)))
+  cli::cli_abort(c("Schema Error:\n", paste("-", out_c)), call = NULL)
 
   invisible()
 }

R/last_check_errors.R

@@ -0,0 +1,13 @@
+#' Retrieve latest schematic run time errors
+#'
+#' Predicates that error will store the error messages internally and these
+#' can be accessed here.
+#'
+#' @return error messages
+#' @export
+#' @examples
+#'
+#' last_check_errors()
+last_check_errors <- function() {
+  schematic_pkgenv$check_errors
+}

R/zzz.R

@@ -0,0 +1,3 @@
+# Package environment for storing state
+# Currently used in error reporting scenarios like `last_check_errors`
+schematic_pkgenv <- new.env(parent = emptyenv())

_pkgdown.yml

@@ -18,3 +18,7 @@ reference:
   desc: Functions that modify predicates to make new predicates
   contents:
   - starts_with("mod_")
+- title: Other
+  desc: Mix bag of other functions
+  contents:
+  - last_check_errors

tests/testthat/_snaps/check_schema.md

@@ -0,0 +1,12 @@
+# rules with an error are handled
+
+    Code
+      last_check_errors()
+    Output
+      $stop
+      [1] "66468684466888888444488884448684"
+
+      $`~"a" + 3`
+      [1] "non-numeric argument to binary operator"
+
+

tests/testthat/test-check_schema.R

@@ -66,7 +66,8 @@ test_that("check_schema works with named args", {
 test_that("check_schema errors on non TRUE/FALSE check", {
   df <- mtcars
   sch <- schema(
-    c(cyl, am) ~ as.character
+    c(cyl, am) ~ as.character,
+    disp ~ as.numeric
   )
   expect_error(
     expect_warning(check_schema(df, sch), "All predicate")
@@ -93,6 +94,23 @@ test_that("rules with an error are handled", {
     ),
     regexp = "Error in predicate"
   )
+
+  sch <- schema(
+    cyl ~ stop,
+    am ~ ~"a" + 3
+  )
+
+  expect_error(
+    expect_warning(
+      check_schema(
+        mtcars,
+        sch
+      ),
+      regexp = "Error in predicate"
+    )
+  )
+
+  expect_snapshot(last_check_errors())
 })
 
 test_that("lots of columns in message are still reported", {