@r-universe/webr 2023.6.11 → 2023.6.21

package/dist/vfs/usr/lib/R/tests/eval-fns.R

@@ -0,0 +1,99 @@
+### Checking parse(* deparse()) "inversion property" ----------------------------
+## EPD := eval-parse-deparse :  eval(text = parse(deparse(*)))
+## Hopefully typically the identity():
+pd0 <- function(expr, backtick = TRUE, ...)
+    parse(text = deparse(expr, backtick=backtick, ...))
+id_epd <- function(expr, control = "all", ...)
+    eval(pd0(expr, control=control, ...))
+dPut <- function(x, control = "all") dput(x, control=control)
+##' Does 'x' contain "real" numbers
+##' with > 3 digits after "." where deparse may be platform dependent?
+hasReal <- function(x) {
+    if(is.double(x) || is.complex(x))
+        !all((x == round(x, 3)) | is.na(x))
+    else if(is.logical(x) || is.integer(x) ||
+	    is.symbol(x) || is.call(x) || is.environment(x) || is.character(x))
+	FALSE
+    else if(is.recursive(x)) # recurse :
+	any(vapply(x, hasReal, NA))
+    else if(isS4(x)) {
+	if(length(sn <- slotNames(x)))
+	    any(vapply(sn, function(s) hasReal(slot(x, s)), NA))
+	else # no slots
+	    FALSE # ?
+    }
+    else FALSE
+}
+isMissObj <- function(obj) identical(obj, alist(a=)[[1]])
+##' Does 'obj' contain "the missing object" ?
+##' @note defined recursively!
+hasMissObj <- function(obj) {
+    if(is.recursive(obj)) {
+        if(is.function(obj) || is.language(obj))
+            FALSE
+        else # incl pairlist()s
+            any(vapply(obj, hasMissObj, NA))
+    } else isMissObj(obj)
+}
+check_EPD <- function(obj, show = !hasReal(obj), oNam = deparse(substitute(obj)),
+                      ## FIXME: add  "niceNames" here:   ?!?
+                      control = c("keepInteger","showAttributes","keepNA"),
+                      not.identical.ldouble = if(!interactive()) c("t1", "t2", "ydata"),
+                      eq.tol = if(noLdbl) 2*.Machine$double.eps else 0) {
+    stopifnot(is.character(oNam))
+    if(show) dPut(obj)
+    if(is.environment(obj) || hasMissObj(obj)) {
+        cat("__ not parse()able __:",
+           if(is.environment(obj)) "environment" else "hasMissObj(.) is true", "\n")
+        return(invisible(obj)) # cannot parse it
+    }
+    ob2 <- id_epd(obj)
+    po <- tryCatch(pd0(obj, control=control),# the default deparse() *should* typically parse
+                   error = function(e) {
+                       cat("default parse(*, deparse(obj)) failed:\n  ",
+                           conditionMessage(e),
+                           "\n  but deparse(*, control='all') should work.\n")
+                       pd0(obj, control = "all") })
+    noLdbl <- (.Machine$sizeof.longdouble <= 8) ## TRUE typically from  --disable-long-double
+    if(!identical(obj, ob2, ignore.environment=TRUE,
+                  ignore.bytecode=TRUE, ignore.srcref=TRUE)) {
+        ae <- all.equal(obj, ob2, tolerance = eq.tol, # in case of functions:
+                        check.environment=FALSE)
+        if(is.na(match(oNam, not.identical.ldouble))) {
+            ae.txt <- "all.equal(*,*, tol = ..)"
+            ## differs for "no-ldouble": sprintf("all.equal(*,*, tol = %.3g)", eq.tol)
+            cat("not identical(*, ignore.env=T),", if(isTRUE(ae)) paste("but", ae.txt), "\n")
+        }
+        if(!isTRUE(ae)) stop("Not equal: ", ae.txt,
+                             paste(c(" giving", head(ae, 2),
+                                     if(length(ae) > 2) "...."), collapse = "\n  "))
+    }
+    if(!is.language(obj)) {
+	ob2. <- eval(obj) ## almost always *NOT* identical to obj, but eval()ed
+    }
+    if(show || !is.list(obj)) { ## check it works when wrapped (but do not recurse inf.!)
+        cat(" --> checking list(*): ")
+        check_EPD(list(.chk = obj), show = FALSE, oNam=oNam, eq.tol=eq.tol)
+        cat("Ok\n")
+    }
+    invisible(obj)
+}
+
+
+##' Check deparse <--> parse  consistency for *all* objects:
+runEPD_checks <- function(env = .GlobalEnv) {
+    stopifnot(is.environment(env))
+    for(nm in ls(envir=env)) {
+	cat(nm,": ", sep="")
+	x <- env[[nm]]
+	## if(!any(nm == "mf")) ## 'mf' [bug in deparse(mf, control="all") now fixed]
+	check_EPD(x, oNam=nm)
+	if(is.function(x) && !inherits(x, "classGeneratorFunction")) {
+	    ## FIXME? classGeneratorFunction, e.g., mForm don't "work" yet
+	    cat("checking body(.):\n")
+	    check_EPD(if(is.language(bx <- body(x))) removeSource(bx) else bx)
+	    cat("checking formals(.):\n"); check_EPD(formals(x))
+	}
+	cat("--=--=--=--=--\n")
+    }
+}

