>>>>> Serguei Sokol <[email protected]>
>>>>> on Mon, 15 May 2017 16:32:20 +0200 writes:
> Le 15/05/2017 à 15:37, Martin Maechler a écrit :
>>>>>>> Serguei Sokol <[email protected]>
>>>>>>> on Mon, 15 May 2017 13:14:34 +0200 writes:
>> > I see in the archives that the attachment cannot pass.
>> > So, here is the code:
>>
>> [....... MM: I needed to reformat etc to match closely to
>> the current source code which is in
>> https://svn.r-project.org/R/trunk/src/library/base/R/stop.R
>> or its corresponding github mirror
>> https://github.com/wch/r-source/blob/trunk/src/library/base/R/stop.R
>> ]
>>
>> > Best,
>> > Serguei.
>>
>> Yes, something like that seems even simpler than Peter's
>> suggestion...
>>
>> It currently breaks 'make check' in the R sources,
>> specifically in tests/reg-tests-2.R (lines 6574 ff),
>> the new code now gives
>>
>> > ## error messages from (C-level) evalList
>> > tst <- function(y) { stopifnot(is.numeric(y)); y+ 1 }
>> > try(tst())
>> Error in eval(cl.i, pfr) : argument "y" is missing, with no default
>>
>> whereas previously it gave
>>
>> Error in stopifnot(is.numeric(y)) :
>> argument "y" is missing, with no default
>>
>>
>> But I think that change (of call stack in such an error case) is
>> unavoidable and not a big problem.
> It can be avoided but at price of customizing error() and warning() calls
with something like:
> wrn <- function(w) {w$call <- cl.i; warning(w)}
> err <- function(e) {e$call <- cl.i; stop(e)}
> ...
> tryCatch(r <- eval(cl.i, pfr), warning=wrn, error=err)
> Serguei.
Well, a good idea, but the 'warning' case is more complicated
(and the above incorrect): I do want the warning there, but
_not_ return the warning, but rather, the result of eval() :
So this needs even more sophistication, using withCallingHandlers(.)
and maybe that really get's too sophisticated and no
more "readable" to 99.9% of the R users ... ?
I now do append my current version -- in case some may want to
comment or improve further.
Martin
stopifnot <- function(...)
{
penv <- parent.frame()
cl <- match.call(envir = penv)[-1]
Dparse <- function(call, cutoff = 60L) {
ch <- deparse(call, width.cutoff = cutoff)
if(length(ch) > 1L) paste(ch[1L], "....") else ch
}
head <- function(x, n = 6L) ## basically utils:::head.default()
x[seq_len(if(n < 0L) max(length(x) + n, 0L) else min(n, length(x)))]
abbrev <- function(ae, n = 3L)
paste(c(head(ae, n), if(length(ae) > n) "...."), collapse="\n ")
benv <- baseenv()
for (i in seq_along(cl)) {
cl.i <- cl[[i]]
## r <- eval(cl.i, envir = penv, enclos = benv)
## ---- but with correct warn/err messages:
r <- withCallingHandlers(
tryCatch(eval(cl.i, envir = penv, enclos = benv),
error = function(e) { e$call <- cl.i; stop(e) }),
warning = function(w) { w$call <- cl.i; w })
if (!(is.logical(r) && !anyNA(r) && all(r))) {
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 ||
length(cl.i <- cl.i[!nzchar(ni)]) == 3L))
sprintf(gettext("%s and %s are not equal:\n %s"),
Dparse(cl.i[[2]]),
Dparse(cl.i[[3]]), abbrev(r))
else
sprintf(ngettext(length(r),
"%s is not TRUE",
"%s are not all TRUE"),
Dparse(cl.i))
stop(msg, call. = FALSE, domain = NA)
}
}
invisible()
}
______________________________________________
[email protected] mailing list
https://stat.ethz.ch/mailman/listinfo/r-devel
