	##================================================================##
	###  In longer simulations, aka computer experiments,		 ###
	###  you may want to						 ###
	###  1) catch all errors and warnings (and continue)		 ###
	###  2) store the error or warning messages			 ###
	###								 ###
	###  Here's a solution	(see R-help mailing list, Dec 9, 2010):	 ###
	##================================================================##

##' Catch *and* save both errors and warnings, and in the case of
##' a warning, also keep the computed result.
##'
##' @title tryCatch both warnings (with value) and errors
##' @param expr an \R expression to evaluate
##' @return a list with 'value' and 'warning', where
##'   'value' may be an error caught.
##' @author Martin Maechler;
##' Copyright (C) 2010-2023  The R Core Team
tryCatch.W.E <- function(expr)
{
    W <- NULL
    w.handler <- function(w) { # warning handler
	W <<- w
	invokeRestart("muffleWarning")
    }
    list(value = withCallingHandlers(tryCatch(expr, error = function(e) e),
				     warning = w.handler),
	 warning = W)
}

str( tryCatch.W.E( log( 2 ) ) )
str( tryCatch.W.E( log( -1) ) )
str( tryCatch.W.E( log("a") ) )


##' @title Catch *all* warnings and the value
##' @param expr an \R expression to evaluate
##' @return a list with 'value' and 'warnings'
##' @author Luke Tierney (2004), R-help post
##'	https://stat.ethz.ch/pipermail/r-help/2004-June/052132.html
withWarnings <- function(expr) {
    W <- NULL
    wHandler <- function(w) {
	W <<- c(W, list(w))
	invokeRestart("muffleWarning")
    }
    val <- withCallingHandlers(expr, warning = wHandler)
    list(value = val, warnings = W)
}

withWarnings({ warning("first"); warning("2nd"); pi })

r <- withWarnings({ log(-1) + sqrt(-4); exp(1) })
str(r, digits=14)

##' @title tryCatch *all* warnings and messages, and an error or the final value
##' @param expr an \R expression to evaluate
##' @return a list with `messages`, `warnings`, and
##'         `value` which may be an error caught.
##' @author Martin Maechler (combining the above)
tryCatch_WEMs <- function(expr)
{
    W <- M <- NULL
    w.handler <- function(w) { # warning handler
	W <<- c(W, list(w)); invokeRestart("muffleWarning")
    }
    m.handler <- function(m) { # message handler
	M <<- c(M, list(m)); invokeRestart("muffleMessage")
    }
    list(value = withCallingHandlers(tryCatch(expr, error = function(e) e),
				     warning = w.handler, message = m.handler),
	 messages = M,
	 warnings = W)
}

f3 <- function(x) {
    r <- log(-x) + sqrt(-x) # produce warnings when x >= 0
    if(anyNA(r)) message(sprintf("%d NA's produced by log(.) + sqrt(.)", sum(is.na(r))))
    r <- exp(-x)
    if(any(ii <- is.infinite(r))) message(sprintf("Got +/- Inf from x[%s]", deparse(which(ii))))
    r
}

str( r0 <- tryCatch_WEMs(f3("A")) ) # just an error from '-x'
stopifnot(exprs = {
    inherits (r0$value, "error")
    identical(r0$value$call, quote(-x))
    sapply(r0[c("messages","warnings")], is.null)
})

(x <- c(-1:1, (-1:1)/0))
str( rI <- tryCatch_WEMs(f3(x) ))
stopifnot(exprs = {
    identical(lengths(rI), c(value = length(x), messages = 2L, warnings = 2L))
    rI$value[4] == Inf
    all.equal(rI$value, exp(-x))
    length(rI$messages) == 2; sapply(rI$messages, inherits, what="message")
    length(rI$warnings) == 2; sapply(rI$warnings, inherits, what="warning")
})


#  Copyright (C) 1997-2018 The R Core Team

### The Base package has a couple of non-functions:
##
## These may be in "base" when they exist;  discount them here
## (see also  'dont.mind' in checkConflicts() inside library()) :
xtraBaseNms <- c("last.dump", "last.warning", ".Last.value",
                 ".Random.seed", ".Traceback")
ls.base <- Filter(function(nm) is.na(match(nm, xtraBaseNms)),
                  ls("package:base", all=TRUE))
base.is.f <- sapply(ls.base, function(x) is.function(get(x)))
cat("\nNumber of all base objects:\t", length(ls.base),
    "\nNumber of functions from these:\t", sum(base.is.f),
    "\n\t starting with 'is.' :\t  ",
    sum(grepl("^is\\.", ls.base[base.is.f])), "\n", sep = "")
