| #### 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") |