[Rd] stopifnot
Suharto Anggono Suharto Anggono
@uh@rto_@nggono @end|ng |rom y@hoo@com
Sat Mar 2 09:28:23 CET 2019
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 using stat.math.ethz.ch> wrote:
Subject: Re: [Rd] stopifnot
Cc: "Martin Maechler" <maechler using stat.math.ethz.ch>, r-devel using r-project.org
Date: Friday, 1 March, 2019, 6:40 PM
>>>>> Suharto Anggono Suharto Anggono
>>>>> on Wed, 27 Feb 2019 22:46:04 +0000 writes:
[...]
> 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()
More information about the R-devel
mailing list