-
Notifications
You must be signed in to change notification settings - Fork 0
/
assert_create.R
297 lines (243 loc) · 12 KB
/
assert_create.R
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
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
#' Create an assertion function
#'
#' This function creates an assertion function that can be used to check the
#' validity of an input.
#' All assertions provided with this package are created using either [assert_create()] or [assert_create_chain()]
#'
#' @param func A function defining the assertion criteria. This function should
#' return a logical value (`TRUE` when assertion is passed or `FALSE` when it fails).
#' Alternatively, instead of returning FALSE, you can return a string which will act as the error message.
#' In this latter case, you don't need to supply a `default_error_msg`
#' @param default_error_msg A character string providing an error message in case
#' the assertion fails. Must be supplied if function `func` returns `FALSE` when assertion fails (as opposed to a string)
#' Can include the following special terms
#`
#' 1. `{arg_name}` to refer to the name of the variable supplied to the assertion.
#'
#' 2. `{arg_value}` to refer to the value of the variable supplied to the assertion
#'
#' 3. `{code_to_evaluate}` to evaluate the code within the error message.
#' Replace `code_to_evaluate` with your code
#'
#' 4. `{.strong bold_text}` to perform inline formatting. Replace `bold_text` with your text.
#' See [cli documentation](https://cli.r-lib.org/reference/inline-markup.html) for details
#'
#'
#' @return An assertion function.
#'
#' @examples
#' #' # Create an assertion function that checks that a character string is all
#' # lower case
#' assert_character <- assert_create(
#' is.character,
#' "{arg_name} must be a character vector, not a {class(arg_value)}"
#' )
#'
#' # Use the assertion function
#' try({
#' is_lower("hello") # Returns invisible TRUE
#' is_lower("Hello") # Aborts the function with the error message
#'})
#' @include utils.R
#' @concept assert_create
#' @export
assert_create <- function(func, default_error_msg = NULL){
# Check arguments
function_name <- paste0(deparse(substitute(func)), collapse = "")
# Ensure func is a valid function
if(!is.function(func)){
cli::cli_abort("`{function_name}` must be a function, not a {class(func)}")
}
# Ensure func has at least 1 argument
if(func_arg_count(func) == 0){
if (func_supports_variable_arguments(func))
additional_note = " (Note '...' does NOT count as an argument)"
else additional_note = ""
cli::cli_abort("`{function_name}` must have at least 1 paramater to be used in `assert_create`{additional_note}")
}
# Ensure default_error_msg is a string
if(!is.null(default_error_msg) & !is_string(default_error_msg)){
default_error_msg_deparsed <- deparse(substitute(default_error_msg))
cli::cli_abort("{default_error_msg_deparsed} must be a string (length 1 character vector). Class: {class(default_error_msg)}; Length: {length(default_error_msg)}")
}
# Get arguments of user supplied function
args <- func_args_as_pairlist(func)
# Assert that function has no arguments named 'msg' or 'call', 'arg_name', since we need to add our own
if(any(c('msg', 'call', 'arg_name') %in% names(args))){
cli::cli_abort("Function supplied to `func` argument of `create_dataframe` cannot include paramaters namex 'msg' or 'call', 'arg_name', since we add our own arguments with these names")
}
# Change add 'msg', 'call' and 'arg_name' arguments at the end
#args <- append(args, as.pairlist(alist(x = )), after = 0)
args <- append(args, as.pairlist(alist(msg = NULL, call = rlang::caller_env(), arg_name = NULL)),after = Inf)
# Create body of assertion function
body = quote({
# Check mandatory arguments are all supplied
if(required_args_are_missing())
cli::cli_abort('mandatory argument/s were not supplied')
# Setup some variables ( these will be useful later)
if(is.null(arg_name))
arg_name <- deparse(match.call()[[2]])
else if(!is_string(arg_name))
cli::cli_abort("{.strong arg_name} must be a string, not a {class(arg_name)}")
# Create arg_value val
arg_value <- eval(match.call()[[2]], envir = call)
# Create useful functions
#.name <- function(obj) { browser(); deparse(substitute(obj, env)) }
# Get the list of arguments with values explicitly supplied in function call
explicit_args <- as.list(match.call())[-1]
# Assert all arguments without defaults are explicitly supplied in the function call
arg_has_default <- !unlist(as.list(formals()) == substitute())
args_without_defaults <- names(arg_has_default)[arg_has_default == FALSE]
args_missing <- args_without_defaults[!args_without_defaults %in% names(explicit_args)]
if(length(args_missing) > 0){
cli::cli_abort("{args_missing} are required, with no default")
}
# Create list of arguments - value pairs to be called with func (using do.call)
# Lets just supply x in position 1 (unnamed), then pass whatevers supplied by arg_has_default with its original names
names(explicit_args)[1] <- "" # unname first argument
# Also filter out msg & call arguments the user supplied func won't understand these
explicit_args_for_func <- explicit_args[!names(explicit_args) %in% c("msg", "call", "arg_name")]
# Info
#cli::cli_alert_info("Calling `func` using the argument values: {paste0(names(explicit_args_for_func), ' = ', explicit_args_for_func)}")
# Call supplied function
condition <- do.call(func, args = explicit_args_for_func, envir = parent.frame())
if(!(is.logical(condition) || is.character(condition)) || length(condition) != 1) # Change to is.flag once this method is created
cli::cli_abort("Assertion Function `{.strong {function_name}}` must return TRUE if assertion passes and FALSE or a String if assertion should fail. Instead returned: `{condition}`")
if(isFALSE(condition) & is.null(default_error_msg))
cli::cli_abort("Assertion Function `{.strong {function_name}}` returned FALSE, indicating assertion should fail, however no {.arg default_error_msg} was supplied! Please add a {.arg default_error_msg} to your assert_create call, or change function to return a string describing the error instead of `FALSE`")
# If user doesn't supply an error message, set msg to the default
if(is.null(msg)){
msg_evaluation_environment <- rlang::current_env() # Evaluate error message in current envrionment
if(isFALSE(condition))
msg <- default_error_msg
else if(is.character(condition))
msg <- condition
}
else { # If user does supply a default error message
msg_evaluation_environment <- rlang::caller_env(n = 1) # Evaluate it in caller environment
# Add special keywords to environment:
# arg_name, arv_value
assign("arg_name", value = arg_name, envir = msg_evaluation_environment)
assign("arg_value", value = arg_value, envir = msg_evaluation_environment)
}
# If assertion fails, abort with error statement
if(is.character(condition) || !condition )
cli::cli_abort(msg, call = call, .envir = msg_evaluation_environment)
else
return(invisible(TRUE))
})
# Create assertion_function
assertion_function <- rlang::new_function(args, body, env = rlang::env(func = func))
return(assertion_function)
}
#' @title Create Chains of Assertions
#'
#' @description
#' Combine multiple assertion functions created by `assert_create()` into a single assertion function with diverse failure modes and error messages.
#'
#' @param ... assertion functions created by `assert_create()`.
#'
#' @return A single assertion function that calls each of the input functions in the order they are supplied.
#'
#'
#' @examples
#' # Create an assertion function that checks for both positive integers and even values
#' assert_string <- assert_create_chain(
#' assert_create(is.character, '{{arg_name}} must be a character'),
#' assert_create(function(x){{ length(x)==1 }}, '{{arg_name}} must be length 1')
#' )
#'
#' # Use the assertion function to check a valid value
#' assert_string("String")
#'
#' # Use the assertion function to check an invalid value
#' try({
#' assert_string(3)
#' # Output: Error: '3' must be a character
#' })
#' @export
assert_create_chain <- function(...){
# Get list of arguments
dot_args <- list(...)
# Check dot_args are all functions
lgl_is_function <- vapply(dot_args, is.function, FUN.VALUE = logical(1))
if(!all(lgl_is_function)){
cli::cli_abort(
c("Input to {.strong assert_create_chain} must must be {.strong functions} created by {.strong `assert_create()`}",
"",
assert_create_chain_example()
))
}
# Check functions all have the required arguments (x, msg & call)
if(!all(vapply(dot_args, function(f){ all(c('msg', 'call', 'arg_name') %in% func_arg_names(f)) }, FUN.VALUE = logical(1)))){
cli::cli_abort(
c("Input to {.strong assert_create_chain} must must be {.strong functions} created by {.strong `assert_create()`}",
"",
assert_create_chain_example()
))
}
# Check functions have at least 4 args (some_obj_to_test and officially required functions: msg, call, arg_name)
if(!all(vapply(dot_args, function(f){ func_arg_count(f) >= 4 }, FUN.VALUE = logical(1)))){
cli::cli_abort(
c("Input to {.strong assert_create_chain} must must be {.strong functions} created by {.strong `assert_create()`}",
"",
assert_create_chain_example()
))
}
# Save assertion functons in a list
assertion_functions <- dot_args
# Get arguments of each assertion function
param_pairlist_nested <- lapply(assertion_functions, func_args_as_pairlist)
param_pairlist_flat <- unlist(param_pairlist_nested, recursive = FALSE)
param_pairlist <- param_pairlist_flat[!duplicated(names(param_pairlist_flat))]
# reorder arguments so that arguments to functions take precedence
args_to_put_at_end <- c("msg", "call", "arg_name")
param_pairlist <- c(param_pairlist[!(names(param_pairlist) %in% args_to_put_at_end)], param_pairlist[names(param_pairlist) %in% args_to_put_at_end])
#unique_params <- unlist(unique(arglist))
# Return a wrapper function that calls each of the functions
chained_assertion_function <- rlang::new_function(
args = param_pairlist,
body = quote({
arg_name_upperlevel <- deparse(substitute(x))
explicit_args <- as.list(match.call())[-1]
explicit_args <- lapply(explicit_args, function(a) {
if(is.symbol(a))
eval.parent(a, n = 3)
else return(a)
})
# Assert all arguments without defaults are explicitly supplied in the function call
arg_has_default <- !unlist(as.list(formals()) == substitute())
args_without_defaults <- names(arg_has_default)[arg_has_default == FALSE]
args_missing <- args_without_defaults[!args_without_defaults %in% names(explicit_args)]
if(length(args_missing) > 0){
cli::cli_abort("{args_missing} are required, with no default")
}
# If user doesn't override `explicit_args`, set to variable name
# This lets downstream functions use the correct variable name as {arg_name}
if(!"arg_name" %in% names(explicit_args)){
explicit_args <- append(explicit_args, list(arg_name = arg_name_upperlevel), after = Inf)
}
# Do a simliar thing with call, since if you just let the assertions use the default call, it will be the assertion functions parent env, not the caller
if(! "call" %in% names(explicit_args)){
explicit_args <- append(explicit_args, list(call = call), after = Inf)
}
for (f in assertion_functions) {
# filter explicit_args for only the functions args that 'f' understands.
args_relevant_to_function_f <- explicit_args[names(explicit_args) %in% func_arg_names(f)]
do.call(what = f, args = args_relevant_to_function_f, envir = rlang::caller_env())
}
return(invisible(TRUE))
}),
env = rlang::env(assertion_functions = assertion_functions)
)
return(chained_assertion_function)
}
assert_create_chain_example <- function(){
c(
"{.strong For example:}",
"assert_string <- assert_create_chain(",
' ' = "assert_create(is.character, '{{arg_name}} must be a character'),",
' ' = "assert_create(function(s){{ length(s)==1 }}, '{{arg_name}} must be length 1')",
")"
)
}