stopifnot

Sat, Mar 2, 2019 12:28 AM

A private reply by Martin made me realize that I was wrong about
stopifnot(exprs=TRUE) .
It actually works fine. I apologize. What I tried and was failed was
stopifnot(exprs=T) .
Error in exprs[[1]] : object of type 'symbol' is not subsettable

The shortcut
assert <- function(exprs) stopifnot(exprs = exprs)
mentioned in "Warning" section of the documentation similarly fails when called, for example
assert({})

About shortcut, a definition that rather works:
assert <- function(exprs) eval.parent(substitute(stopifnot(exprs = exprs)))

Looking at https://stat.ethz.ch/pipermail/r-devel/2017-May/074227.html , using sys.parent() may be not good. For example, in
f <- function() stopifnot(exprs={FALSE}, local=FALSE); f()

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

--------------------------------------------

On Fri, 1/3/19, Martin Maechler <maechler at stat.math.ethz.ch> wrote:

Subject: Re: [Rd] stopifnot

 Cc: "Martin Maechler" <maechler at stat.math.ethz.ch>, r-devel at r-project.org
 Date: Friday, 1 March, 2019, 6:40 PM

[...]

? ? > Another thing: currently,
? ? > stopifnot(exprs=TRUE)
? ? > fails.

good catch - indeed!

I've started to carefully test and try the interesting nice
patch you've provided below.

[...]

Martin


? ? > A patch:
? ? > --- stop.R? ? 2019-02-27 16:15:45.324167577 +0000
? ? > +++ stop_new.R? ? 2019-02-27 16:22:15.936203541 +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,27 @@

? ? > 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[-1]
? ? > else if(identical(quote(expression), E1))
? ? > eval(exprs, envir=envir)
? ? > else
? ? > as.expression(exprs) # or fail ..
? ? > +? ? ? ? if(!is.null(names(cl))) names(cl) <- NULL
? ? > +? ? ? ? return(eval(as.call(c(sys.call()[[1]], as.list(cl))), envir=envir))
? ? > }
? ? > Dparse <- function(call, cutoff = 60L) {
? ? > ch <- deparse(call, width.cutoff = cutoff)
? ? > @@ -62,14 +64,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 +82,11 @@
? ? > "%s are not all TRUE"),
? ? > Dparse(cl.i))

? ? > -? ? ? ? stop(simpleError(msg, call = sys.call(-1)))
? ? > +? ? ? ? p <- sys.parent()
? ? > +? ? ? ? if(p && identical(sys.function(p), stopifnot) &&
? ? > +? ? ? ? ? !eval(expression(missE), p)) # originally stopifnot(exprs=*)
? ? > +? ? ? ? p <- sys.parent(2)
? ? > +? ? ? ? stop(simpleError(msg, call = if(p) sys.call(p)))
? ? > }
? ? > }
? ? > invisible()

stopifnot

Thread (2 messages)