[Rd] Extending suggestion for stopifnot

[Martin Morgan]

On 08/20/2013 11:41 AM, ivo welch wrote:
> A second enhancement would be a "smart string", which knows that
> everything inside {{...}} should be evaluated.
>
>    stopifnot( is.matrix(m), "m is not a matrix, but a {{class(m)}}" )

a variant with more traditional syntax might be

   if (!is.matrix(m))
       stopf("m is not a matrix, but a '%s'", class(m))
or

   stopifnotf(is.matrix(m), "m is not a matrix, but a '%s'", class(m))

where stopf is analogous to sprintf but signalling the corresponding condition 
(perhaps taking the opportunity to strwrap to getOption("width")). This would 
work well with gettextf to allow for translation. An imperfect implementation 
(call. is incorrect, for example) is

.msg <-
     function(fmt, ..., domain=NULL, width=getOption("width"))
     ## Use this helper to format all error / warning / message text
{
     txt <- strwrap(gettextf(fmt, ..., domain=domain), width=width,
                    exdent=2)
     paste(txt, collapse="\n")
}

stopf <-
     function(..., call.=FALSE)
{
     stop(.msg(...), call.=call.)
}

stopifnotf <-
     function(test, fmt, ...)
{
     if (!test)
         stopf(fmt, ...)
}

One might also wish to expose the condition class system, along the lines of

.textf <- ## a variant of .makeMessage
     function(fmt, ..., width = getOption("width"), domain = NULL,
              appendLF = FALSE)
{
     txt <- gettextf(fmt, ..., domain = domain)
     msg <- paste(strwrap(txt, width = width, indent = 2, exdent = 2),
                  collapse="\n")
     if (appendLF)
         paste0(msg, "\n")
     else msg
}

.condition <-
     function(fmt, ..., class, call = NULL)
{
     msg <- .textf(fmt, ...)
     if (is.null(call))
         msg <- paste0("\n", msg)
     class <- c(class, "condition")
     structure(list(message=msg, call = call), class=class)
}

stopf <-
     function(fmt, ..., class. = "simpleError", call. = TRUE, domain = NULL)
{
     call. <- if (is.logical(call.) && 1L == length(call.) && call.)
         sys.call(-1)
     else NULL
     cond <- .condition(fmt, ..., domain = domain,
                        class = c(class., "error"), call = call.)
     stop(cond)
}

warnf <-
     function(fmt, ..., class. = "simpleWarning", call. = TRUE, domain = NULL)
{
     ## does not support immediate., but options(warn=1) supported
     call. <- if (is.logical(call.) && 1L == length(call.) && call.)
         sys.call(-1)
     else NULL
     cond <- .condition(fmt, ..., domain = domain,
                        class = c(class., "warning" ), call = call.)
     warning(cond)
}

messagef <-
     function(fmt, ..., class. = "simpleMessage", domain = NULL,
              appendLF = TRUE)
{
     cond <- .condition(fmt, ..., domain = domain, appendLF = appendLF,
                        class = c(class., "message"))
     message(cond)
}


-- 
Computational Biology / Fred Hutchinson Cancer Research Center
1100 Fairview Ave. N.
PO Box 19024 Seattle, WA 98109

Location: Arnold Building M1 B861
Phone: (206) 667-2793