Add unit tests and standardize code style

Author: iofarm

R/cstr_foreign_key.R

@@ -21,14 +21,16 @@ cstr_foreign_key <- function(cols, reference) {
       ref_table_chr <- ".self"
       ref_table_obj <- .table
     } else {
-      if (is.null(attr(.table, "context"))) stop("'reference' refers to a separate
-      table, but no information on other tables in the dataset was found")
+      if (is.null(attr(.table, "context")))
+        stop("'reference' refers to a separate table, but no information on ",
+          "other tables in the dataset was found")
       ref_table_chr <- select_names(
         ref_table_quo,
         attr(.table, "context")
       )
-      if (length(ref_table_chr) != 1) stop("A foreign key must have a single
-      reference table, but ", length(ref_table_chr), " were selected")
+      if (length(ref_table_chr) != 1)
+        stop("A foreign key must have a single reference table, but ",
+          length(ref_table_chr), " were selected")
       ref_table_obj <- attr(.table, "context")[[ref_table_chr]]
     }
     ref_cols_chr <- select_names(ref_cols_quo, ref_table_obj)
@@ -48,13 +50,14 @@ cstr_foreign_key <- function(cols, reference) {
 #' @export
 validate_qf_constraint.cstr_foreign_key <- function(x, table) {
   ref_table_obj <- resolve_table_reference(table, x$ref_table)
-  if (is.null(ref_table_obj)) stop(pretty_class(x), " references a ",
-    "non-existent table: ", x$ref_table)
+  if (is.null(ref_table_obj))
+    stop(pretty_class(x), " references a non-existent table (",
+      x$ref_table, ")")
   references_unique_key <- purrr::some(constraints(ref_table_obj), \(cstr)
     inherits(cstr, "cstr_unique_key") && setequal(x$ref_cols, cstr$cols)
   )
-  if (!references_unique_key) stop(pretty_class(x), " does not reference a ",
-    "unique key")
+  if (!references_unique_key)
+    stop(pretty_class(x), " does not reference a unique key")
   NextMethod()
 }
 

R/qf_constraint.R

@@ -205,17 +205,17 @@ check_constraint_strict <- function(constraint, table) {
 #'
 #' @export
 exceptions <- function(x) {
-  if (!is_qf_constraint(x)) stop("'x' must be a <qf_constraint>, not ",
-    typeof(x))
+  if (!is_qf_constraint(x))
+    stop("'x' must be a <qf_constraint>, not ", typeof(x))
 
   attr(x, "exceptions")
 }
 
 #' @rdname exceptions
 #' @export
 `exceptions<-` <- function(x, value) {
-  if (!is_qf_constraint(x)) stop("'x' must be a <qf_constraint>, not ",
-    typeof(x))
+  if (!is_qf_constraint(x))
+    stop("'x' must be a <qf_constraint>, not ", typeof(x))
   exception_list <-
   if (is_qf_exception(value))
     list(value)

R/qf_dataset.R

@@ -12,13 +12,15 @@ new_qf_dataset <- function(x) {
 
 validate_qf_dataset <- function(x) {
   purrr::walk(x, \(table)
-    if (!is_qf_table(table)) stop("A <qf_dataset> must only contain ",
-      "<qf_table> objects")
+    if (!is_qf_table(table))
+      stop("A <qf_dataset> must only contain <qf_table> objects")
   )
   purrr::iwalk(x, \(table, name) tryCatch(
     validate_qf_table(table),
-    error = \(e) stop("Table ", name, " has invalid structure: \n",
-      e$message)
+    error = \(e) stop(
+      "Table ", name, " has invalid structure: \n",
+      e$message
+    )
   ))
   x
 }

R/qf_exception.R

@@ -46,9 +46,9 @@ except_where <- function(...) {
 excepted_rows <- function(exception, table) {
   conditions <- purrr::map(exception, rlang::eval_tidy, data = table)
   purrr::walk(conditions, \(cond)
-    if (!rlang::is_logical(cond, n = nrow(table))) stop("Each condition must ",
-      "evaluate to a logical vector of length ", nrow(table), ", not a ",
-      typeof(cond), " of length ", length(cond))
+    if (!rlang::is_logical(cond, n = nrow(table)))
+      stop("Each condition must evaluate to a logical vector of length ",
+        nrow(table), ", not a ", typeof(cond), " of length ", length(cond))
   )
   purrr::reduce(conditions, `&`)
 }

R/qf_table.R

@@ -151,9 +151,10 @@ constraints <- function(x) {
 #' @rdname constraints
 #' @export
 `constraints<-` <- function(x, value) {
-  if (!is_qf_table(x)) stop("'x' must be a qualifyr table, not ", typeof(x))
-  if (!rlang::is_list(value)) stop("'value' must be a list, not ",
-    typeof(value))
+  if (!is_qf_table(x))
+    stop("'x' must be a qualifyr table, not ", typeof(x))
+  if (!rlang::is_list(value))
+    stop("'value' must be a list, not ", typeof(value))
   attr(x, "constraints") <- purrr::modify(value, as_qf_constraint, table = x)
   validate_qf_table(x)
 }
@@ -201,10 +202,10 @@ constraint_index <- function(table, cols = NULL, class) {
       )
     }
   matches <- which(matching_class & matching_cols)
-  if (length(matches) == 0) stop(deparse(sys.call(-1)), " does not match any
-    constraints")
-  else if (length(matches) > 1) stop(deparse(sys.call(-1)), " is ambiguous,
-    i.e., matches multiple constraints")
+  if (length(matches) == 0)
+    stop(deparse(sys.call(-1)), " does not match any constraints")
+  else if (length(matches) > 1)
+    stop(deparse(sys.call(-1)), " is ambiguous (matches multiple constraints)")
   else matches
 }
 

R/utils.R

@@ -34,11 +34,11 @@ resolve_table_reference <- function(table, reference) {
   } else {
     # even though this is not an exported function, informative error messages
     # are given here so they do not need to be repeated everywhere that uses it
-    if (!is_qf_dataset(attr(table, "context"))) stop("Reference points to a ",
-      "separate table, but no information on other tables in the dataset was ",
-      "found")
-    if (!(reference %in% names(attr(table, "context")))) stop("Reference ",
-      "points to a non-existent table: ", reference)
+    if (!is_qf_dataset(attr(table, "context")))
+      stop("Reference points to a separate table, but no information on other ",
+        "tables in the dataset was found")
+    if (!(reference %in% names(attr(table, "context"))))
+      stop("Reference points to a non-existent table (", reference, ")")
     attr(table, "context")[[reference]]
   }
 }
@@ -54,7 +54,6 @@ resolve_table_reference <- function(table, reference) {
 #'
 #' @noRd
 pretty_class <- function(object) {
-  if (any(grepl("cnst", class(object)))) browser()
   paste0("<", class(object)[[1]], ">")
 }
 

tests/testthat/_snaps/qf_dataset.md

@@ -0,0 +1,48 @@
+# print() output is correct
+
+    <qf_dataset> with 3 tables: 
+     $ flights : <qf_table>
+     .. - Data: qf_table [336,776 x 19] (S3: qf_table/tbl_df/tbl/data.frame)
+     .. .. $ year          : int [1:336776] 2013 2013 2013 2013 2013 2013 2013 2013 2013 2013 ...
+     .. .. $ month         : int [1:336776] 1 1 1 1 1 1 1 1 1 1 ...
+     .. .. $ day           : int [1:336776] 1 1 1 1 1 1 1 1 1 1 ...
+     .. .. $ dep_time      : int [1:336776] 517 533 542 544 554 554 555 557 557 558 ...
+     .. .. $ sched_dep_time: int [1:336776] 515 529 540 545 600 558 600 600 600 600 ...
+     .. .. $ dep_delay     : num [1:336776] 2 4 2 -1 -6 -4 -5 -3 -3 -2 ...
+     .. .. $ arr_time      : int [1:336776] 830 850 923 1004 812 740 913 709 838 753 ...
+     .. .. $ sched_arr_time: int [1:336776] 819 830 850 1022 837 728 854 723 846 745 ...
+     .. .. $ arr_delay     : num [1:336776] 11 20 33 -18 -25 12 19 -14 -8 8 ...
+     .. .. $ carrier       : chr [1:336776] "UA" "UA" "AA" "B6" ...
+     .. .. $ flight        : int [1:336776] 1545 1714 1141 725 461 1696 507 5708 79 301 ...
+     .. .. $ tailnum       : chr [1:336776] "N14228" "N24211" "N619AA" "N804JB" ...
+     .. .. $ origin        : chr [1:336776] "EWR" "LGA" "JFK" "JFK" ...
+     .. .. $ dest          : chr [1:336776] "IAH" "IAH" "MIA" "BQN" ...
+     .. .. $ air_time      : num [1:336776] 227 227 160 183 116 150 158 53 140 138 ...
+     .. .. $ distance      : num [1:336776] 1400 1416 1089 1576 762 ...
+     .. .. $ hour          : num [1:336776] 5 5 5 5 6 5 6 6 6 6 ...
+     .. .. $ minute        : num [1:336776] 15 29 40 45 0 58 0 0 0 0 ...
+     .. .. $ time_hour     : POSIXct[1:336776], format: "2013-01-01 05:00:00" "2013-01-01 05:00:00" ...
+     .. - Constraints:
+     .. .. - <cstr_primary_key> [year, month, day, carrier, flight]
+     .. .. - <cstr_foreign_key> [carrier] => airlines[carrier]
+     $ planes  : <qf_table>
+     .. - Data: qf_table [3,322 x 9] (S3: qf_table/tbl_df/tbl/data.frame)
+     .. .. $ tailnum     : chr [1:3322] "N10156" "N102UW" "N103US" "N104UW" ...
+     .. .. $ year        : int [1:3322] 2004 1998 1999 1999 2002 1999 1999 1999 1999 1999 ...
+     .. .. $ type        : chr [1:3322] "Fixed wing multi engine" "Fixed wing multi engine" "Fixed wing multi engine" "Fixed wing multi engine" ...
+     .. .. $ manufacturer: chr [1:3322] "EMBRAER" "AIRBUS INDUSTRIE" "AIRBUS INDUSTRIE" "AIRBUS INDUSTRIE" ...
+     .. .. $ model       : chr [1:3322] "EMB-145XR" "A320-214" "A320-214" "A320-214" ...
+     .. .. $ engines     : int [1:3322] 2 2 2 2 2 2 2 2 2 2 ...
+     .. .. $ seats       : int [1:3322] 55 182 182 182 55 182 182 182 182 182 ...
+     .. .. $ speed       : int [1:3322] NA NA NA NA NA NA NA NA NA NA ...
+     .. .. $ engine      : chr [1:3322] "Turbo-fan" "Turbo-fan" "Turbo-fan" "Turbo-fan" ...
+     .. - Constraints:
+     .. .. - <cstr_primary_key> [tailnum]
+     $ airlines: <qf_table>
+     .. - Data: qf_table [16 x 2] (S3: qf_table/tbl_df/tbl/data.frame)
+     .. .. $ carrier: chr [1:16] "9E" "AA" "AS" "B6" ...
+     .. .. $ name   : chr [1:16] "Endeavor Air Inc." "American Airlines Inc." "Alaska Airlines Inc." "JetBlue Airways" ...
+     .. - Constraints:
+     .. .. - <cstr_primary_key> [carrier]
+     .. .. - <cstr_not_missing> [name]
+

tests/testthat/_snaps/qf_table.md

@@ -0,0 +1,17 @@
+# print() output is correct
+
+    <qf_table>
+     - Data: qf_table [3,322 x 9] (S3: qf_table/tbl_df/tbl/data.frame)
+     .. $ tailnum     : chr [1:3322] "N10156" "N102UW" "N103US" "N104UW" ...
+     .. $ year        : int [1:3322] 2004 1998 1999 1999 2002 1999 1999 1999 1999 1999 ...
+     .. $ type        : chr [1:3322] "Fixed wing multi engine" "Fixed wing multi engine" "Fixed wing multi engine" "Fixed wing multi engine" ...
+     .. $ manufacturer: chr [1:3322] "EMBRAER" "AIRBUS INDUSTRIE" "AIRBUS INDUSTRIE" "AIRBUS INDUSTRIE" ...
+     .. $ model       : chr [1:3322] "EMB-145XR" "A320-214" "A320-214" "A320-214" ...
+     .. $ engines     : int [1:3322] 2 2 2 2 2 2 2 2 2 2 ...
+     .. $ seats       : int [1:3322] 55 182 182 182 55 182 182 182 182 182 ...
+     .. $ speed       : int [1:3322] NA NA NA NA NA NA NA NA NA NA ...
+     .. $ engine      : chr [1:3322] "Turbo-fan" "Turbo-fan" "Turbo-fan" "Turbo-fan" ...
+     - Constraints:
+     .. - <cstr_primary_key> [tailnum]
+     - Context: <qf_dataset>: flights, planes, airlines
+

tests/testthat/helper.R

@@ -0,0 +1,21 @@
+example_dataset <- function(constrained = TRUE) {
+  dset <- qf_dataset(
+    flights  = nycflights13::flights,
+    planes   = nycflights13::planes,
+    airlines = nycflights13::airlines
+  )
+  if (constrained) {
+    constraints(dset$airlines) <- list(
+      cstr_primary_key(carrier),
+      cstr_not_missing(name)
+    )
+    constraints(dset$planes) <- list(
+      cstr_primary_key(tailnum)
+    )
+    constraints(dset$flights) <- list(
+      cstr_primary_key(c(year, month, day, carrier, flight)),
+      cstr_foreign_key(carrier, airlines)
+    )
+  }
+  dset
+}

tests/testthat/test-qf_constraint.R

@@ -1,8 +1,5 @@
 test_that("setting constraints works", {
-  dset <- qf_dataset(
-    flights = nycflights13::flights,
-    planes = nycflights13::planes
-  )
+  dset <- example_dataset(constrained = FALSE)
 
   constraints(dset$planes) <- list(
     cstr_primary_key(tailnum)
@@ -34,14 +31,48 @@ test_that("setting constraints works", {
       )
     )
   )
+
+  # Foreign key referencing own table:
+  enneagram <- as_qf_table(data.frame(
+    number         = c(1, 2, 3, 4, 5, 6, 7, 8, 9),
+    disintegration = c(4, 8, 9, 2, 7, 3, 1, 5, 6),
+    integration    = c(7, 4, 6, 1, 8, 9, 5, 2, 3)
+  ))
+  constraints(enneagram) <- list(
+    cstr_primary_key(number),
+    cstr_foreign_key(disintegration, .self$number),
+    cstr_foreign_key(integration, .self$number)
+  )
+  expect_identical(
+    constraints(enneagram),
+    list(
+      structure(
+        list(cols = "number"),
+        class = c("cstr_primary_key", "cstr_unique_key", "qf_constraint")
+      ),
+      structure(
+        list(cols = "disintegration", ref_table = ".self", ref_cols = "number"),
+        class = c("cstr_foreign_key", "qf_constraint")
+      ),
+      structure(
+        list(cols = "integration", ref_table = ".self", ref_cols = "number"),
+        class = c("cstr_foreign_key", "qf_constraint")
+      )
+    )
+  )
+  expect_error(regex = "no information on other tables in the dataset",  {
+    constraints(enneagram) <- list(
+      cstr_primary_key(number),
+      cstr_foreign_key(disintegration, .self$number),
+      cstr_foreign_key(integration, .self$number),
+      cstr_foreign_key(integration, some_other_table)
+    )
+  })
+
 })
 
 test_that("alternative reference specification formats are equivalent", {
-
-  dset <- qf_dataset(
-    flights = nycflights13::flights,
-    planes = nycflights13::planes
-  )
+  dset <- example_dataset(constrained = FALSE)
   constraints(dset$planes) <- list(cstr_primary_key(tailnum))
 
   dset1 <- dset
@@ -58,27 +89,13 @@ test_that("alternative reference specification formats are equivalent", {
   )
   expect_identical(constraints(dset1$flights), constraints(dset2$flights))
   expect_identical(constraints(dset2$flights), constraints(dset3$flights))
-
 })
 
 test_that("constraint checking works", {
-
-  dset <- withr::with_package("nycflights13",
-    qf_dataset(airlines, flights)
-  )
-
-  constraints(dset$airlines) <- list(
-    cstr_primary_key(carrier),
-    cstr_not_missing(name)
-  )
-  constraints(dset$flights) <- list(
-    cstr_primary_key(c(year, month, day, carrier, flight)),
-    cstr_foreign_key(carrier, airlines)
-  )
+  dset <- example_dataset()
 
   # 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)
@@ -88,22 +105,33 @@ test_that("constraint checking works", {
   # Case 2: Primary key and not-missing constraint on 'airlines' is invalid
   #   because of missing values for Delta Airlines; Foreign key on 'flights' is
   #   invalid because it references this primary key.
-
   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)
 
+  # Foreign key referencing own table:
+  enneagram <- as_qf_table(data.frame(
+    number         = c(1, 2, 3, 4, 5, 6, 7, 8, 9),
+    disintegration = c(4, 8, 9, 2, 7, 3, 1, 5, 6),
+    integration    = c(7, 4, 6, 1, 8, 9, 5, 2, 3)
+  ))
+  constraints(enneagram) <- list(
+    cstr_primary_key(number),
+    cstr_foreign_key(disintegration, .self$number),
+    cstr_foreign_key(integration, .self$number)
+  )
+  result9 <- check_constraints(enneagram)
+  expect_true(result9[[2]]$satisfied)
+  expect_true(result9[[3]]$satisfied)
+
 })
 
 test_that("constraint validators work", {
-  dset <- withr::with_package("nycflights13",
-    qf_dataset(airlines, flights)
-  )
+  dset <- example_dataset(constrained = FALSE)
 
   constraints(dset$airlines) <- list(
     cstr_not_missing(name)