Instead of
if(!is.null(names(cl))) names(cl) <- NULL ,
just
names(cl) <- NULL
looks simpler and the memory usage and speed is not bad in my little experiment.
--------------------------------------------
Subject: Re: [Rd] stopifnot
To: r-devel at r-project.org
Date: Saturday, 2 March, 2019, 3:28 PM
[...]
A revised patch (also with simpler 'cl'):
--- stop.R 2019-02-27 16:15:45.324167577 +0000
+++ stop_new.R 2019-03-02 06:21:35.919471080 +0000
@@ -1,7 +1,7 @@
# File src/library/base/R/stop.R
# Part of the R package, https://www.R-project.org
#
-# Copyright (C) 1995-2018 The R Core Team
+# Copyright (C) 1995-2019 The R Core Team
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
@@ -33,25 +33,28 @@
stopifnot <- function(..., exprs, local = TRUE)
{
+ n <- ...length()
missE <- missing(exprs)
- cl <-
if(missE) { ## use '...' instead of exprs
- match.call(expand.dots=FALSE)$...
} else {
- if(...length())
+ if(n)
stop("Must use 'exprs' or unnamed expressions, but not
both")
envir <- if (isTRUE(local)) parent.frame()
else if(isFALSE(local)) .GlobalEnv
else if (is.environment(local)) local
else stop("'local' must be TRUE, FALSE or an
environment")
exprs <- substitute(exprs) # protect from evaluation
- E1 <- exprs[[1]]
+ E1 <- if(is.call(exprs)) exprs[[1]]
+ cl <-
if(identical(quote(`{`), E1)) # { ... }
- do.call(expression, as.list(exprs[-1]))
+ exprs
else if(identical(quote(expression), E1))
- eval(exprs, envir=envir)
+ exprs
else
- as.expression(exprs) # or fail ..
+ call("expression", exprs) # or fail ..
+ if(!is.null(names(cl))) names(cl) <- NULL
+ cl[[1]] <- sys.call()[[1]]
+ return(eval(cl, envir=envir))
}
Dparse <- function(call, cutoff = 60L) {
ch <- deparse(call, width.cutoff = cutoff)
@@ -62,14 +65,10 @@
abbrev <- function(ae, n = 3L)
paste(c(head(ae, n), if(length(ae) > n) "...."),
collapse="\n ")
##
- for (i in seq_along(cl)) {
- cl.i <- cl[[i]]
- ## r <- eval(cl.i, ..) # with correct warn/err messages:
- r <- withCallingHandlers(
- tryCatch(if(missE) ...elt(i) else eval(cl.i, envir=envir),
- error = function(e) { e$call <- cl.i; stop(e) }),
- warning = function(w) { w$call <- cl.i; w })
+ for (i in seq_len(n)) {
+ r <- ...elt(i)
if (!(is.logical(r) && !anyNA(r) && all(r))) {
+ cl.i <- match.call(expand.dots=FALSE)$...[[i]]
msg <- ## special case for decently written 'all.equal(*)':
if(is.call(cl.i) && identical(cl.i[[1]], quote(all.equal))
&&
(is.null(ni <- names(cl.i)) || length(cl.i) == 3L ||
@@ -84,7 +83,12 @@
"%s are not all TRUE"),
Dparse(cl.i))
- stop(simpleError(msg, call = sys.call(-1)))
+ n <- sys.nframe()
+ if((p <- n-3) > 0 &&
+ identical(sys.function(p), sys.function(n)) &&
+ eval(expression(!missE), p)) # originally stopifnot(exprs=*)
+ n <- p
+ stop(simpleError(msg, call = if(n > 1) sys.call(n-1)))
}
}
invisible()
