| #### 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 |
| str(eval(e1)) |
| mode(e1) |
| |
| ( e2 <- quote(c(a=1,b=2)) ) |
| names(e2)[2] <- "a b c" |
| e2 |
| parse(text=deparse(e2)) |
| |
| ##- 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))) ) |
| eval(e3) |
| names(e3) |
| |
| names(e3)[2] <- "Variance ratio" |
| e3 |
| eval(e3) |
| |
| |
| ##- 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") |
| |
| e <- local({x <- 1;environment()}) |
| evalq(dim(x) <- 1,e) |
| dput(get("x",envir=e), control="all") |
| |
| ### 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)) |
| all.equal(as.list(aa), |
| list(as.name("B"), a = expression(x+y)[[1]], b = 3)) |
| (a2 <- A(1,2, named = 3)) #A(1,2, named = 3) |
| all.equal(as.list(a2), |
| list(as.name("B"), a = expression(x+y)[[1]], named = 3)) |
| |
| CC <- function(...) match.call() |
| DD <- function(...) CC(...) |
| a3 <- DD(1,2,3) |
| all.equal(as.list(a3), |
| list(as.name("CC"), 1, 2, 3)) |
| |
| ## 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)) |
| |
| ## 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)" |
| |
| tt <- function(x) { is.vector(x); deparse(substitute(x)) } |
| a <- list(b=3); tt(a$b) == "a$b" # tends to break when ... |
| |
| |
| ## Parser: |
| 1 < |
| 2 |
| 2 <= |
| 3 |
| 4 >= |
| 3 |
| 3 > |
| 2 |
| 2 == |
| 2 |
| ## bug till ... |
| 1 != |
| 3 |
| |
| all(NULL == NULL) |
| |
| ## PR #656 (related) |
| u <- runif(1); length(find(".Random.seed")) == 1 |
| |
| MyVaR <<- "val";length(find("MyVaR")) == 1 |
| rm(MyVaR); length(find("MyVaR")) == 0 |
| |
| |
| ## 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() |
| callme(mm="B") |
| mycaller <- function(x = 1, callme = pi) { callme(x) } |
| mycaller()## wrongly gave `mm = NULL' now = "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 |
| 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) |
| #--------- |
| |
| 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))) |
| 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 |
| |
| ## Action! Check deparse <--> parse consistency for *all* objects: |
| runEPD_checks() |
| |
| summary(warnings()) |
| ## "dput may be incomplete" |
| ## "deparse may be incomplete" |
| |
| |
| ## at the very end |
| cat('Time elapsed: ', proc.time() - .proctime00,'\n') |