>>>>> Serguei Sokol <so...@insa-toulouse.fr> >>>>> on Mon, 15 May 2017 16:32:20 +0200 writes:
> Le 15/05/2017 à 15:37, Martin Maechler a écrit : >>>>>>> Serguei Sokol <so...@insa-toulouse.fr> >>>>>>> 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() }
______________________________________________ R-devel@r-project.org mailing list https://stat.ethz.ch/mailman/listinfo/r-devel