package/dist/vfs/usr/lib/R/tests/iconv.R

@@ -0,0 +1,35 @@
+### Tests of iconv, especially 'sub'
+
+x <- "fa\xE7ile"
+Encoding(x) <- "latin1"
+x
+xx <- iconv(x, "latin1", "UTF-8")
+xx
+stopifnot(charToRaw(xx) == as.raw(c(0x66, 0x61, 0xc3, 0xa7, 0x69, 0x6c, 0x65)))
+
+stopifnot(is.na(iconv(x, "latin1", "ASCII")))
+stopifnot(iconv(x, "latin1", "ASCII", "?")  == "fa?ile")
+stopifnot(iconv(x, "latin1", "ASCII", "") == "faile")
+stopifnot(iconv(x, "latin1", "ASCII", "byte") == "fa<e7>ile")
+stopifnot(iconv(xx, "UTF-8", "ASCII", "Unicode") == "fa<U+00E7>ile")
+stopifnot(iconv(xx, "UTF-8", "ASCII", "c99") == "fa\\u00e7ile")
+stopifnot(charToRaw(iconv(xx, "UTF-8", "ASCII", "c99")) ==
+          sapply(c("f", "a", "\\", "u", "0", "0", "e", "7", "i", "l", "e"), charToRaw))
+
+z <- "\U1f600"
+charToRaw(z)
+stopifnot(iconv(z, "UTF-8", "ASCII", "byte") == "<f0><9f><98><80>")
+stopifnot(iconv(z, "UTF-8", "ASCII", "Unicode") == "<U+0001F600>")
+stopifnot(iconv(z, "UTF-8", "ASCII", "c99") == "\\U0001f600")
+
+## write out to compare with GNU libiconv's iconv on e.g. macOS
+## The reading can only work in a UTF-8 locale
+if(startsWith(extSoftVersion()["iconv"], 'GNU libiconv') &&
+   l10n_info()[["UTF-8"]]) {
+    writeLines(c(xx, z), "test.txt")
+    zz <- system2("iconv", c("-f", "UTF-8", "-t", "c99", "test.txt"),
+                  stdout = TRUE)
+    unlink('test.txt')
+    stopifnot(zz == iconv(c(xx, z), "UTF-8", "ASCII", "c99"))
+    message('sub = "c99" agrees with GNU libiconv')
+} else message('sub = "c99" agrees with GNU libiconv -- SKIPPED')

package/dist/vfs/usr/lib/R/tests/iec60559.R

@@ -0,0 +1,18 @@
+## Tests for various features of IEC60559 doubles.
+## Most of these are optional, so this is a sloppy test.
+
+# Goes to denormal (aka subnormal) numbers at -708.4
+exp(c(-745:-740, -730, -720, -710:-705))
+
+# goes to subnormal numbers at -308, to zero at ca 5e-324.
+10^-(324:307)
+2^-(1022:1075)
+
+# And because most libm pow() functions special-case integer powers.
+10^-(324:307-0.01)/10^0.01
+
+# IEC60559 mandates this, but C99/C11 do not.
+# Mingw-w64 did not do so in v 2.0.1
+x <- 0*(-1) # negative zero
+sqrt(x)
+identical(x, sqrt(x))

package/dist/vfs/usr/lib/R/tests/iec60559.Rout.save

