├── .Rbuildignore ├── .gitignore ├── .lintr ├── .travis.yml ├── DESCRIPTION ├── LICENSE ├── NAMESPACE ├── NEWS.md ├── R ├── contains.R ├── empty.R ├── ensure.R ├── generate.R ├── is.R ├── package.R ├── package_exports_checked.R ├── present.R ├── quickcheck.R ├── simple_string.R ├── validate.R └── within.R ├── README.md ├── man ├── checkr.Rd ├── ensure.Rd ├── force_reload_test_objects.Rd ├── function_name.Rd ├── function_test_objects.Rd ├── get_prevalidated_fn.Rd ├── grapes-contains-grapes.Rd ├── grapes-is-grapes.Rd ├── grapes-within-grapes.Rd ├── installed_dataframes.Rd ├── is.empty.Rd ├── is.simple_string.Rd ├── is.validated_function.Rd ├── list_classes.Rd ├── package_exports_checked.Rd ├── postconditions.Rd ├── preconditions.Rd ├── present.Rd ├── print.validated_function.Rd ├── print_args.Rd ├── quickcheck.Rd ├── random_matrix.Rd ├── random_objs.Rd ├── random_simple_strings.Rd ├── should_be_checked.Rd ├── test_objects_.Rd ├── validate.Rd └── validate_.Rd └── tests ├── testthat.R └── testthat ├── fakepackages ├── allexportedchecked │ ├── .Rbuildignore │ ├── .gitignore │ ├── DESCRIPTION │ ├── NAMESPACE │ ├── R │ │ └── pending.R │ ├── allexportedchecked.Rproj │ └── man │ │ ├── pending.Rd │ │ └── pending_identity.Rd └── notallexportedchecked │ ├── .Rbuildignore │ ├── .gitignore │ ├── DESCRIPTION │ ├── NAMESPACE │ ├── R │ └── pending.R │ ├── allexportedchecked.Rproj │ └── man │ ├── pending.Rd │ └── pending_identity.Rd ├── test-contains.R ├── test-empty.R ├── test-ensure.R ├── test-generate.R ├── test-is.R ├── test-package-exports-checked.R ├── test-present.R ├── test-quickcheck.R ├── test-simple_string.R ├── test-validate.R └── test-within.R /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | .lintr 4 | .travis.yml 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | -------------------------------------------------------------------------------- /.lintr: -------------------------------------------------------------------------------- 1 | linters: with_defaults(line_length_linter(100), commented_code_linter = NULL, open_curly_linter = NULL, closed_curly_linter = NULL, object_length_linter = NULL, multiple_dots_linter = NULL, object_name_linter = NULL, spaces_left_parentheses_linter = NULL) 2 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: r 2 | sudo: required 3 | cache: packages 4 | dist: trusty 5 | r: release 6 | r_binary_packages: 7 | - devtools 8 | r_github_packages: 9 | - klutometis/roxygen 10 | - r-lib/rcmdcheck 11 | - jimhester/lintr 12 | - jimhester/covr 13 | script: 14 | - R -e 'r <- rcmdcheck::rcmdcheck(".", args = c("--no-manual")); l <- lintr::lint_package("."); print(l); devtools::install("."); devtools::test(); quit(save = "no", status = if (length(c(r$errors, r$warnings, l)) > 0) { 1 } else { 0 }, runLast = FALSE)' 15 | after_success: 16 | - R -e 'library(covr); coveralls()' 17 | env: 18 | - global: 19 | - CI=TRUE 20 | - WARNINGS_ARE_ERRORS=1 21 | - _R_CHECK_FORCE_SUGGESTS_=0 22 | - LINTR_COMMENT_BOT=false 23 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: checkr 2 | Title: Automatically Test R Functions 3 | Version: 0.1.4 4 | Author: Peter Hurford 5 | Maintainer: Peter Hurford 6 | Authors@R: person("Peter", "Hurford", email = "peter@peterhurford.com", role = c("aut", "cre")) 7 | Description: Be able to specify preconditions and postconditions for R functions 8 | and have them automatically checked at runtime. Then, randomly generate R 9 | objects and pass them into R functions, verifying that certain specified 10 | conditions hold. 11 | Depends: 12 | R (>= 3.1.0) 13 | License: MIT + file LICENSE 14 | LazyData: true 15 | Imports: 16 | memoise, 17 | methods 18 | Suggests: 19 | testthat, 20 | devtools 21 | RoxygenNote: 6.0.1 22 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2014-2016 Peter Hurford 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(print,validated_function) 4 | export("%contains%") 5 | export("%contains_only%") 6 | export("%does_not_contain%") 7 | export("%is%") 8 | export("%isnot%") 9 | export("%within%") 10 | export(ensure) 11 | export(function_test_objects) 12 | export(get_prevalidated_fn) 13 | export(is.empty) 14 | export(is.simple_string) 15 | export(is.validated_function) 16 | export(is_empty) 17 | export(package_exports_checked) 18 | export(postconditions) 19 | export(preconditions) 20 | export(present) 21 | export(quickcheck) 22 | export(should_be_checked) 23 | export(validate) 24 | export(validate_) 25 | import(memoise) 26 | import(methods) 27 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | #### v0.1.4 2 | 3 | * Fix `is.empty` to work with vectorized input. 4 | 5 | #### v0.1.3 6 | 7 | * `%within%` is vectorized. 8 | 9 | #### v0.1.2 10 | 11 | * Fixed a bug where functions could not be used as formals. 12 | 13 | #### v0.1.1 14 | 15 | * Add the ability to manually define a testing frame using an explicit precondition passed to `function_test_objects`, which is now exported. 16 | 17 | ## v0.1.0 18 | 19 | * Switch to stable versioning. 20 | 21 | 22 | #### v0.0.4.9008 23 | 24 | * Add `is_empty` as an alias for `is.empty`. 25 | 26 | #### v0.0.4.9007 27 | 28 | * Allow empty string to be a default argument in a validated function. 29 | 30 | #### v0.0.4.9006 31 | 32 | * Fixed the bug that prevented using function names in conditions or in arguments. 33 | * Fixed the bug that caused a warning when too many default arguments were assigned. 34 | * `%within%` is exported. 35 | 36 | #### v0.0.4.9005 37 | 38 | * Added a matcher for atomic (e.g., `1 %is% atomic`). 39 | 40 | #### v0.0.4.9004 41 | 42 | * `package_exports_checked` now can take a file path as well as a package name. 43 | 44 | #### v0.0.4.9003 45 | 46 | * Introduce `package_exports_checked`, which checks a package for whether all exported functions are checked using checkr (either have zero formals or are wrapped in `ensure` blocks). 47 | * Add a test for `any` (e.g., `1 %is% any`) that will always be `TRUE`. This is useful to be explicit that your function can take any input. 48 | 49 | #### v0.0.4.9002 50 | 51 | * Allow `NULL` to work as a result of the function in `ensure` or `quickcheck`. 52 | 53 | #### v0.0.4.9001 54 | 55 | 56 | * Prevent errors in testthat from the function name being too long. 57 | 58 | ## v0.0.4.9000 59 | 60 | * Resolve bugs with nesting quickchecks within quickchecks. 61 | * Allow a custom testing frame to be passed to quickcheck. 62 | * Add `%within%` as a helper to test membership within a numeric boundary. 63 | 64 | 65 | ## v0.0.3.9000 66 | 67 | * Validated functions now keep their formals instead of being coerced to splat. 68 | * Add Travis. 69 | * Pass R CMD CHECK and lintr. 70 | * Some functions are no longer validated because this ran into circular issues. 71 | 72 | #### v0.0.2.9002 73 | 74 | * Redo the imputation of arguments within the validator. 75 | 76 | #### v0.0.2.9001 77 | 78 | * Remove calls to the now non-existent `validations` package. 79 | 80 | ## v0.0.2.9000 81 | 82 | * Adds `%does_not_contain%` as a validator. 83 | * Adds NA and NULL as classes that can be tested using `%is%`, `%contains%`, etc. 84 | * Fixed bugs where missing arguments were not allowed in certain places where they should be allowed. 85 | * Prevent a failed quickcheck from breaking the entire test suite. Quickcheck now returns FALSE when failing instead of an error. 86 | * The testthat integration in quickcheck can be turned off with `testthat = FALSE` 87 | * Fixed a bug where the report of the quickcheck failure would not be correct because the output was too long. 88 | * Fixed a bug where quickcheck breaks if it can't load some built-in dataframes. 89 | * Removed stray references to the old validation package. 90 | * Fixed a merge conflict. 91 | 92 | 93 | #### v0.0.1.9002 94 | 95 | * Fixed how we checked for missing args, fixing bugs with `missing` and `present`. 96 | 97 | #### v0.0.1.9001 98 | 99 | * Added `present` to check for the presence of arguments. 100 | 101 | ## v0.0.1.9000 102 | 103 | * Added quickcheck. 104 | 105 | 106 | #### v0.0.0.9003 107 | 108 | * Validating a function twice creates an error. 109 | * Printing a validated function will show the preconditions, postconditions, and the original function, rather than the metaprogramming behind the scenes. 110 | * Fixed a bug when calling functions with default arguments. 111 | * Clarified `random_string` preconditions to not allow length >1 `length` arguments or alphabets where each letter has more than one character. 112 | 113 | #### v0.0.0.9002 114 | 115 | * Adds helpers `preconditions` and `postconditions` for fetching the conditions of validated functions. 116 | * Handles default arguments and missing arguments in function calls. 117 | 118 | #### v0.0.0.9001 119 | 120 | * The resulting function is now also of class `validated_function`. 121 | 122 | ## v0.0.0.9000 123 | 124 | * Initial package 125 | -------------------------------------------------------------------------------- /R/contains.R: -------------------------------------------------------------------------------- 1 | #' Test if a list contains some elements of the desired class. 2 | #' 3 | #' @param match_list list. The list to test for class of the elements. 4 | #' @param expected_class character. The name of the expected class to test. 5 | #' @examples 6 | #' list(1, 2, 3) %contains% numeric 7 | #' list(1, 2, "a") %contains% numeric 8 | #' @return Boolean whether or not the match_list has at least one element of expected_class. 9 | #' @export 10 | `%contains%` <- function(match_list, expected_class) { 11 | if (is.name(substitute(expected_class))) { 12 | expected_class <- deparse(substitute(expected_class)) 13 | } 14 | contains_(match_list, expected_class, exclusive = FALSE) 15 | } 16 | 17 | #' Test if a list does not contain some elements of the desired class. 18 | #' @rdname grapes-contains-grapes 19 | #' @examples 20 | #' list(1, 2, 3) %does_not_contain% character 21 | #' @return Boolean whether or not the match_list has no elements of the expected_class. 22 | #' @export 23 | `%does_not_contain%` <- function(match_list, expected_class) { 24 | if (is.name(substitute(expected_class))) { 25 | expected_class <- deparse(substitute(expected_class)) 26 | } 27 | !contains_(match_list, expected_class, exclusive = FALSE) 28 | } 29 | 30 | #' Test if a list contains only elements of the desired class. 31 | #' @rdname grapes-contains-grapes 32 | #' @examples 33 | #' list(1, 2, 3) %contains_only% numeric 34 | #' list(1, 2, "a") %contains_only% numeric 35 | #' @return Boolean whether or not the match_list has all elements of expected_class. 36 | #' @export 37 | `%contains_only%` <- function(match_list, expected_class) { 38 | if (is.name(substitute(expected_class))) { 39 | expected_class <- deparse(substitute(expected_class)) 40 | } 41 | contains_(match_list, expected_class, exclusive = TRUE) 42 | } 43 | 44 | contains_ <- function(match_list, expected_class, exclusive) { 45 | if (checkr::is.empty(match_list)) { return(FALSE) } 46 | match_fn <- if (isTRUE(exclusive)) { all } else { any } 47 | match_fn(vapply(match_list, `%is_%`, expected_class = expected_class, logical(1))) 48 | } 49 | -------------------------------------------------------------------------------- /R/empty.R: -------------------------------------------------------------------------------- 1 | #' Tests whether an object is empty. 2 | #' 3 | #' Empty items are NULL, NA, or nothing (length 0). 4 | #' 5 | #' @param obj ANY. The object to test. 6 | #' @examples 7 | #' is.empty(NULL) 8 | #' is.empty(NA) 9 | #' is.empty(list(NULL, NA)) 10 | #' is.empty(list()) 11 | #' is.empty(c()) 12 | #' is.empty(data.frame()) 13 | #' is.empty("") 14 | #' is.empty(data.frame()) 15 | #' @return a boolean whether or not the object is empty. 16 | #' @export 17 | is.empty <- function(obj) { 18 | if (methods::is(obj, "list")) { 19 | all(vapply(obj, is.empty, logical(1))) 20 | } else { 21 | suppressWarnings(is.na(obj) || is.null(obj) || NROW(obj) == 0 || identical(obj, "")) 22 | } 23 | } 24 | 25 | #' @rdname is.empty 26 | #' @export 27 | is_empty <- is.empty 28 | -------------------------------------------------------------------------------- /R/ensure.R: -------------------------------------------------------------------------------- 1 | #' Ensure checks that certain preconditions and postconditions of a function are true. 2 | #' 3 | #' @param checker_fn function. A function to run with validated pre- and postconditions. 4 | #' @param preconditions list. A list of preconditions to check. 5 | #' @param postconditions list. A list of postconditions to check. 6 | #' @examples 7 | #' add <- ensure(pre = list(x %is% numeric, y %is% numeric), 8 | #' post = list(result %is% numeric), 9 | #' function(x, y) { x + y }) 10 | #' @return The original function, but also of class validated_function, with added validations. 11 | #' @export 12 | ensure <- function(checker_fn, preconditions = list(), postconditions = list()) { 13 | if (methods::is(checker_fn, "validated_function")) { 14 | stop("The function has already been validated.") 15 | } 16 | pre <- substitute(preconditions) 17 | post <- substitute(postconditions) 18 | force(checker_fn) 19 | validated_fn <- function(...) { 20 | args <- lapply(as.list(sys.call()[-1]), function(expr) { 21 | eval(expr, parent.frame(3)) 22 | }) 23 | formals <- names(formals(checker_fn)) 24 | 25 | # Goal here is to (a) impute names the user doesn't give with the formals 26 | # and (b) detect if any formals are missing so we can place in their defaults 27 | # or error 28 | missing_formals <- setdiff(formals, names(args)) 29 | if (is.null(names(args))) { 30 | names(args) <- head(formals, length(args)) 31 | } else { 32 | empty_names <- vapply(names(args), checkr::is.empty, logical(1)) 33 | names(args)[empty_names] <- head(missing_formals, sum(empty_names)) 34 | } 35 | 36 | # Get all the non-empty arguments to impute missing arguments. 37 | has_default_arg <- function(arg) { nchar(arg) > 0 || 38 | is.null(arg) || 39 | identical(arg, "") || 40 | identical(arg, NA) } 41 | default_args <- Filter(has_default_arg, formals(checker_fn)) 42 | for (pos in seq_along(default_args)) { 43 | if (!(names(default_args)[[pos]] %in% names(args))) { 44 | args[[names(default_args)[[pos]]]] <- default_args[[pos]] 45 | } 46 | } 47 | 48 | # Sometimes we have args that have a default of NULL that are missing. 49 | # This is difficult to populate, but alas. 50 | missing_defaults <- setdiff(names(default_args), names(args)) 51 | if (length(missing_defaults) > 0) { 52 | length(args) <- length(args) + length(missing_defaults) 53 | names(args) <- Filter(Negate(checkr::is.empty), 54 | union(names(args), missing_defaults)) 55 | } 56 | 57 | # Run the preconditions 58 | tryCatch({ 59 | args <- lapply(args, function(expr) eval(expr, envir = parent.frame(3))) 60 | checkr:::validate_(pre, env = args) 61 | }, error = function(e) { 62 | e <- as.character(e) 63 | flag <- "object '.*not found" 64 | if (grepl(flag, e)) { 65 | missing_args_error(gsub("' not found", "", 66 | gsub("object '", "", regmatches(e, regexpr(flag, e))))) 67 | } else { stop(e) } 68 | }) 69 | 70 | # Now we need to add the result to the list of arguments so we can post-validate 71 | # Assignment here must be careful to assign NULL correctly 72 | # http://stackoverflow.com/questions/7944809/assigning-null-to-a-list-element-in-r 73 | args["result"] <- list(do.call(checker_fn, args)) 74 | 75 | checkr:::validate_(post, env = args) 76 | args$result 77 | } 78 | 79 | formals(validated_fn) <- formals(checker_fn) 80 | class(validated_fn) <- append(class(checker_fn), "validated_function", 0) 81 | validated_fn 82 | } 83 | 84 | 85 | #' Get the stated preconditions of a validated function. 86 | #' @param fn validated_function. The function to get the preconditions for. 87 | #' @return a call containing the preconditions. 88 | #' @export 89 | preconditions <- function(fn) conditions_(fn, "pre") 90 | 91 | #' Get the stated postconditions of a validated function. 92 | #' @param fn validated_function. The function to get the postconditions for. 93 | #' @return a call containing the postconditions. 94 | #' @export 95 | postconditions <- function(fn) conditions_(fn, "post") 96 | 97 | conditions_ <- function(fn, key) { environment(fn)[[key]] } 98 | 99 | 100 | #' Get the pre-validated function that is wrapped in validations. 101 | #' @param fn validated_function. The function to get the pre-validated function for. 102 | #' @return a call containing the postconditions. 103 | #' @export 104 | get_prevalidated_fn <- function(fn) { environment(fn)$checker_fn } 105 | 106 | 107 | #' Print validated functions more clearly. 108 | #' @param x function. The function to print. 109 | #' @param ... list. Additional arguments to pass to print. 110 | #' @export 111 | print.validated_function <- function(x, ...) { 112 | print(list( 113 | preconditions = preconditions(x), 114 | postconditions = postconditions(x), 115 | fn = get_prevalidated_fn(x)), 116 | ...) 117 | } 118 | 119 | 120 | missing_args_error <- function(missing_args) { 121 | stop("Error on missing arguments: ", 122 | paste0(missing_args, collapse = ", "), call. = FALSE) 123 | } 124 | -------------------------------------------------------------------------------- /R/generate.R: -------------------------------------------------------------------------------- 1 | # The OBJECTS constant holds all the possible objects to gather into a testing frame. 2 | # It's basically a staging area for our random madness. 3 | default_objects <- memoise::memoise(function() { 4 | OBJECTS <- list( 5 | empties = list(NA, NULL, "", character(0), logical(0), numeric(0), integer(0), 6 | data.frame(), list(), matrix(), c(), structure(NA, class = "table"), 7 | factor(NA)), 8 | positive_doubles = c(seq(100), 1000, 100000, 2147483647), 9 | logicals = c(TRUE, FALSE), 10 | characters = c(letters, LETTERS), 11 | utf8 = setdiff(lapply(seq(1000L), intToUtf8), c(letters, LETTERS)) 12 | ) 13 | OBJECTS$positive_integers <- vapply(OBJECTS$positive_doubles, as.integer, integer(1)) 14 | OBJECTS$negative_integers <- OBJECTS$positive_integers * -1L 15 | OBJECTS$positive_doubles <- append(OBJECTS$positive_doubles, c(1e18, 1e100)) 16 | OBJECTS$negative_doubles <- OBJECTS$positive_doubles * -1 17 | OBJECTS$matricies <- lapply(seq(12), function(n) random_matrix(OBJECTS)) 18 | dataframes <- installed_dataframes() 19 | OBJECTS$dataframes <- Filter(is.data.frame, dataframes) 20 | OBJECTS$factors <- Filter(is.factor, dataframes) 21 | OBJECTS$table <- Filter(is.table, dataframes) 22 | OBJECTS 23 | }) 24 | #TODO: Maybe someday we can also check functions, environments, and some custom structs. 25 | 26 | #' Get all the classes within a list. 27 | #' @param object ANY. The object to check classes for. 28 | list_classes <- function(object) { 29 | classes <- unique(sapply(object, class)) 30 | if (identical(classes, "list")) { 31 | unique(sapply(object, function(sl) { sapply(sl, class) })) 32 | } else { classes } 33 | } 34 | 35 | #' Generate a vector or list of random objects from a particular set of possible choices. 36 | #' 37 | #' @param objects list. The list of objects to generate from. 38 | #' @param amount numeric. The amount of objects to generate. 39 | #' @param list_max_length numeric. What is the maximum size of a given vector or list? 40 | random_objs <- function(objects, amount, list_max_length = 50) { 41 | lengths <- sample(seq(list_max_length), amount, replace = TRUE) 42 | lapply(lengths, function(l) { sample(objects, l, replace = TRUE) }) 43 | } 44 | 45 | #' Generate a random simple string (i.e., a length-1 non-empty vector of characters). 46 | #' @param amount numeric. The amount of simple strings to generate. 47 | #' @param chars logical. Whether or not to include characters. 48 | #' @param utf8 logical. Whether or not to include utf8 characters. 49 | #' @param objects list. The object frame to work from. 50 | random_simple_strings <- function(amount, chars = TRUE, utf8 = FALSE, objects) { 51 | objs <- list() 52 | if (isTRUE(chars)) { objs <- append(objs, objects$characters) } 53 | if (isTRUE(utf8)) { objs <- append(objs, objects$utf8) } 54 | lapply(checkr:::random_objs(objs, amount), function(str) paste0(str, collapse = "")) 55 | } 56 | 57 | #' Generate a random matrix. 58 | #' 59 | #' A random matrix needs three random things... 60 | #' A random width, a random height, and a random data 61 | #' data should be a random assortment of integers, doubles, logicals, or characters, with 62 | #' all of them being the same class. 63 | #' Because there are so many possible matricies, it seems easier to generate them on 64 | #' demand rather than preallocate all possible matricies into default_objects(). 65 | #' We will then populate some random matricies onto default_objects() for later use. 66 | #' 67 | #' @param objects list. The object frame to start from. 68 | random_matrix <- function(objects) { 69 | random_width <- sample(seq(30L), 1) 70 | random_height <- sample(seq(30L), 1) 71 | matrix_classes <- c("integer", "double", "logical", "character", "simple_string") 72 | random_data_class <- sample(matrix_classes, 1) 73 | sample_data <- function(data) { sample(data, random_width * random_height, replace = TRUE) } 74 | random_data <- switch(random_data_class, 75 | integer = sample_data(c(objects$negative_integers, objects$positive_integers)), 76 | double = sample_data(c(objects$negative_doubles, objects$positive_doubles)), 77 | logical = sample_data(objects$logicals), 78 | character = sample_data(c(objects$characters, objects$utf8)), 79 | simple_string = sample_data(random_simple_strings(random_width * random_height, 80 | objects = objects))) 81 | matrix(random_data, random_width, random_height) 82 | } 83 | 84 | #' Get all the user-installed dataframes through data() 85 | installed_dataframes <- function() { 86 | take_only_part_of_name_before_the_space <- function(name) { 87 | if (grepl(" ", name, fixed = TRUE)) { strsplit(name, " ")[[1]][[1]] } 88 | else { name }} 89 | dataframe_names <- lapply(apply(data()$results, 1, `[[`, "Item"), 90 | take_only_part_of_name_before_the_space) 91 | dataframes <- lapply(dataframe_names, function(df) try(get(df), silent = TRUE)) 92 | names(dataframes) <- dataframe_names 93 | dataframes 94 | } 95 | 96 | 97 | #' Generates random R objects to be put into functions for testing purposes. 98 | #' @param objects list. The object frame to work from. 99 | test_objects_ <- function(objects) { 100 | testing_frame <- list() 101 | # start with one of each at random 102 | testing_frame <- append(testing_frame, lapply(objects, function(type) { 103 | random_obj <- sample(type, 1) 104 | if (methods::is(random_obj, "list")) { random_obj[[1]] } else { random_obj } 105 | })) 106 | LIST_SIZE <- 4 # How many different lists of the same kind should be made? 107 | # construct random-length vectors or lists of all types 108 | # (depending on class, vectors when possible) 109 | testing_frame <- append(testing_frame, lapply(objects, function(type) { 110 | checkr:::random_objs(type, LIST_SIZE) 111 | })) 112 | # construct random-length vectors of mixed positive and negative doubles; integers 113 | testing_frame <- append(testing_frame, 114 | checkr:::random_objs(c(objects$positive_doubles, 0, objects$negative_doubles), LIST_SIZE)) 115 | testing_frame <- append(testing_frame, 116 | checkr:::random_objs(c(objects$positive_integers, 0L, objects$negative_integers), LIST_SIZE)) 117 | # construct random-length vectors of single characters 118 | testing_frame <- append(testing_frame, checkr:::random_objs(objects$characters, LIST_SIZE)) 119 | testing_frame <- append(testing_frame, checkr:::random_objs(objects$utf8, LIST_SIZE)) 120 | testing_frame <- append(testing_frame, 121 | checkr:::random_objs(c(objects$characters, objects$utf8), LIST_SIZE)) 122 | # construct random-length simple strings 123 | testing_frame <- append(testing_frame, 124 | random_simple_strings(LIST_SIZE, chars = TRUE, utf8 = FALSE, objects = objects)) 125 | testing_frame <- append(testing_frame, 126 | random_simple_strings(LIST_SIZE, chars = FALSE, utf8 = TRUE, objects = objects)) 127 | testing_frame <- append(testing_frame, 128 | random_simple_strings(LIST_SIZE, chars = TRUE, utf8 = TRUE, objects = objects)) 129 | # construct random-length vectors of simple strings 130 | LIST_MAX_LENGTH <- 50 # What is the maximum size of a given vector or list? 131 | testing_frame <- append(testing_frame, lapply(seq(LIST_SIZE), function(n) { 132 | unlist(random_simple_strings(sample(seq(LIST_MAX_LENGTH), 1), 133 | chars = TRUE, utf8 = FALSE, objects = objects)) })) 134 | testing_frame <- append(testing_frame, lapply(seq(LIST_SIZE), function(n) { 135 | unlist(random_simple_strings(sample(seq(LIST_MAX_LENGTH), 1), 136 | chars = FALSE, utf8 = TRUE, objects = objects)) })) 137 | testing_frame <- append(testing_frame, lapply(seq(LIST_SIZE), function(n) { 138 | unlist(random_simple_strings(sample(seq(LIST_MAX_LENGTH), 1), 139 | chars = TRUE, utf8 = TRUE, objects = objects)) })) 140 | # copy some of the vectors but make them lists 141 | testing_frame <- append(testing_frame, 142 | lapply(Filter(Negate(is.list), testing_frame), as.list)) 143 | # construct random-length lists of mixed doubles and integers 144 | testing_frame <- append(testing_frame, checkr:::random_objs( 145 | c(as.list(objects$positive_doubles), as.list(objects$positive_integers)), LIST_SIZE)) 146 | # construct lists that mix empties into all of the above 147 | testing_frame <- append(testing_frame, 148 | lapply(Filter(Negate(is.empty), Filter(Negate(is.list), testing_frame)), function(item) { 149 | sample(append(item, NA)) 150 | })) 151 | testing_frame <- append(testing_frame, 152 | lapply(Filter(is.list, testing_frame), function(item) { 153 | sample(append(item, sample(objects$empties, 1))) 154 | })) 155 | # make lists that randomly mix all of the above 156 | testing_frame <- append(testing_frame, 157 | lapply(seq(LIST_SIZE), function(n) { 158 | tail(lapply(unname( 159 | Map(c, sample(testing_frame, 1), sample(testing_frame, 1)) 160 | ), sample), LIST_MAX_LENGTH) })) 161 | # and we're done! 162 | testing_frame 163 | } 164 | 165 | test_objects <- memoise::memoise(function(objects = default_objects()) { 166 | testing_frame <- list() 167 | GENERATIONS <- 3 # How many times should the test generation be repeated? 168 | for (generation in seq(GENERATIONS)) { 169 | testing_frame <- append(testing_frame, checkr:::test_objects_(objects)) 170 | } 171 | testing_frame 172 | }) 173 | 174 | #' Function to force reload the test object cache, if needed. 175 | force_reload_test_objects <- function() { 176 | memoise::forget(checkr:::test_objects) 177 | memoise::forget(checkr:::default_objects) 178 | checkr:::test_objects(checkr:::default_objects()) 179 | TRUE 180 | } 181 | -------------------------------------------------------------------------------- /R/is.R: -------------------------------------------------------------------------------- 1 | #' Test for class membership 2 | #' 3 | #' @param match_object ANY. The object to test for class. 4 | #' @param expected_class character. The name of the expected class. 5 | #' @examples 6 | #' 1 %is% numeric 7 | #' 1.0 %is% double 8 | #' 1L %is% integer 9 | #' iris %is% dataframe 10 | #' c("a", "b", "c") %is% vector 11 | #' "pizza" %is% simple_string 12 | #' list(a = "pizza", b = "pie") %is% c("character", "list") 13 | #' @return Boolean whether or not the match_object is the expected_class. 14 | #' @export 15 | `%is%` <- function(match_object, expected_class) { 16 | if (is.name(substitute(expected_class))) { 17 | expected_class <- deparse(substitute(expected_class)) 18 | } 19 | checkr:::`%is_%`(match_object, expected_class) 20 | } 21 | 22 | 23 | `%is_%` <- function(match_object, expected_class) { 24 | if (length(expected_class) > 1) { 25 | return(all(vapply(expected_class, `%is%`, 26 | match_object = match_object, logical(1)))) 27 | } 28 | 29 | 30 | if (identical(expected_class, NULL)) { 31 | expected_class <- "NULL" 32 | } 33 | if (identical(expected_class, NA)) { 34 | expected_class <- "NA" 35 | } 36 | if (identical(expected_class, "string")) { 37 | expected_class <- "character" 38 | } 39 | if (identical(expected_class, "dataframe")) { 40 | expected_class <- "data.frame" 41 | } 42 | 43 | if (identical(tolower(expected_class), "any")) { 44 | return(TRUE) 45 | } 46 | if (identical(expected_class, "simple_string")) { 47 | return(checkr::is.simple_string(match_object)) 48 | } 49 | if (identical(expected_class, "double")) { 50 | return(is.double(match_object)) 51 | } 52 | if (identical(expected_class, "empty")) { 53 | return(checkr::is.empty(match_object)) 54 | } 55 | if (identical(expected_class, "NA")) { 56 | return(!is.null(match_object) && is.na(match_object)) 57 | } 58 | if (identical(expected_class, "vector")) { 59 | return(is.vector(match_object) && !methods::is(match_object, "list")) 60 | } 61 | if (identical(expected_class, "atomic")) { 62 | return(is.atomic(match_object)) 63 | } 64 | methods::is(match_object, expected_class) 65 | } 66 | 67 | #' Test whether a match object is not a member of a particular class. 68 | #' @rdname grapes-is-grapes 69 | #' @export 70 | `%isnot%` <- function(match_object, expected_class) { 71 | if (is.name(substitute(expected_class))) { 72 | expected_class <- deparse(substitute(expected_class)) 73 | } 74 | !(checkr:::`%is_%`(match_object, expected_class)) 75 | } 76 | -------------------------------------------------------------------------------- /R/package.R: -------------------------------------------------------------------------------- 1 | #' Checkr is a testing tool for R. 2 | #' 3 | #' @docType package 4 | #' @name checkr 5 | #' @import memoise methods 6 | NULL 7 | -------------------------------------------------------------------------------- /R/package_exports_checked.R: -------------------------------------------------------------------------------- 1 | #' Checks if all exported functions in the package are checked using checkr. 2 | #' 3 | #' @param package character. The name of the package to check. 4 | #' @param stop logical. If TRUE, errors and tells you which functions are 5 | #' not checked. If FALSE, the function will return FALSE. 6 | #' @return either a logical or an error. 7 | #' @export 8 | package_exports_checked <- function(package, stop = TRUE) { 9 | if (!(package %in% rownames(installed.packages()))) { 10 | package <- devtools::as.package(package)$package 11 | } 12 | exports <- getNamespaceExports(package) 13 | errors <- lapply(exports, function(export) { 14 | fn <- get(export, envir = getNamespace(package)) 15 | if (checkr::should_be_checked(fn)) { 16 | checkr::is.validated_function(fn) 17 | } else { TRUE }}) 18 | names(errors) <- exports 19 | errors <- Filter(function(x) identical(x, FALSE), errors) 20 | if (length(errors) > 0) { 21 | if (isTRUE(stop)) { 22 | stop("The following functions are not checked by checkr: ", 23 | paste0(names(errors), collapse = ", ")) 24 | } else { return(FALSE) } 25 | } 26 | TRUE 27 | } 28 | 29 | #' Determine whether a function ought to be checked with checkr. 30 | #' 31 | #' Functions should be checked as long as they have formals. 32 | #' @param fn function. The function to check. 33 | #' @export 34 | should_be_checked <- function(fn) { length(formals(fn)) > 0 } 35 | 36 | #' Determine whether a function is checked with checkr. 37 | #' 38 | #' @param fn function. The function to check. 39 | #' @export 40 | is.validated_function <- function(fn) { methods::is(fn, "validated_function") } 41 | -------------------------------------------------------------------------------- /R/present.R: -------------------------------------------------------------------------------- 1 | #' Tests whether an argument to a function is present. 2 | #' 3 | #' This function is the opposite of missing. 4 | #' @param ... list. The list of things to check for presence. 5 | #' @export 6 | present <- function(...) { 7 | try(get(deparse(substitute(...)), 8 | envir = parent.frame(), inherits = FALSE), silent = TRUE) %isnot% "try-error" 9 | } 10 | -------------------------------------------------------------------------------- /R/quickcheck.R: -------------------------------------------------------------------------------- 1 | get_testing_frame <- function(formals, frame) { 2 | if (is.null(frame)) { 3 | lapply(seq_along(formals), function(n) sample(checkr:::test_objects())) 4 | } else { 5 | if (!identical(formals, names(frame))) { 6 | stop("The custom testing_frame you submitted does not match the formals.") 7 | } else { 8 | frame 9 | } 10 | } 11 | } 12 | 13 | 14 | #' Create the necessary testing objects to quickcheck a function. 15 | #' 16 | #' @param fn function. A function to generate test objects for. 17 | #' @param pre list. A list of explicit preconditions to pass, if desired. 18 | #' @param frame list. A custom testing_frame to use, if necessary. 19 | #' @export 20 | function_test_objects <- function(fn = NULL, pre = NULL, frame = NULL) { 21 | if (methods::is(fn, "validated_function") || !is.null(substitute(pre))) { 22 | if (methods::is(fn, "validated_function")) { 23 | preconditions <- preconditions(fn) 24 | formals <- names(formals(checkr::get_prevalidated_fn(fn))) 25 | } else { 26 | preconditions <- substitute(pre) 27 | formals <- "x" 28 | } 29 | if (preconditions[[1]] != substitute(list) && is.call(preconditions)) { 30 | preconditions <- list(preconditions) 31 | } 32 | if (length(preconditions) > 1) { preconditions <- preconditions[-1] } 33 | if (length(formals) == 0) { 34 | stop("You cannot quickcheck a function with no arguments.") 35 | } 36 | testing_frame <- checkr:::get_testing_frame(formals, frame) 37 | testing_frame <- tryCatch(lapply(seq_along(testing_frame), function(pos) { 38 | # First we try calculating each input independently so that we can maximize 39 | # the number of test samples. 40 | frame <- testing_frame[[pos]] 41 | Filter(function(item) { 42 | env <- list(item) 43 | names(env) <- formals[[pos]] 44 | for (precondition in as.list(preconditions)) { 45 | if (!grepl(formals[[pos]], deparse(precondition), fixed = TRUE)) { next } 46 | if (!isTRUE(eval(precondition, envir = env))) { return(FALSE) } 47 | } 48 | TRUE 49 | }, frame) 50 | }), error = function(e) { 51 | # If there was an error, we assume it was because of interdependent 52 | # preconditions, so we go to the backup of calculating the arguments jointly. 53 | lapply(lapply(testing_frame, function(frame) { 54 | lapply(seq_along(testing_frame[[1]]), function(pos) { 55 | env <- lapply(testing_frame, `[[`, pos) 56 | names(env) <- formals 57 | for (precondition in as.list(preconditions)) { 58 | if (!isTRUE(eval(precondition, envir = env))) { return(NULL) } 59 | } 60 | frame[[pos]] 61 | }) }), function(frame) { Filter(Negate(is.null), frame) }) 62 | }) 63 | } else { 64 | formals <- names(formals(fn)) 65 | testing_frame <- checkr:::get_testing_frame(formals, frame) 66 | } 67 | names(testing_frame) <- formals 68 | testing_frame 69 | } 70 | 71 | #' Print function arguments 72 | #' @param x ANY. The object to print args for. 73 | #' @examples 74 | #' l <- list(x = seq(3), y = seq(4)) 75 | #' checkr:::print_args(l) 76 | print_args <- function(x) { 77 | paste0(paste(names(x), 78 | unname(sapply(x, function(y) { 79 | # Correct for the tendency of capture.output to go over one string. 80 | gsub(" ", "", paste0(capture.output(dput(y)), collapse = "")) 81 | })), sep = " = "), collapse = ", ") 82 | } 83 | 84 | 85 | #' Get the name from a passed function, which may be a validated function or just a block. 86 | #' 87 | #' @param orig_function_name call. A substituted call of the function. 88 | function_name <- function(orig_function_name) { 89 | function_name <- if (identical(deparse(as.list(orig_function_name)[[1]]), "ensure")) { 90 | as.list(orig_function_name)[length(as.list(orig_function_name))][[1]] 91 | } else { 92 | orig_function_name 93 | } 94 | deparse(function_name) 95 | } 96 | 97 | 98 | #' Quickcheck a function. 99 | #' 100 | #' Tests a function with many automatically generated inputs, checking that stated 101 | #' postconditions hold. 102 | #' 103 | #' If given a function of class \code{validated_function}, the pre- and post-conditions can 104 | #' be automatically inferred by the definition of the function. The test objects used to 105 | #' test the function will be screened ahead of time to ensure they meet the preconditions. 106 | #' 107 | #' @param fn function. A function to randomly check postconditions for. 108 | #' @param postconditions list. Optional postconditions to quickcheck for. 109 | #' @param verbose logical. Whether or not to announce the success. 110 | #' @param testthat logical. Whether or not to run testthat. 111 | #' @param frame list. A custom testing_frame to use, if necessary. 112 | #' @return either TRUE if the function passed the quickcheck or FALSE if it didn't. 113 | #' @export 114 | quickcheck <- function(fn, postconditions = NULL, verbose = TRUE, testthat = TRUE, 115 | frame = NULL) { 116 | post <- substitute(postconditions) 117 | testing_frame <- checkr:::function_test_objects(fn, frame = frame) 118 | if (any(vapply(testing_frame, length, numeric(1)) == 0)) { 119 | stop("No quickcheck testing frame was generated. Make sure your preconditions aren't", 120 | " impossible to satisfy!") 121 | } 122 | function_name <- function_name(substitute(fn)) 123 | if (length(function_name) > 1) { function_name <- function_name[[1]] } 124 | failed <- FALSE 125 | for (pos in seq_along(testing_frame[[1]])) { 126 | if (identical(failed, FALSE)) { 127 | args <- lapply(testing_frame, `[[`, pos) 128 | tryCatch({ 129 | result <- do.call(fn, args) 130 | checkr:::validate_(post, env = list(result = result)) 131 | }, error = function(e) { 132 | failed <<- TRUE 133 | }) 134 | } 135 | } 136 | if (identical(failed, FALSE)) { 137 | if (isTRUE(verbose)) { 138 | message("Quickcheck for ", function_name, " passed on ", pos, " random examples!") 139 | } 140 | if (isTRUE(testthat)) { testthat::expect_true(TRUE) } 141 | TRUE 142 | } else { 143 | error_msg <- paste0("Quickcheck for ", function_name, " failed on item #", pos, ": ", 144 | print_args(args)) 145 | if (isTRUE(verbose) && !isTRUE(testthat)) { message(error_msg) } 146 | if (isTRUE(testthat)) { testthat::expect_true(FALSE, error_msg) } 147 | FALSE 148 | } 149 | } 150 | #TODO: Handle splats 151 | #TODO, but later: Can mix-in your own custom objects into the test objects 152 | -------------------------------------------------------------------------------- /R/simple_string.R: -------------------------------------------------------------------------------- 1 | #' Tests whether a string is simple. 2 | #' 3 | #' A simple string is an R object that is a length-1 vector of non-empty characters. 4 | #' 5 | #' @param string character. 6 | #' @examples 7 | #' is.simple_string("pizza") # true 8 | #' is.simple_string(c("pizza", "apple")) # false 9 | #' is.simple_string(iris) # false 10 | #' is.simple_string(NA) # false 11 | #' @return a boolean whether or not string is simple string. 12 | #' @export 13 | is.simple_string <- function(string) { 14 | is.character(string) && length(string) == 1 && nzchar(string) && !is.na(string) 15 | } 16 | -------------------------------------------------------------------------------- /R/validate.R: -------------------------------------------------------------------------------- 1 | #' Validate checks that certain facts are true. 2 | #' 3 | #' @param ... list. A list of conditions to check. 4 | #' @examples 5 | #' validate(1 == 1, "a" %is% character, length(c(1, 2, 3)) == 3) 6 | #' @return Either TRUE or stops with a list of errors. 7 | #' @export 8 | validate <- function(...) { 9 | conditions <- substitute(list(...)) 10 | checkr:::validate_(conditions) 11 | } 12 | 13 | #' Validate without NSE. 14 | #' @param conditions list. A list of conditions to check. 15 | #' @param env environment. An optional environment to evaluate within. Defaults to 16 | #' \code{parent.frame(2)}, which contains the variables in the scope immediately beyond 17 | #' the validate (though not the validate_) function. 18 | #' @export 19 | validate_ <- function(conditions, env = parent.frame(2)) { 20 | # Substituted R expressions have length > 1, so we need to wrap them in lists. 21 | if (conditions[[1]] != substitute(list) && is.call(conditions)) { 22 | conditions <- list(conditions) 23 | } 24 | errors <- Filter(Negate(is.null), lapply(conditions, checkr:::verify_condition, env = env)) 25 | if (length(errors) > 0) { 26 | stop("Error on ", paste(errors, collapse = ", "), call. = FALSE) 27 | } 28 | TRUE 29 | } 30 | 31 | verify_condition <- function(condition, env) { 32 | if (identical(eval(condition, envir = env), FALSE)) { deparse(condition) } 33 | else { NULL } 34 | } 35 | -------------------------------------------------------------------------------- /R/within.R: -------------------------------------------------------------------------------- 1 | #' Define if a number is within a certain range. 2 | #' 3 | #' @param num numeric. The number to check. 4 | #' @param range numeric. A vector with one number specifying the lower-bound and another 5 | #' number specifying the upper-bound. 6 | #' @export 7 | `%within%` <- ensure( 8 | pre = list(num %is% numeric, 9 | range %is% vector, length(range) == 2, range %contains_only% numeric), 10 | post = result %is% logical, 11 | from <- function(num, range) { 12 | num >= range[[1]] & num <= range[[2]] 13 | }) 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Checkr 2 | 3 | R is a dynamically typed language. This is pretty great for writing code quickly, but bad for architecturing large systems. 4 | 5 | While [some have tried admirably](https://github.com/zatonovo/lambda.r), it seems like a bad idea to enforce a lot of static checks on R functions. However, we can still be explicit about our preconditions and postconditions when writing R functions, to adopt a solid functional style. 6 | 7 | Things still die on runtime instead of compile-time, which is sad, but functions are more explicit about what they do and less tests need to be written -- better than the status quo! 8 | 9 | Another problem is writing tests. Thanks to Hadley's [testthat package](https://github.com/hadley/testthat), writing tests for R code [is pretty easy](http://r-pkgs.had.co.nz/). But writing tests take a long time and it's easy to forget to write certain tests. And [while coverage tools in R exist](https://github.com/jimhester/covr), 100% test coverage is still insufficient for verifying that your code works. 10 | 11 | Quickcheck, inspired by [the Haskell namesake](https://github.com/nick8325/quickcheck) (and in true Haskell style you can [see the corresponding academic paper](http://www.eecs.northwestern.edu/~robby/courses/395-495-2009-fall/quick.pdf)), aims to automatically verify your code through running hundreds of tests that you don't have to write yourself. Checkr implements a version of this in R so that you can generate tests automatically without having to write them yourself. 12 | 13 | **Checkr** provides helpers to easily validate and test R functions. 14 | 15 | 16 | ## Validations 17 | 18 | ```R 19 | library(checkr) 20 | 21 | #' Add two numbers. 22 | #' 23 | #' @param x numeric. The number to add. 24 | #' @param y numeric. The number to add. 25 | add <- ensure( 26 | pre = list(x %is% numeric, y %is% numeric), 27 | post = result %is% numeric, # `result` matches whatever the function returns. 28 | function(x, y) x + y) 29 | add(1, 2) 30 | # 3 31 | add("a", 2) 32 | # Error on x %is% numeric 33 | add("a", "b") 34 | # Error on x %is% numeric, y %is% numeric. 35 | ``` 36 | 37 | ```R 38 | #' Generate a random string. 39 | #' 40 | #' @param length numeric. The length of the random string to generate. 41 | #' @param alphabet character. A list of characters to draw from to create the string. 42 | random_string <- ensure( 43 | pre = list(length %is% numeric, length(length) == 1, length > 0, 44 | length < 1e+7, length %% 1 == 0, 45 | alphabet %is% list || alphabet %is% vector, 46 | alphabet %contains_only% simple_string, 47 | all(sapply(alphabet, nchar) == 1)), 48 | post = list(result %is% simple_string, nchar(result) == length), 49 | function(length, alphabet) { 50 | paste0(sample(alphabet, length, replace = TRUE), collapse = "") 51 | }) 52 | ``` 53 | 54 | 55 | 56 | ## Using Quickcheck 57 | 58 | #### The Random String 59 | 60 | Imagine you want to generate a random string of a given length from a given possible alphabet of characters. Your R function might look like this: 61 | 62 | ```R 63 | random_string <- function(length, alphabet) { 64 | paste0(sample(alphabet, 10), collapse = "") 65 | } 66 | ``` 67 | 68 | This is a pretty simple function, but it's possible to make an error even on something this simple -- as you can see, we accidentally hardcoded the length as 10 instead of using the built-in `length` parameter (this isn't contrived -- this is a typo [I have made in real life](https://github.com/peterhurford/checkr/commit/585af6de4ee25622dfaa665e83106a2398cc946c)). 69 | 70 | We may write some tests using testthat: 71 | 72 | ```R 73 | test_that("it generates a random string from the given alphabet", { 74 | random_string <- random_string(10, letters) 75 | all(strsplit(random_string, "")[[1]] %in% letters) 76 | }) 77 | test_that("it generates a random string of the given length", { 78 | random_string <- random_string(10, letters) 79 | expect_equal(nchar(random_string), 10) 80 | }) 81 | ``` 82 | 83 | But because we were lazy when writing the tests and had 10 in our mind, all the tests pass and we don't catch our error. 84 | 85 | Additionally, we don't look for other errors, such as: 86 | 87 | (a) Does it work when the alphabet is only a length 1 list? 88 | 89 | (b) Does it work when the alphabet is a string? 90 | 91 | (c) Does it work when length is a negative number? 92 | 93 | (d) Does it work when length is a list? 94 | 95 | For example, if we had written a thorough test for (a), we would have noticed that we're using `sample` with `replace = FALSE`, which means that if the `length` is larger than `length(alphabet)`, the function will crash. We should use `replace = TRUE` instead! 96 | 97 | ...So we could add all these tests ourselves and be really thorough, or we could use quickcheck and just automatically test some simple properties: 98 | 99 | ```R 100 | quickcheck(ensure( 101 | pre = list(length %is% numeric, length(length) == 1, length > 0, length < 1e+7, 102 | alphabet %is% list || alphabet %is% vector, 103 | alphabet %contains_only% simple_string), 104 | post = list(nchar(result) == length, length(result) == 1, 105 | is.character(result), all(strsplit(result, "")[[1]] %in% alphabet)), 106 | random_string)) 107 | ``` 108 | ``` 109 | Error: Quickcheck for random_string failed on item #1: length = 53L, alphabet = list("shtafWoWGRWmCSIRquDNxqskiKGyVdHFApld") 110 | ``` 111 | 112 | We use `ensure` to specify preconditions for what random items we should test our function with and to specify postconditions that must hold true for every run that satisfies the preconditions. (I recommend making every-day use of validations even if not doing `quickcheck`, because it creates more clear functions that are more explicit about what they require and are less likely to crash in confusing ways. ...They're also way easier to quickcheck.) 113 | 114 | This quickcheck will automatically generate possible arguments that match the preconditions and then do some verifications, such as (a) verifying that the number of characters of the resulting string is the same as the `length` that you passed into the function, (b) that the resulting string is not a length > 1 vector, (c) that the resulting string is all characters, and (d) that all the characters in the string are within the given `alphabet`. 115 | 116 | This easily accomplishes in two lines what normally takes five well thought-out and detailed tests. 117 | 118 | (Why `length < 1e+7`?... Another thing I learned only by quickchecking -- you can break `sample` with sufficiently large lengths.) 119 | 120 | #### Reversing and Property-based Testing 121 | 122 | Let's say that we want to be confident that the `rev` function in R's base works as intended to reverse a list. We could create a few test cases ourselves, or we could use quickcheck to specify **properties** that should hold about `rev` are actually true over our randomly generated examples: 123 | 124 | First, we know that reversing a length-1 list should be itself. 125 | 126 | ```R 127 | quickcheck(ensure(pre = list(length(x) == 1, x %is% vector || x %is% list), 128 | post = identical(result, x), function(x) rev(x))) 129 | ``` 130 | 131 | And when we run the Quickcheck, we get: 132 | 133 | ``` 134 | Quickcheck for function(x) rev(x) passed on 132 random examples! 135 | ``` 136 | 137 | ...Here, 576 random possible test objects were created and these objects were filtered down to the 132 ones that met the specified preconditions (input must be a length 1 vector or list). All of these were then sent to the `rev` function and the result was then checked against the postcondition that `identical(result, x)` to make sure the result is identical to the original `x`. 138 | 139 | And we can also test that the reverse of a reverse of a list is that same list: 140 | 141 | ```R 142 | quickcheck(ensure(pre = list(x %is% vector || x %is% list), 143 | post = identical(result, x), function(x) rev(rev(x)))) 144 | ``` 145 | ``` 146 | Quickcheck for function(x) rev(rev(x)) passed on 708 random examples! 147 | ``` 148 | 149 | 150 | ## Why not use Quickcheck by Revolution Analytics? 151 | 152 | In June 2015 (8 months before me), Revolution Analytics released [their own version of Quickcheck for R](https://github.com/RevolutionAnalytics/quickcheck) which works [to also automatically verify properties of R functions](https://github.com/RevolutionAnalytics/quickcheck/blob/master/docs/tutorial.md). 153 | 154 | However, this version of Quickcheck has a few important improvements: 155 | 156 | (1) The tight integration with validations lets you more clearly specify the preconditions and postconditions. 157 | 158 | (2) You can be a lot more specific about the preconditions you can specify on the random objects. Revolution Analytics' objects are always one class and all objects of that class, whereas with this package you can mix and match classes and specify other things (e.g., all >0). 159 | 160 | (3) The random object generator is smarter (a.k.a. biased), making sure to explicitly test important things you might forget (e.g., a vector of all negative numbers) and that might not come up in a truly random generator (like Revolution Analytics'). 161 | 162 | (4) This version naturally integrates with Hadley's popular testthat package. 163 | 164 | 165 | ## Installation 166 | 167 | This package is not yet available from CRAN. Instead, it can be installed using [devtools](http://www.github.com/hadley/devtools): 168 | 169 | ```R 170 | if (!require("devtools")) { install.packages("devtools") } 171 | devtools::install_github("peterhurford/checkr") 172 | ``` 173 | 174 | 175 | ## Credits 176 | 177 | Inspired by [Cobra](http://cobra-language.com/). 178 | 179 | Similar to the [ensurer](https://github.com/smbache/ensurer) package (and I think these two packages would work well together), but I didn't remember that package existed until now. 180 | 181 | Also similar in syntax to [RDL](https://github.com/plum-umd/rdl) in Ruby, which I did not know about until months after I made this package. 182 | -------------------------------------------------------------------------------- /man/checkr.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/package.R 3 | \docType{package} 4 | \name{checkr} 5 | \alias{checkr} 6 | \alias{checkr-package} 7 | \title{Checkr is a testing tool for R.} 8 | \description{ 9 | Checkr is a testing tool for R. 10 | } 11 | -------------------------------------------------------------------------------- /man/ensure.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ensure.R 3 | \name{ensure} 4 | \alias{ensure} 5 | \title{Ensure checks that certain preconditions and postconditions of a function are true.} 6 | \usage{ 7 | ensure(checker_fn, preconditions = list(), postconditions = list()) 8 | } 9 | \arguments{ 10 | \item{checker_fn}{function. A function to run with validated pre- and postconditions.} 11 | 12 | \item{preconditions}{list. A list of preconditions to check.} 13 | 14 | \item{postconditions}{list. A list of postconditions to check.} 15 | } 16 | \value{ 17 | The original function, but also of class validated_function, with added validations. 18 | } 19 | \description{ 20 | Ensure checks that certain preconditions and postconditions of a function are true. 21 | } 22 | \examples{ 23 | add <- ensure(pre = list(x \%is\% numeric, y \%is\% numeric), 24 | post = list(result \%is\% numeric), 25 | function(x, y) { x + y }) 26 | } 27 | -------------------------------------------------------------------------------- /man/force_reload_test_objects.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/generate.R 3 | \name{force_reload_test_objects} 4 | \alias{force_reload_test_objects} 5 | \title{Function to force reload the test object cache, if needed.} 6 | \usage{ 7 | force_reload_test_objects() 8 | } 9 | \description{ 10 | Function to force reload the test object cache, if needed. 11 | } 12 | -------------------------------------------------------------------------------- /man/function_name.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/quickcheck.R 3 | \name{function_name} 4 | \alias{function_name} 5 | \title{Get the name from a passed function, which may be a validated function or just a block.} 6 | \usage{ 7 | function_name(orig_function_name) 8 | } 9 | \arguments{ 10 | \item{orig_function_name}{call. A substituted call of the function.} 11 | } 12 | \description{ 13 | Get the name from a passed function, which may be a validated function or just a block. 14 | } 15 | -------------------------------------------------------------------------------- /man/function_test_objects.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/quickcheck.R 3 | \name{function_test_objects} 4 | \alias{function_test_objects} 5 | \title{Create the necessary testing objects to quickcheck a function.} 6 | \usage{ 7 | function_test_objects(fn = NULL, pre = NULL, frame = NULL) 8 | } 9 | \arguments{ 10 | \item{fn}{function. A function to generate test objects for.} 11 | 12 | \item{pre}{list. A list of explicit preconditions to pass, if desired.} 13 | 14 | \item{frame}{list. A custom testing_frame to use, if necessary.} 15 | } 16 | \description{ 17 | Create the necessary testing objects to quickcheck a function. 18 | } 19 | -------------------------------------------------------------------------------- /man/get_prevalidated_fn.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ensure.R 3 | \name{get_prevalidated_fn} 4 | \alias{get_prevalidated_fn} 5 | \title{Get the pre-validated function that is wrapped in validations.} 6 | \usage{ 7 | get_prevalidated_fn(fn) 8 | } 9 | \arguments{ 10 | \item{fn}{validated_function. The function to get the pre-validated function for.} 11 | } 12 | \value{ 13 | a call containing the postconditions. 14 | } 15 | \description{ 16 | Get the pre-validated function that is wrapped in validations. 17 | } 18 | -------------------------------------------------------------------------------- /man/grapes-contains-grapes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/contains.R 3 | \name{\%contains\%} 4 | \alias{\%contains\%} 5 | \alias{\%does_not_contain\%} 6 | \alias{\%contains_only\%} 7 | \title{Test if a list contains some elements of the desired class.} 8 | \usage{ 9 | match_list \%contains\% expected_class 10 | 11 | match_list \%does_not_contain\% expected_class 12 | 13 | match_list \%contains_only\% expected_class 14 | } 15 | \arguments{ 16 | \item{match_list}{list. The list to test for class of the elements.} 17 | 18 | \item{expected_class}{character. The name of the expected class to test.} 19 | } 20 | \value{ 21 | Boolean whether or not the match_list has at least one element of expected_class. 22 | 23 | Boolean whether or not the match_list has no elements of the expected_class. 24 | 25 | Boolean whether or not the match_list has all elements of expected_class. 26 | } 27 | \description{ 28 | Test if a list contains some elements of the desired class. 29 | 30 | Test if a list does not contain some elements of the desired class. 31 | 32 | Test if a list contains only elements of the desired class. 33 | } 34 | \examples{ 35 | list(1, 2, 3) \%contains\% numeric 36 | list(1, 2, "a") \%contains\% numeric 37 | list(1, 2, 3) \%does_not_contain\% character 38 | list(1, 2, 3) \%contains_only\% numeric 39 | list(1, 2, "a") \%contains_only\% numeric 40 | } 41 | -------------------------------------------------------------------------------- /man/grapes-is-grapes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/is.R 3 | \name{\%is\%} 4 | \alias{\%is\%} 5 | \alias{\%isnot\%} 6 | \title{Test for class membership} 7 | \usage{ 8 | match_object \%is\% expected_class 9 | 10 | match_object \%isnot\% expected_class 11 | } 12 | \arguments{ 13 | \item{match_object}{ANY. The object to test for class.} 14 | 15 | \item{expected_class}{character. The name of the expected class.} 16 | } 17 | \value{ 18 | Boolean whether or not the match_object is the expected_class. 19 | } 20 | \description{ 21 | Test for class membership 22 | 23 | Test whether a match object is not a member of a particular class. 24 | } 25 | \examples{ 26 | 1 \%is\% numeric 27 | 1.0 \%is\% double 28 | 1L \%is\% integer 29 | iris \%is\% dataframe 30 | c("a", "b", "c") \%is\% vector 31 | "pizza" \%is\% simple_string 32 | list(a = "pizza", b = "pie") \%is\% c("character", "list") 33 | } 34 | -------------------------------------------------------------------------------- /man/grapes-within-grapes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/within.R 3 | \name{\%within\%} 4 | \alias{\%within\%} 5 | \title{Define if a number is within a certain range.} 6 | \usage{ 7 | num \%within\% range 8 | } 9 | \arguments{ 10 | \item{num}{numeric. The number to check.} 11 | 12 | \item{range}{numeric. A vector with one number specifying the lower-bound and another number specifying the upper-bound.} 13 | } 14 | \description{ 15 | Define if a number is within a certain range. 16 | } 17 | -------------------------------------------------------------------------------- /man/installed_dataframes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/generate.R 3 | \name{installed_dataframes} 4 | \alias{installed_dataframes} 5 | \title{Get all the user-installed dataframes through data()} 6 | \usage{ 7 | installed_dataframes() 8 | } 9 | \description{ 10 | Get all the user-installed dataframes through data() 11 | } 12 | -------------------------------------------------------------------------------- /man/is.empty.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/empty.R 3 | \name{is.empty} 4 | \alias{is.empty} 5 | \alias{is_empty} 6 | \title{Tests whether an object is empty.} 7 | \usage{ 8 | is.empty(obj) 9 | 10 | is_empty(obj) 11 | } 12 | \arguments{ 13 | \item{obj}{ANY. The object to test.} 14 | } 15 | \value{ 16 | a boolean whether or not the object is empty. 17 | } 18 | \description{ 19 | Empty items are NULL, NA, or nothing (length 0). 20 | } 21 | \examples{ 22 | is.empty(NULL) 23 | is.empty(NA) 24 | is.empty(list(NULL, NA)) 25 | is.empty(list()) 26 | is.empty(c()) 27 | is.empty(data.frame()) 28 | is.empty("") 29 | is.empty(data.frame()) 30 | } 31 | -------------------------------------------------------------------------------- /man/is.simple_string.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/simple_string.R 3 | \name{is.simple_string} 4 | \alias{is.simple_string} 5 | \title{Tests whether a string is simple.} 6 | \usage{ 7 | is.simple_string(string) 8 | } 9 | \arguments{ 10 | \item{string}{character.} 11 | } 12 | \value{ 13 | a boolean whether or not string is simple string. 14 | } 15 | \description{ 16 | A simple string is an R object that is a length-1 vector of non-empty characters. 17 | } 18 | \examples{ 19 | is.simple_string("pizza") # true 20 | is.simple_string(c("pizza", "apple")) # false 21 | is.simple_string(iris) # false 22 | is.simple_string(NA) # false 23 | } 24 | -------------------------------------------------------------------------------- /man/is.validated_function.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/package_exports_checked.R 3 | \name{is.validated_function} 4 | \alias{is.validated_function} 5 | \title{Determine whether a function is checked with checkr.} 6 | \usage{ 7 | is.validated_function(fn) 8 | } 9 | \arguments{ 10 | \item{fn}{function. The function to check.} 11 | } 12 | \description{ 13 | Determine whether a function is checked with checkr. 14 | } 15 | -------------------------------------------------------------------------------- /man/list_classes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/generate.R 3 | \name{list_classes} 4 | \alias{list_classes} 5 | \title{Get all the classes within a list.} 6 | \usage{ 7 | list_classes(object) 8 | } 9 | \arguments{ 10 | \item{object}{ANY. The object to check classes for.} 11 | } 12 | \description{ 13 | Get all the classes within a list. 14 | } 15 | -------------------------------------------------------------------------------- /man/package_exports_checked.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/package_exports_checked.R 3 | \name{package_exports_checked} 4 | \alias{package_exports_checked} 5 | \title{Checks if all exported functions in the package are checked using checkr.} 6 | \usage{ 7 | package_exports_checked(package, stop = TRUE) 8 | } 9 | \arguments{ 10 | \item{package}{character. The name of the package to check.} 11 | 12 | \item{stop}{logical. If TRUE, errors and tells you which functions are 13 | not checked. If FALSE, the function will return FALSE.} 14 | } 15 | \value{ 16 | either a logical or an error. 17 | } 18 | \description{ 19 | Checks if all exported functions in the package are checked using checkr. 20 | } 21 | -------------------------------------------------------------------------------- /man/postconditions.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ensure.R 3 | \name{postconditions} 4 | \alias{postconditions} 5 | \title{Get the stated postconditions of a validated function.} 6 | \usage{ 7 | postconditions(fn) 8 | } 9 | \arguments{ 10 | \item{fn}{validated_function. The function to get the postconditions for.} 11 | } 12 | \value{ 13 | a call containing the postconditions. 14 | } 15 | \description{ 16 | Get the stated postconditions of a validated function. 17 | } 18 | -------------------------------------------------------------------------------- /man/preconditions.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ensure.R 3 | \name{preconditions} 4 | \alias{preconditions} 5 | \title{Get the stated preconditions of a validated function.} 6 | \usage{ 7 | preconditions(fn) 8 | } 9 | \arguments{ 10 | \item{fn}{validated_function. The function to get the preconditions for.} 11 | } 12 | \value{ 13 | a call containing the preconditions. 14 | } 15 | \description{ 16 | Get the stated preconditions of a validated function. 17 | } 18 | -------------------------------------------------------------------------------- /man/present.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/present.R 3 | \name{present} 4 | \alias{present} 5 | \title{Tests whether an argument to a function is present.} 6 | \usage{ 7 | present(...) 8 | } 9 | \arguments{ 10 | \item{...}{list. The list of things to check for presence.} 11 | } 12 | \description{ 13 | This function is the opposite of missing. 14 | } 15 | -------------------------------------------------------------------------------- /man/print.validated_function.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ensure.R 3 | \name{print.validated_function} 4 | \alias{print.validated_function} 5 | \title{Print validated functions more clearly.} 6 | \usage{ 7 | \method{print}{validated_function}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{function. The function to print.} 11 | 12 | \item{...}{list. Additional arguments to pass to print.} 13 | } 14 | \description{ 15 | Print validated functions more clearly. 16 | } 17 | -------------------------------------------------------------------------------- /man/print_args.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/quickcheck.R 3 | \name{print_args} 4 | \alias{print_args} 5 | \title{Print function arguments} 6 | \usage{ 7 | print_args(x) 8 | } 9 | \arguments{ 10 | \item{x}{ANY. The object to print args for.} 11 | } 12 | \description{ 13 | Print function arguments 14 | } 15 | \examples{ 16 | l <- list(x = seq(3), y = seq(4)) 17 | checkr:::print_args(l) 18 | } 19 | -------------------------------------------------------------------------------- /man/quickcheck.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/quickcheck.R 3 | \name{quickcheck} 4 | \alias{quickcheck} 5 | \title{Quickcheck a function.} 6 | \usage{ 7 | quickcheck(fn, postconditions = NULL, verbose = TRUE, testthat = TRUE, 8 | frame = NULL) 9 | } 10 | \arguments{ 11 | \item{fn}{function. A function to randomly check postconditions for.} 12 | 13 | \item{postconditions}{list. Optional postconditions to quickcheck for.} 14 | 15 | \item{verbose}{logical. Whether or not to announce the success.} 16 | 17 | \item{testthat}{logical. Whether or not to run testthat.} 18 | 19 | \item{frame}{list. A custom testing_frame to use, if necessary.} 20 | } 21 | \value{ 22 | either TRUE if the function passed the quickcheck or FALSE if it didn't. 23 | } 24 | \description{ 25 | Tests a function with many automatically generated inputs, checking that stated 26 | postconditions hold. 27 | } 28 | \details{ 29 | If given a function of class \code{validated_function}, the pre- and post-conditions can 30 | be automatically inferred by the definition of the function. The test objects used to 31 | test the function will be screened ahead of time to ensure they meet the preconditions. 32 | } 33 | -------------------------------------------------------------------------------- /man/random_matrix.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/generate.R 3 | \name{random_matrix} 4 | \alias{random_matrix} 5 | \title{Generate a random matrix.} 6 | \usage{ 7 | random_matrix(objects) 8 | } 9 | \arguments{ 10 | \item{objects}{list. The object frame to start from.} 11 | } 12 | \description{ 13 | A random matrix needs three random things... 14 | A random width, a random height, and a random data 15 | data should be a random assortment of integers, doubles, logicals, or characters, with 16 | all of them being the same class. 17 | Because there are so many possible matricies, it seems easier to generate them on 18 | demand rather than preallocate all possible matricies into default_objects(). 19 | We will then populate some random matricies onto default_objects() for later use. 20 | } 21 | -------------------------------------------------------------------------------- /man/random_objs.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/generate.R 3 | \name{random_objs} 4 | \alias{random_objs} 5 | \title{Generate a vector or list of random objects from a particular set of possible choices.} 6 | \usage{ 7 | random_objs(objects, amount, list_max_length = 50) 8 | } 9 | \arguments{ 10 | \item{objects}{list. The list of objects to generate from.} 11 | 12 | \item{amount}{numeric. The amount of objects to generate.} 13 | 14 | \item{list_max_length}{numeric. What is the maximum size of a given vector or list?} 15 | } 16 | \description{ 17 | Generate a vector or list of random objects from a particular set of possible choices. 18 | } 19 | -------------------------------------------------------------------------------- /man/random_simple_strings.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/generate.R 3 | \name{random_simple_strings} 4 | \alias{random_simple_strings} 5 | \title{Generate a random simple string (i.e., a length-1 non-empty vector of characters).} 6 | \usage{ 7 | random_simple_strings(amount, chars = TRUE, utf8 = FALSE, objects) 8 | } 9 | \arguments{ 10 | \item{amount}{numeric. The amount of simple strings to generate.} 11 | 12 | \item{chars}{logical. Whether or not to include characters.} 13 | 14 | \item{utf8}{logical. Whether or not to include utf8 characters.} 15 | 16 | \item{objects}{list. The object frame to work from.} 17 | } 18 | \description{ 19 | Generate a random simple string (i.e., a length-1 non-empty vector of characters). 20 | } 21 | -------------------------------------------------------------------------------- /man/should_be_checked.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/package_exports_checked.R 3 | \name{should_be_checked} 4 | \alias{should_be_checked} 5 | \title{Determine whether a function ought to be checked with checkr.} 6 | \usage{ 7 | should_be_checked(fn) 8 | } 9 | \arguments{ 10 | \item{fn}{function. The function to check.} 11 | } 12 | \description{ 13 | Functions should be checked as long as they have formals. 14 | } 15 | -------------------------------------------------------------------------------- /man/test_objects_.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/generate.R 3 | \name{test_objects_} 4 | \alias{test_objects_} 5 | \title{Generates random R objects to be put into functions for testing purposes.} 6 | \usage{ 7 | test_objects_(objects) 8 | } 9 | \arguments{ 10 | \item{objects}{list. The object frame to work from.} 11 | } 12 | \description{ 13 | Generates random R objects to be put into functions for testing purposes. 14 | } 15 | -------------------------------------------------------------------------------- /man/validate.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/validate.R 3 | \name{validate} 4 | \alias{validate} 5 | \title{Validate checks that certain facts are true.} 6 | \usage{ 7 | validate(...) 8 | } 9 | \arguments{ 10 | \item{...}{list. A list of conditions to check.} 11 | } 12 | \value{ 13 | Either TRUE or stops with a list of errors. 14 | } 15 | \description{ 16 | Validate checks that certain facts are true. 17 | } 18 | \examples{ 19 | validate(1 == 1, "a" \%is\% character, length(c(1, 2, 3)) == 3) 20 | } 21 | -------------------------------------------------------------------------------- /man/validate_.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/validate.R 3 | \name{validate_} 4 | \alias{validate_} 5 | \title{Validate without NSE.} 6 | \usage{ 7 | validate_(conditions, env = parent.frame(2)) 8 | } 9 | \arguments{ 10 | \item{conditions}{list. A list of conditions to check.} 11 | 12 | \item{env}{environment. An optional environment to evaluate within. Defaults to 13 | \code{parent.frame(2)}, which contains the variables in the scope immediately beyond 14 | the validate (though not the validate_) function.} 15 | } 16 | \description{ 17 | Validate without NSE. 18 | } 19 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(checkr) 3 | test_check("checkr") 4 | -------------------------------------------------------------------------------- /tests/testthat/fakepackages/allexportedchecked/.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | -------------------------------------------------------------------------------- /tests/testthat/fakepackages/allexportedchecked/.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | -------------------------------------------------------------------------------- /tests/testthat/fakepackages/allexportedchecked/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: allexportedchecked 2 | Title: A fake test package where all exports are checked using checkr 3 | Version: 0.0.0.9000 4 | Authors@R: person("First", "Last", email = "first.last@example.com", role = c("aut", "cre")) 5 | Description: What the package does (one paragraph). 6 | Depends: 7 | R (>= 3.2.3) 8 | Imports: 9 | checkr 10 | License: What license is it under? 11 | LazyData: true 12 | RoxygenNote: 5.0.1.9000 13 | -------------------------------------------------------------------------------- /tests/testthat/fakepackages/allexportedchecked/NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export(pending) 4 | export(pending_identity) 5 | import(checkr) 6 | -------------------------------------------------------------------------------- /tests/testthat/fakepackages/allexportedchecked/R/pending.R: -------------------------------------------------------------------------------- 1 | #' Pending! 2 | #' 3 | #' This function has no formals, so it won't be counted against checkr! 4 | #' @export 5 | pending <- function() { "Pending!" } 6 | 7 | 8 | #' Pending identity. 9 | #' 10 | #' This function needs to be checked or else the test will fail. 11 | #' @import checkr 12 | #' @export 13 | pending_identity <- checkr::ensure(pre = list(x %is% any), identity) 14 | -------------------------------------------------------------------------------- /tests/testthat/fakepackages/allexportedchecked/allexportedchecked.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: No 4 | SaveWorkspace: No 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | Encoding: UTF-8 9 | 10 | AutoAppendNewline: Yes 11 | StripTrailingWhitespace: Yes 12 | 13 | BuildType: Package 14 | PackageUseDevtools: Yes 15 | PackageInstallArgs: --no-multiarch --with-keep.source 16 | PackageRoxygenize: rd,collate,namespace 17 | -------------------------------------------------------------------------------- /tests/testthat/fakepackages/allexportedchecked/man/pending.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/pending.R 3 | \name{pending} 4 | \alias{pending} 5 | \title{Pending!} 6 | \usage{ 7 | pending() 8 | } 9 | \description{ 10 | This function has no formals, so it won't be counted against checkr! 11 | } 12 | 13 | -------------------------------------------------------------------------------- /tests/testthat/fakepackages/allexportedchecked/man/pending_identity.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/pending.R 3 | \name{pending_identity} 4 | \alias{pending_identity} 5 | \title{Pending identity.} 6 | \usage{ 7 | pending_identity(x) 8 | } 9 | \description{ 10 | This function needs to be checked or else the test will fail. 11 | } 12 | 13 | -------------------------------------------------------------------------------- /tests/testthat/fakepackages/notallexportedchecked/.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | -------------------------------------------------------------------------------- /tests/testthat/fakepackages/notallexportedchecked/.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | -------------------------------------------------------------------------------- /tests/testthat/fakepackages/notallexportedchecked/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: notallexportedchecked 2 | Title: A fake test package where all exports are not checked using checkr 3 | Version: 0.0.0.9000 4 | Authors@R: person("First", "Last", email = "first.last@example.com", role = c("aut", "cre")) 5 | Description: What the package does (one paragraph). 6 | Depends: 7 | R (>= 3.2.3) 8 | License: What license is it under? 9 | LazyData: true 10 | RoxygenNote: 5.0.1.9000 11 | -------------------------------------------------------------------------------- /tests/testthat/fakepackages/notallexportedchecked/NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export(pending) 4 | export(pending_identity) 5 | -------------------------------------------------------------------------------- /tests/testthat/fakepackages/notallexportedchecked/R/pending.R: -------------------------------------------------------------------------------- 1 | #' Pending! 2 | #' 3 | #' This function has no formals, so it won't be counted against checkr! 4 | #' @export 5 | pending <- function() { "Pending!" } 6 | 7 | 8 | #' Pending identity. 9 | #' 10 | #' This function needs to be checked or else the test will fail. But it's not checked! 11 | #' @export 12 | pending_identity <- identity 13 | -------------------------------------------------------------------------------- /tests/testthat/fakepackages/notallexportedchecked/allexportedchecked.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: No 4 | SaveWorkspace: No 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | Encoding: UTF-8 9 | 10 | AutoAppendNewline: Yes 11 | StripTrailingWhitespace: Yes 12 | 13 | BuildType: Package 14 | PackageUseDevtools: Yes 15 | PackageInstallArgs: --no-multiarch --with-keep.source 16 | PackageRoxygenize: rd,collate,namespace 17 | -------------------------------------------------------------------------------- /tests/testthat/fakepackages/notallexportedchecked/man/pending.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/pending.R 3 | \name{pending} 4 | \alias{pending} 5 | \title{Pending!} 6 | \usage{ 7 | pending() 8 | } 9 | \description{ 10 | This function has no formals, so it won't be counted against checkr! 11 | } 12 | 13 | -------------------------------------------------------------------------------- /tests/testthat/fakepackages/notallexportedchecked/man/pending_identity.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/pending.R 3 | \name{pending_identity} 4 | \alias{pending_identity} 5 | \title{Pending identity.} 6 | \usage{ 7 | pending_identity(x) 8 | } 9 | \description{ 10 | This function needs to be checked or else the test will fail. But it's not checked! 11 | } 12 | 13 | -------------------------------------------------------------------------------- /tests/testthat/test-contains.R: -------------------------------------------------------------------------------- 1 | context("contains") 2 | 3 | test_that("simple matchers", { 4 | expect_true(list(1, 2, 3) %contains_only% numeric) 5 | expect_true(list("a", "b", "c") %contains_only% character) 6 | expect_false(list("1", "2", "3") %contains% numeric) 7 | expect_false(list(1, 2, 3) %contains% character) 8 | }) 9 | 10 | test_that("it is FALSE for empty lists", { 11 | expect_false(list("", "", "") %contains_only% character) 12 | }) 13 | 14 | test_that("complex class matching", { 15 | obj <- structure("obj", class = "obj_class") 16 | expect_true(obj %is% obj_class) 17 | expect_true(list(obj, obj) %contains_only% obj_class) 18 | }) 19 | 20 | describe("custom matchers", { 21 | test_that("simple_string", { 22 | expect_true(list("pizza", "a") %contains_only% simple_string) 23 | expect_false(list(list("a", "b")) %contains_only% simple_string) 24 | }) 25 | test_that("double", { 26 | expect_true(list(1.0, 1) %contains_only% double) 27 | }) 28 | test_that("vector", { 29 | expect_true(list(c(1, 2, 3), c("a", "b", "c")) %contains_only% vector) 30 | }) 31 | }) 32 | 33 | test_that("contains vs. contains_only", { 34 | expect_true(list(1, 2, "a") %contains% numeric) 35 | expect_false(list(1, 2, "a") %contains_only% numeric) 36 | }) 37 | 38 | test_that("does_not_contain is the opposite of contains", { 39 | expect_true(list(1, 2, 3) %does_not_contain% character) 40 | expect_false(list("1", "2", "3") %does_not_contain% character) 41 | expect_false(list(1, 2, 3) %does_not_contain% numeric) 42 | expect_true(list("1", "2", "3") %does_not_contain% numeric) 43 | }) 44 | -------------------------------------------------------------------------------- /tests/testthat/test-empty.R: -------------------------------------------------------------------------------- 1 | context("is.empty") 2 | 3 | test_that("it is TRUE for NULL, NA, and empty string", { 4 | expect_true(is.empty(NULL)) 5 | expect_true(is.empty(NA)) 6 | expect_true(is.empty("")) 7 | }) 8 | 9 | test_that("it is TRUE for length-0 objects", { 10 | expect_true(is.empty(list())) 11 | expect_true(is.empty(c())) 12 | expect_true(is.empty(data.frame())) 13 | expect_true(is.empty(logical(0))) 14 | }) 15 | 16 | test_that("it is TRUE for lists and vectors that combine the above", { 17 | expect_true(is.empty(list(NA, NA))) 18 | expect_true(is.empty(list(NA, NULL, NA))) 19 | expect_true(is.empty(list(list()))) 20 | expect_true(is.empty(list(a = list()))) 21 | expect_true(is.empty(list(a = list(NA, NULL), b = list(NA)))) 22 | }) 23 | 24 | test_that("it is FALSE for everything else", { 25 | expect_false(is.empty("a")) 26 | expect_false(is.empty(1)) 27 | expect_false(is.empty(iris)) 28 | expect_false(is.empty(list(NA, NULL, 1))) 29 | expect_false(is.empty(list(a = list(NA, NA), b = list(1, 2)))) 30 | expect_false(is.empty(c("", "a"))) 31 | }) 32 | -------------------------------------------------------------------------------- /tests/testthat/test-ensure.R: -------------------------------------------------------------------------------- 1 | context("ensure") 2 | 3 | # Used for testing the ability to find global formals 4 | CONSTANT_NUMBER <- 10 5 | global_fn <- function() 5 6 | 7 | #' Generate a random string. 8 | #' 9 | #' @param length numeric. The length of the random string to generate. 10 | #' @param alphabet character. A list of characters to draw from to create the string. 11 | random_string <- ensure( 12 | pre = list(length %is% numeric, length(length) == 1, length > 0, length < 1e+7, 13 | alphabet %is% list || alphabet %is% vector, 14 | alphabet %contains_only% simple_string, 15 | all(sapply(alphabet, nchar) == 1)), 16 | post = list(result %is% simple_string, nchar(result) == length), 17 | function(length, alphabet) { 18 | paste0(sample(alphabet, length, replace = TRUE), collapse = "") 19 | }) 20 | 21 | describe("classes", { 22 | test_that("the result is a validated function", { 23 | expect_true(random_string %is% "function") 24 | expect_true(random_string %is% validated_function) 25 | }) 26 | test_that("validation preserves original classes", { 27 | add <- function(x, y) x + y 28 | class(add) <- "adding_function" 29 | expect_true(add %is% adding_function) 30 | add <- ensure(pre = list(x %is% numeric, y %is% numeric), post = result %is% numeric, add) 31 | expect_true(add %is% validated_function) 32 | expect_true(add %is% adding_function) 33 | }) 34 | test_that("validation preserves original formals", { 35 | add <- function(x, y) x + y 36 | eadd <- ensure(pre = list(x %is% numeric, y %is% numeric), post = result %is% numeric, add) 37 | expect_equal(formals(add), formals(eadd)) 38 | }) 39 | }) 40 | 41 | describe("precondition validations", { 42 | test_that("length is checked for numeric", { 43 | expect_error(random_string("pizza", LETTERS), "Error on length %is% numeric") 44 | }) 45 | test_that("alphabet is checked for existence", { 46 | expect_error(random_string(10), "Error on missing arguments: alphabet") 47 | }) 48 | test_that("alphabet is checked for list or vector", { 49 | expect_error(random_string(10, "pizza"), 50 | "Error on alphabet %is% list || alphabet %is% vector") 51 | }) 52 | test_that("alphabet is checked that it only contains characters", { 53 | expect_error(random_string(10, list(1, 2, 3)), 54 | "Error on alphabet %contains_only% simple_string") 55 | }) 56 | test_that("can have multiple errors", { 57 | expect_error(random_string(-10, list(1, 2, 3)), 58 | "Error on length > 0, alphabet %contains_only% simple_string") 59 | }) 60 | test_that("default args are also checked", { 61 | add_default <- ensure(pre = list(x %is% numeric, y %is% numeric), post = result %is% numeric, 62 | function(x, y = "a") x + y) 63 | expect_equal(add_default(4, 5), 9) 64 | expect_error(add_default(4), "Error on y %is% numeric") 65 | }) 66 | }) 67 | 68 | describe("postconditions", { 69 | random_string <- ensure( 70 | pre = list(length %is% numeric, 71 | alphabet %is% list || alphabet %is% vector, 72 | alphabet %contains_only% simple_string, 73 | length > 0), 74 | # Use bogus post-conditions 75 | post = list(result %is% numeric, nchar(result) == length), 76 | function(length, alphabet) { 77 | paste0(sample(alphabet, 10, replace = TRUE), collapse = "") 78 | }) 79 | test_that("result is checked for numeric", { 80 | expect_error(random_string(10, LETTERS), "Error on result %is% numeric") 81 | }) 82 | 83 | random_string <- ensure( 84 | pre = list(length %is% numeric, 85 | alphabet %is% list || alphabet %is% vector, 86 | alphabet %contains_only% simple_string, 87 | length > 0), 88 | # Use bogus post-conditions 89 | post = list(result %is% simple_string, nchar(result) < length), 90 | function(length, alphabet) { 91 | paste0(sample(alphabet, 10, replace = TRUE), collapse = "") 92 | }) 93 | test_that("result is checked for length", { 94 | expect_error(random_string(10, LETTERS), "Error on nchar(result) < length", fixed = TRUE) 95 | }) 96 | 97 | test_that("it works for NULL", { 98 | fn <- ensure(post = result %is% NULL, function(x) NULL) 99 | expect_equal(NULL, fn(1)) 100 | expect_equal(NULL, fn("a")) 101 | expect_equal(NULL, fn(NULL)) 102 | }) 103 | 104 | test_that("it works for an empty string", { 105 | fn <- ensure(post = identical(result, ""), function(x) "") 106 | expect_equal("", fn(1)) 107 | expect_equal("", fn("a")) 108 | expect_equal("", fn(NULL)) 109 | }) 110 | }) 111 | 112 | describe("one without the other", { 113 | test_that("it can have preconditions without postconditions", { 114 | add <- ensure(pre = list(x %is% numeric, y %is% numeric), function(x, y) x + y) 115 | expect_equal(add(1, 2), 3) 116 | expect_error(add("a", 2), "x %is% numeric") 117 | expect_error(add("a", "b"), "x %is% numeric, y %is% numeric") 118 | }) 119 | test_that("it can have postconditions without preconditions", { 120 | add <- ensure(post = list(result %is% numeric), function(x, y) x + y) 121 | expect_equal(add(1, 2), 3) 122 | add <- ensure(post = list(result %is% character), function(x, y) x + y) 123 | expect_error(add(1, 2), "result %is% character") 124 | }) 125 | test_that("a single postcondition does not have to be a list", { 126 | add <- ensure(post = result %is% numeric, function(x, y) x + y) 127 | expect_equal(add(1, 2), 3) 128 | add <- ensure(post = result %is% character, function(x, y) x + y) 129 | expect_error(add(1, 2), "result %is% character") 130 | }) 131 | }) 132 | 133 | describe("fetchers", { 134 | add <- ensure(pre = list(x %is% numeric, y %is% numeric), post = result %is% numeric, 135 | function(x, y) x + y) 136 | test_that("preconditions fetches the preconditions", { 137 | expect_identical(preconditions(add), substitute(list(x %is% numeric, y %is% numeric))) 138 | }) 139 | test_that("postconditions fetches the postconditions", { 140 | expect_equal(postconditions(add), substitute(result %is% numeric)) 141 | }) 142 | test_that("get_prevalidated_fn gets the pre-validated function", { 143 | expect_equal(get_prevalidated_fn(add), function(x, y) x + y) 144 | }) 145 | }) 146 | 147 | describe("passing conditions", { 148 | test_that("random_string works with both pre- and post- checks", { 149 | rand_string <- random_string(10, LETTERS) 150 | expect_is(rand_string, "character") 151 | expect_true(nchar(rand_string) == 10) 152 | }) 153 | test_that("random_string works with both pre- and post- checks and explicit formals", { 154 | rand_string <- random_string(length = 10, alphabet = LETTERS) 155 | expect_is(rand_string, "character") 156 | expect_true(nchar(rand_string) == 10) 157 | }) 158 | test_that("add works with both pre- and post- checks", { 159 | add <- ensure(pre = list(x %is% numeric, y %is% numeric), post = result %is% numeric, 160 | function(x, y) x + y) 161 | expect_equal(add(4, 5), 9) 162 | expect_equal(add(4L, 5L), 9L) 163 | }) 164 | test_that("add works with both pre- and post- checks and explicit formals", { 165 | add <- ensure(pre = list(x %is% numeric, y %is% numeric), post = result %is% numeric, 166 | function(x, y) x + y) 167 | expect_equal(add(x = 4, y = 5), 9) 168 | expect_equal(add(x = 4L, y = 5L), 9L) 169 | }) 170 | test_that("function works with a default argument", { 171 | add_default <- ensure(pre = list(x %is% numeric, y %is% numeric), post = result %is% numeric, 172 | function(x, y = 1) x + y) 173 | expect_equal(add_default(4, 5), 9) 174 | expect_equal(add_default(4), 5) 175 | }) 176 | test_that("function works with a default argument and explicit formals", { 177 | add_default <- ensure(pre = list(x %is% numeric, y %is% numeric), post = result %is% numeric, 178 | function(x, y = 1) x + y) 179 | expect_equal(add_default(x = 4, y = 5), 9) 180 | expect_equal(add_default(x = 4), 5) 181 | }) 182 | test_that("can't validate twice", { 183 | expect_error(ensure(pre = x %is% numeric, random_string), "already been validated") 184 | }) 185 | }) 186 | 187 | describe("present", { 188 | test_that("present can be used in a validation", { 189 | fn <- ensure(pre = !(present(x) && present(y)), 190 | function(x, y) { 191 | if (missing(x)) { x <- 1 } 192 | if (missing(y)) { y <- 1 } 193 | x + y 194 | }) 195 | expect_equal(3, fn(x = 2)) 196 | expect_equal(3, fn(y = 2)) 197 | expect_error(fn(x = 2, y = 2), "Error on !(present(x) && present(y))", fixed = TRUE) 198 | }) 199 | }) 200 | 201 | describe("missing arguments I", { 202 | fn <- ensure(pre = list(a %is% list, b %is% list), 203 | function(a, b, c = NULL) { c(a, b, c) }) 204 | test_that("the function works I", { 205 | expect_equal(list(1, 2, 3), fn(a = list(1), b = list(2), c = list(3))) 206 | }) 207 | test_that("the function works without names I", { 208 | expect_equal(list(1, 2, 3), fn(list(1), list(2), list(3))) 209 | }) 210 | test_that("the function works with partial names I", { 211 | expect_equal(list(1, 2, 3), fn(a = list(1), list(2), list(3))) 212 | expect_equal(list(1, 2, 3), fn(list(1), b = list(2), list(3))) 213 | expect_equal(list(1, 2, 3), fn(list(1), list(2), c = list(3))) 214 | expect_equal(list(1, 2, 3), fn(list(1), b = list(2), c = list(3))) 215 | expect_equal(list(1, 2, 3), fn(a = list(1), b = list(2), list(3))) 216 | }) 217 | test_that("the function works in the opposite order I", { 218 | expect_equal(list(1, 2, 3), fn(a = list(1), c = list(3), b = list(2))) 219 | expect_equal(list(1, 2, 3), fn(list(1), c = list(3), b = list(2))) 220 | expect_equal(list(1, 2, 3), fn(b = list(2), c = list(3), a = list(1))) 221 | expect_equal(list(1, 2, 3), fn(b = list(2), a = list(1), c = list(3))) 222 | expect_equal(list(1, 2, 3), fn(c = list(3), b = list(2), a = list(1))) 223 | }) 224 | test_that("c can be missing I", { 225 | expect_equal(list(1, 2), fn(a = list(1), b = list(2))) 226 | expect_equal(list(1, 2), fn(list(1), b = list(2))) 227 | expect_equal(list(1, 2), fn(a = list(1), list(2))) 228 | expect_equal(list(1, 2), fn(list(1), list(2))) 229 | }) 230 | test_that("silence I", { 231 | expect_silent(fn(list(1), b = list(2))) 232 | }) 233 | test_that("c can be missing in the opposite order I", { 234 | expect_equal(list(1, 2), fn(b = list(2), a = list(1))) 235 | }) 236 | test_that("b cannot be missing I", { 237 | expect_error(fn(a = list(1), c = list(2)), "Error on missing arguments: b") 238 | expect_error(fn(list(1), c = list(2)), "Error on missing arguments: b") 239 | }) 240 | test_that("a cannot be missing I", { 241 | expect_error(fn(b = list(1), c = list(2)), "Error on missing arguments: a") 242 | }) 243 | }) 244 | 245 | describe("missing arguments II", { 246 | fn <- ensure(pre = list(a %is% list, b %is% list), 247 | function(a, b, c) { 248 | if (missing(c)) { c <- 1 } 249 | c(a, b, c) 250 | }) 251 | test_that("the function works II", { 252 | expect_equal(list(1, 2, 3), fn(a = list(1), b = list(2), c = list(3))) 253 | }) 254 | test_that("the function works without names II", { 255 | expect_equal(list(1, 2, 3), fn(list(1), list(2), list(3))) 256 | }) 257 | test_that("the function works with partial names II", { 258 | expect_equal(list(1, 2, 3), fn(a = list(1), list(2), list(3))) 259 | expect_equal(list(1, 2, 3), fn(list(1), b = list(2), list(3))) 260 | expect_equal(list(1, 2, 3), fn(list(1), list(2), c = list(3))) 261 | expect_equal(list(1, 2, 3), fn(list(1), b = list(2), c = list(3))) 262 | expect_equal(list(1, 2, 3), fn(a = list(1), b = list(2), list(3))) 263 | }) 264 | test_that("the function works in the opposite order II", { 265 | expect_equal(list(1, 2, 3), fn(a = list(1), c = list(3), b = list(2))) 266 | expect_equal(list(1, 2, 3), fn(list(1), c = list(3), b = list(2))) 267 | expect_equal(list(1, 2, 3), fn(b = list(2), c = list(3), a = list(1))) 268 | expect_equal(list(1, 2, 3), fn(b = list(2), a = list(1), c = list(3))) 269 | expect_equal(list(1, 2, 3), fn(c = list(3), b = list(2), a = list(1))) 270 | }) 271 | test_that("c can be missing II", { 272 | expect_equal(list(1, 2, 1), fn(a = list(1), b = list(2))) 273 | expect_equal(list(1, 2, 1), fn(list(1), b = list(2))) 274 | expect_equal(list(1, 2, 1), fn(a = list(1), list(2))) 275 | expect_equal(list(1, 2, 1), fn(list(1), list(2))) 276 | }) 277 | test_that("silence II", { 278 | expect_silent(fn(list(1), b = list(2))) 279 | }) 280 | test_that("c can be missing in the opposite order II", { 281 | expect_equal(list(1, 2, 1), fn(b = list(2), a = list(1))) 282 | }) 283 | test_that("b cannot be missing II", { 284 | expect_error(fn(a = list(1), c = list(2)), "Error on missing arguments: b") 285 | expect_error(fn(list(1), c = list(2)), "Error on missing arguments: b") 286 | }) 287 | test_that("a cannot be missing II", { 288 | expect_error(fn(b = list(1), c = list(2)), "Error on missing arguments: a") 289 | }) 290 | }) 291 | 292 | describe("missing arguments III", { 293 | fn <- ensure(pre = list( 294 | if (present(a)) { a %is% list }, 295 | if (present(b)) { b %is% list }, 296 | if (present(c)) { c %is% list }), 297 | function(a, b, c) { 298 | if (missing(a)) { a <- NULL } 299 | if (missing(b)) { b <- NULL } 300 | if (missing(c)) { c <- NULL } 301 | c(a, b, c) 302 | }) 303 | test_that("the function works III", { 304 | expect_equal(list(1, 2, 3), fn(a = list(1), b = list(2), c = list(3))) 305 | }) 306 | test_that("the function works without names III", { 307 | expect_equal(list(1, 2, 3), fn(list(1), list(2), list(3))) 308 | }) 309 | test_that("the function works with partial names III", { 310 | expect_equal(list(1, 2, 3), fn(a = list(1), list(2), list(3))) 311 | expect_equal(list(1, 2, 3), fn(list(1), b = list(2), list(3))) 312 | expect_equal(list(1, 2, 3), fn(list(1), list(2), c = list(3))) 313 | expect_equal(list(1, 2, 3), fn(list(1), b = list(2), c = list(3))) 314 | expect_equal(list(1, 2, 3), fn(a = list(1), b = list(2), list(3))) 315 | }) 316 | test_that("the function works in the opposite order III", { 317 | expect_equal(list(1, 2, 3), fn(a = list(1), c = list(3), b = list(2))) 318 | expect_equal(list(1, 2, 3), fn(list(1), c = list(3), b = list(2))) 319 | expect_equal(list(1, 2, 3), fn(b = list(2), c = list(3), a = list(1))) 320 | expect_equal(list(1, 2, 3), fn(b = list(2), a = list(1), c = list(3))) 321 | expect_equal(list(1, 2, 3), fn(c = list(3), b = list(2), a = list(1))) 322 | }) 323 | test_that("c can be missing III", { 324 | expect_equal(list(1, 2), fn(a = list(1), b = list(2))) 325 | expect_equal(list(1, 2), fn(list(1), b = list(2))) 326 | expect_equal(list(1, 2), fn(a = list(1), list(2))) 327 | expect_equal(list(1, 2), fn(list(1), list(2))) 328 | }) 329 | test_that("silence III", { 330 | expect_silent(fn(list(1), b = list(2))) 331 | }) 332 | test_that("c can be missing in the opposite order III", { 333 | expect_equal(list(1, 2), fn(b = list(2), a = list(1))) 334 | }) 335 | test_that("b can be missing III", { 336 | expect_equal(list(1, 2), fn(a = list(1), c = list(2))) 337 | expect_equal(list(1, 2), fn(list(1), c = list(2))) 338 | }) 339 | test_that("b can be missing in the opposite order III", { 340 | expect_equal(list(1, 2), fn(c = list(2), a = list(1))) 341 | }) 342 | test_that("a can be missing III", { 343 | expect_equal(list(1, 2), fn(b = list(1), c = list(2))) 344 | }) 345 | test_that("a can be missing in the opposite order III", { 346 | expect_equal(list(1, 2), fn(c = list(2), b = list(1))) 347 | }) 348 | }) 349 | 350 | describe("missing arguments IV", { 351 | fn <- ensure(pre = list( 352 | a %is% list || a %is% NULL, 353 | b %is% list || b %is% NULL, 354 | c %is% list || c %is% NULL), 355 | function(a = NULL, b = NULL, c = NULL) { c(a, b, c) }) 356 | test_that("the function works IV", { 357 | expect_equal(list(1, 2, 3), fn(a = list(1), b = list(2), c = list(3))) 358 | }) 359 | test_that("the function works without names IV", { 360 | expect_equal(list(1, 2, 3), fn(list(1), list(2), list(3))) 361 | }) 362 | test_that("the function works with partial names IV", { 363 | expect_equal(list(1, 2, 3), fn(a = list(1), list(2), list(3))) 364 | expect_equal(list(1, 2, 3), fn(list(1), b = list(2), list(3))) 365 | expect_equal(list(1, 2, 3), fn(list(1), list(2), c = list(3))) 366 | expect_equal(list(1, 2, 3), fn(list(1), b = list(2), c = list(3))) 367 | expect_equal(list(1, 2, 3), fn(a = list(1), b = list(2), list(3))) 368 | }) 369 | test_that("the function works in the opposite order IV", { 370 | expect_equal(list(1, 2, 3), fn(a = list(1), c = list(3), b = list(2))) 371 | expect_equal(list(1, 2, 3), fn(list(1), c = list(3), b = list(2))) 372 | expect_equal(list(1, 2, 3), fn(b = list(2), c = list(3), a = list(1))) 373 | expect_equal(list(1, 2, 3), fn(b = list(2), a = list(1), c = list(3))) 374 | }) 375 | test_that("c can be missing IV", { 376 | expect_equal(list(1, 2), fn(a = list(1), b = list(2))) 377 | expect_equal(list(1, 2), fn(list(1), b = list(2))) 378 | expect_equal(list(1, 2), fn(a = list(1), list(2))) 379 | expect_equal(list(1, 2), fn(list(1), list(2))) 380 | }) 381 | test_that("silence IV", { 382 | expect_silent(fn(list(1), b = list(2))) 383 | }) 384 | test_that("c can be missing in the opposite order IV", { 385 | expect_equal(list(1, 2), fn(b = list(2), a = list(1))) 386 | }) 387 | test_that("b can be missing IV", { 388 | expect_equal(list(1, 2), fn(a = list(1), c = list(2))) 389 | expect_equal(list(1, 2), fn(list(1), c = list(2))) 390 | }) 391 | test_that("b can be missing in the opposite order IV", { 392 | expect_equal(list(1, 2), fn(c = list(2), a = list(1))) 393 | }) 394 | test_that("a can be missing IV", { 395 | expect_equal(list(1, 2), fn(b = list(1), c = list(2))) 396 | }) 397 | test_that("a can be missing in the opposite order IV", { 398 | expect_equal(list(1, 2), fn(c = list(2), b = list(1))) 399 | }) 400 | }) 401 | 402 | describe("missing arguments V", { 403 | fn <- ensure(pre = list(fn %is% "function", flag %is% logical), 404 | post = result %is% logical, 405 | function(fn, flag = TRUE) { fn(flag) }) 406 | test_that("the function works V", { 407 | expect_true(fn(isTRUE, flag = TRUE)) 408 | expect_false(fn(isTRUE, flag = FALSE)) 409 | expect_true(fn(fn = isTRUE, flag = TRUE)) 410 | expect_false(fn(fn = isTRUE, flag = FALSE)) 411 | }) 412 | test_that("the function works in the opposite order V", { 413 | expect_true(fn(flag = TRUE, fn = isTRUE)) 414 | expect_false(fn(flag = FALSE, fn = isTRUE)) 415 | }) 416 | test_that("flag can be missing V", { 417 | expect_true(fn(isTRUE)) 418 | }) 419 | }) 420 | 421 | describe("missing arguments VI", { 422 | fn <- ensure(pre = list(fn %is% "function", flag %is% logical, second_flag %is% character), 423 | post = result %is% logical, 424 | function(fn, flag = TRUE, second_flag = "hi") { fn(flag) }) 425 | test_that("the function works VI", { 426 | expect_true(fn(fn = isTRUE, flag = TRUE, second_flag = "pizza")) 427 | expect_false(fn(fn = isTRUE, flag = FALSE, second_flag = "pizza")) 428 | expect_true(fn(isTRUE, flag = TRUE, second_flag = "pizza")) 429 | expect_false(fn(isTRUE, flag = FALSE, second_flag = "pizza")) 430 | expect_true(fn(isTRUE, TRUE, second_flag = "pizza")) 431 | expect_false(fn(isTRUE, FALSE, second_flag = "pizza")) 432 | expect_true(fn(isTRUE, TRUE, "pizza")) 433 | expect_false(fn(isTRUE, FALSE, "pizza")) 434 | }) 435 | test_that("the function works in the opposite order VI", { 436 | expect_true(fn(fn = isTRUE, second_flag = "pizza", flag = TRUE)) 437 | expect_false(fn(fn = isTRUE, second_flag = "pizza", flag = FALSE)) 438 | expect_true(fn(isTRUE, second_flag = "pizza", flag = TRUE)) 439 | expect_false(fn(isTRUE, second_flag = "pizza", flag = FALSE)) 440 | expect_true(fn(flag = TRUE, fn = isTRUE, second_flag = "pizza")) 441 | expect_false(fn(flag = FALSE, fn = isTRUE, second_flag = "pizza")) 442 | expect_true(fn(flag = TRUE, fn = isTRUE, "pizza")) 443 | expect_false(fn(flag = FALSE, fn = isTRUE, "pizza")) 444 | expect_true(fn(flag = TRUE, second_flag = "pizza", fn = isTRUE)) 445 | expect_false(fn(flag = FALSE, second_flag = "pizza", fn = isTRUE)) 446 | }) 447 | test_that("flag can be missing VI", { 448 | expect_true(fn(isTRUE, second_flag = "pizza")) 449 | expect_true(fn(fn = isTRUE, second_flag = "pizza")) 450 | }) 451 | test_that("flag can be missing in the opposite order VI", { 452 | expect_true(fn(second_flag = "pizza", fn = isTRUE)) 453 | }) 454 | test_that("second_flag can be missing VI", { 455 | expect_false(fn(isTRUE, flag = FALSE)) 456 | expect_false(fn(fn = isTRUE, flag = FALSE)) 457 | }) 458 | test_that("second_flag can be missing in the opposite order VI", { 459 | expect_false(fn(flag = FALSE, fn = isTRUE)) 460 | }) 461 | }) 462 | 463 | describe("default arguments", { 464 | test_that("NULL can be a formal", { 465 | fn <- checkr::ensure( 466 | pre = list(x %is% numeric || is.null(x), 467 | y %is% numeric || is.null(y)), 468 | function(x = NULL, y = NULL) list(x, y)) 469 | expect_equal(list(NULL, NULL), fn()) 470 | }) 471 | test_that("empty string can be a formal", { 472 | fn <- checkr::ensure( 473 | pre = list(x %is% numeric || identical(x, ""), 474 | y %is% numeric || identical(y, "")), 475 | function(x = "", y = "") list(x, y)) 476 | expect_equal(list("", ""), fn()) 477 | }) 478 | test_that("NA can be a formal", { 479 | fn <- checkr::ensure( 480 | pre = list(x %is% numeric || is.na(x), 481 | y %is% numeric || is.na(y)), 482 | function(x = NA, y = NA) list(x, y)) 483 | expect_equal(list(NA, NA), fn()) 484 | }) 485 | test_that("function can be a formal I", { 486 | fn <- function() 4 487 | fn2 <- checkr::ensure( 488 | pre = list(x %is% numeric, 489 | y %is% numeric), 490 | function(x = fn(), y = fn()) list(x, y)) 491 | expect_equal(list(4, 4), fn2()) 492 | }) 493 | test_that("function can be a formal II", { 494 | fn2 <- checkr::ensure( 495 | pre = list(x %is% numeric, 496 | y %is% numeric), 497 | function(x = global_fn(), y = global_fn()) list(x, y)) 498 | expect_equal(list(5, 5), fn2()) 499 | }) 500 | }) 501 | 502 | describe("finding formals", { 503 | test_that("finding a global variable", { 504 | fn <- checkr::ensure(pre = x %is% numeric, function(x) x) 505 | a <- 12 506 | expect_equal(12, fn(a)) 507 | a <- "a" 508 | expect_error(fn(a), "x %is% numeric") 509 | }) 510 | test_that("finding a constant", { 511 | fn <- checkr::ensure(pre = x %is% numeric, function(x) x) 512 | expect_equal(10, fn(CONSTANT_NUMBER)) 513 | }) 514 | test_that("finding a base function", { 515 | fn <- checkr::ensure(pre = x %is% "function", function(x) x) 516 | expect_is(c, "function") 517 | expect_equal(c, fn(c)) 518 | }) 519 | test_that("finding a function from another package", { 520 | fn <- checkr::ensure(pre = x %is% "function", function(x) x) 521 | expect_is(testthat::test_that, "function") 522 | expect_equal(testthat::test_that, fn(testthat::test_that)) 523 | }) 524 | test_that("it can find a function - complex example", { 525 | batch <- checkr::ensure( 526 | pre = list(batch_fn %is% "function", 527 | keys %is% atomic || keys %is% list, 528 | size %is% numeric, size > 0, length(size) == 1, size %% 1 == 0, 529 | combination_strategy %is% "function", 530 | trycatch %is% logical, 531 | retry %is% numeric, retry >= 0, retry %% 1 == 0), 532 | function(batch_fn, keys, size = 50, combination_strategy = c, 533 | trycatch = FALSE, retry = 0) { 534 | function(...) { 535 | list(result = combination_strategy(batch_fn(...)), 536 | size = size, 537 | trycatch = trycatch, 538 | retry = retry) 539 | } 540 | }) 541 | expect_silent(fn <- batch(function(x) x + 1, "x", size = 100)) 542 | expect_is(fn, "function") 543 | target <- list(result = seq(2, 11), size = 100, trycatch = FALSE, retry = 0) 544 | expect_equal(target, fn(seq(10))) 545 | }) 546 | 547 | describe("threading I - numerics", { 548 | a <- 1 549 | fn <- checkr::ensure(pre = w %is% numeric, function(w) w + 1) 550 | fn2 <- checkr::ensure(pre = x %is% numeric, function(x) x + 2) 551 | fn3 <- checkr::ensure(pre = y %is% numeric, function(y) y + 3) 552 | fn4 <- checkr::ensure(pre = z %is% numeric, function(z) z + 4) 553 | test_that("threading one function up - numerics", { 554 | expect_equal(2, fn(a)) 555 | }) 556 | test_that("threading two functions up - numerics", { 557 | expect_equal(4, fn(fn2(a))) 558 | }) 559 | test_that("threading three functions up - numerics", { 560 | expect_equal(7, fn(fn2(fn3(a)))) 561 | }) 562 | test_that("threading four functions up - numerics", { 563 | expect_equal(11, fn(fn2(fn3(fn4(a))))) 564 | }) 565 | }) 566 | describe("threading I - dataframes", { 567 | a <- iris 568 | fn <- checkr::ensure(pre = w %is% dataframe, function(w) w) 569 | fn2 <- checkr::ensure(pre = x %is% dataframe, function(x) x) 570 | fn3 <- checkr::ensure(pre = y %is% dataframe, function(y) y) 571 | fn4 <- checkr::ensure(pre = z %is% dataframe, function(z) z) 572 | test_that("threading one function up - dataframes", { 573 | expect_equal(iris, fn(a)) 574 | }) 575 | test_that("threading two functions up - dataframes", { 576 | expect_equal(iris, fn(fn2(a))) 577 | }) 578 | test_that("threading three functions up - dataframes", { 579 | expect_equal(iris, fn(fn2(fn3(a)))) 580 | }) 581 | test_that("threading four functions up - dataframes", { 582 | expect_equal(iris, fn(fn2(fn3(a)))) 583 | }) 584 | }) 585 | describe("threading II - numerics", { 586 | a <- 1 587 | b <- 1 588 | fn1 <- function(x, y) { 589 | fn2(x, y) 590 | } 591 | fn2 <- function(c, d) { 592 | c <- fn3(c) 593 | d <- fn3(d) 594 | fn4(c, d) 595 | } 596 | fn3 <- checkr::ensure(pre = z %is% numeric, function(z) z + 3) 597 | fn4 <- checkr::ensure(pre = list(n %is% numeric, m %is% numeric), 598 | function(n, m) n + 4 + m + 4) 599 | test_that("threading four functions up II - numerics", { 600 | expect_equal(16, fn1(a, b)) 601 | }) 602 | }) 603 | describe("threading II - dataframes", { 604 | a <- iris 605 | b <- iris 606 | fn1 <- function(x, y) { 607 | fn2(x, y) 608 | } 609 | fn2 <- function(c, d) { 610 | c <- fn3(c) 611 | d <- fn3(d) 612 | fn4(c, d) 613 | } 614 | fn3 <- checkr::ensure(pre = w %is% dataframe, function(w) head(w)) 615 | fn4 <- checkr::ensure(pre = list(n %is% dataframe, m %is% dataframe), 616 | function(n, m) rbind(n, m)) 617 | test_that("threading four functions up II - dataframes", { 618 | expect_equal(rbind(head(iris), head(iris)), fn1(a, b)) 619 | }) 620 | }) 621 | describe("threading III - dataframes", { 622 | a <- iris 623 | b <- iris 624 | fn1 <- function(c, d) { 625 | fn2(c, d) 626 | } 627 | fn2 <- function(n, m) { 628 | fn3(rbind(n, m), m) 629 | } 630 | fn3 <- function(o, p) { 631 | o <- fn4(o) 632 | p <- fn4(p) 633 | fn5(o, p) 634 | } 635 | fn4 <- checkr::ensure(pre = q %is% dataframe, function(q) head(q)) 636 | fn5 <- checkr::ensure(pre = list(r %is% dataframe, s %is% dataframe), 637 | function(r, s) rbind(r, s)) 638 | test_that("threading four functions up III - dataframes", { 639 | expect_equal(rbind(head(rbind(iris, iris)), head(iris)), fn1(a, b)) 640 | }) 641 | }) 642 | test_that("threading - custom arguments", { 643 | all.equal.custom_data <- function(target, current, ...) { 644 | target <- sanitize_data_frame(target) 645 | current <- sanitize_data_frame(current) 646 | all.equal.default(target, current) 647 | } 648 | sanitize_data_frame <- checkr::ensure( 649 | pre = list(df %is% dataframe, all(dim(df) > 0)), 650 | function(df) { 651 | id_col <- which(names(iris3) == "id") 652 | if (length(id_col) > 0) { 653 | df <- df[order(df[[id_col]]), ] 654 | } 655 | df <- df[, vapply(df, function(x) !all(is.na(x)), logical(1)), drop = FALSE] 656 | df <- lapply(df, function(x) if (is.atomic(x) && !is.character(x)) as.character(x) else x) 657 | data.frame(df, stringsAsFactors = FALSE) 658 | }) 659 | iris2 <- iris 660 | iris2$id <- seq(NROW(iris2)) 661 | iris3 <- iris2[sample(seq(NROW(iris2))), ] 662 | expect_false(isTRUE(all.equal(iris2, iris3))) 663 | expect_true(isTRUE(all.equal(sanitize_data_frame(iris2), sanitize_data_frame(iris3)))) 664 | class(iris2) <- c("custom_data", "data.frame") 665 | class(iris3) <- c("custom_data", "data.frame") 666 | expect_true(isTRUE(all.equal.custom_data(iris2, iris3))) 667 | expect_true(isTRUE(all.equal(iris2, iris3))) 668 | }) 669 | }) 670 | 671 | describe("matching up multiple missing formals", { 672 | test_that("Simple example", { 673 | fn <- function(a = 1, b = 2, c = 3, flag = "add") { 674 | if (identical(flag, "add")) { 675 | a + b + c 676 | } else { 677 | a - b - c 678 | } 679 | } 680 | expect_silent(result <- fn(1, c = 2)) 681 | expect_equal(5, result) 682 | }) 683 | test_that("More complex example", { 684 | batch <- checkr::ensure( 685 | pre = list(batch_fn %is% "function", 686 | keys %is% atomic || keys %is% list, 687 | size %is% numeric, size > 0, length(size) == 1, size %% 1 == 0, 688 | trycatch %is% logical, 689 | retry %is% numeric, retry >= 0, retry %% 1 == 0), 690 | function(batch_fn, keys, size = 50, flag = "flag", trycatch = FALSE, retry = 0) { 691 | function(...) { 692 | list(result = batch_fn(...), 693 | size = size, 694 | flag = flag, 695 | trycatch = trycatch, 696 | retry = retry) 697 | } 698 | }) 699 | expect_silent(fn <- batch(function(x) x + 1, "x", flag = "truck")) 700 | expect_is(fn, "function") 701 | target <- list(result = seq(2, 11), size = 50, 702 | flag = "truck", trycatch = FALSE, retry = 0) 703 | expect_equal(target, fn(seq(10))) 704 | }) 705 | }) 706 | 707 | describe("printing calculates preconditions, postconditions, and the before_fn", { 708 | called_pre <- FALSE 709 | called_post <- FALSE 710 | called_prevalid <- FALSE 711 | with_mock( 712 | `checkr::preconditions` = function(...) { called_pre <<- TRUE }, 713 | `checkr::postconditions` = function(...) { called_post <<- TRUE }, 714 | `checkr::get_prevalidated_fn` = function(...) { called_prevalid <<- TRUE }, { 715 | expect_false(called_pre) 716 | expect_false(called_post) 717 | expect_false(called_prevalid) 718 | print(random_string) 719 | expect_true(called_pre) 720 | expect_true(called_post) 721 | expect_true(called_prevalid) 722 | }) 723 | }) 724 | -------------------------------------------------------------------------------- /tests/testthat/test-generate.R: -------------------------------------------------------------------------------- 1 | context("generate") 2 | 3 | desired_classes <- c("numeric", "integer", "list", "character", "logical", 4 | "matrix", "data.frame", "NULL", "table", "factor") 5 | objects <- checkr:::default_objects() 6 | testing_frame <- checkr:::test_objects() 7 | 8 | describe("objects", { 9 | test_that("objects has one of every class", { 10 | found_classes <- unique(unname(unlist(lapply(objects, list_classes)))) 11 | report <- vapply(desired_classes, 12 | function(klass) klass %in% found_classes, logical(1)) 13 | error <- paste(paste0(names(which(!report)), collapse = ", "), "not found among objects") 14 | expect_true(all(report), info = error) 15 | }) 16 | test_that("The empties are one of every class, plus NULL-class", { 17 | found_classes <- list_classes(objects$empties) 18 | report <- vapply(desired_classes, 19 | function(klass) klass %in% found_classes, logical(1)) 20 | error <- paste(paste0(names(which(!report)), collapse = ", "), "not found among empties") 21 | expect_true(all(report), info = error) 22 | }) 23 | test_that("The negative integers for objects work right", { 24 | expect_true(all(objects$negative_integers < 0)) 25 | expect_equal("integer", unique(sapply(objects$negative_integers, class))) 26 | }) 27 | }) 28 | 29 | describe("test_objects", { 30 | test_that("the testing_frame has one of every class", { 31 | found_classes <- unique(unname(unlist(lapply(testing_frame, list_classes)))) 32 | report <- vapply(desired_classes, 33 | function(klass) klass %in% found_classes, logical(1)) 34 | error <- paste(paste0(names(which(!report)), collapse = ", "), 35 | "not found among testing_frame") 36 | expect_true(all(report), info = error) 37 | }) 38 | test_that("the function is memoised", { 39 | expect_true(memoise::is.memoised(test_objects)) 40 | }) 41 | test_that("force_reload_test_objects reloads test objects", { 42 | expect_false(memoise::is.memoised(force_reload_test_objects)) 43 | testing_frame1 <- test_objects() 44 | testing_frame2 <- test_objects() 45 | expect_true(force_reload_test_objects()) 46 | testing_frame3 <- test_objects() 47 | expect_identical(testing_frame1, testing_frame2) 48 | expect_false(identical(testing_frame1, testing_frame3)) 49 | expect_false(identical(testing_frame2, testing_frame3)) 50 | }) 51 | }) 52 | -------------------------------------------------------------------------------- /tests/testthat/test-is.R: -------------------------------------------------------------------------------- 1 | context("is") 2 | 3 | test_that("simple matchers", { 4 | expect_true(1 %is% numeric) 5 | expect_true(1L %is% integer) 6 | expect_true("a" %is% character) 7 | expect_false("a" %is% numeric) 8 | expect_false(1 %is% character) 9 | }) 10 | 11 | test_that("more complex classes", { 12 | expect_true(iris %is% data.frame) 13 | expect_true(list(1, 2, 3) %is% list) 14 | expect_true((a ~ b + c) %is% formula) 15 | }) 16 | 17 | test_that("complex class matching", { 18 | obj <- structure("obj", class = "obj_class") 19 | expect_true(obj %is% obj_class) 20 | }) 21 | 22 | test_that("no overlap in classes", { 23 | expect_true(is.list(iris)) 24 | expect_false(iris %is% list) # because it is a dataframe 25 | }) 26 | 27 | test_that("custom class names", { 28 | expect_true("a" %is% string) 29 | expect_true(iris %is% dataframe) 30 | expect_true(NULL %is% NULL) 31 | }) 32 | 33 | describe("custom matchers", { 34 | test_that("simple_string", { 35 | expect_true("pizza" %is% simple_string) 36 | }) 37 | test_that("double", { 38 | expect_true(1.0 %is% double) 39 | expect_true(1 %is% double) 40 | expect_false(1L %is% double) 41 | }) 42 | test_that("vector", { 43 | expect_true(c(1, 2, 3) %is% vector) 44 | expect_true(c("a", "b", "c") %is% vector) 45 | expect_true(c(a = "a", b = "b", c = "c") %is% vector) 46 | expect_false(iris$Species %is% vector) 47 | expect_false(list(1, 2, 3) %is% vector) 48 | expect_false(iris %is% vector) 49 | }) 50 | test_that("atomic", { 51 | expect_true(c(1, 2, 3) %is% atomic) 52 | expect_true(c("a", "b", "c") %is% atomic) 53 | expect_true(c(a = "a", b = "b", c = "c") %is% atomic) 54 | expect_true(iris$Species %is% atomic) 55 | expect_false(list(1, 2, 3) %is% atomic) 56 | expect_false(iris %is% atomic) 57 | }) 58 | test_that("all", { 59 | expect_true("a" %is% any) 60 | expect_true("a" %is% ANY) 61 | expect_true(1 %is% any) 62 | expect_true(1.0 %is% any) 63 | expect_true(list(1, "a", 2) %is% any) 64 | expect_true(iris %is% any) 65 | }) 66 | test_that("empty", { 67 | expect_true("" %is% empty) 68 | expect_true(NA %is% empty) 69 | expect_true(NULL %is% empty) 70 | expect_false(1 %is% empty) 71 | expect_false("a" %is% empty) 72 | expect_false(iris %is% empty) 73 | }) 74 | test_that("NA", { 75 | expect_true(NA %is% NA) 76 | expect_true(NA_character_ %is% NA) 77 | expect_true(NA_integer_ %is% NA) 78 | expect_false("" %is% NA) 79 | expect_false(NULL %is% NA) 80 | }) 81 | }) 82 | 83 | test_that("multiple matchers", { 84 | expect_false("a" %is% c("character", "numeric")) 85 | expect_true(structure("a", class = c("character", "numeric")) %is% c("character", "numeric")) 86 | }) 87 | 88 | test_that("isnot negates is", { 89 | expect_true("a" %isnot% numeric) 90 | expect_true(1 %isnot% string) 91 | expect_false(1 %isnot% numeric) 92 | expect_false("a" %isnot% string) 93 | }) 94 | -------------------------------------------------------------------------------- /tests/testthat/test-package-exports-checked.R: -------------------------------------------------------------------------------- 1 | context("package_exports_checked") 2 | 3 | test_that("it passes when all exported functions are checked", { 4 | devtools::install("fakepackages/allexportedchecked") 5 | expect_true(package_exports_checked("allexportedchecked")) 6 | expect_true(package_exports_checked("fakepackages/allexportedchecked")) 7 | remove.packages("allexportedchecked") 8 | unloadNamespace("notallexportedchecked") 9 | }) 10 | 11 | test_that("it fails when all exported functions are not checked", { 12 | devtools::install("fakepackages/notallexportedchecked") 13 | expect_false(package_exports_checked("notallexportedchecked", stop = FALSE)) 14 | expect_error(package_exports_checked("notallexportedchecked"), 15 | "not checked by checkr: pending_identity") 16 | expect_false(package_exports_checked("fakepackages/notallexportedchecked", stop = FALSE)) 17 | remove.packages("notallexportedchecked") 18 | unloadNamespace("notallexportedchecked") 19 | }) 20 | 21 | test_that("for example, it doesn't work on checkr", { 22 | expect_false(package_exports_checked("checkr", stop = FALSE)) 23 | expect_error(package_exports_checked("checkr"), "not checked by checkr") 24 | }) 25 | -------------------------------------------------------------------------------- /tests/testthat/test-present.R: -------------------------------------------------------------------------------- 1 | context("present") 2 | 3 | test_that("missing works", { 4 | fn <- function(x, y) { 5 | if (missing(x)) { x <- 1 } 6 | x + y 7 | } 8 | expect_equal(4, fn(1, 3)) 9 | expect_equal(4, fn(y = 3)) 10 | expect_error(fn(x = 3)) 11 | }) 12 | 13 | test_that("present is the opposite of missing", { 14 | fn <- function(x, y) { 15 | if (!present(x)) { x <- 1 } 16 | x + y 17 | } 18 | expect_equal(4, fn(1, 3)) 19 | expect_equal(4, fn(y = 3)) 20 | expect_error(fn(x = 3)) 21 | }) 22 | 23 | test_that("present can be used in the positive case", { 24 | fn <- function(x) { 25 | if (present(x)) { x <- 1 } 26 | if (missing(x)) { x <- 3 } 27 | x 28 | } 29 | expect_equal(1, fn(x = 5)) 30 | expect_equal(1, fn(x = NULL)) 31 | expect_equal(3, fn()) 32 | }) 33 | 34 | test_that("present only tests variables in the scope and doesn't get confused", { 35 | fn <- function(mean) { # Could get confused for the funtion `mean`. 36 | if (present(mean)) { mean <- 1 } 37 | if (missing(mean)) { mean <- 3 } 38 | mean 39 | } 40 | expect_equal(1, fn(mean = 5)) 41 | expect_equal(1, fn(mean = NULL)) 42 | expect_equal(3, fn()) 43 | }) 44 | 45 | test_that("present only tests variables in the scope and doesn't get confused II", { 46 | a <- 1 47 | fn <- function(b) { 48 | expect_false(present(a)) 49 | expect_true(present(b)) 50 | } 51 | fn(1) 52 | }) 53 | -------------------------------------------------------------------------------- /tests/testthat/test-quickcheck.R: -------------------------------------------------------------------------------- 1 | context("quickcheck") 2 | 3 | describe("testing frame", { 4 | test_that("by default it has everything", { 5 | expect_true(length(list_classes(function_test_objects(identity)[[1]])) > 3) 6 | }) 7 | test_that("it results in only integers if the function takes only integers", { 8 | add_one_int <- ensure(pre = x %is% integer, function(x) x + 1L) 9 | expect_true(function_test_objects(add_one_int)[[1]] %contains_only% integer) 10 | }) 11 | test_that("it results in only doubles if the function takes only doubles", { 12 | add_one_double <- ensure(pre = x %is% double, function(x) x + 1.0) 13 | expect_true(function_test_objects(add_one_double)[[1]] %contains_only% double) 14 | }) 15 | test_that("it results in both numerics if the function takes numerics", { 16 | add_one_number <- ensure(pre = x %is% numeric, function(x) x + 1) 17 | testing_frame <- function_test_objects(add_one_number)[[1]] 18 | expect_equal(2, length(list_classes(testing_frame))) 19 | expect_true(testing_frame %contains% integer) 20 | expect_true(testing_frame %contains% double) 21 | }) 22 | test_that("it results in lists of all sorts but only lists if the function takes lists", { 23 | rev_list <- ensure(pre = x %is% list, rev) 24 | testing_frame <- function_test_objects(rev_list)[[1]] 25 | expect_true(testing_frame %contains_only% list) 26 | }) 27 | test_that("it results in dataframes of all sorts but only dataframes", { 28 | rev_df <- ensure(pre = x %is% dataframe, rev) 29 | testing_frame <- function_test_objects(rev_df)[[1]] 30 | expect_true(testing_frame %contains_only% dataframe) 31 | }) 32 | test_that("it results in both lists and vectors if the function takes that", { 33 | rev <- ensure(pre = x %is% list || x %is% vector, rev) 34 | testing_frame <- function_test_objects(rev)[[1]] 35 | expect_true(testing_frame %is% list) 36 | expect_true(testing_frame %contains% list) 37 | expect_true(testing_frame %contains% vector) 38 | expect_false(testing_frame %contains_only% list) 39 | expect_false(testing_frame %contains_only% vector) 40 | }) 41 | test_that("it can further restrict based on things other than class", { 42 | add_positive <- ensure(pre = list(x %is% numeric, all(x > 0)), function(x) x + 1) 43 | testing_frame <- function_test_objects(add_positive)[[1]] 44 | expect_true(testing_frame %contains_only% numeric) 45 | expect_true(all(sapply(testing_frame, function(vec) all(na.omit(vec) > 0)))) 46 | }) 47 | test_that("it generates for two formals", { 48 | add_two <- ensure(pre = list(x %is% numeric, y %is% numeric), function(x, y) x + y) 49 | expect_equal(2, length(function_test_objects(add_two))) 50 | }) 51 | test_that("it generates for three formals", { 52 | add_three <- ensure(pre = list(x %is% numeric, y %is% numeric, z %is% numeric), 53 | function(x, y, z) x + y + z) 54 | expect_equal(3, length(function_test_objects(add_three))) 55 | }) 56 | test_that("it generates based on restrictions of each formal I", { 57 | add_three <- ensure(pre = list(x %is% numeric, y %is% numeric, z %is% numeric), 58 | function(x, y, z) x + y + z) 59 | testing_frame <- function_test_objects(add_three) 60 | lapply(testing_frame, function(frame) { 61 | expect_true(frame %contains% integer) 62 | expect_true(frame %contains% double) 63 | expect_true(frame %contains_only% numeric) 64 | }) 65 | }) 66 | test_that("it generates based on restrictions of each formal II", { 67 | random_string <- ensure( 68 | pre = list(length %is% numeric, length(length) == 1, length > 0, length < 1e+7, 69 | alphabet %is% list || alphabet %is% vector, 70 | alphabet %contains_only% simple_string), 71 | function(length, alphabet) { 72 | paste0(sample(alphabet, length, replace = TRUE), collapse = "") 73 | }) 74 | testing_frame <- function_test_objects(random_string) 75 | expect_true(testing_frame$length %contains_only% numeric) 76 | expect_true(all(vapply(testing_frame$alphabet, 77 | function(alpha) alpha %contains_only% simple_string, logical(1)))) 78 | }) 79 | test_that("formals can be interdependent when necessary", { 80 | class_matcher <- ensure(pre = identical(class(x), class(y)), function(x, y) c(x, y)) 81 | testing_frame <- function_test_objects(class_matcher) 82 | expect_equal(sapply(testing_frame$x, class), sapply(testing_frame$y, class)) 83 | }) 84 | test_that("the preconditions can be passed explicitly using pre", { 85 | testing_frame <- function_test_objects(pre = x %is% list)[[1]] 86 | expect_true(testing_frame %contains_only% list) 87 | }) 88 | }) 89 | 90 | describe("custom testing frames", { 91 | test_that("it can be custom", { 92 | custom_testing_frame <- function_test_objects(identity, frame = list(x = 1)) 93 | expect_equal(list(x = 1), custom_testing_frame) 94 | }) 95 | test_that("a custom testing frame must match the formals of the function", { 96 | expect_error(function_test_objects(function(x) x, frame = list(y = 1))) 97 | }) 98 | }) 99 | 100 | describe("quickcheck", { 101 | describe("integration tests", { 102 | test_that("simple success example I", { 103 | quickcheck(identity) 104 | }) 105 | test_that("simple seccess example II", { 106 | add_one <- ensure( 107 | pre = x %is% numeric, 108 | post = result %is% numeric, 109 | function(x) x + 1) 110 | quickcheck(add_one) 111 | }) 112 | test_that("simple failure example I", { 113 | add_one <- ensure( 114 | pre = x %is% numeric, 115 | post = result %is% character, # this will fail because the result will actually be numeric 116 | function(x) x + 1) 117 | expect_false(quickcheck(add_one, testthat = FALSE)) 118 | }) 119 | test_that("simple failure example II", { 120 | add_one <- ensure( 121 | pre = x %is% character, # quickcheck will only generate characters which will fail 122 | post = result %is% numeric, 123 | function(x) x + 1) 124 | expect_false(quickcheck(add_one, testthat = FALSE)) 125 | }) 126 | test_that("reverse example", { 127 | quickcheck(ensure(pre = list(length(x) == 1, x %is% vector || x %is% list), 128 | post = identical(result, x), function(x) rev(x))) 129 | quickcheck(ensure(pre = list(x %is% vector || x %is% list), 130 | post = identical(result, x), function(x) rev(rev(x)))) 131 | }) 132 | test_that("random string example - failure", { 133 | random_string <- function(length, alphabet) { 134 | paste0(sample(alphabet, 10), collapse = "") 135 | } 136 | expect_false(quickcheck(ensure( 137 | pre = list(length %is% numeric, length(length) == 1, length > 0, 138 | alphabet %is% list || alphabet %is% vector, 139 | alphabet %contains_only% simple_string), 140 | post = list(nchar(result) == length, length(result) == 1, 141 | is.character(result), all(strsplit(result, "")[[1]] %in% alphabet)), 142 | random_string), testthat = FALSE)) 143 | }) 144 | test_that("random string example - success", { 145 | random_string <- function(length, alphabet) { 146 | paste0(sample(alphabet, length, replace = TRUE), collapse = "") 147 | } 148 | quickcheck(ensure( 149 | pre = list(length %is% numeric, length(length) == 1, length > 0, length < 1e7, 150 | alphabet %is% list || alphabet %is% vector, 151 | alphabet %contains_only% simple_string, 152 | all(sapply(alphabet, nchar) == 1)), 153 | post = list(nchar(result) == length, length(result) == 1, 154 | is.character(result), all(strsplit(result, "")[[1]] %in% alphabet)), 155 | random_string)) 156 | }) 157 | }) 158 | describe("unit tests", { 159 | test_that("it works on a long function", { 160 | suppressWarnings(quickcheck(ensure(pre = x %is% numeric, 161 | function(x) { x + x + x + x + x + x + x + x + x }))) 162 | }) 163 | test_that("it errors if the testing frame is reduced to 0", { 164 | impossible_preconditions <- ensure(pre = list(x %is% character, x %isnot% character), 165 | identity) 166 | expect_error(quickcheck(impossible_preconditions), "impossible to satisfy") 167 | }) 168 | test_that("it errors if it quickchecks a function with no formals", { 169 | expect_error( 170 | quickcheck(ensure(post = result %is% character, function() "Hi!")), 171 | "no arguments") 172 | }) 173 | test_that("NULL is allowed", { 174 | quickcheck(ensure(post = result %is% NULL, function(x) NULL)) 175 | }) 176 | }) 177 | }) 178 | 179 | describe("print_args", { 180 | test_that("works on a simple example I", { 181 | expect_equal("a = \"a\"", print_args(list(a = "a"))) 182 | }) 183 | test_that("works on a simple example II", { 184 | expect_equal("x = 1:3, y = 1:4", 185 | print_args(list(x = seq(3), y = seq(4)))) 186 | }) 187 | test_that("works on a simple example III", { 188 | expect_equal("x = list(3), y = list(4)", 189 | print_args(list(x = list(3), y = list(4)))) 190 | }) 191 | test_that("works on a simple example IV", { 192 | expect_equal("x = list(3, 2, \"a\"), y = list(4, 3, \"b\")", 193 | print_args(list(x = list(3, 2, "a"), y = list(4, 3, "b")))) 194 | }) 195 | test_that("works on a dataframe", { 196 | expect_equal(paste0("df = structure(list(a = 1, b = 2), ", 197 | ".Names = c(\"a\", \"b\"), row.names = c(NA, -1L), class = \"data.frame\")"), 198 | print_args(list(df = data.frame(a = 1, b = 2)))) 199 | }) 200 | test_that("works on a long list", { 201 | expect_equal(paste0("x = list(1, 2, 3, 4, 1, 2, 3, 4, 1, 2, 3, 4, 1, 2, 3, 41", 202 | ", 2, 3, 4, 1, 2, 3, 4, 1, 2, 3, 4, 1, 2, 3, 4)"), 203 | print_args(list(x = list(1, 2, 3, 4, 1, 2, 3, 4, 1, 2, 3, 4, 1, 2, 3, 41, 204 | 2, 3, 4, 1, 2, 3, 4, 1, 2, 3, 4, 1, 2, 3, 4)))) 205 | }) 206 | }) 207 | -------------------------------------------------------------------------------- /tests/testthat/test-simple_string.R: -------------------------------------------------------------------------------- 1 | context("is.simple_string") 2 | 3 | test_that("it is TRUE for length-1 non-empty strings", { 4 | expect_true(is.simple_string("pizza")) 5 | expect_true(is.simple_string("paul")) 6 | expect_true(is.simple_string("having spaces is okay too")) 7 | expect_true(is.simple_string("also /slashes and nonAlph@nUm3ric char$")) 8 | }) 9 | 10 | test_that("it is FALSE for length >1 non-empty strings", { 11 | expect_false(is.simple_string(c("two", "strings"))) 12 | expect_false(is.simple_string(c("a", "vector", "with", "five", "strings"))) 13 | }) 14 | 15 | test_that("it is FALSE for length-1 empty strings", { 16 | expect_false(is.simple_string(NA)) 17 | expect_false(is.simple_string(NULL)) 18 | }) 19 | 20 | test_that("it is FALSE for length-1 non-empty non-strings", { 21 | expect_false(is.simple_string(FALSE)) 22 | expect_false(is.simple_string(iris)) 23 | }) 24 | -------------------------------------------------------------------------------- /tests/testthat/test-validate.R: -------------------------------------------------------------------------------- 1 | context("validate") 2 | 3 | test_that("simple errors", { 4 | expect_error(validate(1 %is% string), "1 %is% string") 5 | expect_error(validate("a" %is% double), "\"a\" %is% double") 6 | expect_error(validate(iris %isnot% dataframe), "iris %isnot% dataframe") 7 | }) 8 | 9 | test_that("functions", { 10 | expect_true(validate(function(x) x %is% "function")) 11 | expect_true(validate(c %is% "function")) 12 | expect_true(validate(checkr:::validate %is% "function")) 13 | expect_true(validate(testthat::test_that %is% "function")) 14 | }) 15 | 16 | test_that("simple errors with complex objects", { 17 | expect_error(validate((a ~ b + c) %isnot% formula), 18 | "(a ~ b + c) %isnot% formula", fixed = TRUE) 19 | expect_error(validate(c("a", "b") %is% simple_string), 20 | "c(\"a\", \"b\") %is% simple_string", fixed = TRUE) 21 | expect_error(validate(list(1, 2, 3) %isnot% list), 22 | "list(1, 2, 3) %isnot% list", fixed = TRUE) 23 | }) 24 | 25 | test_that("pre-conditions other than class matching", { 26 | expect_error(validate(1 + 1 == 3), "1 + 1 == 3", fixed = TRUE) 27 | }) 28 | 29 | test_that("multiple pre-conditions", { 30 | expect_error(validate(1 %is% string, "a" %is% double), 31 | "1 %is% string, \"a\" %is% double") 32 | expect_error(validate(iris %isnot% dataframe, "a" %isnot% simple_string), 33 | "iris %isnot% dataframe, \"a\" %isnot% simple_string") 34 | expect_error(validate(iris %isnot% dataframe, NROW(iris) < 10), 35 | "iris %isnot% dataframe, NROW(iris) < 10", fixed = TRUE) 36 | }) 37 | 38 | test_that("multiple matchers", { 39 | expect_error(validate(1 %is% c("string", "double")), 40 | "1 %is% c(\"string\", \"double\")", fixed = TRUE) 41 | }) 42 | 43 | test_that("testing variables", { 44 | num <- 10 45 | str <- "pizza" 46 | expect_error(validate(num %isnot% numeric), "num %isnot% numeric") 47 | expect_error(validate(num %isnot% double), "num %isnot% double") 48 | expect_error(validate(str %isnot% character), "str %isnot% character") 49 | expect_error(validate(str %isnot% simple_string), "str %isnot% simple_string") 50 | }) 51 | -------------------------------------------------------------------------------- /tests/testthat/test-within.R: -------------------------------------------------------------------------------- 1 | context("within") 2 | 3 | test_that("within", { 4 | expect_true(1 %within% c(0, 2)) 5 | expect_true(1 %within% c(0, 1.5)) 6 | expect_true(1 %within% c(-10, 2)) 7 | expect_true(1 %within% c(1, 2)) 8 | expect_true(1 %within% c(0, 1)) 9 | expect_true(1 %within% c(1, 1)) 10 | 11 | expect_false(1 %within% c(0, 0)) 12 | expect_false(1 %within% c(-1, 0)) 13 | expect_false(1 %within% c(0, 0.9)) 14 | }) 15 | 16 | test_that("it can be vectorized", { 17 | expect_equal(seq(5) %within% c(1, 3), c(TRUE, TRUE, TRUE, FALSE, FALSE)) 18 | expect_equal(c(1, 2, 3) %within% c(1, 1), c(TRUE, FALSE, FALSE)) 19 | expect_equal(c(1, 2, 3) %within% c(0, 0), c(FALSE, FALSE, FALSE)) 20 | }) 21 | 22 | test_that("quickcheck I", { 23 | checkr::quickcheck(checkr::ensure( 24 | pre = list(a %is% numeric, length(a) == 1, 25 | b %is% numeric, length(b) == 1, 26 | c %is% numeric, length(c) == 1, 27 | a >= b, a <= c), 28 | post = isTRUE(result), 29 | function(a, b, c) { a %within% c(b, c) } 30 | ), frame = list(a = sample(seq(1000)), b = sample(seq(1000)), c = sample(seq(1000)))) 31 | }) 32 | 33 | test_that("quickcheck II", { 34 | checkr::quickcheck(checkr::ensure( 35 | pre = list(a %is% numeric, length(a) == 1, 36 | b %is% numeric, length(b) == 1, 37 | c %is% numeric, length(c) == 1, 38 | a < b), 39 | post = !isTRUE(result), 40 | function(a, b, c) { a %within% c(b, c) } 41 | ), frame = list(a = sample(seq(1000)), b = sample(seq(1000)), c = sample(seq(1000)))) 42 | }) 43 | 44 | test_that("quickcheck III", { 45 | checkr::quickcheck(checkr::ensure( 46 | pre = list(a %is% numeric, length(a) == 1, 47 | b %is% numeric, length(b) == 1, 48 | c %is% numeric, length(c) == 1, 49 | a > c), 50 | post = !isTRUE(result), 51 | function(a, b, c) { a %within% c(b, c) } 52 | ), frame = list(a = sample(seq(1000)), b = sample(seq(1000)), c = sample(seq(1000)))) 53 | }) 54 | 55 | test_that("quickcheck vectorized", { 56 | checkr::quickcheck(checkr::ensure( 57 | pre = list(length(a) > 1, 58 | b %is% numeric, length(b) == 1, 59 | c %is% numeric, length(c) == 1, 60 | all(a >= b) && all(b <= c)), 61 | post = all(result), 62 | function(a, b, c) { a %within% c(b, c) }) 63 | , frame = list(a = replicate(100, sample(seq(100)), simplify = FALSE), 64 | b = sample(seq(0, 100)), c = sample(seq(80, 1000)))) 65 | }) 66 | --------------------------------------------------------------------------------