[Rd] stopifnot

[Suharto Anggono Suharto Anggono]

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 using 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()