Skip to content

Commit 0237082

Browse files
iofarmiofarm
committed
Improve interface
1 parent 6d13994 commit 0237082

16 files changed

Lines changed: 381 additions & 115 deletions

‎NAMESPACE‎

Lines changed: 23 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -2,19 +2,34 @@
22

33
S3method("$",qf_dataset)
44
S3method("$<-",qf_dataset)
5+
S3method("&",qf_constraint)
6+
S3method("&",qf_constraint_list)
57
S3method("[",qf_dataset)
68
S3method("[<-",qf_dataset)
79
S3method("[[",qf_dataset)
810
S3method("[[<-",qf_dataset)
11+
S3method("|",qf_exception)
12+
S3method("|",qf_exception_list)
913
S3method(as_qf_constraint,qf_constraint)
1014
S3method(as_qf_constraint,qf_constraint_specifier)
15+
S3method(as_qf_constraint_list,list)
16+
S3method(as_qf_constraint_list,qf_constraint)
17+
S3method(as_qf_constraint_list,qf_constraint_list)
18+
S3method(as_qf_exception_list,list)
19+
S3method(as_qf_exception_list,qf_exception)
20+
S3method(as_qf_exception_list,qf_exception_list)
1121
S3method(check_constraint_strict,cstr_foreign_key)
1222
S3method(check_constraint_strict,cstr_not_missing)
1323
S3method(check_constraint_strict,cstr_primary_key)
1424
S3method(check_constraint_strict,cstr_unique_key)
1525
S3method(check_constraints,qf_dataset)
1626
S3method(check_constraints,qf_table)
27+
S3method(print,cstr_foreign_key)
28+
S3method(print,qf_constraint)
1729
S3method(print,qf_dataset)
30+
S3method(print,qf_report_check)
31+
S3method(print,qf_report_check_dataset)
32+
S3method(print,qf_report_check_table)
1833
S3method(print,qf_table)
1934
S3method(utils::str,qf_dataset)
2035
S3method(utils::str,qf_table)
@@ -25,10 +40,10 @@ S3method(validate_qf_constraint,cstr_unique_key)
2540
S3method(validate_qf_constraint,qf_constraint)
2641
export("constraints<-")
2742
export("exceptions<-")
28-
export("foreign_key<-")
29-
export("not_missing<-")
30-
export("primary_key<-")
31-
export("unique_key<-")
43+
export("get_foreign_key<-")
44+
export("get_not_missing<-")
45+
export("get_primary_key<-")
46+
export("get_unique_key<-")
3247
export(as_qf_table)
3348
export(check_constraints)
3449
export(constraints)
@@ -38,12 +53,12 @@ export(cstr_primary_key)
3853
export(cstr_unique_key)
3954
export(except_where)
4055
export(exceptions)
41-
export(foreign_key)
56+
export(get_foreign_key)
57+
export(get_not_missing)
58+
export(get_primary_key)
59+
export(get_unique_key)
4260
export(is_qf_constraint)
4361
export(is_qf_dataset)
4462
export(is_qf_exception)
4563
export(is_qf_table)
46-
export(not_missing)
47-
export(primary_key)
4864
export(qf_dataset)
49-
export(unique_key)

‎R/cstr_foreign_key.R‎

Lines changed: 14 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -77,16 +77,26 @@ check_constraint_strict.cstr_foreign_key <- function(constraint, table) {
7777
result
7878
}
7979

