Nothing
#' 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({
# 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')",
")"
)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.