The R Project SVN R

#### Produce an R test script -*- R -*-
## The logic here (BDR, 2003-02-02) is
## identify all is. and as. functions which might be thought of
## as precursors to is() and as().  Identify only generics.
##
## Then for a set of boundary-case inputs x, if as.foo(x) works
## check that is.foo(as.foo(x)) is true.
## Also check idempotency: as.foo(as.foo(x)) == as.foo(x)
## and that as.foo(x) == x iff is.foo(x) is true.
##
## One problem with the last is that no realistic x's are used.
##
ls.base <- c(ls("package:base"), ls("package:stats"))
base.is.f <- sapply(ls.base, function(x) is.function(get(x)))
bi <- ls.base[base.is.f]
iroot <- substring(is.bi <- bi[substring(bi,1,3) == "is."],4)
## is.single is a dummy
iroot <- iroot[-match("single", iroot)]
aroot <- substring(as.bi <- bi[substring(bi,1,3) == "as."],4)
## eliminate as.foo methods: there are no is.foo methods
## this works because data.frame.*  has no other matches for data.
aroot <- aroot[!duplicated(sub("\\..*", "", aroot))]
root <- intersect(iroot, aroot) # both an  is.foo and as.foo function exist

ex.list <- expression(integer(0), NULL, list(), 1:1, pi, "1.3", list(a=1),
    as.data.frame(character(0)))

##--- producing the real R script:
sink("isas-tests.R")

cat(".proctime00 <- proc.time()\n",
    "isall.equal <- function(x,y)",
    "typeof(x) == typeof(y) && is.logical(r <- all.equal(x,y, tolerance=0)) && r \n",
    sep="\n")

cat("report <- function(x) {print(x); stopifnot(x)}\n")

cat("options(error = expression(NULL))",
    "# don't stop on error in batch\n##~~~~~~~~~~~~~~\n")
for(x in ex.list) {
    cat("\n###--------\n x <- ", deparse(x), "\n", sep="")
    ## is.foo(as.foo( bar )) #>> TRUE :
    for(r in root) {
        cat("res <- try(as.", r, "( x ), silent = TRUE)\n", sep="")
        cat("if(!inherits(res, 'try-error')) report(is.",r,"(res))\n", sep="")
    }
    cat("\n")
    ## if(is.foo(bar))  bar ``=='' as.foo(bar) :
    for(r in root) {
        cat("res <- try(as.", r, "( x ), silent = TRUE)\n", sep="")
        cat("if(!inherits(res, 'try-error'))\n   report({if(is.",r,"(x)) { ",
            "cat('IS: ');all.equal(x, res, tolerance=0)\n",
            "   } else   !isall.equal(x, res)})\n", sep="")
    }

    ## f <- as.foo(x)  ==>  as.foo(f) == f :
    for(r in aroot)
        cat("f <- try(as.",r,"( x ), silent = TRUE)\n  if(!inherits(f, 'try-error')) report(identical(f, as.",r,"( f )))\n", sep="")
}
cat("cat('Time elapsed: ', proc.time() - .proctime00,'\\n')\n")