R version 3.5.0 RC (2018-04-15 r74605) -- "Joy in Playing" 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 > > ### Checking parse(* deparse()) "inversion property" ---------------------------- > ## EPD := eval-parse-deparse : eval(text = parse(deparse(*))) > ## Hopefully typically the identity(): > pd0 <- function(expr, backtick = TRUE, + control = c("keepInteger","showAttributes","keepNA"), ...) + parse(text = deparse(expr, backtick=backtick, control=control, ...)) > id_epd <- function(expr, control = c("all","digits17"), ...) + eval(pd0(expr, control=control, ...)) > dPut <- function(x, control = c("all","digits17")) dput(x, control=control) > ##' Does 'x' contain "real" numbers > ##' with > 3 digits after "." where deparse may be platform dependent? > hasReal <- function(x) { + if(is.double(x) || is.complex(x)) + !all((x == round(x, 3)) | is.na(x)) + else if(is.logical(x) || is.integer(x) || + is.symbol(x) || is.call(x) || is.environment(x) || is.character(x)) + FALSE + else if(is.recursive(x)) # recurse : + any(vapply(x, hasReal, NA)) + else if(isS4(x)) { + if(length(sn <- slotNames(x))) + any(vapply(sn, function(s) hasReal(slot(x, s)), NA)) + else # no slots + FALSE # ? + } + else FALSE + } > isMissObj <- function(obj) identical(obj, alist(a=)[[1]]) > ##' Does 'obj' contain "the missing object" ? > ##' @note defined recursively! > hasMissObj <- function(obj) { + if(is.recursive(obj)) { + if(is.function(obj) || is.language(obj)) + FALSE + else # incl pairlist()s + any(vapply(obj, hasMissObj, NA)) + } else isMissObj(obj) + } > check_EPD <- function(obj, show = !hasReal(obj), + eq.tol = if(.Machine$sizeof.longdouble <= 8) # no long-double + 2*.Machine$double.eps else 0) { + if(show) dPut(obj) + if(is.environment(obj) || hasMissObj(obj)) { + cat("__ not parse()able __:", + if(is.environment(obj)) "environment" else "hasMissObj(.) is true", "\n") + return(invisible(obj)) # cannot parse it + } + ob2 <- id_epd(obj) + po <- tryCatch(pd0(obj),# the default deparse() *should* typically parse + error = function(e) { + cat("default deparse() was not parse():\n ", + conditionMessage(e), + "\n but deparse(*, control='all') should work.\n") + pd0(obj, control = "all") }) + if(!identical(obj, ob2, ignore.environment=TRUE, + ignore.bytecode=TRUE, ignore.srcref=TRUE)) { + ae <- all.equal(obj, ob2, tolerance = eq.tol) + ae.txt <- sprintf("all.equal(*,*, tol = %.3g)", eq.tol) + cat("not identical(*, ignore.env=T),", + if(isTRUE(ae)) paste("but", ae.txt), + "\n") + if(!isTRUE(ae)) stop("Not equal: ", ae.txt, " giving\n", ae) + } + if(!is.language(obj)) { + ob2. <- eval(pd0) ## almost always *NOT* identical to obj, but eval()ed + } + if(show || !is.list(obj)) { ## check it works when wrapped (but do not recurse inf.!) + cat(" --> checking list(*): ") + check_EPD(list(.chk = obj), show = FALSE) + cat("Ok\n") + } + invisible(obj) + } > > 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))))) + ## + if(require("Matrix")) { cat("Trying some Matrix objects, too\n") + D5. <- Diagonal(x = 5:1) + D5N <- D5.; D5N[5,5] <- NA + example(Matrix) + ## a subset from example(sparseMatrix) : + i <- c(1,3:8); j <- c(2,9,6:10); x <- 7 * (1:7) + A <- sparseMatrix(i, j, x = x) + sA <- sparseMatrix(i, j, x = x, symmetric = TRUE) + tA <- sparseMatrix(i, j, x = x, triangular= TRUE) + ## dims can be larger than the maximum row or column indices + AA <- sparseMatrix(c(1,3:8), c(2,9,6:10), x = 7 * (1:7), dims = c(10,20)) + ## i, j and x can be in an arbitrary order, as long as they are consistent + set.seed(1); (perm <- sample(1:7)) + A1 <- sparseMatrix(i[perm], j[perm], x = x[perm]) + ## the (i,j) pairs can be repeated, in which case the x's are summed + args <- data.frame(i = c(i, 1), j = c(j, 2), x = c(x, 2)) + Aa <- do.call(sparseMatrix, args) + A. <- do.call(sparseMatrix, c(args, list(use.last.ij = TRUE))) + ## for a pattern matrix, of course there is no "summing": + nA <- do.call(sparseMatrix, args[c("i","j")]) + dn <- list(LETTERS[1:3], letters[1:5]) + ## pointer vectors can be used, and the (i,x) slots are sorted if necessary: + m <- sparseMatrix(i = c(3,1, 3:2, 2:1), p= c(0:2, 4,4,6), x = 1:6, dimnames = dn) + ## no 'x' --> patter*n* matrix: + n <- sparseMatrix(i=1:6, j=rev(2:7)) + ## an empty sparse matrix: + e <- sparseMatrix(dims = c(4,6), i={}, j={}) + ## a symmetric one: + sy <- sparseMatrix(i= c(2,4,3:5), j= c(4,7:5,5), x = 1:5, + dims = c(7,7), symmetric=TRUE) + } + }# 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))) Loading required package: Matrix Trying some Matrix objects, too Matrix> Matrix(0, 3, 2) # 3 by 2 matrix of zeros -> sparse 3 x 2 sparse Matrix of class "dgCMatrix" [1,] . . [2,] . . [3,] . . Matrix> Matrix(0, 3, 2, sparse=FALSE)# -> 'dense' 3 x 2 Matrix of class "dgeMatrix" [,1] [,2] [1,] 0 0 [2,] 0 0 [3,] 0 0 Matrix> Matrix(0, 2, 2, sparse=FALSE)# diagonal ! 2 x 2 diagonal matrix of class "ddiMatrix" [,1] [,2] [1,] 0 . [2,] . 0 Matrix> Matrix(0, 2, 2, sparse=FALSE, doDiag=FALSE)# -> dense 2 x 2 Matrix of class "dsyMatrix" [,1] [,2] [1,] 0 0 [2,] 0 0 Matrix> Matrix(1:6, 3, 2) # a 3 by 2 matrix (+ integer warning) 3 x 2 Matrix of class "dgeMatrix" [,1] [,2] [1,] 1 4 [2,] 2 5 [3,] 3 6 Matrix> Matrix(1:6 + 1, nrow=3) 3 x 2 Matrix of class "dgeMatrix" [,1] [,2] [1,] 2 5 [2,] 3 6 [3,] 4 7 Matrix> ## logical ones: Matrix> Matrix(diag(4) > 0)# -> "ldiMatrix" with diag = "U" 4 x 4 diagonal matrix of class "ldiMatrix" [,1] [,2] [,3] [,4] [1,] TRUE . . . [2,] . TRUE . . [3,] . . TRUE . [4,] . . . TRUE Matrix> Matrix(diag(4) > 0, sparse=TRUE)# -> sparse... 4 x 4 sparse Matrix of class "lsCMatrix" [1,] | . . . [2,] . | . . [3,] . . | . [4,] . . . | Matrix> Matrix(diag(4) >= 0)# -> "lsyMatrix" (of all 'TRUE') 4 x 4 Matrix of class "lsyMatrix" [,1] [,2] [,3] [,4] [1,] TRUE TRUE TRUE TRUE [2,] TRUE TRUE TRUE TRUE [3,] TRUE TRUE TRUE TRUE [4,] TRUE TRUE TRUE TRUE Matrix> ## triangular Matrix> l3 <- upper.tri(matrix(,3,3)) Matrix> (M <- Matrix(l3)) # -> "ltCMatrix" 3 x 3 sparse Matrix of class "ltCMatrix" [1,] . | | [2,] . . | [3,] . . . Matrix> Matrix(! l3)# -> "ltrMatrix" 3 x 3 Matrix of class "ltrMatrix" [,1] [,2] [,3] [1,] TRUE . . [2,] TRUE TRUE . [3,] TRUE TRUE TRUE Matrix> as(l3, "CsparseMatrix") 3 x 3 sparse Matrix of class "lgCMatrix" [1,] . | | [2,] . . | [3,] . . . Matrix> Matrix(1:9, nrow=3, Matrix+ dimnames = list(c("a", "b", "c"), c("A", "B", "C"))) 3 x 3 Matrix of class "dgeMatrix" A B C a 1 4 7 b 2 5 8 c 3 6 9 Matrix> (I3 <- Matrix(diag(3)))# identity, i.e., unit "diagonalMatrix" 3 x 3 diagonal matrix of class "ddiMatrix" [,1] [,2] [,3] [1,] 1 . . [2,] . 1 . [3,] . . 1 Matrix> str(I3) # note the empty 'x' slot Formal class 'ddiMatrix' [package "Matrix"] with 4 slots ..@ diag : chr "U" ..@ Dim : int [1:2] 3 3 ..@ Dimnames:List of 2 .. ..$ : NULL .. ..$ : NULL ..@ x : num(0) Matrix> (A <- cbind(a=c(2,1), b=1:2))# symmetric *apart* from dimnames a b [1,] 2 1 [2,] 1 2 Matrix> Matrix(A) # hence 'dgeMatrix' 2 x 2 Matrix of class "dgeMatrix" a b [1,] 2 1 [2,] 1 2 Matrix> (As <- Matrix(A, dimnames = list(NULL,NULL)))# -> symmetric 2 x 2 Matrix of class "dsyMatrix" [,1] [,2] [1,] 2 1 [2,] 1 2 Matrix> stopifnot(is(As, "symmetricMatrix"), Matrix+ is(Matrix(0, 3,3), "sparseMatrix"), Matrix+ is(Matrix(FALSE, 1,1), "sparseMatrix")) > > ## 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: new("dgCMatrix", i = c(0L, 3L, 4L, 5L, 2L, 6L, 7L), p = c(0L, 0L, 1L, 1L, 1L, 1L, 2L, 3L, 4L, 6L, 7L), Dim = c(8L, 10L), Dimnames = list( NULL, NULL), x = c(7, 21, 28, 35, 14, 42, 49), factors = list()) --> checking list(*): Ok --=--=--=--=-- A.: new("dgCMatrix", i = c(0L, 3L, 4L, 5L, 2L, 6L, 7L), p = c(0L, 0L, 1L, 1L, 1L, 1L, 2L, 3L, 4L, 6L, 7L), Dim = c(8L, 10L), Dimnames = list( NULL, NULL), x = c(2, 21, 28, 35, 14, 42, 49), factors = list()) --> checking list(*): Ok --=--=--=--=-- A1: new("dgCMatrix", i = c(0L, 3L, 4L, 5L, 2L, 6L, 7L), p = c(0L, 0L, 1L, 1L, 1L, 1L, 2L, 3L, 4L, 6L, 7L), Dim = c(8L, 10L), Dimnames = list( NULL, NULL), x = c(7, 21, 28, 35, 14, 42, 49), factors = list()) --> checking list(*): Ok --=--=--=--=-- AA: new("dgCMatrix", i = c(0L, 3L, 4L, 5L, 2L, 6L, 7L), p = c(0L, 0L, 1L, 1L, 1L, 1L, 2L, 3L, 4L, 6L, 7L, 7L, 7L, 7L, 7L, 7L, 7L, 7L, 7L, 7L, 7L), Dim = c(10L, 20L), Dimnames = list(NULL, NULL), x = c(7, 21, 28, 35, 14, 42, 49), factors = list()) --> checking list(*): Ok --=--=--=--=-- Aa: new("dgCMatrix", i = c(0L, 3L, 4L, 5L, 2L, 6L, 7L), p = c(0L, 0L, 1L, 1L, 1L, 1L, 2L, 3L, 4L, 6L, 7L), Dim = c(8L, 10L), Dimnames = list( NULL, NULL), x = c(9, 21, 28, 35, 14, 42, 49), factors = list()) --> checking list(*): Ok --=--=--=--=-- As: new("dsyMatrix", x = c(2, 1, 1, 2), Dim = c(2L, 2L), Dimnames = list( NULL, NULL), uplo = "U", factors = list()) --> checking list(*): Ok --=--=--=--=-- 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 --=--=--=--=-- D5.: new("ddiMatrix", diag = "N", Dim = c(5L, 5L), Dimnames = list( NULL, NULL), x = c(5, 4, 3, 2, 1)) --> checking list(*): Ok --=--=--=--=-- D5N: new("ddiMatrix", diag = "N", Dim = c(5L, 5L), Dimnames = list( NULL, NULL), x = c(5, 4, 3, 2, NA)) --> checking list(*): Ok --=--=--=--=-- 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 --=--=--=--=-- I3: new("ddiMatrix", diag = "U", Dim = c(3L, 3L), Dimnames = list( NULL, NULL), x = numeric(0)) --> 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 --=--=--=--=-- M: new("ltCMatrix", i = c(0L, 0L, 1L), p = c(0L, 0L, 1L, 3L), Dim = c(3L, 3L), Dimnames = list(NULL, NULL), x = c(TRUE, TRUE, TRUE), uplo = "U", diag = "N") --> 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 --=--=--=--=-- args: structure(list(i = c(1, 3, 4, 5, 6, 7, 8, 1), j = c(2, 9, 6, 7, 8, 9, 10, 2), x = c(7, 14, 21, 28, 35, 42, 49, 2)), class = "data.frame", row.names = c(NA, -8L)) --> 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), eq.tol = if (.Machine$sizeof.longdouble <= 8) 2 * .Machine$double.eps else 0) { 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), error = function(e) { cat("default deparse() was not parse():\n ", conditionMessage(e), "\n but deparse(*, control='all') should work.\n") pd0(obj, control = "all") }) if (!identical(obj, ob2, ignore.environment = TRUE, ignore.bytecode = TRUE, ignore.srcref = TRUE)) { ae <- all.equal(obj, ob2, tolerance = eq.tol) ae.txt <- sprintf("all.equal(*,*, tol = %.3g)", eq.tol) cat("not identical(*, ignore.env=T),", if (isTRUE(ae)) paste("but", ae.txt), "\n") if (!isTRUE(ae)) stop("Not equal: ", ae.txt, " giving\n", ae) } if (!is.language(obj)) { ob2. <- eval(pd0) } if (show || !is.list(obj)) { cat(" --> checking list(*): ") check_EPD(list(.chk = obj), show = FALSE) cat("Ok\n") } invisible(obj) } --> checking list(*): Ok checking body(.): quote({ 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), error = function(e) { cat("default deparse() was not parse():\n ", conditionMessage(e), "\n but deparse(*, control='all') should work.\n") pd0(obj, control = "all") }) if (!identical(obj, ob2, ignore.environment = TRUE, ignore.bytecode = TRUE, ignore.srcref = TRUE)) { ae <- all.equal(obj, ob2, tolerance = eq.tol) ae.txt <- sprintf("all.equal(*,*, tol = %.3g)", eq.tol) cat("not identical(*, ignore.env=T),", if (isTRUE(ae)) paste("but", ae.txt), "\n") if (!isTRUE(ae)) stop("Not equal: ", ae.txt, " giving\n", ae) } if (!is.language(obj)) { ob2. <- eval(pd0) } if (show || !is.list(obj)) { cat(" --> checking list(*): ") check_EPD(list(.chk = obj), show = FALSE) cat("Ok\n") } invisible(obj) }) --> checking list(*): Ok checking formals(.): as.pairlist(alist(obj = , show = quote(!hasReal(obj)), eq.tol = quote(if (.Machine$sizeof.longdouble <= 8) 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 --=--=--=--=-- dn: list(c("A", "B", "C"), c("a", "b", "c", "d", "e")) --> checking list(*): Ok --=--=--=--=-- e: new("ngCMatrix", i = integer(0), p = c(0L, 0L, 0L, 0L, 0L, 0L, 0L), Dim = c(4L, 6L), Dimnames = list(NULL, NULL), factors = list()) --> checking list(*): Ok --=--=--=--=-- 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 = 0) --> checking list(*): not identical(*, ignore.env=T), but all.equal(*,*, tol = 0) 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 --=--=--=--=-- i: c(1, 3, 4, 5, 6, 7, 8) --> checking list(*): Ok --=--=--=--=-- 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 --=--=--=--=-- j: c(2, 9, 6, 7, 8, 9, 10) --> checking list(*): Ok --=--=--=--=-- k: function (...) g(...) --> checking list(*): Ok checking body(.): quote(g(...)) --> checking list(*): Ok checking formals(.): as.pairlist(alist(... = )) __ not parse()able __: hasMissObj(.) is true --=--=--=--=-- l3: structure(c(FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, TRUE, TRUE, FALSE), .Dim = c(3L, 3L)) --> checking list(*): Ok --=--=--=--=-- lf: list(ff = y ~ f(x), osf = ~sin(x)) not identical(*, ignore.env=T), but all.equal(*,*, tol = 0) --> checking list(*): not identical(*, ignore.env=T), but all.equal(*,*, tol = 0) Ok --=--=--=--=-- m: new("dgCMatrix", i = c(2L, 0L, 1L, 2L, 0L, 1L), p = c(0L, 1L, 2L, 4L, 4L, 6L), Dim = c(3L, 5L), Dimnames = list(c("A", "B", "C"), c("a", "b", "c", "d", "e")), x = c(1, 2, 4, 3, 6, 5), factors = list()) --> checking list(*): 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 = 0) --> checking list(*): not identical(*, ignore.env=T), but all.equal(*,*, tol = 0) Ok --=--=--=--=-- mForm: new("classGeneratorFunction", .Data = function (...) new("mForm", ...), className = structure("mForm", package = ".GlobalEnv"), package = ".GlobalEnv") not identical(*, ignore.env=T), but all.equal(*,*, tol = 0) --> checking list(*): not identical(*, ignore.env=T), but all.equal(*,*, tol = 0) Ok --=--=--=--=-- mList: new("classGeneratorFunction", .Data = function (...) new("mList", ...), className = structure("mList", package = ".GlobalEnv"), package = ".GlobalEnv") not identical(*, ignore.env=T), but all.equal(*,*, tol = 0) --> checking list(*): not identical(*, ignore.env=T), but all.equal(*,*, tol = 0) Ok --=--=--=--=-- mf: new("mForm", .S3Class = "formula", ~f(x)) not identical(*, ignore.env=T), but all.equal(*,*, tol = 0) --> checking list(*): not identical(*, ignore.env=T), but all.equal(*,*, tol = 0) 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 --=--=--=--=-- n: new("ngCMatrix", i = 5:0, p = c(0L, 0L, 1L, 2L, 3L, 4L, 5L, 6L ), Dim = 6:7, Dimnames = list(NULL, NULL), factors = list()) --> checking list(*): Ok --=--=--=--=-- nA: new("ngCMatrix", i = c(0L, 3L, 4L, 5L, 2L, 6L, 7L), p = c(0L, 0L, 1L, 1L, 1L, 1L, 2L, 3L, 4L, 6L, 7L), Dim = c(8L, 10L), Dimnames = list( NULL, NULL), factors = list()) --> checking list(*): Ok --=--=--=--=-- nmdExp: expression(e1 = sin(pi), e2 = cos(-pi)) --> checking list(*): Ok --=--=--=--=-- pd0: function (expr, backtick = TRUE, control = c("keepInteger", "showAttributes", "keepNA"), ...) parse(text = deparse(expr, backtick = backtick, control = control, ...)) --> checking list(*): Ok checking body(.): quote(parse(text = deparse(expr, backtick = backtick, control = control, ...))) --> checking list(*): Ok checking formals(.): as.pairlist(alist(expr = , backtick = TRUE, control = quote(c("keepInteger", "showAttributes", "keepNA")), ... = )) __ not parse()able __: hasMissObj(.) is true --=--=--=--=-- perm: c(2L, 3L, 6L, 4L, 1L, 7L, 5L) --> checking list(*): Ok --=--=--=--=-- 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 --=--=--=--=-- sA: new("dsCMatrix", i = c(0L, 3L, 4L, 5L, 2L, 6L, 7L), p = c(0L, 0L, 1L, 1L, 1L, 1L, 2L, 3L, 4L, 6L, 7L), Dim = c(10L, 10L), Dimnames = list( NULL, NULL), x = c(7, 21, 28, 35, 14, 42, 49), uplo = "U", factors = list()) --> 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 --=--=--=--=-- sy: new("dsCMatrix", i = c(1L, 3L, 4L, 2L, 3L), p = c(0L, 0L, 0L, 0L, 1L, 3L, 4L, 5L), Dim = c(7L, 7L), Dimnames = list(NULL, NULL), x = c(1, 4, 5, 3, 2), uplo = "U", factors = list()) --> checking list(*): Ok --=--=--=--=-- t1: --> checking list(*): Ok --=--=--=--=-- t2: --> checking list(*): Ok --=--=--=--=-- tA: new("dtCMatrix", i = c(0L, 3L, 4L, 5L, 2L, 6L, 7L), p = c(0L, 0L, 1L, 1L, 1L, 1L, 2L, 3L, 4L, 6L, 7L), Dim = c(10L, 10L), Dimnames = list( NULL, NULL), x = c(7, 21, 28, 35, 14, 42, 49), uplo = "U", diag = "N") --> 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 deparse(expr, backtick = backtick, control = control, ...) : deparse may be incomplete 3: In deparse(expr, backtick = backtick, control = control, ...) : deparse may be incomplete 4: In dput(x, control = control) : deparse may be incomplete 5: In deparse(expr, backtick = backtick, control = control, ...) : deparse may be incomplete 6: In deparse(expr, backtick = backtick, control = control, ...) : deparse may be incomplete 7: In dput(x, control = control) : deparse may be incomplete 8: In deparse(expr, backtick = backtick, control = control, ...) : deparse may be incomplete 9: In deparse(expr, backtick = backtick, control = control, ...) : deparse may be incomplete > summary(warnings()) Summary of (a total of 9) warning messages: 6x : In dput(x, control = control) : deparse may be incomplete 3x : In deparse(expr, backtick = backtick, control = control, ... : 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: 1.576 0.082 1.681 0 0 >