Another possible shortcut definition:
assert <- function(exprs)
do.call("stopifnot", list(exprs = substitute(exprs), local = parent.frame()))
After thinking again, I propose to use
stop(simpleError(msg, call = if(p <- sys.parent()) sys.call(p)))
- It seems that the call is the call of the frame where stopifnot(...) is
evaluated. Because that is the correct context, I think it is good.
- It is simpler and also works for call that originally comes from
stopifnot(exprs=*) .
- It allows shortcut ('assert') to have the same call in error message as
stopifnot(exprs=*) .
Another thing: Is it intended that
do.call("stopifnot", list(exprs = expression()))
evaluates each element of the expression object? If so, maybe add a case for
'cl', like
else if(is.expression(exprs))
as.call(c(quote(expression), exprs))
--------------------------------------------
On Mon, 4/3/19, Martin Maechler <maech...@stat.math.ethz.ch> wrote:
Subject: Re: [Rd] stopifnot
Cc: r-devel@r-project.org
Date: Monday, 4 March, 2019, 4:59 PM
>>>>> Suharto Anggono Suharto Anggono via R-devel
>>>>> on Sat, 2 Mar 2019 08:28:23 +0000 writes:
>>>>> Suharto Anggono Suharto Anggono via R-devel
>>>>> on Sat, 2 Mar 2019 08:28:23 +0000 writes:
> 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
indeed! .. and your patch below does address that, too.
> 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)))
Interesting... thank you for the suggestion! I plan to add it
to the help page and then use it a bit .. before considering more.
> 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()
I'm glad you found this too.. I did have "uneasy feelings" about
using sys.parent(2) to find the correct call .. and I'm still
not 100% sure about the smart computation of 'n' for
sys.call(n-1) ... but I agree we should move in that direction
as it is so much faster than using withCallingHandlers() + tryCatch()
for all the expressions.
In my tests your revised patch (including the simplificationn
you sent 4 hours later) seems good and indeed does have very
good timing in simple experiments.
It will lead to some error messages being changed,
but in the examples I've seen, the few changes were acceptable
(sometimes slightly less helpful, sometimes easier to read).
Martin
> 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 <maech...@stat.math.ethz.ch> wrote:
> Subject: Re: [Rd] stopifnot
> Cc: "Martin Maechler" <maech...@stat.math.ethz.ch>, r-devel@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.
[[elided Yahoo spam]]
> 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()
> ______________________________________________
> R-devel@r-project.org mailing list
> https://stat.ethz.ch/mailman/listinfo/r-devel
______________________________________________
R-devel@r-project.org mailing list
https://stat.ethz.ch/mailman/listinfo/r-devel
