#' Generate input-validation checks
#'
#' \code{localize} derives a function that \emph{generates} check formulae of
#' local scope from a check formula of global scope. \code{globalize} takes such
#' a check-formula generator and returns the underlying global check formula.
#' These operations are mutually invertible.
#'
#' @seealso The notion of \dQuote{scope} is explained in the \emph{Check
#' Formulae} section of \link{firmly}.
#'
#' Ready-made checkers for \link[=type-checkers]{types},
#' \link[=scalar-checkers]{scalar objects}, and
#' \link[=misc-checkers]{miscellaneous predicates} are provided as a
#' convenience, and as a model for creating families of check makers.
#' @examples
#' chk_pos_gbl <- "Not positive" ~ {. > 0}
#' chk_pos_lcl <- localize(chk_pos_gbl)
#' chk_pos_lcl(~x, "y not greater than x" ~ x - y)
#' # list("Not positive: x" ~ x, "y not greater than x" ~ x - y) ~ {. > 0}
#'
#' # localize and globalize are mutual inverses
#' identical(globalize(localize(chk_pos_gbl)), chk_pos_gbl) # [1] TRUE
#' all.equal(localize(globalize(chk_pos_lcl)), chk_pos_lcl) # [1] TRUE
#'
#' \dontrun{
#'
#' pass <- function(x, y) "Pass"
#'
#' # Impose local positivity checks
#' f <- firmly(pass, chk_pos_lcl(~x, "y not greater than x" ~ x - y))
#' f(2, 1) # [1] "Pass"
#' f(2, 2) # Error: "y not greater than x"
#' f(0, 1) # Errors: "Not positive: x", "y not greater than x"
#'
#' # Or just check positivity of x
#' g <- firmly(pass, chk_pos_lcl(~x))
#' g(1, 0) # [1] "Pass"
#' g(0, 0) # Error: "Not positive: x"
#'
#' # In contrast, chk_pos_gbl checks positivity for all arguments
#' h <- firmly(pass, chk_pos_gbl)
#' h(2, 2) # [1] "Pass"
#' h(1, 0) # Error: "Not positive: `y`"
#' h(0, 0) # Errors: "Not positive: `x`", "Not positive: `y`"
#'
#' # Alternatively, globalize the localized checker
#' h2 <- firmly(pass, globalize(chk_pos_lcl))
#' all.equal(h, h2) # [1] TRUE
#'
#' # Use localize to make parameterized checkers
#' chk_lte <- function(n, ...) {
#' err_msg <- paste("Not <=", as.character(n))
#' localize(err_msg ~ {. <= n})(...)
#' }
#' fib <- function(n) {
#' if (n <= 1L) return(1L)
#' Recall(n - 1) + Recall(n - 2)
#' }
#' capped_fib <- firmly(fib, chk_lte(30, ~ ceiling(n)))
#' capped_fib(19) # [1] 6765
#' capped_fib(31) # Error: "Not <= 30: ceiling(n)"
#' }
#'
#' @name input-validators
NULL
is_check_maker <- function(x) {
is_closure(x) && inherits(x, "check_maker")
}
#' @rdname input-validators
#' @export
#' @param chk Check formula of global scope \emph{with} custom error message,
#' i.e., a formula of the form \code{<string> ~ <predicate>}.
#' @return \code{localize} returns a function of class \code{"check_maker"} and
#' call signature \code{function(...)}:
#' \itemize{
#' \item The \code{\dots} are \strong{check items} (see \emph{Check Formulae
#' of Local Scope} in the documentation page \link{firmly}).
#' \item The return value is the check formula of local scope whose scope is
#' comprised of these check items, and whose predicate function is that of
#' \code{chk} (i.e., the right-hand side of \code{chk}). Unless a check
#' item has its own error message, the error message is derived from that
#' of \code{chk} (i.e., the left-hand side of \code{chk}).
#' }
localize <- list(
list("`chk` must be a formula of the form <string> ~ <predicate>" ~ chk) ~
is_gbl_check_formula
) %checkin%
function(chk) {
.msg <- f_eval_lhs(chk)
.rhs <- lazyeval::f_rhs(chk)
.env <- lazyeval::f_env(chk)
chkr <- function(...) {
fs <- list(...)
not_check_expr <- vapply(fs, Negate(is_check_expr), logical(1))
if (any(not_check_expr)) {
args <- paste(
vapply(fs[not_check_expr], deparse_collapse, character(1)),
collapse = ", "
)
stop_wo_call("LHS of formula(e) not empty or string: ", args)
}
wo_msg <- vapply(fs, is_onesided, logical(1))
fs[wo_msg] <- lapply(fs[wo_msg], function(f) {
lazyeval::f_lhs(f) <- paste(.msg, deparse_collapse(lazyeval::f_rhs(f)), sep = ": ")
f
})
lazyeval::f_new(.rhs, fs, .env)
}
structure(chkr, class = c("check_maker", class(chkr)))
}
#' @rdname input-validators
#' @export
#' @param chkr Function of class \code{"check_maker"}, i.e., a function created
#' by \code{localize}.
#' @return \code{globalize} returns the global-scope check formula from which
#' the function \code{chkr} is derived.
globalize <- list(
list("`chkr` must be a local checker function (see ?localize)" ~ chkr) ~
is_check_maker
) %checkin%
function(chkr) {
environment(chkr)$chk
}
#' @export
print.check_maker <- function(x, ...) {
env <- environment(x)
p <- env$.rhs
cat("<check_maker>\n")
cat("\n* Predicate function:\n")
if (is_lambda(p)) {
cat(deparse_collapse(express_lambda(p)), "\n")
} else {
print.default(p)
}
cat("\n* Error message:\n")
cat(encodeString(env$.msg, quote = "\""), "\n")
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.