80-
#' @rdname pick_constraint
80+
#' @rdname get_constraint
8181
#' @order 3
8282
#' @export
83-
foreign_key <- function(table, cols = NULL) {
83+
get_foreign_key <- function(table, cols = NULL) {
8484
constraint(table, {{ cols }}, "cstr_foreign_key")
8585
}
86-
#' @rdname pick_constraint
86+
#' @rdname get_constraint
8787
#' @order 13
8888
#' @export
89-
`foreign_key<-` <- function(table, cols = NULL, value) {
89+
`get_foreign_key<-` <- function(table, cols = NULL, value) {
9090
constraint(table, {{ cols }}, "cstr_foreign_key") <- value
9191
table
9292
}
93+
94+
#' @noRd
95+
#' @export
96+
print.cstr_foreign_key <- function(x, ...) {
97+
base <- utils::capture.output(NextMethod())
98+
ref_col_names <- paste(x$ref_cols, collapse = ", ")
99+
cat0(base, " => ", x$ref_table, "[", ref_col_names, "]")
100+
cat("\n")
101+
invisible(x)
102+
}

‎R/cstr_not_missing.R‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -27,16 +27,16 @@ check_constraint_strict.cstr_not_missing <- function(constraint, table) {
2727
result
2828
}
2929

30-
#' @rdname pick_constraint
30+
#' @rdname get_constraint
3131
#' @order 4
3232
#' @export
33-
not_missing <- function(table, cols = NULL) {
33+
get_not_missing <- function(table, cols = NULL) {
3434
constraint(table, {{ cols }}, "cstr_not_missing")
3535
}
36-
#' @rdname pick_constraint
36+
#' @rdname get_constraint
3737
#' @order 14
3838
#' @export
39-
`not_missing<-` <- function(table, cols = NULL, value) {
39+
`get_not_missing<-` <- function(table, cols = NULL, value) {
4040
constraint(table, {{ cols }}, "cstr_not_missing") <- value
4141
table
4242
}

‎R/cstr_primary_key.R‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -30,16 +30,16 @@ check_constraint_strict.cstr_primary_key <- function(constraint, table) {
3030
result
3131
}
3232

33-
#' @rdname pick_constraint
33+
#' @rdname get_constraint
3434
#' @order 2
3535
#' @export
36-
primary_key <- function(table, cols = NULL) {
36+
get_primary_key <- function(table, cols = NULL) {
3737
constraint(table, {{ cols }}, "cstr_primary_key")
3838
}
39-
#' @rdname pick_constraint
39+
#' @rdname get_constraint
4040
#' @order 12
4141
#' @export
42-
`primary_key<-` <- function(table, cols = NULL, value) {
42+
`get_primary_key<-` <- function(table, cols = NULL, value) {
4343
constraint(table, {{ cols }}, "cstr_primary_key") <- value
4444
table
4545
}

‎R/cstr_unique_key.R‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -30,16 +30,16 @@ check_constraint_strict.cstr_unique_key <- function(constraint, table) {
3030
result
3131
}
3232

33-
#' @rdname pick_constraint
33+
#' @rdname get_constraint
3434
#' @order 1
3535
#' @export
36-
unique_key <- function(table, cols = NULL) {
36+
get_unique_key <- function(table, cols = NULL) {
3737
constraint(table, {{ cols }}, "cstr_unique_key")
3838
}
39-
#' @rdname pick_constraint
39+
#' @rdname get_constraint
4040
#' @order 11
4141
#' @export
42-
`unique_key<-` <- function(table, cols = NULL, value) {
42+
`get_unique_key<-` <- function(table, cols = NULL, value) {
4343
constraint(table, {{ cols }}, "cstr_unique_key") <- value
4444
table
4545
}

‎R/qf_constraint.R‎

Lines changed: 126 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -46,6 +46,69 @@ as_qf_constraint.qf_constraint_specifier <- function(x, table, ...) {
4646

4747

4848

49+
# Constraint lists =============================================================
50+
51+
new_qf_constraint_list <- function(x) {
52+
stopifnot(is.list(x))
53+
stopifnot(purrr::every(x, is_qf_constraint))
54+
structure(x, class = c("qf_constraint_list", "list"))
55+
}
56+
57+
is_qf_constraint_list <- function(x) {
58+
inherits(x, "qf_constraint_list")
59+
}
60+
61+
as_qf_constraint_list <- function(x) {
62+
UseMethod("as_qf_constraint_list")
63+
}
64+
65+
#' @noRd
66+
#' @export
67+
as_qf_constraint_list.qf_constraint_list <- function(x) {
68+
x
69+
}
70+
#' @noRd
71+
#' @export
72+
as_qf_constraint_list.list <- function(x) {
73+
purrr::walk(x, \(cstr) {
74+
if (!is_qf_constraint(cstr))
75+
stop("<qf_constraint_list> cannot include a ", typeof(x))
76+
})
77+
new_qf_constraint_list(x)
78+
}
79+
#' @noRd
80+
#' @export
81+
as_qf_constraint_list.qf_constraint <- function(x) {
82+
new_qf_constraint_list(list(x))
83+
}
84+
85+
#' @noRd
86+
#' @export
87+
`&.qf_constraint_list` <- function(e1, e2) {
88+
new_qf_constraint_list(c(
89+
as_qf_constraint_list(e1),
90+
as_qf_constraint_list(e2))
91+
)
92+
}
93+
#' @noRd
94+
#' @export
95+
`&.qf_constraint` <- `&.qf_constraint_list`
96+
97+
98+
99+
# Methods ======================================================================
100+
101+
#' @noRd
102+
#' @export
103+
print.qf_constraint <- function(x, ...) {
104+
column_names <- paste(x$cols, collapse = ", ")
105+
cat0(pretty_class(x), " [", column_names, "]")
106+
cat("\n")
107+
invisible(x)
108+
}
109+
110+
111+
49112
# Constraint specification =====================================================
50113

51114
#' Create a constraint specifier
@@ -150,7 +213,7 @@ NULL
150213

151214

152215

153-
# Generics =====================================================================
216+
# Constraint checking ==========================================================
154217

155218
#' Check that a constraint is satisfied
156219
#'
@@ -166,15 +229,15 @@ check_constraint <- function(constraint, table) {
166229
purrr::map(excepted_rows, table = table) |>
167230
purrr::reduce(`|`, .init = rep(FALSE, nrow(table)))
168231
handled_rows <- satisfied_rows | excepted_rows
169-
list(
232+
structure(list(
170233
satisfied = all(satisfied_rows),
171234
handled = all(handled_rows),
172235
rows = list(
173236
satisfied = satisfied_rows,
174237
excepted = excepted_rows,
175238
handled = handled_rows
176239
)
177-
)
240+
), class = "qf_report_check", constraint = constraint)
178241
}
179242

180243
#' Check that a constraint is satisfied, ignoring exceptions
@@ -190,6 +253,65 @@ check_constraint_strict <- function(constraint, table) {
190253
UseMethod("check_constraint_strict")
191254
}
192255

256+
#' @noRd
257+
#' @export
258+
print.qf_report_check <- function(x, max_width = getOption("width"), ...) {
259+
print(attr(x, "constraint"))
260+
if (x$satisfied) {
261+
cat(" All rows satisfied")
262+
} else if (x$handled) {
263+
cat(" All rows satisfied or excepted")
264+
} else {
265+
message <- " Violating rows: "
266+
indices <- format_indices(
267+
which(!x$rows$handled),
268+
max_width - nchar(message)
269+
)
270+
cat0(message, indices)
271+
}
272+
cat("\n")
273+
invisible(x)
274+
}
275+
276+
#' @noRd
277+
#' @export
278+
print.qf_report_check_table <- function(x, ...) {
279+
report_check_header(x)
280+
for (cstr in x) print(cstr)
281+
invisible(x)
282+
}
283+
284+
#' @noRd
285+
#' @export
286+
print.qf_report_check_dataset <- function(x, ...) {
287+
report_check_header(unlist(x, recursive = FALSE))
288+
indent <- " "
289+
for (i in 1:length(x)) {
290+
if (any(vapply(x[[i]], \(el) !el$handled, logical(1)))) {
291+
cat0("=> In table '", names(x)[[i]], "':\n")
292+
for (j in 1:length(x[[i]])) {
293+
if (!x[[i]][[j]]$handled) {
294+
report_check_constraint <- utils::capture.output({
295+
cat0("[[", j, "]] ")
296+
print(x[[i]][[j]], max_width = getOption("width") - nchar(indent))
297+
})
298+
cat(paste0(indent, report_check_constraint), sep = "\n")
299+
}
300+
}
301+
}
302+
}
303+
}
304+
305+
report_check_header <- function(x) {
306+
satisfied <- purrr::map_lgl(x, "satisfied")
307+
handled <- purrr::map_lgl(x, "handled")
308+
n_satisfied <- sum(satisfied)
309+
n_excepted <- sum(handled) - sum(satisfied)
310+
n_violated <- length(x) - sum(handled)
311+
cat("Constraint check report:", n_satisfied, "satisfied", "/", n_excepted,
312+
"excepted", "/", n_violated, "violated:", "\n")
313+
}
314+
193315

194316

195317
# Exception handling ===========================================================
@@ -216,15 +338,6 @@ exceptions <- function(x) {
216338
`exceptions<-` <- function(x, value) {
217339
if (!is_qf_constraint(x))
218340
stop("'x' must be a <qf_constraint>, not ", typeof(x))
219-
exception_list <-
220-
if (is_qf_exception(value))
221-
list(value)
222-
else if (is.list(value))
223-
purrr::walk(value, \(expt) if (!is_qf_exception(expt)) stop("'value' must
224-
contain only <qf_exception> objects, not ", typeof(expt)))
225-
else stop("'value' must be a <qf_exception> or list of <qf_exception> objects,
226-
not ", typeof(value))
227-
228-
attr(x, "exceptions") <- exception_list
341+
attr(x, "exceptions") <- as_qf_exception_list(value)
229342
x
230343
}

‎R/qf_dataset.R‎

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -61,7 +61,10 @@ is_qf_dataset <- function(x) {
6161
#' @rdname check_constraints
6262
#' @export
6363
check_constraints.qf_dataset <- function(x) {
64-
x |> purrr::map(check_constraints)
64+
structure(
65+
purrr::map(x, check_constraints),
66+
class = "qf_report_check_dataset"
67+
)
6568
}
6669

6770
#' @noRd
@@ -85,7 +88,7 @@ str.qf_dataset <- function(object,
8588
#' @noRd
8689
#' @export
8790
print.qf_dataset <- function(x, ...) {
88-
str(x)
91+
utils::str(x)
8992
}
9093

9194
#' Subsetting qualifyr data sets

0 commit comments

Comments
 (0)