R version 3.5.2 RC (2018-12-13 r75856) -- "Eggshell Igloo" Copyright (C) 2018 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 > ##- 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 > > 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] > #--------- > > library(stats) > ## some more "critical" cases > nmdExp <- expression(e1 = sin(pi), e2 = cos(-pi)) > xn <- setNames(pi^(1:3), paste0("pi^",1:3)) > 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 > 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: > for(nm in ls(env=.GlobalEnv)) { + cat(nm,": ", sep="") + ## if(!any(nm == "mf")) ## 'mf' [bug in deparse(mf, control="all") now fixed] + check_EPD(obj = (x <- .GlobalEnv[[nm]])) + if(is.function(x) && !inherits(x, "classGeneratorFunction")) { + ## FIXME? classGeneratorFunction, e.g., mForm don't "work" yet + cat("checking body(.):\n" ); check_EPD( body(x)) + cat("checking formals(.):\n"); check_EPD(formals(x)) + } + cat("--=--=--=--=--\n") + } 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 --=--=--=--=-- CO: function (..., file = NULL, append = FALSE, type = c("output", "message"), split = FALSE) { args <- substitute(list(...))[-1L] type <- match.arg(type) rval <- NULL closeit <- TRUE if (is.null(file)) file <- textConnection("rval", "w", local = TRUE) else if (is.character(file)) file <- file(file, if (append) "a" else "w") else if (inherits(file, "connection")) { if (!isOpen(file)) open(file, if (append) "a" else "w") else closeit <- FALSE } else stop("'file' must be NULL, a character string or a connection") sink(file, type = type, split = split) on.exit({ sink(type = type, split = split) if (closeit) close(file) }) pf <- parent.frame() evalVis <- function(expr) withVisible(eval(expr, pf)) for (i in seq_along(args)) { expr <- args[[i]] tmp <- switch(mode(expr), expression = lapply(expr, evalVis), call = , name = list(evalVis(expr)), stop("bad argument")) for (item in tmp) if (item$visible) print(item$value) } on.exit() sink(type = type, split = split) if (closeit) close(file) if (is.null(rval)) invisible(NULL) else rval } --> checking list(*): Ok checking body(.): quote({ args <- substitute(list(...))[-1L] type <- match.arg(type) rval <- NULL closeit <- TRUE if (is.null(file)) file <- textConnection("rval", "w", local = TRUE) else if (is.character(file)) file <- file(file, if (append) "a" else "w") else if (inherits(file, "connection")) { if (!isOpen(file)) open(file, if (append) "a" else "w") else closeit <- FALSE } else stop("'file' must be NULL, a character string or a connection") sink(file, type = type, split = split) on.exit({ sink(type = type, split = split) if (closeit) close(file) }) pf <- parent.frame() evalVis <- function(expr) withVisible(eval(expr, pf)) for (i in seq_along(args)) { expr <- args[[i]] tmp <- switch(mode(expr), expression = lapply(expr, evalVis), call = , name = list(evalVis(expr)), stop("bad argument")) for (item in tmp) if (item$visible) print(item$value) } on.exit() sink(type = type, split = split) if (closeit) close(file) if (is.null(rval)) invisible(NULL) else rval }) --> checking list(*): Ok checking formals(.): as.pairlist(alist(... = , file = NULL, append = FALSE, type = quote(c("output", "message")), split = FALSE)) __ 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 --=--=--=--=-- 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, " giving\n", ae) } 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, " giving\n", ae) } 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: __ 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 --=--=--=--=-- 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 --=--=--=--=-- 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 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]) } } 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 --=--=--=--=-- 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 --=--=--=--=-- 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: --> checking list(*): Ok --=--=--=--=-- xn: --> 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.317 0.014 0.337 0 0 >