R version 3.3.1 RC (2016-06-14 r70774) -- "Bug in Your Hair" Copyright (C) 2016 The R Foundation for Statistical Computing Platform: x86_64-pc-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > basic_tests <- list( + list(input=c(TRUE, FALSE), any=TRUE, all=FALSE), + list(input=c(FALSE, TRUE), any=TRUE, all=FALSE), + + list(input=c(TRUE, TRUE), any=TRUE, all=TRUE), + list(input=c(FALSE, FALSE), any=FALSE, all=FALSE), + + list(input=c(NA, FALSE), any=NA, all=FALSE, any.na.rm=FALSE), + list(input=c(FALSE, NA), any=NA, all=FALSE, any.na.rm=FALSE), + + list(input=c(NA, TRUE), any=TRUE, all=NA, all.na.rm=TRUE), + list(input=c(TRUE, NA), any=TRUE, all=NA, all.na.rm=TRUE), + + list(input=logical(0), any=FALSE, all=TRUE), + + list(input=NA, any=NA, all=NA, any.na.rm=FALSE, any.na.rm=TRUE), + + list(input=c(TRUE, NA, FALSE), any=TRUE, any.na.rm=TRUE, + all=FALSE, all.na.rm=FALSE) + ) > > ## any, all accept '...' for input. > list_input_tests <- + list( + list(input=list(TRUE, TRUE), all=TRUE, any=TRUE), + list(input=list(FALSE, FALSE), all=FALSE, any=FALSE), + list(input=list(TRUE, FALSE), all=FALSE, any=TRUE), + list(input=list(FALSE, TRUE), all=FALSE, any=TRUE), + + list(input=list(FALSE, NA), + all=FALSE, all.na.rm=FALSE, any=NA, any.na.rm=FALSE), + list(input=list(NA, FALSE), + all=FALSE, all.na.rm=FALSE, any=NA, any.na.rm=FALSE), + + list(input=list(TRUE, NA), + all=NA, all.na.rm=TRUE, any=TRUE, any.na.rm=TRUE), + list(input=list(NA, TRUE), + all=NA, all.na.rm=TRUE, any=TRUE, any.na.rm=TRUE), + + list(input=list(NA, NA), + any=NA, any.na.rm=FALSE, all=NA, all.na.rm=TRUE), + + list(input=list(rep(TRUE, 2), rep(TRUE, 10)), + all=TRUE, any=TRUE), + + list(input=list(rep(TRUE, 2), c(TRUE, NA)), + all=NA, all.na.rm=TRUE, any=TRUE), + + list(input=list(rep(TRUE, 2), c(TRUE, FALSE)), + all=FALSE, any=TRUE), + + list(input=list(c(TRUE, FALSE), c(TRUE, NA)), + all=FALSE, all.na.rm=FALSE, any=TRUE, any.na.rm=TRUE) + ) > > > > do_tests <- function(L) + { + run <- function(f, input, na.rm = FALSE) + { + if (is.list(input)) + do.call(f, c(input, list(na.rm = na.rm))) + else f(input, na.rm = na.rm) + } + + do_check <- function(case, f) + { + fun <- deparse(substitute(f)) + if (!identical(case[[fun]], run(f, case$input))) { + cat("input: "); dput(case$input) + stop(fun, " returned ", run(f, case$input), + " wanted ", case[[fun]], call. = FALSE) + } + narm <- paste(fun, ".na.rm", sep = "") + if (!is.null(case[[narm]])) { + if (!identical(case[[narm]], + run(f, case$input, na.rm = TRUE))) { + cat("input: "); dput(case$input) + stop(narm, " returned ", run(f, case$input, na.rm = TRUE), + " wanted ", case[[narm]], call. = FALSE) + } + } + } + lab <- deparse(substitute(L)) + for (case in L) { + do_check(case, any) + do_check(case, all) + } + } > > do_tests(basic_tests) > do_tests(list_input_tests) >