@r-universe/webr 2023.6.11 → 2023.6.21

package/dist/vfs/usr/lib/R/tests/eval-etc.Rout.save

@@ -0,0 +1,1014 @@
+
+R Under development (unstable) (2023-02-21 r83888) -- "Unsuffered Consequences"
+Copyright (C) 2023 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.
+
+> ####  eval / parse / deparse / substitute  etc
+> 
+> set.seed(2017-08-24) # as we will deparse all objects *and* use *.Rout.save
+> .proctime00 <- proc.time() # start timing
+> 
+> ##- From: Peter Dalgaard BSA <p.dalgaard@biostat.ku.dk>
+> ##- Subject: Re: source() / eval() bug ??? (PR#96)
+> ##- Date: 20 Jan 1999 14:56:24 +0100
+> e1 <- parse(text='c(F=(f <- .3), "Tail area" = 2 * if(f < 1) 30 else 90)')[[1]]
+> e1
+c(F = (f <- 0.3), `Tail area` = 2 * if (f < 1) 30 else 90)
+> str(eval(e1))
+ Named num [1:2] 0.3 60
+ - attr(*, "names")= chr [1:2] "F" "Tail area"
+> mode(e1)
+[1] "call"
+> 
+> ( e2 <- quote(c(a=1,b=2)) )
+c(a = 1, b = 2)
+> names(e2)[2] <- "a b c"
+> e2
+c(`a b c` = 1, b = 2)
+> parse(text=deparse(e2))
+expression(c(`a b c` = 1, b = 2))
+> 
+> ##- From: Peter Dalgaard BSA <p.dalgaard@biostat.ku.dk>
+> ##- Date: 22 Jan 1999 11:47
+> 
+> ( e3 <- quote(c(F=1,"tail area"=pf(1,1,1))) )
+c(F = 1, `tail area` = pf(1, 1, 1))
+> eval(e3)
+        F tail area 
+      1.0       0.5 
+> names(e3)
+[1] ""          "F"         "tail area"
+> 
+> names(e3)[2] <- "Variance ratio"
+> e3
+c(`Variance ratio` = 1, `tail area` = pf(1, 1, 1))
+> eval(e3)
+Variance ratio      tail area 
+           1.0            0.5 
+> 
+> 
+> ##- From: Peter Dalgaard BSA <p.dalgaard@biostat.ku.dk>
+> ##- Date: 2 Sep 1999
+> 
+> ## The first failed in 0.65.0 :
+> attach(list(x=1))
+> evalq(dim(x) <- 1,as.environment(2))
+> dput(get("x", envir=as.environment(2)), control="all")
+structure(1, dim = 1L)
+> 
+> e <- local({x <- 1;environment()})
+> evalq(dim(x) <- 1,e)
+> dput(get("x",envir=e), control="all")
+structure(1, dim = 1L)
+> 
+> ### Substitute, Eval, Parse, etc
+> 
+> ## PR#3 : "..." matching
+> ## Revised March 7 2001 -pd
+> A <- function(x, y, ...) {
++     B <- function(a, b, ...) { match.call() }
++     B(x+y, ...)
++ }
+> (aa <- A(1,2,3))
+B(a = x + y, b = 3)
+> all.equal(as.list(aa),
++           list(as.name("B"), a = expression(x+y)[[1]], b = 3))
+[1] TRUE
+> (a2 <- A(1,2, named = 3)) #A(1,2, named = 3)
+B(a = x + y, named = 3)
+> all.equal(as.list(a2),
++           list(as.name("B"), a = expression(x+y)[[1]], named = 3))
+[1] TRUE
+> 
+> CC <- function(...) match.call()
+> DD <- function(...) CC(...)
+> a3 <- DD(1,2,3)
+> all.equal(as.list(a3),
++           list(as.name("CC"), 1, 2, 3))
+[1] TRUE
+> 
+> ## More dots issues: March 19 2001 -pd
+> ## Didn't work up to and including 1.2.2
+> 
+> f <- function(...) {
++ 	val <- match.call(expand.dots=FALSE)$...
++         x <- val[[1]]
++ 	eval.parent(substitute(missing(x)))
++ }
+> g <- function(...) h(f(...))
+> h <- function(...) list(...)
+> k <- function(...) g(...)
+> X <- k(a=)
+> all.equal(X, list(TRUE))
+[1] TRUE
+> 
+> ## Bug PR#24
+> f <- function(x,...) substitute(list(x,...))
+> deparse(f(a, b)) == "list(a, b)" &&
++ deparse(f(b, a)) == "list(b, a)" &&
++ deparse(f(x, y)) == "list(x, y)" &&
++ deparse(f(y, x)) == "list(y, x)"
+[1] TRUE
+> 
+> tt <- function(x) { is.vector(x); deparse(substitute(x)) }
+> a <- list(b=3); tt(a$b) == "a$b" # tends to break when ...
+[1] TRUE
+> 
+> 
+> ## Parser:
+> 1 <
++     2
+[1] TRUE
+> 2 <=
++     3
+[1] TRUE
+> 4 >=
++     3
+[1] TRUE
+> 3 >
++     2
+[1] TRUE
+> 2 ==
++     2
+[1] TRUE
+> ## bug till ...
+> 1 !=
++     3
+[1] TRUE
+> 
+> all(NULL == NULL)
+[1] TRUE
+> 
+> ## PR #656 (related)
+> u <- runif(1);	length(find(".Random.seed")) == 1
+[1] TRUE
+> 
+> MyVaR <<- "val";length(find("MyVaR")) == 1
+[1] TRUE
+> rm(MyVaR);	length(find("MyVaR")) == 0
+[1] TRUE
+> 
+> 
+> ## Martin Maechler: rare bad bug in sys.function() {or match.arg()} (PR#1409)
+> callme <- function(a = 1, mm = c("Abc", "Bde")) {
++     mm <- match.arg(mm); cat("mm = "); str(mm) ; invisible()
++ }
+> ## The first two were as desired:
+> callme()
+mm =  chr "Abc"
+> callme(mm="B")
+mm =  chr "Bde"
+> mycaller <- function(x = 1, callme = pi) { callme(x) }
+> mycaller()## wrongly gave `mm = NULL'  now = "Abc"
+mm =  chr "Abc"
+> 
+> CO <- utils::capture.output
+> 
+> ## Garbage collection  protection problem:
+> if(FALSE) ## only here to be run as part of  'make test-Gct'
++     gctorture() # <- for manual testing
+> x <- c("a", NA, "b")
+> fx <- factor(x, exclude="")
+> ST <- if(interactive()) system.time else invisible
+> ST(r <- replicate(20, CO(print(fx))))
+> table(r[2,]) ## the '<NA>' levels part would be wrong occasionally
+
+Levels: a b <NA> 
+              20 
+> stopifnot(r[2,] == "Levels: a b <NA>") # in case of failure, see r[2,] above
+> 
+> 
+> ## withAutoprint() : must *not* evaluate twice *and* do it in calling environment:
+> stopifnot(
++     identical(
++ 	## ensure it is only evaluated _once_ :
++ 	CO(withAutoprint({ x <- 1:2; cat("x=",x,"\n") }))[1],
++ 	paste0(getOption("prompt"), "x <- 1:2"))
++    ,
++     ## need "enough" deparseCtrl for this:
++     grepl("1L, NA_integer_", CO(withAutoprint(x <- c(1L, NA_integer_, NA))))
++    ,
++     identical(CO(r1 <- withAutoprint({ formals(withAutoprint); body(withAutoprint) })),
++ 	      CO(r2 <- source(expr = list(quote(formals(withAutoprint)),
++ 					  quote(body(withAutoprint)) ),
++ 			      echo=TRUE))),
++     identical(r1,r2)
++ )
+> ## partly failed in R 3.4.0 alpha
+> rm(CO) # as its deparse() depends on if utils was installed w/ keep.source.pkgs=TRUE
+> 
+> srcdir <- file.path(Sys.getenv("SRCDIR"), "eval-fns.R")
+> source(if(file.exists(srcdir)) srcdir else "./eval-fns.R", echo = TRUE)
+
+> 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)
+
+> hasReal <- function(x) {
++     if (is.double(x) || is.complex(x)) 
++         !all((x == round(x, 3)) | is.na(x))
++     else if (is.logical(x) || is. .... [TRUNCATED] 
+
+> isMissObj <- function(obj) identical(obj, alist(a = )[[1]])
+
+> hasMissObj <- function(obj) {
++     if (is.recursive(obj)) {
++         if (is.function(obj) || is.language(obj)) 
++             FALSE
++         else .... [TRUNCATED] 
+
+> check_EPD <- function(obj, show = !hasReal(obj), oNam = deparse(substitute(obj)), 
++     control = c("keepInteger", "showAttributes", "keepNA"), not .... [TRUNCATED] 
+
+> runEPD_checks <- function(env = .GlobalEnv) {
++     stopifnot(is.environment(env))
++     for (nm in ls(envir = env)) {
++         cat(nm, ": ", sep = .... [TRUNCATED] 
+> rm("srcdir")
+> 
+> library(stats)
+> ## some more "critical" cases
+> nmdExp <- expression(e1 = sin(pi), e2 = cos(-pi))
+> xn <- setNames(3.5^(1:3), paste0("3½^",1:3)) # 3.5: so have 'show'
+> ## "" in names :
+> x0 <- xn; names(x0)[2] <- ""
+> en0  <- setNames(0L, "")
+> en12 <- setNames(1:2, c("",""))
+> en24 <- setNames(2:4, c("two","","vier"))
+> enx0  <- `storage.mode<-`(en0, "double")
+> enx12 <- `storage.mode<-`(en12,"double")
+> enx24 <- `storage.mode<-`(en24,"double")
+> L1 <- list(c(A="Txt"))
+> L2 <- list(el = c(A=2.5))
+> ## "m:n" named integers and _inside list_
+> i6 <- setNames(5:6, letters[5:6])
+> L4  <- list(ii = 5:2) # not named
+> L6  <- list(L = i6)
+> L6a <- list(L = structure(rev(i6), myDoc = "info"))
+> ## these must use structure() to keep NA_character_ name:
+> LNA <- setNames(as.list(c(1,2,99)), c("A", "NA", NA))
+> iNA <- unlist(LNA)
+> missL <- setNames(rep(list(alist(.=)$.), 3), c("",NA,"c"))
+> ## empty *named* atomic vectors
+> i00 <- setNames(integer(), character()); i0 <- structure(i00, foo = "bar")
+> L00 <- setNames(logical(), character()); L0 <- structure(L00, class = "Logi")
+> r00 <- setNames(raw(), character())
+> sii <- structure(4:7, foo = list(B="bar", G="grizzly",
++                                  vec=c(a=1L,b=2L), v2=i6, v0=L00))
+> fm <- y ~ f(x)
+> lf <- list(ff = fm, osf = ~ sin(x))
+> stopifnot(identical(deparse(lf, control="all"), # no longer quote()s
++ 		    deparse(lf)))
+Warning message:
+In deparse(lf, control = "all") : deparse may be incomplete
+> abc <- setNames(letters[1:4], c("one", "recursive", "use.names", "four"))
+> r13 <- i13 <- setNames(1:3, names(abc)[3:1]); mode(r13) <- "double"
+> 
+> ## Creating a collection of S4 objects, ensuring deparse <-> parse are inverses
+> library(methods)
+> example(new) # creating t1 & t2 at least
+
+new> ## using the definition of class "track" from setClass
+new> 
+new> ## Don't show: 
+new> setClass("track", slots = c(x="numeric", y="numeric"))
+
+new> setClass("trackCurve", contains = "track",
+new+           slots = c(smooth = "numeric"))
+
+new> ydata <- stats::rnorm(10); ysmooth <- 1:10
+
+new> ## End(Don't show)
+new> 
+new> ## a new object with two slots specified
+new> t1 <- new("track", x = seq_along(ydata), y = ydata)
+
+new> # a new object including an object from a superclass, plus a slot
+new> t2 <- new("trackCurve", t1, smooth = ysmooth)
+
+new> ### define a method for initialize, to ensure that new objects have
+new> ### equal-length x and y slots.  In this version, the slots must still be
+new> ### supplied by name.
+new> 
+new> setMethod("initialize", "track", 
+new+     function(.Object, ...) {
+new+       .Object <- callNextMethod()
+new+       if(length(.Object@x) != length(.Object@y))
+new+       stop("specified x and y of different lengths")
+new+       .Object
+new+     })
+
+new> ### An alternative version that allows x and y to be supplied
+new> ### unnamed.  A still more friendly version would make the default x
+new> ### a vector of the same length as y, and vice versa.
+new> 
+new> setMethod("initialize", "track",
+new+           function(.Object, x = numeric(0), y = numeric(0), ...) {
+new+               .Object <- callNextMethod(.Object, ...)
+new+               if(length(x) != length(y))
+new+                   stop("specified x and y of different lengths")
+new+               .Object@x <- x
+new+               .Object@y <- y
+new+               .Object
+new+           })
+
+new> ## Don't show: 
+new> removeMethod("initialize", "track")
+[1] TRUE
+
+new> ## End(Don't show)
+new> 
+new> 
+new> 
+> ## an S4 object of type "list" of "mp1" objects [see pkg 'Rmpfr']:
+> setClass("mp1", slots = c(prec = "integer", d = "integer"))
+> setClass("mp", contains = "list", ## of "mp1" entries:
++          validity = function(object) {
++ 	     if(all(vapply(object@.Data, class, "") == "mp1"))
++ 		 return(TRUE)
++ 	     ## else
++ 		 "Not all components are of class 'mp1'"
++ 	 })
+> validObject(m0 <- new("mp"))
+[1] TRUE
+> validObject(m1 <- new("mp", list(new("mp1"), new("mp1", prec=1L, d = 3:5))))
+[1] TRUE
+> typeof(m1)# "list", not "S4"
+[1] "list"
+> dput(m1) # now *is* correct -- will be check_EPD()ed below
+new("mp", .Data = list(new("mp1", prec = integer(0), d = integer(0)), 
+    new("mp1", prec = 1L, d = 3:5)))
+> ##
+> mList <- setClass("mList", contains = "list")
+> mForm <- setClass("mForm", contains = "formula")
+> mExpr <- setClass("mExpr", contains = "expression")
+> ## more to come
+> attrS4 <- function(x)
++     c(S4 = isS4(x), obj= is.object(x), type.S4 = typeof(x) == "S4")
+> attrS4(ml <- mList(list(1, letters[1:3])))# use *unnamed* list
+     S4     obj type.S4 
+   TRUE    TRUE   FALSE 
+> attrS4(mf <- mForm( ~ f(x)))
+     S4     obj type.S4 
+   TRUE    TRUE   FALSE 
+> attrS4(E2 <- mExpr(expression(x^2)))
+     S4     obj type.S4 
+   TRUE    TRUE   FALSE 
+> stopifnot(identical(mf, eval(parse(text=deparse(mf)))))
+> stopifnot(identical(mf, eval(parse(text=deparse(mf, control="all"))))) # w/ a warning
+Warning message:
+In deparse(mf, control = "all") : deparse may be incomplete
+> 
+> 
+> ## Action!  Check deparse <--> parse  consistency for *all* objects:
+> runEPD_checks()
+A: function (x, y, ...) 
+{
+    B <- function(a, b, ...) {
+        match.call()
+    }
+    B(x + y, ...)
+}
+ --> checking list(*): Ok
+checking body(.):
+quote({
+    B <- function(a, b, ...) {
+        match.call()
+    }
+    B(x + y, ...)
+})
+ --> checking list(*): Ok
+checking formals(.):
+as.pairlist(alist(x = , y = , ... = ))
+__ not parse()able __: hasMissObj(.) is true 
+--=--=--=--=--
+CC: function (...) 
+match.call()
+ --> checking list(*): Ok
+checking body(.):
+quote(match.call())
+ --> checking list(*): Ok
+checking formals(.):
+as.pairlist(alist(... = ))
+__ not parse()able __: hasMissObj(.) is true 
+--=--=--=--=--
+DD: function (...) 
+CC(...)
+ --> checking list(*): Ok
+checking body(.):
+quote(CC(...))
+ --> checking list(*): Ok
+checking formals(.):
+as.pairlist(alist(... = ))
+__ not parse()able __: hasMissObj(.) is true 
+--=--=--=--=--
+E2: new("mExpr", .Data = expression(x^2))
+ --> checking list(*): Ok
+--=--=--=--=--
+L0: structure(logical(0), names = character(0), class = "Logi")
+ --> checking list(*): Ok
+--=--=--=--=--
+L00: structure(logical(0), names = character(0))
+ --> checking list(*): Ok
+--=--=--=--=--
+L1: list(c(A = "Txt"))
+ --> checking list(*): Ok
+--=--=--=--=--
+L2: list(el = c(A = 2.5))
+ --> checking list(*): Ok
+--=--=--=--=--
+L4: list(ii = 5:2)
+ --> checking list(*): Ok
+--=--=--=--=--
+L6: list(L = structure(5:6, names = c("e", "f")))
+ --> checking list(*): Ok
+--=--=--=--=--
+L6a: list(L = structure(6:5, names = c("f", "e"), myDoc = "info"))
+ --> checking list(*): Ok
+--=--=--=--=--
+LNA: structure(list(1, 2, 99), names = c("A", "NA", NA))
+ --> checking list(*): Ok
+--=--=--=--=--
+ST: .Primitive("invisible")
+ --> checking list(*): Ok
+checking body(.):
+NULL
+ --> checking list(*): Ok
+checking formals(.):
+NULL
+ --> checking list(*): Ok
+--=--=--=--=--
+X: list(TRUE)
+ --> checking list(*): Ok
+--=--=--=--=--
+a: list(b = 3)
+ --> checking list(*): Ok
+--=--=--=--=--
+a2: quote(B(a = x + y, named = 3))
+ --> checking list(*): Ok
+--=--=--=--=--
+a3: quote(CC(1, 2, 3))
+ --> checking list(*): Ok
+--=--=--=--=--
+aa: quote(B(a = x + y, b = 3))
+ --> checking list(*): Ok
+--=--=--=--=--
+abc: structure(c("a", "b", "c", "d"), names = c("one", "recursive", 
+"use.names", "four"))
+ --> checking list(*): Ok
+--=--=--=--=--
+attrS4: function (x) 
+c(S4 = isS4(x), obj = is.object(x), type.S4 = typeof(x) == "S4")
+ --> checking list(*): Ok
+checking body(.):
+quote(c(S4 = isS4(x), obj = is.object(x), type.S4 = typeof(x) == 
+    "S4"))
+ --> checking list(*): Ok
+checking formals(.):
+as.pairlist(alist(x = ))
+__ not parse()able __: hasMissObj(.) is true 
+--=--=--=--=--
+callme: function (a = 1, mm = c("Abc", "Bde")) 
+{
+    mm <- match.arg(mm)
+    cat("mm = ")
+    str(mm)
+    invisible()
+}
+ --> checking list(*): Ok
+checking body(.):
+quote({
+    mm <- match.arg(mm)
+    cat("mm = ")
+    str(mm)
+    invisible()
+})
+ --> checking list(*): Ok
+checking formals(.):
+pairlist(a = 1, mm = quote(c("Abc", "Bde")))
+ --> checking list(*): Ok
+--=--=--=--=--
+check_EPD: function (obj, show = !hasReal(obj), oNam = deparse(substitute(obj)), 
+    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))
+    }
+    ob2 <- id_epd(obj)
+    po <- tryCatch(pd0(obj, control = control), 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)
+    if (!identical(obj, ob2, ignore.environment = TRUE, ignore.bytecode = TRUE, 
+        ignore.srcref = TRUE)) {
+        ae <- all.equal(obj, ob2, tolerance = eq.tol, check.environment = FALSE)
+        if (is.na(match(oNam, not.identical.ldouble))) {
+            ae.txt <- "all.equal(*,*, 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)
+    }
+    if (show || !is.list(obj)) {
+        cat(" --> checking list(*): ")
+        check_EPD(list(.chk = obj), show = FALSE, oNam = oNam, 
+            eq.tol = eq.tol)
+        cat("Ok\n")
+    }
+    invisible(obj)
+}
+ --> checking list(*): Ok
+checking body(.):
+quote({
+    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))
+    }
+    ob2 <- id_epd(obj)
+    po <- tryCatch(pd0(obj, control = control), 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)
+    if (!identical(obj, ob2, ignore.environment = TRUE, ignore.bytecode = TRUE, 
+        ignore.srcref = TRUE)) {
+        ae <- all.equal(obj, ob2, tolerance = eq.tol, check.environment = FALSE)
+        if (is.na(match(oNam, not.identical.ldouble))) {
+            ae.txt <- "all.equal(*,*, 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)
+    }
+    if (show || !is.list(obj)) {
+        cat(" --> checking list(*): ")
+        check_EPD(list(.chk = obj), show = FALSE, oNam = oNam, 
+            eq.tol = eq.tol)
+        cat("Ok\n")
+    }
+    invisible(obj)
+})
+ --> checking list(*): Ok
+checking formals(.):
+as.pairlist(alist(obj = , show = quote(!hasReal(obj)), oNam = quote(deparse(substitute(obj))), control = quote(c("keepInteger", 
+    "showAttributes", "keepNA")), not.identical.ldouble = quote(if (!interactive()) c("t1", 
+    "t2", "ydata")), eq.tol = quote(if (noLdbl) 2 * .Machine$double.eps else 0)))
+__ not parse()able __: hasMissObj(.) is true 
+--=--=--=--=--
+dPut: function (x, control = "all") 
+dput(x, control = control)
+ --> checking list(*): Ok
+checking body(.):
+quote(dput(x, control = control))
+ --> checking list(*): Ok
+checking formals(.):
+as.pairlist(alist(x = , control = "all"))
+__ not parse()able __: hasMissObj(.) is true 
+--=--=--=--=--
+e: <environment>
+__ not parse()able __: environment 
+--=--=--=--=--
+e1: quote(c(F = (f <- 0.29999999999999999), `Tail area` = 2 * if (f < 
+    1) 30 else 90))
+ --> checking list(*): Ok
+--=--=--=--=--
+e2: quote(c(`a b c` = 1, b = 2))
+ --> checking list(*): Ok
+--=--=--=--=--
+e3: quote(c(`Variance ratio` = 1, `tail area` = pf(1, 1, 1)))
+ --> checking list(*): Ok
+--=--=--=--=--
+en0: structure(0L, names = "")
+ --> checking list(*): Ok
+--=--=--=--=--
+en12: structure(1:2, names = c("", ""))
+ --> checking list(*): Ok
+--=--=--=--=--
+en24: structure(2:4, names = c("two", "", "vier"))
+ --> checking list(*): Ok
+--=--=--=--=--
+enx0: structure(0, names = "")
+ --> checking list(*): Ok
+--=--=--=--=--
+enx12: structure(c(1, 2), names = c("", ""))
+ --> checking list(*): Ok
+--=--=--=--=--
+enx24: c(two = 2, 3, vier = 4)
+ --> checking list(*): Ok
+--=--=--=--=--
+f: function (x, ...) 
+substitute(list(x, ...))
+ --> checking list(*): Ok
+checking body(.):
+quote(substitute(list(x, ...)))
+ --> checking list(*): Ok
+checking formals(.):
+as.pairlist(alist(x = , ... = ))
+__ not parse()able __: hasMissObj(.) is true 
+--=--=--=--=--
+fm: y ~ f(x)
+not identical(*, ignore.env=T), but all.equal(*,*, tol = ..) 
+ --> checking list(*): not identical(*, ignore.env=T), but all.equal(*,*, tol = ..) 
+Ok
+--=--=--=--=--
+fx: structure(c(1L, 3L, 2L), levels = c("a", "b", NA), class = "factor")
+ --> checking list(*): Ok
+--=--=--=--=--
+g: function (...) 
+h(f(...))
+ --> checking list(*): Ok
+checking body(.):
+quote(h(f(...)))
+ --> checking list(*): Ok
+checking formals(.):
+as.pairlist(alist(... = ))
+__ not parse()able __: hasMissObj(.) is true 
+--=--=--=--=--
+h: function (...) 
+list(...)
+ --> checking list(*): Ok
+checking body(.):
+quote(list(...))
+ --> checking list(*): Ok
+checking formals(.):
+as.pairlist(alist(... = ))
+__ not parse()able __: hasMissObj(.) is true 
+--=--=--=--=--
+hasMissObj: function (obj) 
+{
+    if (is.recursive(obj)) {
+        if (is.function(obj) || is.language(obj)) 
+            FALSE
+        else any(vapply(obj, hasMissObj, NA))
+    }
+    else isMissObj(obj)
+}
+ --> checking list(*): Ok
+checking body(.):
+quote({
+    if (is.recursive(obj)) {
+        if (is.function(obj) || is.language(obj)) 
+            FALSE
+        else any(vapply(obj, hasMissObj, NA))
+    }
+    else isMissObj(obj)
+})
+ --> checking list(*): Ok
+checking formals(.):
+as.pairlist(alist(obj = ))
+__ not parse()able __: hasMissObj(.) is true 
+--=--=--=--=--
+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)) 
+        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 FALSE
+    }
+    else FALSE
+}
+ --> checking list(*): Ok
+checking body(.):
+quote({
+    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)) 
+        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 FALSE
+    }
+    else FALSE
+})
+ --> checking list(*): Ok
+checking formals(.):
+as.pairlist(alist(x = ))
+__ not parse()able __: hasMissObj(.) is true 
+--=--=--=--=--
+i0: structure(integer(0), names = character(0), foo = "bar")
+ --> checking list(*): Ok
+--=--=--=--=--
+i00: structure(integer(0), names = character(0))
+ --> checking list(*): Ok
+--=--=--=--=--
+i13: structure(1:3, names = c("use.names", "recursive", "one"))
+ --> checking list(*): Ok
+--=--=--=--=--
+i6: structure(5:6, names = c("e", "f"))
+ --> checking list(*): Ok
+--=--=--=--=--
+iNA: structure(c(1, 2, 99), names = c("A", "NA", NA))
+ --> checking list(*): Ok
+--=--=--=--=--
+id_epd: function (expr, control = "all", ...) 
+eval(pd0(expr, control = control, ...))
+ --> checking list(*): Ok
+checking body(.):
+quote(eval(pd0(expr, control = control, ...)))
+ --> checking list(*): Ok
+checking formals(.):
+as.pairlist(alist(expr = , control = "all", ... = ))
+__ not parse()able __: hasMissObj(.) is true 
+--=--=--=--=--
+isMissObj: function (obj) 
+identical(obj, alist(a = )[[1]])
+ --> checking list(*): Ok
+checking body(.):
+quote(identical(obj, alist(a = )[[1]]))
+ --> checking list(*): Ok
+checking formals(.):
+as.pairlist(alist(obj = ))
+__ not parse()able __: hasMissObj(.) is true 
+--=--=--=--=--
+k: function (...) 
+g(...)
+ --> checking list(*): Ok
+checking body(.):
+quote(g(...))
+ --> checking list(*): Ok
+checking formals(.):
+as.pairlist(alist(... = ))
+__ not parse()able __: hasMissObj(.) is true 
+--=--=--=--=--
+lf: list(ff = y ~ f(x), osf = ~sin(x))
+not identical(*, ignore.env=T), but all.equal(*,*, tol = ..) 
+ --> checking list(*): not identical(*, ignore.env=T), but all.equal(*,*, tol = ..) 
+Ok
+--=--=--=--=--
+m0: new("mp", .Data = list())
+ --> checking list(*): Ok
+--=--=--=--=--
+m1: new("mp", .Data = list(new("mp1", prec = integer(0), d = integer(0)), 
+    new("mp1", prec = 1L, d = 3:5)))
+ --> checking list(*): Ok
+--=--=--=--=--
+mExpr: new("classGeneratorFunction", .Data = function (...) 
+new("mExpr", ...), className = structure("mExpr", package = ".GlobalEnv"), 
+    package = ".GlobalEnv")
+not identical(*, ignore.env=T), but all.equal(*,*, tol = ..) 
+ --> checking list(*): not identical(*, ignore.env=T), but all.equal(*,*, tol = ..) 
+Ok
+--=--=--=--=--
+mForm: new("classGeneratorFunction", .Data = function (...) 
+new("mForm", ...), className = structure("mForm", package = ".GlobalEnv"), 
+    package = ".GlobalEnv")
+not identical(*, ignore.env=T), but all.equal(*,*, tol = ..) 
+ --> checking list(*): not identical(*, ignore.env=T), but all.equal(*,*, tol = ..) 
+Ok
+--=--=--=--=--
+mList: new("classGeneratorFunction", .Data = function (...) 
+new("mList", ...), className = structure("mList", package = ".GlobalEnv"), 
+    package = ".GlobalEnv")
+not identical(*, ignore.env=T), but all.equal(*,*, tol = ..) 
+ --> checking list(*): not identical(*, ignore.env=T), but all.equal(*,*, tol = ..) 
+Ok
+--=--=--=--=--
+mf: new("mForm", .S3Class = "formula", ~f(x))
+not identical(*, ignore.env=T), but all.equal(*,*, tol = ..) 
+ --> checking list(*): not identical(*, ignore.env=T), but all.equal(*,*, tol = ..) 
+Ok
+--=--=--=--=--
+missL: structure(list(, , ), names = c("", NA, "c"))
+__ not parse()able __: hasMissObj(.) is true 
+--=--=--=--=--
+ml: new("mList", .Data = list(1, c("a", "b", "c")))
+ --> checking list(*): Ok
+--=--=--=--=--
+mycaller: function (x = 1, callme = pi) 
+{
+    callme(x)
+}
+ --> checking list(*): Ok
+checking body(.):
+quote({
+    callme(x)
+})
+ --> checking list(*): Ok
+checking formals(.):
+pairlist(x = 1, callme = quote(pi))
+ --> checking list(*): Ok
+--=--=--=--=--
+nmdExp: expression(e1 = sin(pi), e2 = cos(-pi))
+ --> checking list(*): Ok
+--=--=--=--=--
+pd0: function (expr, backtick = TRUE, ...) 
+parse(text = deparse(expr, backtick = backtick, ...))
+ --> checking list(*): Ok
+checking body(.):
+quote(parse(text = deparse(expr, backtick = backtick, ...)))
+ --> checking list(*): Ok
+checking formals(.):
+as.pairlist(alist(expr = , backtick = TRUE, ... = ))
+__ not parse()able __: hasMissObj(.) is true 
+--=--=--=--=--
+r: structure(c("[1] a    <NA> b   ", "Levels: a b <NA>", "[1] a    <NA> b   ", 
+"Levels: a b <NA>", "[1] a    <NA> b   ", "Levels: a b <NA>", 
+"[1] a    <NA> b   ", "Levels: a b <NA>", "[1] a    <NA> b   ", 
+"Levels: a b <NA>", "[1] a    <NA> b   ", "Levels: a b <NA>", 
+"[1] a    <NA> b   ", "Levels: a b <NA>", "[1] a    <NA> b   ", 
+"Levels: a b <NA>", "[1] a    <NA> b   ", "Levels: a b <NA>", 
+"[1] a    <NA> b   ", "Levels: a b <NA>", "[1] a    <NA> b   ", 
+"Levels: a b <NA>", "[1] a    <NA> b   ", "Levels: a b <NA>", 
+"[1] a    <NA> b   ", "Levels: a b <NA>", "[1] a    <NA> b   ", 
+"Levels: a b <NA>", "[1] a    <NA> b   ", "Levels: a b <NA>", 
+"[1] a    <NA> b   ", "Levels: a b <NA>", "[1] a    <NA> b   ", 
+"Levels: a b <NA>", "[1] a    <NA> b   ", "Levels: a b <NA>", 
+"[1] a    <NA> b   ", "Levels: a b <NA>", "[1] a    <NA> b   ", 
+"Levels: a b <NA>"), dim = c(2L, 20L))
+ --> checking list(*): Ok
+--=--=--=--=--
+r00: structure(raw(0), names = character(0))
+ --> checking list(*): Ok
+--=--=--=--=--
+r1: list(value = quote({
+    if (!evaluated) {
+        exprs <- substitute(exprs)
+        if (is.call(exprs)) {
+            if (exprs[[1]] == quote(`{`)) 
+                exprs <- as.list(exprs[-1])
+        }
+    }
+    source(exprs = exprs, local = local, print.eval = print., 
+        echo = echo, max.deparse.length = max.deparse.length, 
+        width.cutoff = width.cutoff, deparseCtrl = deparseCtrl, 
+        ...)
+}), visible = TRUE)
+ --> checking list(*): Ok
+--=--=--=--=--
+r13: structure(c(1, 2, 3), names = c("use.names", "recursive", "one"
+))
+ --> checking list(*): Ok
+--=--=--=--=--
+r2: list(value = quote({
+    if (!evaluated) {
+        exprs <- substitute(exprs)
+        if (is.call(exprs)) {
+            if (exprs[[1]] == quote(`{`)) 
+                exprs <- as.list(exprs[-1])
+        }
+    }
+    source(exprs = exprs, local = local, print.eval = print., 
+        echo = echo, max.deparse.length = max.deparse.length, 
+        width.cutoff = width.cutoff, deparseCtrl = deparseCtrl, 
+        ...)
+}), visible = TRUE)
+ --> checking list(*): Ok
+--=--=--=--=--
+runEPD_checks: function (env = .GlobalEnv) 
+{
+    stopifnot(is.environment(env))
+    for (nm in ls(envir = env)) {
+        cat(nm, ": ", sep = "")
+        x <- env[[nm]]
+        check_EPD(x, oNam = nm)
+        if (is.function(x) && !inherits(x, "classGeneratorFunction")) {
+            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")
+    }
+}
+ --> checking list(*): Ok
+checking body(.):
+quote({
+    stopifnot(is.environment(env))
+    for (nm in ls(envir = env)) {
+        cat(nm, ": ", sep = "")
+        x <- env[[nm]]
+        check_EPD(x, oNam = nm)
+        if (is.function(x) && !inherits(x, "classGeneratorFunction")) {
+            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")
+    }
+})
+ --> checking list(*): Ok
+checking formals(.):
+pairlist(env = quote(.GlobalEnv))
+ --> checking list(*): Ok
+--=--=--=--=--
+sii: structure(4:7, foo = list(B = "bar", G = "grizzly", vec = structure(1:2, names = c("a", 
+"b")), v2 = structure(5:6, names = c("e", "f")), v0 = structure(logical(0), names = character(0))))
+ --> checking list(*): Ok
+--=--=--=--=--
+t1:  --> checking list(*): Ok
+--=--=--=--=--
+t2:  --> checking list(*): Ok
+--=--=--=--=--
+tt: function (x) 
+{
+    is.vector(x)
+    deparse(substitute(x))
+}
+ --> checking list(*): Ok
+checking body(.):
+quote({
+    is.vector(x)
+    deparse(substitute(x))
+})
+ --> checking list(*): Ok
+checking formals(.):
+as.pairlist(alist(x = ))
+__ not parse()able __: hasMissObj(.) is true 
+--=--=--=--=--
+u:  --> checking list(*): Ok
+--=--=--=--=--
+x: c(1L, NA, NA)
+ --> checking list(*): Ok
+--=--=--=--=--
+x0: c(`3½^1` = 3.5, 12.25, `3½^3` = 42.875)
+ --> checking list(*): Ok
+--=--=--=--=--
+xn: c(`3½^1` = 3.5, `3½^2` = 12.25, `3½^3` = 42.875)
+ --> checking list(*): Ok
+--=--=--=--=--
+ydata:  --> checking list(*): Ok
+--=--=--=--=--
+ysmooth: 1:10
+ --> checking list(*): Ok
+--=--=--=--=--
+Warning messages:
+1: In dput(x, control = control) : deparse may be incomplete
+2: In dput(x, control = control) : deparse may be incomplete
+3: In deparse(expr, backtick = backtick, ...) : deparse may be incomplete
+4: In deparse(expr, backtick = backtick, ...) : deparse may be incomplete
+5: In dput(x, control = control) : deparse may be incomplete
+6: In deparse(expr, backtick = backtick, ...) : deparse may be incomplete
+7: In deparse(expr, backtick = backtick, ...) : deparse may be incomplete
+8: In dput(x, control = control) : deparse may be incomplete
+9: In deparse(expr, backtick = backtick, ...) : deparse may be incomplete
+10: In deparse(expr, backtick = backtick, ...) : deparse may be incomplete
+> 
+> summary(warnings())
+Summary of (a total of 10) warning messages:
+4x : In dput(x, control = control) : deparse may be incomplete
+6x : In deparse(expr, backtick = backtick, ...) : deparse may be incomplete
+> ## "dput    may be incomplete"
+> ## "deparse may be incomplete"
+> 
+> 
+> ## at the very end
+> cat('Time elapsed: ', proc.time() - .proctime00,'\n')
+Time elapsed:  0.739 0.042 0.791 0 0 
+>