Simplify structure and interface of constraint check results objects

Author: iofarm

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: qualifyr
 Type: Package
 Title: Validate Relational Data Structures
-Version: 0.1.0.9002
+Version: 0.1.0.9003
 Authors@R: c(
     person(
       "Ian", "Farm",

NAMESPACE

@@ -10,6 +10,7 @@ S3method("[[",qf_dataset)
 S3method("[[<-",qf_dataset)
 S3method("|",qf_exception)
 S3method("|",qf_exception_list)
+S3method(as.logical,qf_check)
 S3method(as_qf_constraint,qf_constraint)
 S3method(as_qf_constraint,qf_constraint_specifier)
 S3method(as_qf_constraint_list,list)
@@ -25,11 +26,11 @@ S3method(check_constraint_strict,cstr_unique_key)
 S3method(check_constraints,qf_dataset)
 S3method(check_constraints,qf_table)
 S3method(print,cstr_foreign_key)
+S3method(print,qf_check)
+S3method(print,qf_check_dataset)
+S3method(print,qf_check_table)
 S3method(print,qf_constraint)
 S3method(print,qf_dataset)
-S3method(print,qf_report_check)
-S3method(print,qf_report_check_dataset)
-S3method(print,qf_report_check_table)
 S3method(print,qf_table)
 S3method(utils::str,qf_dataset)
 S3method(utils::str,qf_table)
@@ -58,8 +59,10 @@ export(get_foreign_key)
 export(get_not_missing)
 export(get_primary_key)
 export(get_unique_key)
+export(handled)
 export(is_qf_constraint)
 export(is_qf_dataset)
 export(is_qf_exception)
 export(is_qf_table)
 export(qf_dataset)
+export(satisfied)

R/qf_check.R

@@ -0,0 +1,111 @@
+# Class definition =============================================================
+
+new_qf_check <- function(x, subclass, satisfied, handled, ...) {
+  structure(
+    x,
+    class = c(subclass, "qf_check"),
+    satisfied = satisfied, handled = handled,
+    ...
+  )
+}
+
+
+
+# Accessors ====================================================================
+
+#' Inspect constraint check results
+#'
+#' Functions to access attributes of constraint check results
+#'
+#' @param x An object returned by [`check_constraints()`], i.e., a `<qf_check`>
+#'   object
+#' @param ... Not used
+#'
+#' @returns Logical; for `satisfied()`, whether all constraints were satisfied,
+#'   and for `handled()`, whether all constraints were either satisfied or
+#'   excepted. `as.logical(x)` is equivalent to `handled(x)`.
+#'
+#' @name inspect_results
+NULL
+
+
+#' @rdname inspect_results
+#' @export
+satisfied <- function(x) {
+  attr(x, "satisfied")
+}
+#' @rdname inspect_results
+#' @export
+handled <- function(x) {
+  attr(x, "handled")
+}
+#' @rdname inspect_results
+#' @export
+as.logical.qf_check <- function(x, ...) {
+  handled(x)
+}
+
+
+
+# Pretty printing ==============================================================
+
+#' @noRd
+#' @export
+print.qf_check <- function(x, max_width = getOption("width"), ...) {
+  print(attr(x, "constraint"))
+  if (satisfied(x)) {
+    cat("   All rows satisfied")
+  } else if (handled(x)) {
+    cat("   All rows satisfied or excepted")
+  } else {
+    message <- "   Violating rows: "
+    indices <- format_indices(
+      which(!x$handled),
+      max_width - nchar(message)
+    )
+    cat0(message, indices)
+  }
+  cat("\n")
+  invisible(x)
+}
+
+#' @noRd
+#' @export
+print.qf_check_table <- function(x, ...) {
+  check_header(x)
+  for (cstr in x) print(cstr)
+  invisible(x)
+}
+
+#' @noRd
+#' @export
+print.qf_check_dataset <- function(x, ...) {
+  check_header(unlist(x, recursive = FALSE))
+  indent <- "   "
+  for (i in 1:length(x)) {
+    if (!purrr::every(x[[i]], handled)) {
+      cat0("=> In table '", names(x)[[i]], "':\n")
+      for (j in 1:length(x[[i]])) {
+        if (!handled(x[[i]][[j]])) {
+          constraint_check_text <- utils::capture.output({
+            cat0("[[", j, "]] ")
+            print(x[[i]][[j]], max_width = getOption("width") - nchar(indent))
+          })
+          cat(paste0(indent, constraint_check_text), sep = "\n")
+        }
+      }
+    }
+  }
+}
+
+check_header <- function(x) {
+  satisfied <- purrr::map_lgl(x, satisfied)
+  handled <- purrr::map_lgl(x, handled)
+  n_satisfied <- sum(satisfied)
+  n_excepted <- sum(handled) - sum(satisfied)
+  n_violated <- length(x) - sum(handled)
+  cat("Constraint check report:", n_satisfied, "satisfied", "/", n_excepted,
+    "excepted", "/", n_violated, "violated:", "\n")
+}
+
+

R/qf_constraint.R

@@ -246,24 +246,23 @@ apply_to_each <- function(.cstr, ..., .args = list()) {
 #' @param constraint A `<qf_constraint>` object
 #' @param table The table to which the constraint is applied
 #'
-#' @returns A list; see `check_constraints` for details.
+#' @returns A `<qf_check_constraint/qf_check>` object
 #'
 #' @noRd
 check_constraint <- function(constraint, table) {
-  satisfied_rows <- check_constraint_strict(constraint, table)
-  excepted_rows <- attr(constraint, "exceptions") |>
+  results <- data.frame(row.names = seq_len(nrow(table)))
+  results$satisfied <- check_constraint_strict(constraint, table)
+  results$excepted <- attr(constraint, "exceptions") |>
     purrr::map(excepted_rows, table = table) |>
     purrr::reduce(`|`, .init = rep(FALSE, nrow(table)))
-  handled_rows <- satisfied_rows | excepted_rows
-  structure(list(
-    satisfied = all(satisfied_rows),
-    handled = all(handled_rows),
-    rows = list(
-      satisfied = satisfied_rows,
-      excepted = excepted_rows,
-      handled = handled_rows
-    )
-  ), class = "qf_report_check", constraint = constraint)
+  results$handled <- results$satisfied | results$excepted
+  new_qf_check(
+    results,
+    satisfied = all(results$satisfied),
+    handled = all(results$handled),
+    constraint = constraint,
+    subclass = "qf_check_constraint"
+  )
 }
 
 #' Check that a constraint is satisfied, ignoring exceptions
@@ -279,69 +278,6 @@ check_constraint_strict <- function(constraint, table) {
   UseMethod("check_constraint_strict")
 }
 
-#' @noRd
-#' @export
-print.qf_report_check <- function(x, max_width = getOption("width"), ...) {
-  print(attr(x, "constraint"))
-  if (x$satisfied) {
-    cat("   All rows satisfied")
-  } else if (x$handled) {
-    cat("   All rows satisfied or excepted")
-  } else {
-    message <- "   Violating rows: "
-    indices <- format_indices(
-      which(!x$rows$handled),
-      max_width - nchar(message)
-    )
-    cat0(message, indices)
-  }
-  cat("\n")
-  invisible(x)
-}
-
-#' @noRd
-#' @export
-print.qf_report_check_table <- function(x, ...) {
-  report_check_header(x)
-  for (cstr in x) print(cstr)
-  invisible(x)
-}
-
-#' @noRd
-#' @export
-print.qf_report_check_dataset <- function(x, ...) {
-  report_check_header(unlist(x, recursive = FALSE))
-  indent <- "   "
-  for (i in 1:length(x)) {
-    if (any(vapply(x[[i]], \(el) !el$handled, logical(1)))) {
-      cat0("=> In table '", names(x)[[i]], "':\n")
-      for (j in 1:length(x[[i]])) {
-        if (!x[[i]][[j]]$handled) {
-          report_check_constraint <- utils::capture.output({
-            cat0("[[", j, "]] ")
-            print(x[[i]][[j]], max_width = getOption("width") - nchar(indent))
-          })
-          cat(paste0(indent, report_check_constraint), sep = "\n")
-        }
-      }
-    }
-  }
-}
-
-report_check_header <- function(x) {
-  satisfied <- purrr::map_lgl(x, "satisfied")
-  handled <- purrr::map_lgl(x, "handled")
-  n_satisfied <- sum(satisfied)
-  n_excepted <- sum(handled) - sum(satisfied)
-  n_violated <- length(x) - sum(handled)
-  cat("Constraint check report:", n_satisfied, "satisfied", "/", n_excepted,
-    "excepted", "/", n_violated, "violated:", "\n")
-}
-
-
-
-# Exception handling ===========================================================
-
 #' Get or set the exceptions of a constraint
 #'
 #' @param x A constraint object

R/qf_dataset.R

@@ -61,9 +61,12 @@ is_qf_dataset <- function(x) {
 #' @rdname check_constraints
 #' @export
 check_constraints.qf_dataset <- function(x) {
-  structure(
-    purrr::map(x, check_constraints),
-    class = "qf_report_check_dataset"
+  table_checks <- purrr::map(x, check_constraints)
+  new_qf_check(
+    table_checks,
+    subclass = "qf_check_dataset",
+    satisfied = purrr::every(table_checks, satisfied),
+    handled = purrr::every(table_checks, handled)
   )
 }
 

R/qf_table.R

@@ -63,9 +63,12 @@ is_qf_table <- function(x) {
 #' @rdname check_constraints
 #' @export
 check_constraints.qf_table <- function(x) {
-  structure(
-    purrr::map(constraints(x), check_constraint, x),
-    class = "qf_report_check_table"
+  constraint_checks <- purrr::map(constraints(x), check_constraint, x)
+  new_qf_check(
+    constraint_checks,
+    subclass = "qf_check_table",
+    satisfied = purrr::every(constraint_checks, satisfied),
+    handled = purrr::every(constraint_checks, satisfied)
   )
 }
 

man/inspect_results.Rd

@@ -94,10 +94,10 @@ test_that("constraint checking works", {
   # Case 1: Primary key on 'flights' is invalid because of duplicate keys;
   #   otherwise OK
   result <- check_constraints(dset)
-  expect_true(result$airlines[[1]]$satisfied)
-  expect_true(result$airlines[[2]]$satisfied)
-  expect_false(result$flights[[1]]$satisfied)
-  expect_true(result$flights[[2]]$satisfied)
+  expect_true(satisfied(result$airlines[[1]]))
+  expect_true(satisfied(result$airlines[[2]]))
+  expect_false(satisfied(result$flights[[1]]))
+  expect_true(satisfied(result$flights[[2]]))
 
   expect_snapshot_output(print(result))
 
@@ -107,10 +107,10 @@ test_that("constraint checking works", {
   dset2 <- dset
   dset2$airlines[dset$airlines$carrier == "DL", ] <- NA
   result2 <- check_constraints(dset2)
-  expect_false(result2$airlines[[1]]$satisfied)
-  expect_false(result2$airlines[[2]]$satisfied)
-  expect_false(result2$flights[[1]]$satisfied)
-  expect_false(result2$flights[[2]]$satisfied)
+  expect_false(satisfied(result2$airlines[[1]]))
+  expect_false(satisfied(result2$airlines[[2]]))
+  expect_false(satisfied(result2$flights[[1]]))
+  expect_false(satisfied(result2$flights[[2]]))
 
   # Foreign key referencing own table:
   enneagram <- as_qf_table(data.frame(
@@ -124,8 +124,8 @@ test_that("constraint checking works", {
     cstr_foreign_key(integration, .self$number)
   )
   result9 <- check_constraints(enneagram)
-  expect_true(result9[[2]]$satisfied)
-  expect_true(result9[[3]]$satisfied)
+  expect_true(satisfied(result9[[2]]))
+  expect_true(satisfied(result9[[3]]))
 
 })
 

tests/testthat/test-qf_constraint.R

@@ -4,6 +4,6 @@ test_that("exceptions work", {
     except_where(carrier %in% "WN", flight %in% 2269) |
     except_where(carrier %in% "UA", flight %in% c(207, 236, 258, 635))
   result <- check_constraints(dset)$flights[[1]]
-  expect_false(result$satisfied)
-  expect_true(result$handled)
+  expect_false(satisfied(result))
+  expect_true(handled(result))
 })