@@ -0,0 +1,60 @@
+
+R Under development (unstable) (2022-03-19 r81942) -- "Unsuffered Consequences"
+Copyright (C) 2022 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.
+
+> ## Tests for various features of IEC60559 doubles.
+> ## Most of these are optional, so this is a sloppy test.
+> 
+> # Goes to denormal (aka subnormal) numbers at -708.4
+> exp(c(-745:-740, -730, -720, -710:-705))
+ [1] 4.940656e-324 9.881313e-324 1.976263e-323 5.434722e-323 1.531604e-322
+ [6] 4.199558e-322 9.226315e-318 2.032231e-313 4.476286e-309 1.216781e-308
+[11] 3.307553e-308 8.990861e-308 2.443969e-307 6.643398e-307
+> 
+> # goes to subnormal numbers at -308, to zero at ca 5e-324.
+> 10^-(324:307)
+ [1]  0.000000e+00 9.881313e-324 9.881313e-323 9.980126e-322 9.999889e-321
+ [6] 9.999889e-320 9.999987e-319 1.000000e-317 1.000000e-316 1.000000e-315
+[11] 1.000000e-314 1.000000e-313 1.000000e-312 1.000000e-311 1.000000e-310
+[16] 1.000000e-309 1.000000e-308 1.000000e-307
+> 2^-(1022:1075)
+ [1] 2.225074e-308 1.112537e-308 5.562685e-309 2.781342e-309 1.390671e-309
+ [6] 6.953356e-310 3.476678e-310 1.738339e-310 8.691695e-311 4.345847e-311
+[11] 2.172924e-311 1.086462e-311 5.432309e-312 2.716155e-312 1.358077e-312
+[16] 6.790387e-313 3.395193e-313 1.697597e-313 8.487983e-314 4.243992e-314
+[21] 2.121996e-314 1.060998e-314 5.304989e-315 2.652495e-315 1.326247e-315
+[26] 6.631237e-316 3.315618e-316 1.657809e-316 8.289046e-317 4.144523e-317
+[31] 2.072262e-317 1.036131e-317 5.180654e-318 2.590327e-318 1.295163e-318
+[36] 6.475817e-319 3.237909e-319 1.618954e-319 8.094772e-320 4.047386e-320
+[41] 2.023693e-320 1.011846e-320 5.059232e-321 2.529616e-321 1.264808e-321
+[46] 6.324040e-322 3.162020e-322 1.581010e-322 7.905050e-323 3.952525e-323
+[51] 1.976263e-323 9.881313e-324 4.940656e-324  0.000000e+00
+> 
+> # And because most libm pow() functions special-case integer powers.
+> 10^-(324:307-0.01)/10^0.01
+ [1]  0.000000e+00 9.881313e-324 1.037538e-322 9.980126e-322 9.999889e-321
+ [6] 1.000038e-319 9.999987e-319 9.999997e-318 1.000000e-316 1.000000e-315
+[11] 1.000000e-314 1.000000e-313 1.000000e-312 1.000000e-311 1.000000e-310
+[16] 1.000000e-309 1.000000e-308 1.000000e-307
+> 
+> # IEC60559 mandates this, but C99/C11 do not.
+> # Mingw-w64 did not do so in v 2.0.1
+> x <- 0*(-1) # negative zero
+> sqrt(x)
+[1] 0
+> identical(x, sqrt(x))
+[1] TRUE
+> 

package/dist/vfs/usr/lib/R/tests/internet.R

@@ -0,0 +1,20 @@
+## These are tests that require a working Internet connection.
+## We attempt to test for that.
+
+if(.Platform$OS.type == "unix" &&
+   is.null(nsl("cran.r-project.org"))) q()
+
+# test do_download (and "record" #{packages}):
+ap <- available.packages(contrib.url("http://cran.r-project.org"))
+## IGNORE_RDIFF_BEGIN
+nrow(ap)
+## IGNORE_RDIFF_END
+
+# test url connections on http
+zz <- url("http://cran.r-project.org/")
+readLines(zz)
+close(zz)
+
+# and via read.table
+
+read.table("http://www.stats.ox.ac.uk/pub/datasets/csb/ch11b.dat")

package/dist/vfs/usr/lib/R/tests/internet.Rout.save

