R Under development (unstable) (2023-09-20 r85183) -- "Unsuffered Consequences" Copyright (C) 2023 The R Foundation for Statistical Computing Platform: x86_64-pc-linux-gnu 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 > ##- 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 > ##- 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 > ##- 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 '' levels part would be wrong occasionally Levels: a b 20 > stopifnot(r[2,] == "Levels: a b ") # 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 > rm(r2) > > 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 = c("quoteExpression", + "showAttributes", "niceNames", "keepInteger")) 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 = c("quoteExpression", "showAttributes", "niceNames", "keepInteger")) 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("quoteExpression", "showAttributes", "niceNames", "keepInteger")))) __ not parse()able __: hasMissObj(.) is true --=--=--=--=-- e: __ not parse()able __: environment --=--=--=--=-- e1: quote(c(F = (f <- 0.3), `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 b ", "Levels: a b ", "[1] a b ", "Levels: a b ", "[1] a b ", "Levels: a b ", "[1] a b ", "Levels: a b ", "[1] a b ", "Levels: a b ", "[1] a b ", "Levels: a b ", "[1] a b ", "Levels: a b ", "[1] a b ", "Levels: a b ", "[1] a b ", "Levels: a b ", "[1] a b ", "Levels: a b ", "[1] a b ", "Levels: a b ", "[1] a b ", "Levels: a b ", "[1] a b ", "Levels: a b ", "[1] a b ", "Levels: a b ", "[1] a b ", "Levels: a b ", "[1] a b ", "Levels: a b ", "[1] a b ", "Levels: a b ", "[1] a b ", "Levels: a b ", "[1] a b ", "Levels: a b ", "[1] a b ", "Levels: a b "), 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] if (missing(skip.echo) && is.list(srcrefs <- attr(exprs, "srcref"))) { skip.echo <- srcrefs[[1L]][7L] - 1L } } } } source(exprs = exprs, local = local, print.eval = print., echo = echo, max.deparse.length = max.deparse.length, width.cutoff = width.cutoff, deparseCtrl = deparseCtrl, skip.echo = skip.echo, ...) }), visible = TRUE) --> checking list(*): Ok --=--=--=--=-- r13: structure(c(1, 2, 3), names = c("use.names", "recursive", "one" )) --> 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 deparse(expr, backtick = backtick, ...) : deparse may be incomplete 2: In deparse(expr, backtick = backtick, ...) : 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 deparse(expr, backtick = backtick, ...) : deparse may be incomplete 6: In deparse(expr, backtick = backtick, ...) : deparse may be incomplete > > summary(warnings()) 6 identical warnings: 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.103 0.009 0.112 0 0 >