#' Basic predicates for validation
#'
#' @description The following predicate functions augment predicates from the
#' \pkg{base} and \pkg{rlang} packages to enable them to produce informative
#' error messages when used as checks in [fasten()], [firmly()],
#' [validator()], [validate()].
#'
#' - [Boolean predicates][predicates-boolean]
#' - [Object predicates][predicates-object]
#' - [Pattern predicates][predicates-pattern]
#' - [Property predicates][predicates-property]
#' - [Relational predicates][predicates-relational]
#' - [Set predicates][predicates-set]
#' - [Type predicates][predicates-type]
#'
#' @examples
#' ## chk_double() and rlang::is_double() are identical as functions
#' chk_double(runif(2))
#' chk_double(runif(2), n = 1)
#' chk_double(1:2)
#' rlang::is_double(runif(2))
#' rlang::is_double(runif(2), n = 1)
#' rlang::is_double(1:2)
#'
#' ## But when rlang::is_double() is used in firmly(),
#' ## it produces an auto-generated error message ...
#' \dontrun{
#' firmly(function(x) x, rlang::is_double(n = 1))(runif(2))}
#'
#' ## ... whereas chk_double() produces a specialized error message
#' \dontrun{
#' firmly(function(x) x, chk_double(n = 1))(runif(2))}
#'
#' \dontrun{
#' validate(mtcars, is.matrix, {"cylinder" %in% names(.)})
#' validate(mtcars, chk_matrix, chk_has_name("cylinder"))}
#'
#' @name predicates
NULL
predicates <- list(
boolean = NULL,
object = NULL,
pattern = NULL,
property = NULL,
relation = NULL,
set = NULL,
type = NULL
)
predicates$boolean <- list(
list(
"true",
"{{.}} is not true",
isTRUE
),
list(
"is",
"{{.}} is not true",
isTRUE
),
list(
"false",
"{{.}} is not false",
function(x) identical(x, FALSE)
),
list(
"not",
"{{.}} is not false",
function(x) identical(x, FALSE)
),
list(
"all",
"{{.}} is not all true",
function(x, na.rm = FALSE) all(x, na.rm = na.rm)
),
list(
"any",
"{{.}} is all false",
function(x, na.rm = FALSE) any(x, na.rm = na.rm)
),
list(
"none",
"{{.}} not all false",
function(x, na.rm = FALSE) all(!x, na.rm = na.rm)
),
list(
"all_map",
"{{.}} is not all true when mapped by {{.expr$.f}}",
function(x, .f, na.rm = FALSE)
all(vapply(x, .f, logical(1)), na.rm = na.rm)
),
list(
"any_map",
"{{.}} is all false when mapped by {{.expr$.f}}",
function(x, .f, na.rm = FALSE)
any(vapply(x, .f, logical(1)), na.rm = na.rm)
),
list(
"none_map",
"{{.}} not all false when mapped by {{.expr$.f}}",
function(x, .f, na.rm = FALSE)
all(!vapply(x, .f, logical(1)), na.rm = na.rm)
)
)
predicates$object <- list(
list(
"call",
"{{.}} is not a call",
is.call
),
list(
"factor",
"{{.}} is not a factor",
is.factor
),
list(
"data_frame",
"{{.}} is not a data frame",
is.data.frame
),
list(
"matrix",
"{{.}} is not a matrix",
is.matrix
),
list(
"formula",
"{{.}} is not a formula",
function(x) inherits(x, "formula")
),
list(
"function",
"{{.}} is not a function",
is.function
)
)
predicates$pattern <- list(
list(
"grepl",
"Pattern {{.expr$pattern}} is not matched in {{.}}",
function(x, pattern, ignore.case = FALSE, perl = FALSE)
all(grepl(pattern, x, ignore.case = ignore.case, perl = perl))
),
list(
"starts_with",
"Not every entry of {{.}} starts with {{.expr$prefix}}",
function(x, prefix, na.rm = FALSE)
all(startsWith(as.character(x), prefix), na.rm = na.rm)
),
list(
"ends_with",
"Not every entry of {{.}} ends with {{.expr$suffix}}",
function(x, suffix, na.rm = FALSE)
all(endsWith(as.character(x), suffix), na.rm = na.rm)
)
)
predicates$property <- list(
list(
"empty",
"{{.}} is not empty",
is_empty
),
list(
"not_empty",
"{{.}} is empty",
function(x) length(x) != 0
),
list(
"singleton",
"{{.}} is not a singleton",
function(x) length(x) == 1
),
list(
"not_na",
"{{.}} is NA",
function(x) !is_na(x)
),
list(
"without_na",
"{{.}} has an NA",
function(x) !anyNA(x)
),
list(
"named",
"{{.}} is not named",
is_named
),
list(
"has_name",
"{{.}} does not have name {{.value$nm}}",
function(x, nm) isTRUE(nm %in% names(x))
),
list(
"has_names",
"{{.expr$nms}} are not all names of {{.}}",
function(x, nms) all(nms %in% names(x))
),
list(
"has_length",
"{{.}} is not of length {{.value$n}}",
function(x, n) length(x) == n
),
list(
"has_attr",
"{{.}} does not have attribute {{.value$which}}",
function(x, which) !is.null(attr(x, which, exact = TRUE))
),
list(
"has_attrs",
"{{.expr$which}} are not all attributes of {{.}}",
function(x, which) all(which %in% names(attributes(x)))
),
list(
"inherits",
'{{.}} is not of class "{{.value$what}}"',
function(x, what) inherits(x, what)
)
)
predicates$relation <- list(
list(
"identical",
"{{.}} is not identical to {{.expr$to}}",
function(x, to) identical(x, to)
),
list(
"not_identical",
"{{.}} is identical to {{.expr$to}}",
function(x, to) !identical(x, to)
),
list(
"equal",
"{{.}} does not equal {{.expr$to}}",
function(x, to) isTRUE(all.equal(to, x))
),
list(
"not_equal",
"{{.}} equals {{.expr$to}}",
function(x, to) !isTRUE(all.equal(to, x))
),
list(
"equivalent",
"{{.}} is not equivalent to {{.expr$to}}",
function(x, to) isTRUE(all.equal(to, x, check.attributes = FALSE))
),
list(
"not_equivalent",
"{{.}} is equivalent to {{.expr$to}}",
function(x, to) !isTRUE(all.equal(to, x, check.attributes = FALSE))
),
list(
"gt",
"{{.}} is not greater than {{.value$lwr}}",
function(x, lwr, na.rm = FALSE) all(x > lwr, na.rm = na.rm)
),
list(
"lt",
"{{.}} is not less than {{.value$upr}}",
function(x, upr, na.rm = FALSE) all(x < upr, na.rm = na.rm)
),
list(
"gte",
"{{.}} is not greater than or equal to {{.value$lwr}}",
function(x, lwr, na.rm = FALSE) all(x >= lwr, na.rm = na.rm)
),
list(
"lte",
"{{.}} is not less than or equal to {{.value$upr}}",
function(x, upr, na.rm = FALSE) all(x <= upr, na.rm = na.rm)
)
)
predicates$set <- list(
list(
"in",
"{{.}} is not in {{.expr$set}}",
function(x, set) isTRUE(x %in% set)
),
list(
"not_in",
"{{.}} is in {{.expr$set}}",
function(x, set) isTRUE(! x %in% set)
),
list(
"include",
"{{.}} does not include {{.expr$set}}",
function(x, set) all(set %in% x)
),
list(
"exclude",
"{{.}} intersects {{.expr$set}}",
function(x, set) all(! set %in% x)
),
list(
"within",
"{{.}} is not contained in {{.expr$set}}",
function(x, set) all(x %in% set)
),
list(
"intersect",
"{{.}} is disjoint from {{.expr$set}}",
function(x, set) length(intersect(x, set)) != 0
),
list(
"avoid",
"{{.}} intersects {{.expr$set}}",
function(x, set) length(intersect(x, set)) == 0
),
list(
"setequal",
"{{.}} and {{.expr$set}} are not equal as sets",
function(x, set) setequal(x, set)
)
)
make_predicate_data <- function(ns, xs, prefix, env) {
unname(
Map(function(nm, this) {
list(
nm,
paste("{{.}} is not", this),
getExportedValue(ns, paste0(prefix, nm)),
env = env
)
}, names(xs), xs)
)
}
types_base <- list(
null = "NULL",
symbol = "a symbol",
pairlist = "a pairlist",
environment = "an environment"
)
types_rlang <- list(
atomic = "an atomic vector{{of_length(.value$n)}}",
list = "a list{{of_length(.value$n)}}",
vector = "an atomic vector or list{{of_length(.value$n)}}",
logical = "a logical vector{{of_length(.value$n)}}",
integer = "an integer vector{{of_length(.value$n)}}",
double = "a double vector{{of_length(.value$n)}}",
character = "a character vector{{of_length(.value$n)}}",
raw = "a raw vector{{of_length(.value$n)}}"
)
env_formatter <- new.env(parent = baseenv())
env_formatter$of_length <- evalq(
function(n) if (is.null(n)) "" else paste(" of length", n),
env_formatter
)
predicates$type <- c(
list(
list(
"not_null",
"{{.}} is NULL",
function(x) !is.null(x)
),
list(
"closure",
"{{.}} is not a closure",
is_closure
),
list(
"language",
"{{.}} is not of type 'language'",
function(x) typeof(x) == "language"
),
list(
"numerical",
"{{.}} is not a numerical vector{{of_length(.value$n)}}",
function(x, n = NULL) {
if (! typeof(x) %in% c("double", "integer"))
return(FALSE)
if (!is.null(n) && length(x) != n)
return(FALSE)
TRUE
},
env = env_formatter
),
list(
"integerish",
"{{.}} is not an integerish vector{{of_length(.value$n)}}",
function(x, n = NULL) {
if (! typeof(x) %in% c("double", "integer"))
return(FALSE)
if (!is.null(n) && length(x) != n)
return(FALSE)
all(x == as.integer(x))
},
env = env_formatter
),
list(
"complex",
"{{.}} is not a complex vector{{of_length(.value$n)}}",
function(x, n = NULL) {
if (typeof(x) != "complex")
return(FALSE)
if (!is.null(n) && length(x) != n)
return(FALSE)
TRUE
},
env = env_formatter
),
list(
"number",
"{{.}} is not a number",
function(x)
typeof(x) %in% c("double", "integer") && length(x) == 1 && !is.na(x)
),
list(
"boolean",
"{{.}} is not a boolean",
function(x)
is.logical(x) && length(x) == 1 && !is.na(x)
),
list(
"string",
"{{.}} is not a string",
function(x)
is.character(x) && length(x) == 1 && !is.na(x)
)
),
make_predicate_data("base", types_base, "is.", baseenv()),
make_predicate_data("rlang", types_rlang, "is_", env_formatter)
)
for (x in unlist(predicates, recursive = FALSE)) {
nm <- paste0("chk_", x[[1]])
pred <- as_closure(x[[3]])
vld_error_msg(pred) <- new_quosure(x[[2]], x$env %|||% baseenv())
assign(nm, pred)
}
#' @rawNamespace exportPattern("^chk_.+$")
NULL
# Documentation -----------------------------------------------------------
nms_predicates <- lapply(predicates, function(x) {
nms <- vapply(x, `[[`, character(1), 1)
paste0("chk_", nms)
})
# Order types as they appear in the "R Language Definition" manual
nms_predicates$type <- c(
"chk_null",
"chk_not_null",
"chk_symbol",
"chk_pairlist",
"chk_closure",
"chk_environment",
"chk_language",
"chk_atomic",
"chk_vector",
"chk_logical",
"chk_boolean",
"chk_numerical",
"chk_number",
"chk_integer",
"chk_integerish",
"chk_double",
"chk_complex",
"chk_character",
"chk_string",
"chk_list",
"chk_raw"
)
#' Boolean predicates
#'
#' @evalRd rd_alias(nms_predicates$boolean)
#' @evalRd rd_usage(nms_predicates$boolean)
#'
#' @param x Object to test.
#' @param .f Function to map over the expressions to validate.
#' @param na.rm Should `NA` values be disregarded?
#'
#' @examples
#' f <- function(x, y) NULL
#'
#' ## Require x, y to have the same length
#' foo <- firmly(f, chk_true(length(x) == length(y)))
#' foo(runif(3), rnorm(3))
#' \dontrun{
#' foo(runif(2), rnorm(3))}
#'
#' ## Require x to contain only non-empty objects
#' msg <- "{{.}} contains empty objects"
#' bar <- firmly(f, !! msg := chk_all_map(function(.) length(.) != 0, x))
#' bar(1:2)
#' \dontrun{
#' bar(list(1, NULL))}
#'
#' ## Or more efficiently, in a vectorized manner:
#' baz <- firmly(f, chk_all("x contains empty objects" := lengths(x) != 0))
#' baz(1:2)
#' \dontrun{
#' baz(list(1, NULL))}
#'
#' @name predicates-boolean
NULL
#' Object predicates
#'
#' @evalRd rd_alias(nms_predicates$object)
#' @evalRd rd_usage(nms_predicates$object)
#'
#' @param x Object to test.
#'
#' @examples
#' row_sums <- firmly(rowSums, chk_matrix(x))
#' row_sums(matrix(1:6, 2, 3))
#'
#' ## Meaningless to sum across rows when column units differ
#' \dontrun{
#' row_sums(mtcars)}
#'
#' @seealso [Type predicates][predicates-type]
#'
#' @name predicates-object
NULL
#' Pattern predicates
#'
#' @evalRd rd_alias(nms_predicates$pattern)
#' @evalRd rd_usage(nms_predicates$pattern)
#'
#' @param x Object to test.
#' @param pattern Regular expression.
#' @param ignore.case Should pattern matching ignore case?
#' @param perl Should Perl-compatible regular expressions be used?
#' @param prefix,suffix String to match.
#' @param na.rm Should `NA` values be disregarded?
#'
#' @details To maintain consistency with [grepl()], `chk_starts_with()` and
#' `chk_ends_with()` coerce to `character` before matching.
#'
#' @seealso [grepl()], [startsWith()], [endsWith()]
#'
#' @examples
#' ymd <- function(y, m, d) paste(y, m, d, sep = "/")
#'
#' too_old <- "Not a 21st-century year"
#' recent_ymd <- firmly(ymd, !! too_old := chk_grepl("^20[[:digit:]]{2}$", y))
#'
#' recent_ymd(2017, 01, 01)
#' \dontrun{
#' recent_ymd(1999, 01, 01)}
#'
#' way_too_old <- "Pre-2010 year is too old"
#' more_recent_ymd <- firmly(ymd, !! way_too_old := chk_starts_with("201", y))
#'
#' more_recent_ymd(2017, 01, 01)
#' \dontrun{
#' more_recent_ymd(2001, 01, 01)}
#'
#' @name predicates-pattern
NULL
#' Property predicates
#'
#' @evalRd rd_alias(nms_predicates$property)
#' @evalRd rd_usage(nms_predicates$property)
#'
#' @param x Object to test.
#' @param nm,nms Name(s).
#' @param n Length.
#' @param which Object attribute(s).
#' @param what Class name.
#'
#' @seealso [Set predicates][predicates-set],
#' [chk_null()], [chk_not_null()]
#'
#' @examples
#' f <- function(x, y) NULL
#' foo <- firmly(f, "x, y are not disjoint" := chk_empty(intersect(x, y)))
#' foo(letters[1:3], letters[4:5])
#' \dontrun{
#' foo(letters[1:3], letters[3:5])}
#'
#' @name predicates-property
NULL
#' Relational predicates
#'
#' @evalRd rd_alias(nms_predicates$relation)
#' @evalRd rd_usage(nms_predicates$relation)
#'
#' @param x Object to test.
#' @param to Reference object.
#' @param lwr,upr Lower/upper bound.
#' @param na.rm Should `NA` values be disregarded?
#'
#' @seealso [all.equal()], [identical()]
#'
#' @examples
#' f <- function(x, y) log(y - x) / log(x)
#' foo <- firmly(f, chk_gt(0, x - 1, "y not greater than x" := y - x))
#' foo(2, 4)
#' \dontrun{
#' foo(1, 2)
#' foo(2, 2)}
#'
#' @name predicates-relational
NULL
#' Set predicates
#'
#' @evalRd rd_alias(nms_predicates$set)
#' @evalRd rd_usage(nms_predicates$set)
#'
#' @param x Object to test.
#' @param set Reference set (as a vector).
#'
#' @seealso [Set operations][setequal()],
#' [Property predicates][predicates-property]
#'
#' @examples
#' s3methods <- function(x) {
#' methods <- attr(methods(class = class(x)), "info")
#' with(methods, generic[!isS4])
#' }
#' foo <- fasten(
#' chk_include("predict", s3methods(object))
#' )(
#' function(object, data) {
#' pred <- predict(object, data)
#' "Do something with prediction"
#' }
#' )
#'
#' mdl <- lm(mpg ~ wt, mtcars[1:10, ])
#' data <- mtcars[11:12, ]
#'
#' foo(mdl, data)
#' \dontrun{
#' foo(NULL, data)}
#'
#' @name predicates-set
NULL
#' Type predicates
#'
#' @evalRd rd_alias(nms_predicates$type)
#' @evalRd rd_usage(nms_predicates$type)
#'
#' @param x Object to test.
#' @param n Length.
#' @param encoding Encoding of a string or character vector. One of `UTF-8`,
#' `latin1`, or `unknown`.
#' @param finite Whether values must be finite. Examples of non-finite values
#' are `Inf`, `-Inf` and `NaN`.
#'
#' @seealso
#' - [rlang type predicates][rlang::type-predicates], which underlie the
#' length-dependent predicates (except `chk_numerical()`)
#' - [Object predicates][predicates-object], for verifying identities that are
#' not characterized by type, e.g., data frames, which have type `list`
#'
#' @examples
#' f <- function(x, y, z) NULL
#'
#' ## Require all arguments to be integer (vectors)
#' foo <- firmly(f, chk_integer())
#' foo(0L, 1:2, length(letters))
#' \dontrun{
#' foo(0L, c(1, 2), length(letters))}
#'
#' ## Require all arguments to be scalar integers
#' bar <- firmly(f, chk_integer(n = 1))
#' bar(0L, 1L, length(NA))
#' \dontrun{
#' bar(0L, 1L, lengths(letters))}
#'
#' ## Require x, y to be character (vectors), and z to be an length-1 list
#' baz <- firmly(f, chk_character(x, y), chk_list(n = 1, z))
#' baz(letters, "text", list(1))
#' \dontrun{
#' baz(0, "text", list(1, 2))}
#'
#' @name predicates-type
NULL
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.