@@ -0,0 +1,164 @@
+
+R Under development (unstable) (2022-11-14 r83344) -- "Unsuffered Consequences"
+Copyright (C) 2022 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.
+
+> ## These are tests that require a working Internet connection.
+> ## We attempt to test for that.
+> 
+> if(.Platform$OS.type == "unix" &&
++    is.null(nsl("cran.r-project.org"))) q()
+> 
+> # test do_download (and "record" #{packages}):
+> ap <- available.packages(contrib.url("http://cran.r-project.org"))
+> ## IGNORE_RDIFF_BEGIN
+> nrow(ap)
+[1] 18844
+> ## IGNORE_RDIFF_END
+> 
+> # test url connections on http
+> zz <- url("http://cran.r-project.org/")
+> readLines(zz)
+ [1] "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Frameset//EN\" \"http://www.w3.org/TR/html4/frameset.dtd\">"
+ [2] "<html>"                                                                                                   
+ [3] "<head>"                                                                                                   
+ [4] "<title>The Comprehensive R Archive Network</title>"                                                       
+ [5] "<META HTTP-EQUIV=\"content-type\" CONTENT=\"text/html; charset=utf-8\">"                                  
+ [6] "<link rel=\"icon\" href=\"favicon.ico\" type=\"image/x-icon\">"                                           
+ [7] "<link rel=\"shortcut icon\" href=\"favicon.ico\" type=\"image/x-icon\">"                                  
+ [8] "<link rel=\"stylesheet\" type=\"text/css\" href=\"R.css\">"                                               
+ [9] "</head>"                                                                                                  
+[10] ""                                                                                                         
+[11] "<FRAMESET cols=\"1*, 4*\" style=\"border: none;\">"                                                       
+[12] "<FRAMESET rows=\"120, 1*\">"                                                                              
+[13] "<FRAME src=\"logo.html\" name=\"logo\" frameborder=0>"                                                    
+[14] "<FRAME src=\"navbar.html\" name=\"contents\" frameborder=0>"                                              
+[15] "</FRAMESET>"                                                                                              
+[16] "<FRAME src=\"banner.shtml\" name=\"banner\" frameborder=0>"                                               
+[17] "<noframes>"                                                                                               
+[18] "<h1>The Comprehensive R Archive Network</h1>"                                                             
+[19] ""                                                                                                         
+[20] "Your browser seems not to support frames,"                                                                
+[21] "here is the <A href=\"navbar.html\">contents page</A> of CRAN."                                           
+[22] "</noframes>"                                                                                              
+[23] "</FRAMESET>"                                                                                              
+[24] "</html>"                                                                                                  
+> close(zz)
+> 
+> # and via read.table
+> 
+> read.table("http://www.stats.ox.ac.uk/pub/datasets/csb/ch11b.dat")
+     V1  V2   V3    V4 V5
+1     1 307  930 36.58  0
+2     2 307  940 36.73  0
+3     3 307  950 36.93  0
+4     4 307 1000 37.15  0
+5     5 307 1010 37.23  0
+6     6 307 1020 37.24  0
+7     7 307 1030 37.24  0
+8     8 307 1040 36.90  0
+9     9 307 1050 36.95  0
+10   10 307 1100 36.89  0
+11   11 307 1110 36.95  0
+12   12 307 1120 37.00  0
+13   13 307 1130 36.90  0
+14   14 307 1140 36.99  0
+15   15 307 1150 36.99  0
+16   16 307 1200 37.01  0
+17   17 307 1210 37.04  0
+18   18 307 1220 37.04  0
+19   19 307 1230 37.14  0
+20   20 307 1240 37.07  0
+21   21 307 1250 36.98  0
+22   22 307 1300 37.01  0
+23   23 307 1310 36.97  0
+24   24 307 1320 36.97  0
+25   25 307 1330 37.12  0
+26   26 307 1340 37.13  0
+27   27 307 1350 37.14  0
+28   28 307 1400 37.15  0
+29   29 307 1410 37.17  0
+30   30 307 1420 37.12  0
+31   31 307 1430 37.12  0
+32   32 307 1440 37.17  0
+33   33 307 1450 37.28  0
+34   34 307 1500 37.28  0
+35   35 307 1510 37.44  0
+36   36 307 1520 37.51  0
+37   37 307 1530 37.64  0
+38   38 307 1540 37.51  0
+39   39 307 1550 37.98  1
+40   40 307 1600 38.02  1
+41   41 307 1610 38.00  1
+42   42 307 1620 38.24  1
+43   43 307 1630 38.10  1
+44   44 307 1640 38.24  1
+45   45 307 1650 38.11  1
+46   46 307 1700 38.02  1
+47   47 307 1710 38.11  1
+48   48 307 1720 38.01  1
+49   49 307 1730 37.91  1
+50   50 307 1740 37.96  1
+51   51 307 1750 38.03  1
+52   52 307 1800 38.17  1
+53   53 307 1810 38.19  1
+54   54 307 1820 38.18  1
+55   55 307 1830 38.15  1
+56   56 307 1840 38.04  1
+57   57 307 1850 37.96  1
+58   58 307 1900 37.84  1
+59   59 307 1910 37.83  1
+60   60 307 1920 37.84  1
+61   61 307 1930 37.74  1
+62   62 307 1940 37.76  1
+63   63 307 1950 37.76  1
+64   64 307 2000 37.64  1
+65   65 307 2010 37.63  1
+66   66 307 2020 38.06  1
+67   67 307 2030 38.19  1
+68   68 307 2040 38.35  1
+69   69 307 2050 38.25  1
+70   70 307 2100 37.86  1
+71   71 307 2110 37.95  1
+72   72 307 2120 37.95  1
+73   73 307 2130 37.76  1
+74   74 307 2140 37.60  1
+75   75 307 2150 37.89  1
+76   76 307 2200 37.86  1
+77   77 307 2210 37.71  1
+78   78 307 2220 37.78  1
+79   79 307 2230 37.82  1
+80   80 307 2240 37.76  1
+81   81 307 2250 37.81  1
+82   82 307 2300 37.84  1
+83   83 307 2310 38.01  1
+84   84 307 2320 38.10  1
+85   85 307 2330 38.15  1
+86   86 307 2340 37.92  1
+87   87 307 2350 37.64  1
+88   88 308    0 37.70  1
+89   89 308   10 37.46  1
+90   90 308   20 37.41  1
+91   91 308   30 37.46  1
+92   92 308   40 37.56  1
+93   93 308   50 37.55  1
+94   94 308  100 37.75  1
+95   95 308  110 37.76  1
+96   96 308  120 37.73  1
+97   97 308  130 37.77  1
+98   98 308  140 38.01  1
+99   99 308  150 38.04  1
+100 100 308  200 38.07  1
+> 

