qassertm: qassert for many at once

R/qassertm.R

@@ -0,0 +1,54 @@
+mkqassert <- function(varname, rule, frame)
+      eval(substitute(qassert(x, spec), list(x=as.name(varname), spec=rule)),
+                      envir=frame)
+
+#' @title Quick checks for multiple variable=rule enumerated as arguments
+#'
+#' @description
+#' Ergonomic wraper for \code{\link{qassert}} to check multiple variable=rule pairs
+#'
+#' @param ... [\code{var.name}=[\code{character}]]\cr
+#'   Any number of named arguments like var.name=rule\cr
+#'   See details of \code{\link{qtest}} for rule explanation.
+#' @template var.name
+#' @return See \code{\link{qassert}}.
+#' @seealso \code{\link{qtest}}, \code{\link{qassert}}
+#' @export
+#' @examples
+#' x=1:10; y=TRUE
+#' qassertm(x="i+", y="b")
+#'
+#' with(data.frame(a=1:26,b=letters), qassertm(a="i+", b="s"))
+qassertm <- function(...) {
+   in_args <- list(...)
+   for (v in names(in_args)) mkqassert(v, in_args[[v]], parent.frame())
+}
+
+#' @title Check single rule against all or enumerated variables
+#'
+#' @description
+#' Ergonomic wraper for \code{\link{qassert}} to check multiple variables against a single rule
+#'
+#' @param rule [[\code{character}]]\cr
+#'   Any number of named arguments like var.name=rule\cr
+#'   See details of \code{\link{qtest}} for rule explanation.
+#' @param ... [[\code{var.name}]]\cr
+#' list of unquoted variables that should match \code{rule}
+#' if none provided, uses all variables in local scope
+#' @return See \code{\link{qassert}}.
+#' @seealso \code{\link{qassertm}}
+#' @export
+#' @examples
+#' x <- TRUE; y <- FALSE
+#' # check all variables, scoped inside function
+#' foofunc <- function(x, y) { qassert_all('n'); print(x); }
+#' foofunc(1, 2)
+#' # only enumerated variables
+#' qassert_all('l', x, y)
+#'
+qassert_all <- function(rule, ...) {
+   qassert(rule,'s')
+   varlist <- lapply(match.call(expand.dots = FALSE)$..., as.character)
+   if(length(varlist)==0L) varlist <- ls(envir=parent.frame())
+   for (v in varlist) mkqassert(v, rule, parent.frame())
+}

tests/testthat/test_qassertm.R

@@ -0,0 +1,42 @@
+context("qassertm")
+
+xb = logical(10)
+xb2 = logical(10)
+xi = integer(10)
+xr = double(10)
+
+test_that("qassertm: fail on any, report first", {
+  # none
+  expect_error(qassertm(), NA)
+  # one
+  expect_error(qassertm(xb="b"), NA)
+  # many
+  expect_error(qassertm(xb="l"),
+               regexp = "'xb' .*'list', not 'logical'")
+
+  expect_error(qassertm(xb="b", xi="i", xr="r"), NA)
+  expect_error(qassertm(xb="b", xi="l", xr="r"),
+               regexp = "'xi' .*'list', not 'integer'")
+  expect_error(qassertm(xb="b", xi="i", xr="b"),
+               regexp = "'xr' .*logical', not 'double'")
+
+  # two wrong. only reports first
+  expect_error(qassertm(xb="b", xi="l", xr="b"),
+               regexp = "'xi' .*'list', not 'integer'")
+})
+
+test_that("qassert_all", {
+  # global
+  expect_error(qassert_all('b',xb,xb2), NA)
+  expect_error(qassert_all('n',xb,xb2),
+               regexp="'xb' .*numeric', not 'logical'")
+  expect_error(qassert_all('r',xr,xb),
+               regexp="'xb' .*double', not 'logical'")
+
+  # within function. reusing gobal names to test scope
+  expect_error((function(xb,xb2) qassert_all("n"))(1,2), NA)
+  expect_error((function(xb,xb2) qassert_all("n"))(1,TRUE),
+               regexp="'xb2' .*numeric', not 'logical'")
+  expect_error((function(xb,xb2) qassert_all("n"))(1),
+               regexp='"xb2" is missing')
+})