Nothing
# Exported functions ----
#' Fuzz-test a function
#'
#' Evaluate how a function responds to unexpected or non-standard inputs.
#'
#' \code{fuzz_function} provides a simple interface to fuzz test a single
#' argument of a function by passing the function, name of the argument, static
#' values of other required arguments, and a named list of test values.
#'
#' \code{p_fuzz_function} takes a nested list of arguments paired with lists of
#' tests to run on each argument, and will evaluate every combination of
#' argument and provided test.
#'
#' @note The user will be asked to confirm before proceeding if the combinations
#' of potential tests exceeds 500,000.
#'
#' @param fun A function.
#' @param arg_name Quoted name of the argument to fuzz test.
#' @param ... Other non-dynamic arguments to pass to \code{fun}. These will be
#' repeated for every one of the \code{tests}.
#' @param tests Which fuzz tests to run. Accepts a named list of inputs,
#' defaulting to \code{\link{test_all}}.
#' @param check_args Check if \code{arg_name} and any arguments passed as
#' \code{...} are accepted by \code{fun}. Set to \code{FALSE} if you need to
#' pass arguments to a function that accepts arguments via \code{...}.
#' @param progress Show a progress bar while running tests?
#'
#' @return A \code{fuzz_results} object.
#'
#' @seealso \code{\link{fuzz_results}} and
#' \code{\link{as.data.frame.fuzz_results}} to access fuzz test results.
#'
#' @export
#' @examples
#' # Evaluate the 'formula' argument of lm, passing additional required variables
#' fr <- fuzz_function(lm, "formula", data = iris)
#'
#' # When evaluating a function that takes ..., set check_args to FALSE
#' fr <- fuzz_function(paste, "x", check_args = FALSE)
fuzz_function <- function(fun, arg_name, ..., tests = test_all(), check_args = TRUE, progress = interactive()) {
fuzz_asserts(fun, check_args, progress)
attr(fun, "fun_name") <- deparse(substitute(fun))
assertthat::assert_that(is_named_l(tests))
# Collect the unevaluated names of variables passed to the original call,
# keeping only those passed in as ... These will be used in the named list
# passed to p_fuzz_function
dots_call_names <- purrr::map_chr(as.list(match.call()), deparse)
.dots = list(...)
dots_call_names <- dots_call_names[names(.dots)]
# Check that arg_name is a string, and the tests passed is a named list
assertthat::assert_that(assertthat::is.string(arg_name), is_named_l(tests))
# Check that arguments passed to fun actually exist in fun
if (check_args)
assertthat::assert_that(
assertthat::has_args(fun, arg_name),
assertthat::has_args(fun, names(.dots)))
# Construct a list of arguments for p_fuzz_function, with tests assigned to
# arg_name, and the values passed via ... saved as lists named after their
# deparsed variable names.
test_args <- c(
purrr::set_names(list(tests), arg_name),
purrr::map2(.dots, dots_call_names, function(x, y) purrr::set_names(list(x), y)))
p_fuzz_function(fun, .l = test_args, check_args = check_args, progress = progress)
}
#' @rdname fuzz_function
#' @param .l A named list of tests.
#' @export
#' @examples
#'
#' # Pass tests to multiple arguments via a named list
#' test_args <- list(
#' data = test_df(),
#' subset = test_all(),
#' # Specify custom tests with a new named list
#' formula = list(all_vars = Sepal.Length ~ ., one_var = mpg ~ .))
#' fr <- p_fuzz_function(lm, test_args)
p_fuzz_function <- function(fun, .l, check_args = TRUE, progress = interactive()) {
fuzz_asserts(fun, check_args, progress)
if (is.null(attr(fun, "fun_name"))) {
fun_name <- deparse(substitute(fun))
} else {
fun_name <- attr(fun, "fun_name")
}
if (check_args)
assertthat::assert_that(assertthat::has_args(fun, names(.l)))
# Ensure .l is a named list of named lists
is_named_ll(.l)
# Replace any NULL test values with .null alias.
.l <- purrr::map(.l, function(li) {
purrr::map(li, function(lli) {
if (is.null(lli)) {
.null
} else {
lli
}
})
})
# Warn if combination of tests is potentially massive
num_tests <- purrr::reduce(purrr::map_int(.l, length), `*`)
if (num_tests >= 500000) {
m <- utils::menu(choices = c("Yes", "No"), title = paste("The supplied tests have", num_tests, "combinations, which may be prohibitively large to calculate. Attempt to proceed?"))
if (m != 1)
return(NULL)
}
# Generate the list of tests to be done
test_list <- named_cross_n(.l)
# After crossing, restore NULL test values
test_list <- purrr::modify_depth(test_list, 3, function(x) {
if (inherits(x, what = "fuzz-null")) {
NULL
} else {
x
}
})
# Create a progress bar, if called for
if (progress) {
pb <- progress::progress_bar$new(
format = " running tests [:bar] :percent eta: :eta",
total = length(test_list), clear = FALSE, width = 60)
pb$tick(0)
}
# For each test combination...
fr <- purrr::map(
test_list, function(x) {
if (exists("pb")) pb$tick()
# Extract values for testing
arglist <- purrr::map(x, getElement, name = "test_value")
# Extract names of tests
testnames <- purrr::map(x, getElement, name = "test_name")
# Create a result list with both the results of try_fuzz, as well as a
# named list pairing argument names with the test names supplied to them
# for this particular round
res <- list(test_result = try_fuzz(fun = fun, fun_name = fun_name,
all_args = arglist))
res[["test_name"]] <- testnames
res
})
structure(fr, class = "fuzz_results")
}
# Internal functions ----
# Pass NULL as a test value
#
# Because it is difficult to work with NULLs in lists as required by most of
# the fuzzr package, this function works as an alias to pass NULL values to
# function arguments for testing.
.null <- structure(list(), class = "fuzz-null")
# This set of assertions need to be checked for both functions
fuzz_asserts <- function(fun, check_args, progress) {
assertthat::assert_that(
is.function(fun), assertthat::is.flag(check_args),
assertthat::is.flag(progress))
}
# Is a list named, and is each of its elements also a named list?
is_named_ll <- function(l) {
assertthat::assert_that(is.list(l), is_named(l))
purrr::walk(l, function(x) assertthat::assert_that(is.list(x), is_named(x)))
}
# Is every element of a list named?
is_named_l <- function(l) {
is.list(l) & is_named(l)
}
assertthat::on_failure(is_named_l) <- function(call, env) {
"Not a named list."
}
# Check that object has no blank names
is_named <- function(x) {
nm <- names(x)
!is.null(nm) & all("" != nm)
}
assertthat::on_failure(is_named) <- function(call, env) {
"Not a completely-named object."
}
# Cross a list of named lists
named_cross_n <- function(ll) {
# Cross the values of the list...
crossed_values <- purrr::cross(ll)
# ... and then cross the names
crossed_names <- purrr::cross(purrr::map(ll, names))
# Then map through both values and names in order to
purrr::map2(crossed_values, crossed_names, function(x, y) {
purrr::map2(x, y, function(m, n) {
list(
test_name = n,
test_value = m
)
})
})
}
# Custom tryCatch/withCallingHandlers function to catch messages, warnings, and
# errors along with any values returned by the expression. Returns a list of
# value, messages, warnings, and errors.
try_fuzz <- function(fun, fun_name, all_args) {
call <- list(fun = fun_name, args = all_args)
messages <- NULL
output <- NULL
warnings <- NULL
errors <- NULL
message_handler <- function(c) {
messages <<- c(messages, conditionMessage(c))
invokeRestart("muffleMessage")
}
warning_handler <- function(c) {
warnings <<- c(warnings, conditionMessage(c))
invokeRestart("muffleWarning")
}
error_handler <- function(c) {
errors <<- c(errors, conditionMessage(c))
return(NULL)
}
# Little trick: that first tryCatch() will return values from the expression
# to the "value" index in this list, but will pass errors to error_handler
# (which returns NULL "value", incidentally.) In the event of messages or
# warnings, handling is passed up to withCallingHandlers, which passes them
# down again to message_handler or warning_handler, respectively. Once the
# expression is done evaluating, messages, warnings, and errors are assigned
# to the list, which is returned as the final result of try_fuzz
output <- utils::capture.output({
value <- withCallingHandlers(
tryCatch(do.call(fun, args = all_args), error = error_handler),
message = message_handler,
warning = warning_handler
)}, type = "output")
if (length(output) == 0) {
output <- NULL
}
list(
call = call,
value = value,
output = output,
messages = messages,
warnings = warnings,
errors = errors
)
}
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.