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