1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
|
# ngettext() does extra work, this function is a simpler version
pluralise <- function(n, singular, plural) {
if (n == 1) {
singular
} else {
plural
}
}
pluralise_len <- function(x, singular, plural) {
pluralise(length(x), singular, plural)
}
bad <- function(..., .envir = parent.frame()) {
glubort(NULL, ..., .envir = parent.frame())
}
bad_args <- function(args, ..., .envir = parent.frame()) {
glubort(fmt_args(args), ..., .envir = .envir)
}
bad_pos_args <- function(pos_args, ..., .envir = parent.frame()) {
glubort(fmt_pos_args(pos_args), ..., .envir = .envir)
}
bad_calls <- function(calls, ..., .envir = parent.frame()) {
glubort(fmt_calls(calls), ..., .envir = .envir)
}
bad_named_calls <- function(named_calls, ..., .envir = parent.frame()) {
glubort(fmt_named_calls(named_calls), ..., .envir = .envir)
}
bad_eq_ops <- function(named_calls, ..., .envir = parent.frame()) {
glubort(fmt_wrong_eq_ops(named_calls), ..., .envir = .envir)
}
bad_cols <- function(cols, ..., .envir = parent.frame()) {
glubort(fmt_cols(cols), ..., .envir = .envir)
}
bad_measures <- function(measures, ..., .envir = parent.frame()) {
glubort(fmt_measures(measures), ..., .envir = .envir)
}
glubort <- function(header, ..., .envir = parent.frame(), .abort = abort) {
text <- glue(..., .envir = .envir)
if (!is_null(header)) text <- paste0(header, " ", text)
.abort(text)
}
fmt_args <- function(x) {
x <- parse_args(x)
fmt_obj(x)
}
fmt_pos_args <- function(x) {
args <- pluralise_len(x, "Argument", "Arguments")
glue("{args} {fmt_comma(x)}")
}
fmt_calls <- function(...) {
x <- parse_named_call(...)
fmt_obj(x)
}
fmt_named_calls <- function(...) {
x <- parse_named_call(...)
fmt_named(x)
}
fmt_wrong_eq_ops <- function(...) {
x <- parse_named_call(...)
fmt_comma(
paste0(fmt_obj1(names2(x)), " (", fmt_obj1(paste0(names2(x), " = ", x)), ")")
)
}
fmt_cols <- function(x) {
cols <- pluralise_len(x, "Column", "Columns")
glue("{cols} {fmt_obj(x)}")
}
fmt_measures <- function(x) {
measures <- pluralise_len(x, "Measure", "Measures")
glue("{measures} {fmt_obj(x)}")
}
fmt_named <- function(x) {
fmt_comma(paste0(fmt_obj1(names2(x)), " = ", x))
}
fmt_obj <- function(x) {
fmt_comma(fmt_obj1(x))
}
fmt_obj1 <- function(x) {
paste0("`", x, "`")
}
fmt_classes <- function(x) {
paste(class(x), collapse = "/")
}
fmt_dims <- function(x) {
paste0("[", paste0(x, collapse = " x "), "]")
}
fmt_comma <- function(...) {
MAX_ITEMS <- 6L
x <- paste0(...)
if (length(x) > MAX_ITEMS) {
length(x) <- MAX_ITEMS
x[[MAX_ITEMS]] <- "..."
}
glue::glue_collapse(x, sep = ", ", last = " and ")
}
parse_args <- function(x) {
# convert single formula to list of length 1
x <- unlist(list(x), recursive = FALSE)
is_fml <- map_lgl(x, is_formula)
x[is_fml] <- map_chr(map(x[is_fml], "[[", 2), as_string)
unlist(x)
}
parse_named_call <- function(x) {
map_chr(x, quo_text)
}
bad_unknown_vars <- function(vars, unknown) {
thing <- vars_pluralise_len(vars, unknown)
abort(glue("Unknown { thing } { fmt_args(unknown) } "))
}
|