## R ver.| #{is*()}
## ------+---------
## 0.14  : 31
## 0.50  : 33
## 0.60  : 34
## 0.63  : 37
## 1.0.0 : 38
## 1.3.0 : 41
## 1.6.0 : 45
## 2.0.0 : 45
## 2.7.0 : 48
## 3.0.0 : 49
if(interactive()) {
    nonDots <- function(nm) substr(nm, 1L, 1L) != "."
    cat("Base non-functions not starting with \".\":\n")
    Filter(nonDots, ls.base[!base.is.f])
}

## Do we have a method (probably)?
is.method <- function(fname) {
    isFun <- function(name) (exists(name, mode="function") &&
                             is.na(match(name, c("is", "as"))))
    np <- length(sp <- strsplit(fname, split = "\\.")[[1]])
    if(np <= 1 )
        FALSE
    else
        (isFun(paste(sp[1:(np-1)], collapse = '.')) ||
         (np >= 3 &&
          isFun(paste(sp[1:(np-2)], collapse = '.'))))
}

is.ALL <- function(obj, func.names = ls(pos=length(search())),
		   not.using = c("is.single", "is.real", "is.loaded",
                     "is.empty.model", "is.R", "is.element", "is.unsorted"),
		   true.only = FALSE, debug = FALSE)
{
    ## Purpose: show many 'attributes' of  R object __obj__
    ## -------------------------------------------------------------------------
    ## Arguments: obj: any R object
    ## -------------------------------------------------------------------------
    ## Author: Martin Maechler, Date: 6 Dec 1996

    is.fn <- func.names[substring(func.names,1,3) == "is."]
    is.fn <- is.fn[substring(is.fn,1,7) != "is.na<-"]
    use.fn <- is.fn[ is.na(match(is.fn, not.using))
                    & ! sapply(is.fn, is.method) ]

    r <- if(true.only) character(0)
    else structure(vector("list", length= length(use.fn)), names= use.fn)
    for(f in use.fn) {
	if(any(f == c("is.na", "is.finite"))) {
	    if(!is.list(obj) && !is.vector(obj) && !is.array(obj)) {
		if(!true.only) r[[f]] <- NA
		next
	    }
	}
	if(any(f == c("is.nan", "is.finite", "is.infinite"))) {
	    if(!is.atomic(obj)) {
	    	if(!true.only) r[[f]] <- NA
	    	next
	    }
	}
	if(debug) cat(f,"")
	fn <- get(f)
	rr <- if(is.primitive(fn) || length(formals(fn))>0)  fn(obj) else fn()
	if(!is.logical(rr)) cat("f=",f," --- rr	 is NOT logical	 = ",rr,"\n")
	##if(1!=length(rr))   cat("f=",f," --- rr NOT of length 1; = ",rr,"\n")
	if(true.only && length(rr)==1 && !is.na(rr) && rr) r <- c(r, f)
	else if(!true.only) r[[f]] <- rr
    }
    if(debug)cat("\n")
    if(is.list(r)) structure(r, class = "isList") else r
}

print.isList <- function(x, ..., verbose = getOption("verbose"))
{
    ## Purpose:	 print METHOD  for `isList' objects
    ## ------------------------------------------------
    ## Author: Martin Maechler, Date: 12 Mar 1997
    if(is.list(x)) {
        if(verbose) cat("print.isList(): list case (length=",length(x),")\n")
	nm <- format(names(x))
	rr <- lapply(x, stats::symnum, na = "NA")
	for(i in seq_along(x)) cat(nm[i],":",rr[[i]],"\n", ...)
    } else NextMethod("print", ...)
}


is.ALL(NULL)
##fails: is.ALL(NULL, not.using = c("is.single", "is.loaded"))
is.ALL(NULL,   true.only = TRUE)
all.equal(NULL, pairlist())
## list() != NULL == pairlist() :
is.ALL(list(), true.only = TRUE)

(pl <- is.ALL(pairlist(1,    list(3,"A")), true.only = TRUE))
(ll <- is.ALL(    list(1,pairlist(3,"A")), true.only = TRUE))
all.equal(pl[pl != "is.pairlist"],
          ll[ll != "is.vector"])## TRUE

is.ALL(1:5)
is.ALL(array(1:24, 2:4))
is.ALL(1 + 3)
e13 <- expression(1 + 3)
is.ALL(e13)
is.ALL(substitute(expression(a + 3), list(a=1)), true.only = TRUE)
is.ALL(y ~ x) #--> NA	 for is.na & is.finite

is0 <- is.ALL(numeric(0))
is0.ok <- 1 == (lis0 <- sapply(is0, length))
is0[!is0.ok]
is0 <- unlist(is0)
is0
ispi <- unlist(is.ALL(pi))
all(ispi[is0.ok] == is0)

is.ALL(numeric(0), true=TRUE)
is.ALL(array(1,1:3), true=TRUE)
is.ALL(cbind(1:3), true=TRUE)

