tests/eval-etc.Rout.save

R version 3.6.2 Patched (2020-02-12 r77795) -- "Dark and Stormy Night"
Copyright (C) 2020 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
> 
> source(file.path(Sys.getenv("SRCDIR"), "eval-fns.R"), echo = TRUE)

> pd0 <- function(expr, backtick = TRUE, ...) parse(text = deparse(expr, 
+     backtick = backtick, ...))

> id_epd <- function(expr, control = c("all", "digits17"), 
+     ...) eval(pd0(expr, control = control, ...))

> dPut <- function(x, control = c("all", "digits17")) 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] 
>                                         #---------
> 
> 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"
> if(getRversion() >= "3.5.0") {
+     ## Creating a collection of S4 objects, ensuring deparse <-> parse are inverses
+ library(methods)
+ example(new) # creating t1 & t2 at least
+ ## 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 "mp" entries:
+          validity = function(object) {
+ 	     if(all(vapply(object@.Data, class, "") == "mp1"))
+ 		 return(TRUE)
+ 	     ## else
+ 		 "Not all components are of class 'mp'"
+ 	 })
+ validObject(m0 <- new("mp"))
+ validObject(m1 <- new("mp", list(new("mp1"), new("mp1", prec=1L, d = 3:5))))
+ typeof(m1)# "list", not "S4"
+ dput(m1) # now *is* correct -- will be check_EPD()ed below
+ ##
+ 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
+ attrS4(mf <- mForm( ~ f(x)))
+ attrS4(E2 <- mExpr(expression(x^2)))
+ ## Now works, but fails for  deparse(*, control="all"):  __FIXME__
+ stopifnot(identical(mf, eval(parse(text=deparse(mf)))))
+ ##
+ }# S4 deparse()ing only since R 3.5.0

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> 
new("mp", .Data = list(new("mp1", prec = integer(0), d = integer(0)), 
    new("mp1", prec = 1L, d = 3:5)))
> 
> ## 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)
        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)
        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 = c("all", "digits17")) 
dput(x, control = control)
 --> checking list(*): Ok
checking body(.):
quote(dput(x, control = control))
 --> checking list(*): Ok
checking formals(.):
as.pairlist(alist(x = , control = quote(c("all", "digits17"))))
__ 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), .Label = 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 = c("all", "digits17"), ...) 
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 = quote(c("all", "digits17")), ... = ))
__ 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:
6x : In dput(x, control = control) : deparse may be incomplete
4x : 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.314 0.017 0.337 0 0 
>