package/dist/vfs/usr/lib/R/tests/internet2.R

@@ -0,0 +1,69 @@
+## These are tests that require socket and internet functionality, and
+## a working Internet connection.
+## We attempt to test for those.
+
+onWindows <- .Platform$OS.type == "windows"
+
+if(.Platform$OS.type == "unix" &&
+   is.null(nsl("cran.r-project.org"))) q()
+
+
+## check graceful failure:
+try(url("http://foo.bar", "r"))
+
+if(onWindows)
+    try(url("http://foo.bar", "r", method = "wininet"))
+
+## download.file(.. , headers = character()) - PR#17710
+tf <- tempfile()
+download.file("https://cloud.r-project.org/src/base/THANKS", destfile = tf,
+              method = if(onWindows) "wininet" else "libcurl",
+              headers = character()) -> err.code
+stopifnot(err.code == 0, file.size(tf) > 999)
+## had failed for the Windows case
+
+
+## everything from here on is directly over sockets
+if(!capabilities("sockets")) stop("no socket capabilities")
+
+# do the same thing via sockets (cut-down httpclient)
+httpget <- function (url, port = 80)
+{
+    urlel <- strsplit(url, "/")[[1]]
+    if (urlel[1] != "http:") stop("Not an http:// URL")
+    host <- urlel[3]
+    rurl <- paste(c("", urlel[-(1:3)]), collapse = "/")
+    a <- make.socket(host, port = port)
+    on.exit(close.socket(a))
+    headreq <- paste("HEAD", rurl, "HTTP/1.0\r\nConnection: Keep-Alive\r\nAccept: text/plain\r\n\r\n")
+    write.socket(a, headreq)
+    head <- read.socket(a, maxlen = 8000)
+    b <- strsplit(head, "\n")[[1]]
+    if (length(grep("200 OK", b[1])) == 0) stop(b[1])
+    len <- as.numeric(strsplit(grep("Content-Length", b, value = TRUE),
+                               ":")[[1]][2])
+    getreq <- paste("GET", rurl, "HTTP/1.0\r\nConnection: Keep-Alive\r\nAccept: text/plain\r\n\r\n")
+    write.socket(a, getreq)
+    junk <- read.socket(a, maxlen = nchar(head))
+    data <- ""
+    b <- strsplit(c(head, junk), "\n")
+    nn <- length(b[[1]])
+    if (length(b[[2]]) > nn)
+        data <- paste(b[[2]][-(1:nn)], collapse = "\n")
+    while (nchar(data) < len) {
+        new_data <- read.socket(a, maxlen = len - nchar(data))
+        if (new_data == "") break
+        data <- paste(data, new_data, sep = "")
+    }
+    strsplit(data, "\n")[[1]]
+}
+
+if(nzchar(Sys.getenv("http_proxy")) || nzchar(Sys.getenv("HTTP_PROXY"))) {
+    cat("http proxy is set, so skip test of http over sockets\n")
+} else {
+## 2022-04-07: now redirects to https://
+##    f <- httpget("http://www.stats.ox.ac.uk/pub/datasets/csb/ch11b.dat")
+    f <- httpget("http://httpbin.org/get")
+    str(f)
+    if (!length(grep('"headers":', f))) stop("Data not fetched via socket")
+}

package/dist/vfs/usr/lib/R/tests/isas-tests.Rin

@@ -0,0 +1,60 @@
+#### 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")