[Rd] stopifnot
Martin Maechler
m@ech|er @end|ng |rom @t@t@m@th@ethz@ch
Mon Mar 4 10:59:46 CET 2019
>>>>> 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 <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()
> ______________________________________________
> R-devel using r-project.org mailing list
> https://stat.ethz.ch/mailman/listinfo/r-devel
More information about the R-devel
mailing list