is.ALL(structure(1:7, names = paste("a",1:7,sep="")))
is.ALL(structure(1:7, names = paste("a",1:7,sep="")), true.only = TRUE)

x <- 1:20 ; y <- 5 + 6*x + rnorm(20)
lm.xy <- lm(y ~ x)
is.ALL(lm.xy)
is.ALL(structure(1:7, names = paste("a",1:7,sep="")))
is.ALL(structure(1:7, names = paste("a",1:7,sep="")), true.only = TRUE)
#  Copyright (C) 1997-2005 The R Core Team

## Adaptive integration:	 Venables and Ripley pp. 105-110
## This is the basic integrator.

area <- function(f, a, b, ..., fa = f(a, ...), fb = f(b, ...), limit
		 = 10, eps = 1.e-5)
{
    h <- b - a
    d <- (a + b)/2
    fd <- f(d, ...)
    a1 <- ((fa + fb) * h)/2
    a2 <- ((fa + 4 * fd + fb) * h)/6
    if(abs(a1 - a2) < eps)
	return(a2)
    if(limit == 0) {
	warning(paste("iteration limit reached near x = ",
		      d))
	return(a2)
    }
    area(f, a, d, ..., fa = fa, fb = fd, limit = limit - 1,
	 eps = eps) + area(f, d, b, ..., fa = fd, fb =
	 fb, limit = limit - 1, eps = eps)
}


## The function to be integrated

fbeta <- function(x, alpha, beta)
{
    x^(alpha - 1) * (1 - x)^(beta - 1)
}


## Compute the approximate integral, the exact integral and the error

b0 <- area(fbeta, 0, 1, alpha=3.5, beta=1.5)
b1 <- exp(lgamma(3.5) + lgamma(1.5) - lgamma(5))
c(b0, b1, b0-b1)


## Modify the function so that it records where it was evaluated

fbeta.tmp <- function (x, alpha, beta)
{
    val <<- c(val, x)
    x^(alpha - 1) * (1 - x)^(beta - 1)
}


## Recompute and plot the evaluation points.

val <- NULL
b0 <- area(fbeta.tmp, 0, 1, alpha=3.5, beta=1.5)
plot(val, fbeta(val, 3.5, 1.5), pch=0)


## Better programming style -- renaming the function will have no effect.
## The use of "Recall" as in V+R is VERY black magic.  You can get the
## same effect transparently by supplying a wrapper function.
## This is the approved Abelson+Sussman method.

area <- function(f, a, b, ..., limit=10, eps=1e-5) {
    area2 <- function(f, a, b, ..., fa = f(a, ...), fb = f(b, ...),
		      limit = limit, eps = eps) {
	h <- b - a
	d <- (a + b)/2
	fd <- f(d, ...)
	a1 <- ((fa + fb) * h)/2
	a2 <- ((fa + 4 * fd + fb) * h)/6
	if(abs(a1 - a2) < eps)
	    return(a2)
	if(limit == 0) {
	    warning(paste("iteration limit reached near x =", d))
	    return(a2)
	}
	area2(f, a, d, ..., fa = fa, fb = fd, limit = limit - 1,
	      eps = eps) + area2(f, d, b, ..., fa = fd, fb =
	      fb, limit = limit - 1, eps = eps)
    }
    area2(f, a, b, ..., limit=limit, eps=eps)
}

## Here is a little example which shows a fundamental difference between
## R and S.  It is a little example from Abelson and Sussman which models
## the way in which bank accounts work.	It shows how R functions can
## encapsulate state information.
##
## When invoked, "open.account" defines and returns three functions
## in a list.  Because the variable "total" exists in the environment
## where these functions are defined they have access to its value.
## This is even true when "open.account" has returned.  The only way
## to access the value of "total" is through the accessor functions
## withdraw, deposit and balance.  Separate accounts maintain their
## own balances.
##
## This is a very nifty way of creating "closures" and a little thought
## will show you that there are many ways of using this in statistics.

#  Copyright (C) 1997-8 The R Core Team

open.account <- function(total) {

    list(
	 deposit = function(amount) {
	     if(amount <= 0)
		 stop("Deposits must be positive!\n")
	     total <<- total + amount
	     cat(amount,"deposited. Your balance is", total, "\n\n")
	 },
	 withdraw = function(amount) {
	     if(amount > total)
		 stop("You don't have that much money!\n")
	     total <<- total - amount
	     cat(amount,"withdrawn.  Your balance is", total, "\n\n")
	 },
	 balance = function() {
	     cat("Your balance is", total, "\n\n")
	 }
	 )
}

ross <- open.account(100)
robert <- open.account(200)

ross$withdraw(30)
ross$balance()
robert$balance()

ross$deposit(50)
ross$balance()
try(ross$withdraw(500)) # no way..
