#### Return the object's value of the Akaike Information Criterion
#### (or "An Inf.. Crit..")

AIC <- function(object, ..., k = 2) UseMethod("AIC")

## AIC for logLik objects
AIC.logLik <- function(object, ..., k = 2)
    -2 * c(object) + k * attr(object, "df")

AIC.default <- function(object, ..., k = 2)
{
    ## AIC for various fitted objects --- any for which there's a logLik() method:

    if(length(list(...))) {# several objects: produce data.frame
	object <- list(object, ...)
	val <- lapply(object, logLik)
	val <- as.data.frame(t(sapply(val,
				      function(el)
				      c(attr(el, "df"), AIC(el, k = k)))))
	names(val) <- c("df", "AIC")
        Call <- match.call()
        Call$k <- NULL
	row.names(val) <- as.character(Call[-1])
	val
    } else AIC(logLik(object), k = k)
}
gammaCody <- function(x) .Internal(gammaCody(x))

besselI <- function(x, nu, expon.scaled = FALSE)
{
    .Internal(besselI(x,nu, 1+ as.logical(expon.scaled)))
}
besselK <- function(x, nu, expon.scaled = FALSE)
{
    .Internal(besselK(x,nu, 1+ as.logical(expon.scaled)))
}
besselJ <- function(x, nu) .Internal(besselJ(x,nu))
besselY <- function(x, nu) .Internal(besselY(x,nu))
C <- function(object, contr, how.many, ...)
{
    if(!nlevels(object)) stop("object not interpretable as a factor")
    if(!missing(contr) && is.name(Xcontr <- substitute(contr)))
	contr <- switch(as.character(Xcontr),
			poly =	"contr.poly",
			helmert = "contr.helmert",
			sum = "contr.sum",
			treatment = "contr.treatment",
			contr
			)
    if(missing(contr)) {
	oc <- getOption("contrasts")
	contr <-
	    if(length(oc) < 2) # should not happen
		if(is.ordered(object)) contr.poly else contr.treatment
	    else oc[1 + is.ordered(object)]
    }
    if(missing(how.many) && !length(list(...)))
	contrasts(object) <- contr
    else {
	if(is.character(contr)) contr <- get(contr, mode = "function")
	if(is.function(contr)) contr <- contr(nlevels(object), ...)
	contrasts(object, how.many) <- contr
    }
    object
}
.Defunct <- function() {
    stop(paste(sQuote(as.character(sys.call(sys.parent())[[1]])),
	       " is defunct.\n",
	       "See ?Defunct.",
	       sep = ""))
}

Version <- function() .Defunct()
provide <- function(package) .Defunct()

## <entry>
## Deprecated in 1.2.0
## Defunct in 1.3.0
getenv <- function(...) .Defunct()
## </entry>

## <entry>
## Deprecated in 1.2.3
## Defunct in 1.3.0
## Removed in 1.4.0: conflicts with lattice
#dotplot <- function(...) .Defunct()
#stripplot <- function(...) .Defunct()
## </entry>

## <entry>
## Deprecated in 1.3.0
## Defunct in 1.4.0
read.table.url <- function(...) .Defunct()
scan.url <- function(...) .Defunct()
source.url <- function(...) .Defunct()
httpclient <- function(...) .Defunct()
parse.dcf <- function(...) .Defunct()
## </entry>

## <entry>
## Deprecated in 1.4.0
## Defunct in 1.5.0
.Alias <- function(...) .Defunct()
reshapeLong <- function(...) .Defunct()
reshapeWide <- function(...) .Defunct()
## </entry>
## <entry>

## Deprecated in 1.5.0
## Defunct in 1.6.0
piechart <- function(...) .Defunct()
## </entry>

## Deprecated in 1.6.0
## Defunct in 1.7.0
machine <- function(...) .Defunct()
Machine <- function(...) .Defunct()
Platform <- function(...) .Defunct()
restart <- function(...) .Defunct()
## </entry>

## Deprecated in 1.7.0
## Defunct in 1.8.0
printNoClass <- function(...) .Defunct()
## </entry>
###----- NOTE:	../man/Deprecated.Rd   must be synchronized with this!
###		--------------------
.Deprecated <- function(new) {
    warning(paste(sQuote(as.character(sys.call(sys.parent())[[1]])),
		  " is deprecated.\n",
		  if (!missing(new))
		  paste("Use", sQuote(new), "instead.\n"),
		  "See ?Deprecated.",
		  sep = ""),
            call. = FALSE)
}

## consider keeping one (commented) entry here, for easier additions
## <entry>
## Deprecated in 1.8.0
## when it is removed, remove also from stoplists in
## methods (base/R/objects.R) and tools/R/Utils.R
print.coefmat <-
    function(x, digits=max(3, getOption("digits") - 2),
             signif.stars = getOption("show.signif.stars"),
             dig.tst = max(1, min(5, digits - 1)),
             cs.ind = 1:k, tst.ind = k + 1, zap.ind = integer(0),
             P.values = NULL,
             has.Pvalue = nc >= 4 && substr(colnames(x)[nc],1,3) == "Pr(",
             eps.Pvalue = .Machine$double.eps,
             na.print = "", ...)
{
    .Deprecated("printCoefmat")
    Call <- match.call(expand.dots = TRUE)
    if(missing(na.print)) Call$na.print <- ""
    Call[[1]] <- as.name("printCoefmat")
    eval.parent(Call)
}
## </entry>

## <entry>
## Deprecated in 1.8.0
codes <- function(x, ...) UseMethod("codes")

codes.factor <- function(x, ...)
{
    ## This is the S-plus semantics.
    ## The deeper meaning? Search me...
    .Deprecated("unclass")
    rank(levels(x))[x]
}

codes.ordered <- function(x, ...)
{
    .Deprecated("unclass")
    as.integer(x)
}

"codes<-" <- function(x, ..., value)
{
    .Deprecated()
    if ( length(value) == 1 )
	value <- rep.int(value, length(x))
    else if ( length(x) != length(value) )
	stop("Length mismatch in \"codes<-\"")
    ## S-plus again...
    if ( !is.ordered(x) ) value <- order(levels(x))[value]
    attributes(value) <- attributes(x)
    value
}
## </entry>

## <entry>
## Deprecated in 1.8.0: unused since 1.2.0
anovalist.lm <- function (object, ..., test = NULL)
{
    .Deprecated("anova.lmlist")
    objects <- list(object, ...)
    responses <- as.character(lapply(objects,
				     function(x) as.character(x$terms[[2]])))
    sameresp <- responses == responses[1]
    if (!all(sameresp)) {
	objects <- objects[sameresp]
	warning("Models with response ", deparse(responses[!sameresp]),
                " removed because response differs from ", "model 1")
    }
    ## calculate the number of models
    nmodels <- length(objects)
    if (nmodels == 1)
	return(anova.lm(object))

    models <- as.character(lapply(objects, function(x) x$terms))

    ## extract statistics
    df.r <- unlist(lapply(objects, df.residual))
    ss.r <- unlist(lapply(objects, deviance))
    df <- c(NA, -diff(df.r))
    ss <- c(NA, -diff(ss.r))
    ms <- ss/df
    f <- p <- rep.int(NA, nmodels)
    for(i in 2:nmodels) {
	if(df[i] > 0) {
	    f[i] <- ms[i]/(ss.r[i]/df.r[i])
	    p[i] <- pf(f[i], df[i], df.r[i], lower.tail = FALSE)
	}
	else if(df[i] < 0) {
	    f[i] <- ms[i]/(ss.r[i-1]/df.r[i-1])
	    p[i] <- pf(f[i], -df[i], df.r[i-1], lower.tail = FALSE)
	}
	else { # df[i] == 0
	    ss[i] <- 0
	}
    }
    table <- data.frame(df.r,ss.r,df,ss,f,p)
    dimnames(table) <- list(1:nmodels, c("Res.Df", "Res.Sum Sq", "Df",
					 "Sum Sq", "F value", "Pr(>F)"))
    ## construct table and title
    title <- "Analysis of Variance Table\n"
    topnote <- paste("Model ", format(1:nmodels),": ",
		     models, sep="", collapse="\n")

    ## calculate test statistic if needed
    structure(table, heading = c(title, topnote),
	      class= c("anova", "data.frame"))# was "tabular"
}
## </entry>

## <entry>
## Deprecated in 1.8.0
lm.fit.null <- function (x, y, method = "qr", tol = 1e-07, ...)
{
    .Deprecated("lm.fit")
    list(coefficients = numeric(0), residuals = y, fitted.values = 0 *
         y, weights = NULL, rank = 0, df.residual = length(y))
}

lm.wfit.null <- function (x, y, w, method = "qr", tol = 1e-07, ...)
{
    .Deprecated("lm.wfit")
    list(coefficients = numeric(0), residuals = y, fitted.values = 0 *
         y, weights = w, rank = 0, df.residual = length(y))
}
glm.fit.null <-
    function (x, y, weights = rep(1, nobs), start = NULL,
              etastart = NULL, mustart = NULL, offset = rep(0, nobs),
              family = gaussian(), control = glm.control(), intercept = FALSE)
{
    .Deprecated("glm.fit")
    if(intercept) stop("null models have no intercept")
    ynames <- names(y)
    conv <- TRUE
    nobs <- NROW(y)
    nvars <- NCOL(x)
    ## define weights and offset if needed
    ## get family functions
    if (is.null(weights))
	weights <- rep.int(1, nobs)
    if (is.null(offset))
	offset <- rep.int(0, nobs)
    variance <- family$variance
    dev.resids <- family$dev.resids
    linkinv <- family$linkinv
    mu.eta <- family$mu.eta
    valideta <- family$valideta
    if (is.null(valideta))
	valideta <- function(eta) TRUE
    validmu <- family$validmu
    if (is.null(validmu))
	validmu <- function(mu) TRUE
	## next line may change y and weights, and set n.
    eval(family$initialize)
    if (NCOL(y) > 1)
	stop("y must be univariate unless binomial")
    eta <- rep.int(0, nobs)
    if (!valideta(eta + offset))
	stop("Invalid linear predictor values in empty model")
    mu <- linkinv(eta + offset)
    ## calculate initial deviance and coefficient
    if (!validmu(mu))
	stop("Invalid fitted means in empty model")
    dev <- sum(dev.resids(y, mu, weights))
    w <- ((weights * mu.eta(eta + offset)^2)/variance(mu))^0.5
    ##	residuals[good] <- z - eta
    residuals <- (y - mu)/mu.eta(eta + offset)
    ## name output
    names(residuals) <- ynames
    names(mu) <- ynames
    names(eta) <- ynames
    names(w) <- ynames
    names(weights) <- ynames
    names(y) <- ynames
    ## calculate null deviance
    wtdmu <- linkinv(offset)
    nulldev <- sum(dev.resids(y, wtdmu, weights))
    ## calculate df
    resdf <- nulldf <- n.ok <- nobs - sum(weights==0)
    aic.model <- family$aic(y, n, mu, weights, dev)
    return(list(coefficients = numeric(0), residuals = residuals,
		fitted.values = mu, rank = 0, family = family,
		linear.predictors = eta + offset, deviance = dev,
		aic = aic.model,
		null.deviance = nulldev, iter = 0, weights = w^2,
		prior.weights = weights, df.residual = resdf,
		df.null = nulldf, y = y, converged = conv, boundary = FALSE))
}

print.atomic <- function(x, quote = TRUE, ...)
{
    .Deprecated("print.default")
    print.default(x, quote=quote)
}
## </entry>
La.eigen <- function (x, symmetric, only.values = FALSE,
                      method = c("dsyevr", "dsyev"))
{
    if(!is.numeric(x) && !is.complex(x))
	stop("argument to La.eigen must be numeric or complex")
    method <- match.arg(method)
    x <- as.matrix(x)
    if (nrow(x) != ncol(x)) stop("non-square matrix in La.eigen")
    if (nrow(x) == 0) stop("0 x 0 matrix in La.eigen")
    complex.x <- is.complex(x)
    if (missing(symmetric)) {
        tx <- if(complex.x) Conj(t(x)) else t(x)
        test <- all.equal.numeric(x, tx, 100 * .Machine$double.eps)
        symmetric <- is.logical(test) && test
    }
    if (is.numeric(x)) storage.mode(x) <- "double"
    if (symmetric) {
        z <- if(!complex.x)
            .Call("La_rs", x, only.values, method, PACKAGE = "base")
        else
            .Call("La_rs_cmplx", x, only.values, PACKAGE = "base")
        ord <- rev(seq(along = z$values))
    } else {
        z <- if(!complex.x)
            .Call("La_rg", x, only.values, PACKAGE = "base")
        else
            .Call("La_rg_cmplx", x, only.values, PACKAGE = "base")
        ord <- sort.list(Mod(z$values), decreasing = TRUE)
    }
    list(values = z$values[ord],
         vectors = if (!only.values) z$vectors[, ord, drop = FALSE])
}

La.svd <- function(x, nu = min(n, p), nv = min(n, p),
                   method = c("dgesdd", "dgesvd"))
{
    if(!is.numeric(x) && !is.complex(x))
	stop("argument to La.svd must be numeric or complex")
    method <- match.arg(method)
    if(is.complex(x) && method == "dgesdd") {
        method <- "dgesvd"
    }
    x <- as.matrix(x)
    if (is.numeric(x)) storage.mode(x) <- "double"
    n <- nrow(x)
    p <- ncol(x)
    if(!n || !p) stop("0 extent dimensions")

    if(method == "dgesvd") {
        if(nu == 0) {
            jobu <- 'N'
            u <- matrix(0, 1, 1)  # dim is checked
        }
        else if(nu == n) {
            jobu <- ifelse(n > p, 'A', 'S')
            u <- matrix(0, n, n)
        }
        else if(nu == p) {
            jobu <- ifelse(n > p, 'S', 'A')
            u <- matrix(0, n, p)
        }
        else
            stop("nu must be 0, nrow(x) or ncol(x)")

        if (nv == 0) {
            jobv <- 'N'
            v <- matrix(0, 1, 1) # dim is checked
        }
        else if (nv == n) {
            jobv <- ifelse(n > p, 'A', 'S')
            v <- matrix(0, min(n, p), p)
        }
        else if (nv == p) {
            jobv <- ifelse(n > p, 'S', 'A')
            v <- matrix(0, p, p)
        }
        else
            stop("nv must be 0, nrow(x) or ncol(x)")
    } else {
        if(nu > 0 || nv > 0) {
            np <- min(n, p)
            if(nu <= np && nv <= np) {
                jobu <- 'S'
                u <- matrix(0, n, np)
                v <- matrix(0, np, p)
            } else {
                jobu <- 'A'
                u <- matrix(0, n, n)
                v <- matrix(0, p, p)
            }
        } else {
            jobu <- 'N'
            # these dimensions _are_ checked, but unused
            u <- matrix(0, 1, 1)
            v <- matrix(0, 1, 1)
        }
        jobv <- ''
        res <- .Call("La_svd", jobu, jobv, x, double(min(n,p)), u, v,
                     method, PACKAGE = "base")
        res <- res[c("d", if(nu) "u", if(nv) "vt")]
        if(nu) res$u <- res$u[, 1:min(n, nu), drop = FALSE]
        if(nv) res$vt <- res$vt[1:min(p, nv), , drop = FALSE]
        return(res)
    }

    if(is.complex(x)) {
        u[] <- as.complex(u)
        v[] <- as.complex(v)
        res <- .Call("La_svd_cmplx", jobu, jobv, x, double(min(n, p)), u, v,
                     PACKAGE = "base")
    } else
        res <- .Call("La_svd", jobu, jobv, x, double(min(n, p)), u, v,
                     method, PACKAGE = "base")
    res[c("d", if(nu) "u", if(nv) "vt")]
}

La.chol <- function(x) .Call("La_chol", as.matrix(x), PACKAGE = "base")

La.chol2inv <- function(x, size = ncol(x)) {
    x <- as.matrix(x) # do it this way so ncol(x) is defined
    .Call("La_chol2inv", x, size, PACKAGE = "base")
}
##vector <- function(mode = "logical", length = 0).Internal(vector(mode,length))

geterrmessage <- function() .Internal(geterrmessage())

try <- function(expr, silent = FALSE)
{
    if (! exists("first", inherits = FALSE)) {
        first <- FALSE
        # turn on the restart bit of the current context, push an
        # error handler on the condition handler stack, and push
        # a tryRestart restart on the restart stack
        .Internal(.addTryHandlers())
        if (silent) {
            op <- options("show.error.messages")
            on.exit(options(op))
            options(show.error.messages = FALSE)
        }
        expr
    }
    else invisible(structure(.Internal(geterrmessage()), class = "try-error"))
}


comment <- function(x).Internal(comment(x))
"comment<-" <- function(x,value).Internal("comment<-"(x,value))

round <- function(x, digits = 0).Internal(round(x,digits))
signif <- function(x, digits = 6).Internal(signif(x,digits))
logb <- log <- function(x, base=exp(1))
    if(missing(base)).Internal(log(x)) else .Internal(log(x,base))
log1p <- function(x).Internal(log1p(x))
expm1 <- function(x).Internal(expm1(x))

atan2 <- function(y, x).Internal(atan2(y, x))

beta <- function(a, b).Internal( beta(a, b))
lbeta <- function(a, b).Internal(lbeta(a, b))

gamma <- function(x).Internal( gamma(x))
lgamma <- function(x).Internal(lgamma(x))
digamma <- function(x).Internal(   digamma(x))
trigamma <- function(x).Internal(  trigamma(x))
tetragamma <- function(x).Internal(tetragamma(x))
pentagamma <- function(x).Internal(pentagamma(x))

choose <- function(n,k).Internal(choose(n,k))
lchoose <- function(n,k).Internal(lchoose(n,k))

##-- 2nd part --
D <- function(expr, name) .Internal(D(expr, name))

# Machine <- function().Internal(Machine())
R.Version <- function().Internal(Version())
commandArgs <- function() .Internal(commandArgs())

args <- function(name).Internal(args(name))

##=== Problems here [[	attr(f, "class") <- "factor"  fails in factor(..)  ]]:
##- attr <- function(x, which).Internal(attr(x, which))
##- "attr<-" <- function(x, which, value).Internal("attr<-"(x, which, value))

cbind <- function(..., deparse.level=1) {
    if(deparse.level != 1) .NotYetUsed("deparse.level != 1")
    .Internal(cbind(...))
}
rbind <- function(..., deparse.level=1) {
    if(deparse.level != 1) .NotYetUsed("deparse.level != 1")
    .Internal(rbind(...))
}

dataentry <- function (data, modes) {
    if(!is.list(data) || !length(data) || !all(sapply(data, is.vector)))
        stop("invalid data argument")
    if(!is.list(modes) ||
       (length(modes) && !all(sapply(modes, is.character))))
        stop("invalid modes argument")
    .Internal(dataentry(data, modes))
}

deparse <-
    function(expr, width.cutoff = 60,
	     backtick = mode(expr) %in% c("call","expression","("))
	.Internal(deparse(expr, width.cutoff, backtick))


do.call <- function(what,args).Internal(do.call(what,args))
drop <- function(x).Internal(drop(x))
format.info <- function(x, nsmall=0).Internal(format.info(x, nsmall))
gc <- function(verbose = getOption("verbose"))
{
    res <-.Internal(gc(verbose))/c(1, 1, 10, 10, 1, 1, rep(10,4))
    res <- matrix(res, 2, 5,
                  dimnames = list(c("Ncells","Vcells"),
                  c("used", "(Mb)", "gc trigger", "(Mb)", "limit (Mb)")))
    if(all(is.na(res[, 5]))) res[, -5] else res
}
gcinfo <- function(verbose).Internal(gcinfo(verbose))
gctorture <- function(on=TRUE)invisible(.Internal(gctorture(on)))

is.unsorted <- function(x, na.rm = FALSE) {
    if(is.null(x)) return(FALSE)
    if(!is.atomic(x) ||
       (!na.rm && any(is.na(x))))
	return(NA)
    ## else
    if(na.rm && any(ii <- is.na(x)))
	x <- x[!ii]
    .Internal(is.unsorted(x))
}

mem.limits <- function(nsize=NA, vsize=NA)
{
    structure(.Internal(mem.limits(as.integer(nsize), as.integer(vsize))),
              names=c("nsize", "vsize"))
}

nchar <- function(x).Internal(nchar(x))

plot.window <- function(xlim, ylim, log = "", asp = NA, ...)
    .Internal(plot.window(xlim, ylim, log, asp, ...))
polyroot <- function(z).Internal(polyroot(z))

readline <- function(prompt="").Internal(readline(prompt))
search <- function().Internal(search())
searchpaths <- function()
{
    s <- search()
    paths <-
        lapply(1:length(s), function(i) attr(as.environment(i), "path"))
    paths[[length(s)]] <- system.file()
    m <- grep("^package:", s)
    if(length(m)) paths[-m] <- as.list(s[-m])
    unlist(paths)
}

sprintf <- function(fmt, ...) .Internal(sprintf(fmt, ...))

##-- DANGER ! ---   substitute(list(...))  inside functions !!!
##substitute <- function(expr, env=NULL).Internal(substitute(expr, env))

t.default <- function(x).Internal(t.default(x))
typeof <- function(x).Internal(typeof(x))


memory.profile <- function() .Internal(memory.profile())

capabilities <- function(what = NULL)
{
    z  <- .Internal(capabilities())
    if(is.null(what)) return(z)
    nm <- names(z)
    i <- pmatch(what, nm)
    if(is.na(i)) logical(0) else z[i]
}

## base has no S4 generics
.noGenerics <- TRUE
## Random Number Generator

## The available kinds are in
## ../../../include/Random.h  and ../../../main/RNG.c [RNG_Table]
##
RNGkind <- function(kind = NULL, normal.kind = NULL)
{
    kinds <- c("Wichmann-Hill", "Marsaglia-Multicarry", "Super-Duper",
               "Mersenne-Twister", "Knuth-TAOCP", "user-supplied",
               "Knuth-TAOCP-2002", "default")
    n.kinds <- c("Buggy Kinderman-Ramage", "Ahrens-Dieter", "Box-Muller",
                 "user-supplied", "Inversion", "Kinderman-Ramage", 
		 "default")
    do.set <- length(kind) > 0
    if(do.set) {
	if(!is.character(kind) || length(kind) > 1)
	    stop("'kind' must be a character string of length 1 (RNG to be used).")
	if(is.na(i.knd <- pmatch(kind, kinds) - 1))
	    stop(paste("'",kind,"' is not a valid abbrevation of an RNG",
		       sep=""))
        if(i.knd == length(kinds) - 1) i.knd <- -1
    } else i.knd <- NULL

    if(!is.null(normal.kind)) {
	if(!is.character(normal.kind) || length(normal.kind) > 1)
	    stop("'normal.kind' must be a character string of length 1.")
	if (normal.kind == "Buggy Kinderman-Ramage")
		warning("Buggy version of Kinderman-Ramage generator used.")
        normal.kind <- pmatch(normal.kind, n.kinds) - 1
        if(is.na(normal.kind))
 	    stop(paste("'", normal.kind,"' is not a valid choice", sep=""))
        if(normal.kind == length(n.kinds) - 1) normal.kind <- -1
    }
    r <- 1 + .Internal(RNGkind(i.knd, normal.kind))
    r <- c(kinds[r[1]], n.kinds[r[2]])
    if(do.set || !is.null(normal.kind)) invisible(r) else r
}

set.seed <- function(seed, kind = NULL)
{
    kinds <- c("Wichmann-Hill", "Marsaglia-Multicarry", "Super-Duper",
               "Mersenne-Twister", "Knuth-TAOCP", "user-supplied",
               "Knuth-TAOCP-2002", "default")
    if(length(kind) > 0) {
	if(!is.character(kind) || length(kind) > 1)
	    stop("'kind' must be a character string of length 1 (RNG to be used).")
	if(is.na(i.knd <- pmatch(kind, kinds) - 1))
	    stop(paste("'",kind,"' is not a valid abbrevation of an RNG",
		       sep=""))
        if(i.knd == length(kinds) - 1) i.knd <- -1
    } else i.knd <- NULL

    invisible(.Internal(set.seed(seed, i.knd)))
}

# Compatibility function to set RNGkind as in a given R version

RNGversion <- function(vstr) 
{
    vnum <- as.numeric(strsplit(vstr,"\\.")[[1]])
    if (length(vnum) < 2) 
	stop("Malformed version string")
    if (vnum[1] == 0 && vnum[2] < 99) 
        RNGkind("Wichmann-Hill", "Buggy Kinderman-Ramage")
    else if (vnum[1] == 0 || vnum[1] == 1 && vnum[2] <= 6) 
	RNGkind("Marsaglia-Multicarry", "Buggy Kinderman-Ramage")
    else
	RNGkind("Mersenne-Twister", "Inversion")
}
.Script <- function(interpreter, script, args, ...)
{
    if(.Platform$OS.type == "windows") {
        cmd <- paste(file.path(R.home(), "bin", "Rcmd"),
                     file.path("..", "share", interpreter, script),
                     args)
        system(cmd, invisible = TRUE)
    }
    else
        system(paste(file.path(R.home(), "bin", "Rcmd"),
                     interpreter,
                     file.path(R.home(), "share", interpreter, script),
                     args),
               ...)
}
###
###               Tukey multiple comparisons for R
###
### Copyright 2000-2001  Douglas M. Bates <bates@stat.wisc.edu>
### Modified for base R 2002 B. D. Ripley
###
### This file is made available under the terms of the GNU General
### Public License, version 2, or at your option, any later version,
### incorporated herein by reference.
###
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
###
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA

TukeyHSD <-
    function(x, which, ordered = FALSE, conf.level = 0.95, ...)
    UseMethod("TukeyHSD")

TukeyHSD.aov <-
    function(x, which = seq(along = tabs), ordered = FALSE,
             conf.level = 0.95, ...)
{
    mm <- model.tables(x, "means")
    tabs <- mm$tables[-1]
    tabs <- tabs[which]
    nn <- mm$n[which]
    out <- vector("list", length(tabs))
    names(out) <- names(tabs)
    MSE <- sum(resid(x)^2)/x$df.residual
    for (nm in names(tabs)) {
        means <- as.vector(tabs[[nm]])
        nms <- names(tabs[[nm]])
        n <- nn[[nm]]
        ## expand n to the correct length if necessary
        if (length(n) < length(means)) n <- rep.int(n, length(means))
        if (as.logical(ordered)) {
            ord <- order(means)
            means <- means[ord]
            n <- n[ord]
            if (!is.null(nms)) nms <- nms[ord]
        }
        center <- outer(means, means, "-")
        keep <- lower.tri(center)
        center <- center[keep]
        width <- qtukey(conf.level, length(means), x$df.residual) *
            sqrt((MSE/2) * outer(1/n, 1/n, "+"))[keep]
        dnames <- list(NULL, c("diff", "lwr", "upr"))
        if (!is.null(nms)) dnames[[1]] <- outer(nms, nms, paste, sep = "-")[keep]
        out[[nm]] <- array(c(center, center - width, center + width),
                           c(length(width), 3), dnames)
    }
    class(out) <- c("multicomp", "TukeyHSD")
    attr(out, "orig.call") <- x$call
    attr(out, "conf.level") <- conf.level
    attr(out, "ordered") <- ordered
    out
}

print.TukeyHSD <- function(x, ...)
{
    cat("  Tukey multiple comparisons of means\n")
    cat("    ", format(100*attr(x, "conf.level"), 2),
        "% family-wise confidence level\n", sep="")
    if (attr(x, "ordered"))
        cat("    factor levels have been ordered\n")
    cat("\nFit: ", deparse(attr(x, "orig.call"), 500), "\n\n", sep="")
    attr(x, "orig.call") <- attr(x, "conf.level") <- attr(x, "ordered") <- NULL
    print.default(unclass(x), ...)
}

plot.TukeyHSD <- function (x, ...)
{
    for (i in seq(along = x)) {
        xi <- x[[i]]
        yvals <- nrow(xi):1
        plot(c(xi[, "lwr"], xi[, "upr"]), rep.int(yvals, 2), type = "n",
             axes = FALSE, xlab = "", ylab = "", ...)
        axis(1, ...)
        axis(2, at = nrow(xi):1, labels = dimnames(xi)[[1]],
             srt = 0, ...)
        abline(h = yvals, lty = 1, lwd = 0, col = "lightgray")
        abline(v = 0, lty = 2, lwd = 0, ...)
        segments(xi[, "lwr"], yvals, xi[, "upr"], yvals, ...)
        segments(as.vector(xi), rep.int(yvals - 0.1, 3), as.vector(xi),
                 rep.int(yvals + 0.1, 3), ...)
        title(main = paste(format(100 * attr(x, "conf.level"),
              2), "% family-wise confidence level\n", sep = ""),
              xlab = paste("Differences in mean levels of", names(x)[i]))
        box()
    }
}
abline <-
    function(a=NULL, b=NULL, h=NULL, v=NULL, reg=NULL, coef=NULL,
	     untf=FALSE, col=par("col"), lty=par("lty"), lwd=NULL, ...)
{
    if(!is.null(reg)) a <- reg
    if(!is.null(a) && is.list(a)) {
	temp <- as.vector(coefficients(a))
	if(length(temp) == 1) {
	    a <- 0
	    b <- temp
	}
	else {
	    a <- temp[1]
	    b <- temp[2]
	}
    }
    if(!is.null(coef)) {
	a <- coef[1]
	b <- coef[2]
    }
    .Internal(abline(a, b, h, v, untf, col, lty, lwd, ...))
    invisible()
}
add1 <- function(object, scope, ...) UseMethod("add1")

add1.default <- function(object, scope, scale = 0, test=c("none", "Chisq"),
			 k = 2, trace = FALSE, ...)
{
    if(missing(scope) || is.null(scope)) stop("no terms in scope")
    if(!is.character(scope))
	scope <- add.scope(object, update.formula(object, scope))
    if(!length(scope))
	stop("no terms in scope for adding to object")
#     newform <- update.formula(object,
#                               paste(". ~ . +", paste(scope, collapse="+")))
#     data <- model.frame(update(object, newform)) # remove NAs
#     object <- update(object, data = data)
    ns <- length(scope)
    ans <- matrix(nrow = ns + 1, ncol = 2)
    dimnames(ans) <- list(c("<none>", scope), c("df", "AIC"))
    ans[1, ] <- extractAIC(object, scale, k = k, ...)
    for(i in seq(ns)) {
	tt <- scope[i]
	if(trace > 1) cat("trying +", tt, "\n")
	nfit <- update(object, as.formula(paste("~ . +", tt)),
                       evaluate = FALSE)
        nfit <- eval.parent(nfit)
	ans[i+1, ] <- extractAIC(nfit, scale, k = k, ...)
    }
    dfs <- ans[,1] - ans[1,1]
    dfs[1] <- NA
    aod <- data.frame(Df = dfs, AIC = ans[,2])
    test <- match.arg(test)
    if(test == "Chisq") {
	dev <- ans[,2] - k*ans[, 1]
	dev <- dev[1] - dev; dev[1] <- NA
	nas <- !is.na(dev)
	P <- dev
	P[nas] <- pchisq(dev[nas], dfs[nas], lower.tail=FALSE)
	aod[, c("LRT", "Pr(Chi)")] <- list(dev, P)
    }
    head <- c("Single term additions", "\nModel:",
	      deparse(as.vector(formula(object))),
	      if(scale > 0) paste("\nscale: ", format(scale), "\n"))
    class(aod) <- c("anova", "data.frame")
    attr(aod, "heading") <- head
    aod
}

add1.lm <- function(object, scope, scale = 0, test=c("none", "Chisq", "F"),
		    x = NULL, k = 2,...)
{
    Fstat <- function(table, RSS, rdf) {
	dev <- table$"Sum of Sq"
	df <- table$Df
	rms <- (RSS - dev)/(rdf - df)
	Fs <- (dev/df)/rms
	Fs[df < .Machine$double.eps] <- NA
	P <- Fs
	nnas <- !is.na(Fs)
	P[nnas] <- pf(Fs[nnas], df[nnas], rdf - df[nnas], lower.tail=FALSE)
	list(Fs=Fs, P=P)
    }

    if(missing(scope) || is.null(scope)) stop("no terms in scope")
    if(!is.character(scope))
	scope <- add.scope(object, update.formula(object, scope))
    if(!length(scope))
	stop("no terms in scope for adding to object")
    oTerms <- attr(object$terms, "term.labels")
    int <- attr(object$terms, "intercept")
    ns <- length(scope)
    y <- object$residuals + predict(object)
    dfs <- numeric(ns+1)
    RSS <- numeric(ns+1)
    names(dfs) <- names(RSS) <- c("<none>", scope)
    dfs[1] <- object$rank
    RSS[1] <- deviance.lm(object)
    add.rhs <- paste(scope, collapse = "+")
    add.rhs <- eval(parse(text = paste("~ . +", add.rhs)))
    new.form <- update.formula(object, add.rhs)
    Terms <- terms(new.form)
    if(is.null(x)) {
	fc <- object$call
	fc$formula <- Terms
	fob <- list(call = fc)
	class(fob) <- oldClass(object)
	m <- model.frame(fob, xlev = object$xlevels)
	x <- model.matrix(Terms, m, contrasts = object$contrasts)
        oldn <- length(y)
        y <- model.response(m, "numeric")
        newn <- length(y)
        if(newn < oldn)
            warning(paste("using the", newn, "/", oldn ,
                          "rows from a combined fit"))
    }
    n <- nrow(x)
    Terms <- attr(Terms, "term.labels")
    asgn <- attr(x, "assign")
    ousex <- match(asgn, match(oTerms, Terms), 0) > 0
    if(int) ousex[1] <- TRUE
    iswt <- !is.null(wt <- object$weights)
    for(tt in scope) {
	usex <- match(asgn, match(tt, Terms), 0) > 0
	X <- x[, usex|ousex, drop = FALSE]
	z <- if(iswt) lm.wfit(X, y, wt) else lm.fit(X, y)
	dfs[tt] <- z$rank
	RSS[tt] <- deviance.lm(z)
    }
    if(scale > 0) aic <- RSS/scale - n + k*dfs
    else aic <- n * log(RSS/n) + k*dfs
    dfs <- dfs - dfs[1]
    dfs[1] <- NA
    aod <- data.frame(Df = dfs, "Sum of Sq" = c(NA, RSS[1] - RSS[-1]),
		      RSS = RSS, AIC = aic,
                      row.names = names(dfs), check.names = FALSE)
    if(scale > 0) names(aod) <- c("Df", "Sum of Sq", "RSS", "Cp")
    test <- match.arg(test)
    if(test == "Chisq") {
        dev <- aod$"Sum of Sq"
        if(scale == 0) {
            dev <- n * log(RSS/n)
            dev <- dev[1] - dev
            dev[1] <- NA
        } else dev <- dev/scale
        df <- aod$Df
        nas <- !is.na(df)
        dev[nas] <- pchisq(dev[nas], df[nas], lower.tail=FALSE)
        aod[, "Pr(Chi)"] <- dev
    } else if(test == "F") {
	rdf <- object$df.resid
	aod[, c("F value", "Pr(F)")] <- Fstat(aod, aod$RSS[1], rdf)
    }
    head <- c("Single term additions", "\nModel:",
	      deparse(as.vector(formula(object))),
	      if(scale > 0) paste("\nscale: ", format(scale), "\n"))
    class(aod) <- c("anova", "data.frame")
    attr(aod, "heading") <- head
    aod
}

add1.glm <- function(object, scope, scale = 0, test=c("none", "Chisq", "F"),
		     x = NULL, k = 2, ...)
{
    Fstat <- function(table, rdf) {
	dev <- table$Deviance
	df <- table$Df
	diff <- pmax(0, (dev[1] - dev)/df)
	Fs <- (diff/df)/(dev/(rdf-df))
	Fs[df < .Machine$double.eps] <- NA
	P <- Fs
	nnas <- !is.na(Fs)
	P[nnas] <- pf(Fs[nnas], df[nnas], rdf - df[nnas], lower.tail=FALSE)
	list(Fs=Fs, P=P)
    }
    if(!is.character(scope))
	scope <- add.scope(object, update.formula(object, scope))
    if(!length(scope))
	stop("no terms in scope for adding to object")
    oTerms <- attr(object$terms, "term.labels")
    int <- attr(object$terms, "intercept")
    ns <- length(scope)
    dfs <- dev <- numeric(ns+1)
    names(dfs) <- names(dev) <- c("<none>", scope)
    dfs[1] <- object$rank
    dev[1] <- object$deviance
    add.rhs <- paste(scope, collapse = "+")
    add.rhs <- eval(parse(text = paste("~ . +", add.rhs)))
    new.form <- update.formula(object, add.rhs)
    Terms <- terms(new.form)
    y <- object$y
    wt <- object$prior.weights
    if(is.null(x)) {
	fc <- object$call
	fc$formula <- Terms
	fob <- list(call = fc)
	class(fob) <- oldClass(object)
	m <- model.frame(fob, xlev = object$xlevels)
	x <- model.matrix(Terms, m, contrasts = object$contrasts)
        oldn <- length(y)
        y <- model.response(m, "numeric")
        ## binomial case has adjusted y.
        if(NCOL(y) == 2) y <- y[, 1]/(y[, 1] + y[,2])
        newn <- length(y)
        if(newn < oldn)
            warning(paste("using the", newn, "/", oldn ,
                          "rows from a combined fit"))
    }
    n <- nrow(x)
    if(is.null(wt)) wt <- rep.int(1, n)
    Terms <- attr(Terms, "term.labels")
    asgn <- attr(x, "assign")
    ousex <- match(asgn, match(oTerms, Terms), 0) > 0
    if(int) ousex[1] <- TRUE
    for(tt in scope) {
	usex <- match(asgn, match(tt, Terms), 0) > 0
	X <- x[, usex|ousex, drop = FALSE]
	z <-  glm.fit(X, y, wt, offset=object$offset,
		      family=object$family, control=object$control)
	dfs[tt] <- z$rank
	dev[tt] <- z$deviance
    }
    if (scale == 0)
	dispersion <- summary(object, dispersion = NULL)$dispersion
    else dispersion <- scale
    fam <- object$family$family
    if(fam == "gaussian") {
	if(scale > 0) loglik <- dev/scale - n
	else loglik <- n * log(dev/n)
    } else loglik <- dev/dispersion
    aic <- loglik + k * dfs
    aic <- aic + (extractAIC(object, k = k)[2] - aic[1])
    dfs <- dfs - dfs[1]
    dfs[1] <- NA
    aod <- data.frame(Df = dfs, Deviance = dev, AIC = aic,
		      row.names = names(dfs), check.names = FALSE)
    if(all(is.na(aic))) aod <- aod[, -3]
    test <- match.arg(test)
    if(test == "Chisq") {
        dev <- pmax(0, loglik[1] - loglik)
        dev[1] <- NA
        LRT <- if(dispersion == 1) "LRT" else "scaled dev."
        aod[, LRT] <- dev
        nas <- !is.na(dev)
        dev[nas] <- pchisq(dev[nas], aod$Df[nas], lower.tail=FALSE)
        aod[, "Pr(Chi)"] <- dev
    } else if(test == "F") {
        if(fam == "binomial" || fam == "poisson")
            warning(paste("F test assumes quasi", fam, " family", sep=""))
	rdf <- object$df.residual
	aod[, c("F value", "Pr(F)")] <- Fstat(aod, rdf)
    }
    head <- c("Single term additions", "\nModel:",
	      deparse(as.vector(formula(object))),
	      if(scale > 0) paste("\nscale: ", format(scale), "\n"))
    class(aod) <- c("anova", "data.frame")
    attr(aod, "heading") <- head
    aod
}

add1.mlm <- function(object, scope, ...)
    stop("no add1 method implemented for mlm models")

drop1 <- function(object, scope, ...) UseMethod("drop1")

drop1.default <- function(object, scope, scale = 0, test=c("none", "Chisq"),
			  k = 2, trace = FALSE, ...)
{
    tl <- attr(object$terms, "term.labels")
    if(missing(scope)) scope <- drop.scope(object)
    else {
	if(!is.character(scope))
	    scope <- attr(terms(update.formula(object, scope)), "term.labels")
	if(!all(match(scope, tl, FALSE)))
	    stop("scope is not a subset of term labels")
    }
#    data <- model.frame(object) # remove NAs
#    object <- update(object, data = data)
    ns <- length(scope)
    ans <- matrix(nrow = ns + 1, ncol = 2)
    dimnames(ans) <- list(c("<none>", scope), c("df", "AIC"))
    ans[1, ] <- extractAIC(object, scale, k = k, ...)
    for(i in seq(ns)) {
	tt <- scope[i]
	if(trace > 1) cat("trying -", tt, "\n")
	nfit <- update(object, as.formula(paste("~ . -", tt)),
                       evaluate = FALSE)
        nfit <- eval.parent(nfit)
	ans[i+1, ] <- extractAIC(nfit, scale, k = k, ...)
    }
    dfs <- ans[1,1] - ans[,1]
    dfs[1] <- NA
    aod <- data.frame(Df = dfs, AIC = ans[,2])
    test <- match.arg(test)
    if(test == "Chisq") {
        dev <- ans[, 2] - k*ans[, 1]
        dev <- dev - dev[1] ; dev[1] <- NA
        nas <- !is.na(dev)
        P <- dev
        P[nas] <- pchisq(dev[nas], dfs[nas], lower.tail = FALSE)
        aod[, c("LRT", "Pr(Chi)")] <- list(dev, P)
    }
    head <- c("Single term deletions", "\nModel:",
	      deparse(as.vector(formula(object))),
	      if(scale > 0) paste("\nscale: ", format(scale), "\n"))
    class(aod) <- c("anova", "data.frame")
    attr(aod, "heading") <- head
    aod
}

drop1.lm <- function(object, scope, scale = 0, all.cols = TRUE,
		     test=c("none", "Chisq", "F"), k = 2, ...)
{
    x <- model.matrix(object)
    iswt <- !is.null(wt <- object$weights)
    n <- nrow(x)
    asgn <- attr(x, "assign")
    tl <- attr(object$terms, "term.labels")
    if(missing(scope)) scope <- drop.scope(object)
    else {
	if(!is.character(scope))
	    scope <- attr(terms(update.formula(object, scope)), "term.labels")
	if(!all(match(scope, tl, FALSE)))
	    stop("scope is not a subset of term labels")
    }
    ndrop <- match(scope, tl)
    ns <- length(scope)
    rdf <- object$df.resid
    chisq <- deviance.lm(object)
    dfs <- numeric(ns)
    RSS <- numeric(ns)
    y <- object$residuals + predict(object)
    na.coef <- (1:length(object$coefficients))[!is.na(object$coefficients)]
    for(i in 1:ns) {
	ii <- seq(along=asgn)[asgn == ndrop[i]]
	if(all.cols) jj <- setdiff(seq(ncol(x)), ii)
	else jj <- setdiff(na.coef, ii)
	z <- if(iswt) lm.wfit(x[, jj, drop = FALSE], y, wt)
	else lm.fit(x[, jj, drop = FALSE], y)
	dfs[i] <- z$rank
	RSS[i] <- deviance.lm(z)
    }
    scope <- c("<none>", scope)
    dfs <- c(object$rank, dfs)
    RSS <- c(chisq, RSS)
    if(scale > 0) aic <- RSS/scale - n + k*dfs
    else aic <- n * log(RSS/n) + k*dfs
    dfs <- dfs[1] - dfs
    dfs[1] <- NA
    aod <- data.frame(Df = dfs, "Sum of Sq" = c(NA, RSS[-1] - RSS[1]),
		      RSS = RSS, AIC = aic,
                      row.names = scope, check.names = FALSE)
    if(scale > 0) names(aod) <- c("Df", "Sum of Sq", "RSS", "Cp")
    test <- match.arg(test)
    if(test == "Chisq") {
        dev <- aod$"Sum of Sq"
        if(scale == 0) {
            dev <- n * log(RSS/n)
            dev <- dev - dev[1]
            dev[1] <- NA
        } else dev <- dev/scale
        df <- aod$Df
        nas <- !is.na(df)
        dev[nas] <- pchisq(dev[nas], df[nas], lower.tail=FALSE)
        aod[, "Pr(Chi)"] <- dev
    } else if(test == "F") {
	dev <- aod$"Sum of Sq"
	dfs <- aod$Df
	rdf <- object$df.resid
	rms <- aod$RSS[1]/rdf
	Fs <- (dev/dfs)/rms
	Fs[dfs < 1e-4] <- NA
	P <- Fs
	nas <- !is.na(Fs)
	P[nas] <- pf(Fs[nas], dfs[nas], rdf, lower.tail=FALSE)
	aod[, c("F value", "Pr(F)")] <- list(Fs, P)
    }
    head <- c("Single term deletions", "\nModel:",
	      deparse(as.vector(formula(object))),
	      if(scale > 0) paste("\nscale: ", format(scale), "\n"))
    class(aod) <- c("anova", "data.frame")
    attr(aod, "heading") <- head
    aod
}

drop1.mlm <- function(object, scope, ...)
    stop("drop1 not implemented for mlm models")

drop1.glm <- function(object, scope, scale = 0, test=c("none", "Chisq", "F"),
		      k = 2, ...)
{
    x <- model.matrix(object)
#    iswt <- !is.null(wt <- object$weights)
    n <- nrow(x)
    asgn <- attr(x, "assign")
    tl <- attr(object$terms, "term.labels")
    if(missing(scope)) scope <- drop.scope(object)
    else {
	if(!is.character(scope))
	    scope <- attr(terms(update.formula(object, scope)), "term.labels")
	if(!all(match(scope, tl, FALSE)))
	    stop("scope is not a subset of term labels")
    }
    ndrop <- match(scope, tl)
    ns <- length(scope)
    rdf <- object$df.resid
    chisq <- object$deviance
    dfs <- numeric(ns)
    dev <- numeric(ns)
    y <- object$y
    if(is.null(y)) y <- model.response(model.frame(object), "numeric")
#    na.coef <- (1:length(object$coefficients))[!is.na(object$coefficients)]
    wt <- object$prior.weights
    if(is.null(wt)) wt <- rep.int(1, n)
    for(i in 1:ns) {
	ii <- seq(along=asgn)[asgn == ndrop[i]]
	jj <- setdiff(seq(ncol(x)), ii)
	z <-  glm.fit(x[, jj, drop = FALSE], y, wt, offset=object$offset,
		      family=object$family, control=object$control)
	dfs[i] <- z$rank
	dev[i] <- z$deviance
    }
    scope <- c("<none>", scope)
    dfs <- c(object$rank, dfs)
    dev <- c(chisq, dev)
    dispersion <- if (is.null(scale) || scale == 0)
	summary(object, dispersion = NULL)$dispersion
    else scale
    fam <- object$family$family
    loglik <-
        if(fam == "gaussian") {
            if(scale > 0) dev/scale - n else n * log(dev/n)
        } else dev/dispersion
    aic <- loglik + k * dfs
    dfs <- dfs[1] - dfs
    dfs[1] <- NA
    aic <- aic + (extractAIC(object, k = k)[2] - aic[1])
    aod <- data.frame(Df = dfs, Deviance = dev, AIC = aic,
		      row.names = scope, check.names = FALSE)
    if(all(is.na(aic))) aod <- aod[, -3]
    test <- match.arg(test)
    if(test == "Chisq") {
        dev <- pmax(0, loglik - loglik[1])
        dev[1] <- NA
        nas <- !is.na(dev)
        LRT <- if(dispersion == 1) "LRT" else "scaled dev."
        aod[, LRT] <- dev
        dev[nas] <- pchisq(dev[nas], aod$Df[nas], lower.tail=FALSE)
        aod[, "Pr(Chi)"] <- dev
    } else if(test == "F") {
        if(fam == "binomial" || fam == "poisson")
            warning(paste("F test assumes quasi", fam, " family", sep=""))
	dev <- aod$Deviance
	rms <- dev[1]/rdf
        dev <- pmax(0, dev - dev[1])
	dfs <- aod$Df
	rdf <- object$df.residual
	Fs <- (dev/dfs)/rms
	Fs[dfs < 1e-4] <- NA
	P <- Fs
	nas <- !is.na(Fs)
	P[nas] <- pf(Fs[nas], dfs[nas], rdf, lower.tail=FALSE)
	aod[, c("F value", "Pr(F)")] <- list(Fs, P)
    }
    head <- c("Single term deletions", "\nModel:",
	      deparse(as.vector(formula(object))),
	      if(!is.null(scale) && scale > 0)
	      paste("\nscale: ", format(scale), "\n"))
    class(aod) <- c("anova", "data.frame")
    attr(aod, "heading") <- head
    aod
}

add.scope <- function(terms1, terms2)
{
    terms1 <- terms(terms1)
    terms2 <- terms(terms2)
    factor.scope(attr(terms1, "factor"),
		 list(add = attr(terms2, "factor")))$add
}

drop.scope <- function(terms1, terms2)
{
    terms1 <- terms(terms1)
    f2 <- if(missing(terms2)) numeric(0)
    else attr(terms(terms2), "factor")
    factor.scope(attr(terms1, "factor"), list(drop = f2))$drop
}

factor.scope <- function(factor, scope)
{
    drop <- scope$drop
    add <- scope$add

    if(length(factor) && !is.null(drop)) {# have base model
	nmdrop <- colnames(drop)
	facs <- factor
	if(length(drop)) {
	    nmfac <- colnames(factor)
	    where <- match(nmdrop, nmfac, 0)
	    if(any(!where)) stop("lower scope is not included in model")
	    facs <- factor[, -where, drop = FALSE]
	    nmdrop <- nmfac[-where]
	} else nmdrop <- colnames(factor)
	if(ncol(facs) > 1) {
            ## check no interactions will be left without margins.
	    keep <- rep.int(TRUE, ncol(facs))
	    f <- crossprod(facs > 0)
	    for(i in seq(keep)) keep[i] <- max(f[i, - i]) != f[i, i]
	    nmdrop <- nmdrop[keep]
	}
    } else nmdrop <- character(0)

    if(!length(add)) nmadd <- character(0)
    else {
	nmfac <- colnames(factor)
	nmadd <- colnames(add)
	if(!is.null(nmfac)) {
	    where <- match(nmfac, nmadd, 0)
	    if(any(!where)) stop("upper scope does not include model")
	    nmadd <- nmadd[-where]
	    add <- add[, -where, drop = FALSE]
	}
	if(ncol(add) > 1) {             # check marginality:
	    keep <- rep.int(TRUE, ncol(add))
	    f <- crossprod(add > 0)
	    for(i in seq(keep)) keep[-i] <- keep[-i] & (f[i, -i] < f[i, i])
	    nmadd <- nmadd[keep]
	}
    }
    list(drop = nmdrop, add = nmadd)
}

step <- function(object, scope, scale = 0,
		 direction = c("both", "backward", "forward"),
		 trace = 1, keep = NULL, steps = 1000, k = 2, ...)
{
#     fixFormulaObject <- function(object) {
# 	tt <- terms(object)
# 	tmp <- attr(tt, "term.labels")
# 	if (!attr(tt, "intercept"))
# 	    tmp <- c(tmp, "0")
# 	if (!length(tmp))
# 	    tmp <- "1"
#         tmp <- paste("~", paste(tmp, collapse = " + "))
#         form <- formula(object) # some formulae have no lhs
#         tmp <- if(length(form) > 2) paste(deparse(form[[2]]), tmp)
#         ## must be as.character as deparse gives spurious ()
# 	if (length(offset <- attr(tt, "offset")))
# 	    tmp <- paste(tmp, as.character(attr(tt, "variables")[offset + 1]),
# 			 sep = " + ")
# 	form <- formula(tmp)
#         environment(form) <- environment(tt)
#         form
#     }
    mydeviance <- function(x, ...)
    {
        dev <- deviance(x)
        if(!is.null(dev)) dev else extractAIC(x, k=0)[2]
    }

    cut.string <- function(string)
    {
	if(length(string) > 1)
	    string[-1] <- paste("\n", string[-1], sep = "")
	string
    }
    re.arrange <- function(keep)
    {
	namr <- names(k1 <- keep[[1]])
	namc <- names(keep)
	nc <- length(keep)
	nr <- length(k1)
	array(unlist(keep, recursive = FALSE), c(nr, nc), list(namr, namc))
    }

    step.results <- function(models, fit, object, usingCp=FALSE)
    {
	change <- sapply(models, "[[", "change")
	rd <- sapply(models, "[[", "deviance")
        dd <- c(NA, abs(diff(rd)))
	rdf <- sapply(models, "[[", "df.resid")
	ddf <- c(NA, diff(rdf))
	AIC <- sapply(models, "[[", "AIC")
	heading <- c("Stepwise Model Path \nAnalysis of Deviance Table",
		     "\nInitial Model:", deparse(as.vector(formula(object))),
		     "\nFinal Model:", deparse(as.vector(formula(fit))),
		     "\n")
	aod <- data.frame(Step = I(change), Df = ddf, Deviance = dd,
                          "Resid. Df" = rdf, "Resid. Dev" = rd, AIC = AIC,
                          check.names = FALSE)
        if(usingCp) {
            cn <- colnames(aod)
            cn[cn == "AIC"] <- "Cp"
            colnames(aod) <- cn
        }
	attr(aod, "heading") <- heading
        ##stop gap attr(aod, "class") <- c("anova", "data.frame")
	fit$anova <- aod
	fit
    }

    Terms <- terms(object)
    object$call$formula <- object$formula <- Terms
    md <- missing(direction)
    direction <- match.arg(direction)
    backward <- direction == "both" | direction == "backward"
    forward  <- direction == "both" | direction == "forward"
    if(missing(scope)) {
	fdrop <- numeric(0)
        fadd <- attr(Terms, "factors")
        if(md) forward <- FALSE
    }
    else {
	if(is.list(scope)) {
	    fdrop <- if(!is.null(fdrop <- scope$lower))
		attr(terms(update.formula(object, fdrop)), "factors")
	    else numeric(0)
	    fadd <- if(!is.null(fadd <- scope$upper))
		attr(terms(update.formula(object, fadd)), "factors")
	}
        else {
	    fadd <- if(!is.null(fadd <- scope))
		attr(terms(update.formula(object, scope)), "factors")
	    fdrop <- numeric(0)
	}
    }
    models <- vector("list", steps)
    if(!is.null(keep)) keep.list <- vector("list", steps)
    n <- length(object$residuals)
    fit <- object
    bAIC <- extractAIC(fit, scale, k = k, ...)
    edf <- bAIC[1]
    bAIC <- bAIC[2]
    if(is.na(bAIC))
        stop("AIC is not defined for this model, so step cannot proceed")
    nm <- 1
    Terms <- fit$terms
    if(trace)
	cat("Start:  AIC=", format(round(bAIC, 2)), "\n",
	    cut.string(deparse(as.vector(formula(fit)))), "\n\n")

    models[[nm]] <- list(deviance = mydeviance(fit), df.resid = n - edf,
			 change = "", AIC = bAIC)
    if(!is.null(keep)) keep.list[[nm]] <- keep(fit, bAIC)
    usingCp <- FALSE
    while(steps > 0) {
	steps <- steps - 1
	AIC <- bAIC
	ffac <- attr(Terms, "factors")
	scope <- factor.scope(ffac, list(add = fadd, drop = fdrop))
	aod <- NULL
	change <- NULL
	if(backward && length(scope$drop)) {
	    aod <- drop1(fit, scope$drop, scale = scale,
                         trace = trace, k = k, ...)
	    rn <- row.names(aod)
	    row.names(aod) <- c(rn[1], paste("-", rn[-1], sep=" "))
            ## drop zero df terms first: one at time since they
            ## may mask each other
	    if(any(aod$Df == 0, na.rm=TRUE)) {
		zdf <- aod$Df == 0 & !is.na(aod$Df)
		change <- rev(rownames(aod)[zdf])[1]
	    }
	}
	if(is.null(change)) {
	    if(forward && length(scope$add)) {
		aodf <- add1(fit, scope$add, scale = scale,
                             trace = trace, k = k, ...)
		rn <- row.names(aodf)
		row.names(aodf) <- c(rn[1], paste("+", rn[-1], sep=" "))
		aod <-
                    if(is.null(aod)) aodf
                    else rbind(aod, aodf[-1, , drop = FALSE])
	    }
	    attr(aod, "heading") <- NULL
	    ## need to remove any terms with zero df from consideration
	    nzdf <- if(!is.null(aod$Df))
		aod$Df != 0 | is.na(aod$Df)
	    aod <- aod[nzdf, ]
	    if(is.null(aod) || ncol(aod) == 0) break
	    nc <- match(c("Cp", "AIC"), names(aod))
	    nc <- nc[!is.na(nc)][1]
	    o <- order(aod[, nc])
	    if(trace) print(aod[o, ])
	    if(o[1] == 1) break
	    change <- rownames(aod)[o[1]]
	}
	usingCp <- match("Cp", names(aod), 0) > 0
        ## may need to look for a `data' argument in parent
	fit <- update(fit, paste("~ .", change), evaluate = FALSE)
        fit <- eval.parent(fit)
        if(length(fit$residuals) != n)
            stop("number of rows in use has changed: remove missing values?")
        Terms <- terms(fit)
	bAIC <- extractAIC(fit, scale, k = k, ...)
	edf <- bAIC[1]
	bAIC <- bAIC[2]
	if(trace)
	    cat("\nStep:  AIC=", format(round(bAIC, 2)), "\n",
		cut.string(deparse(as.vector(formula(fit)))), "\n\n")
        ## add a tolerance as dropping 0-df terms might increase AIC slightly
	if(bAIC >= AIC + 1e-7) break
	nm <- nm + 1
	models[[nm]] <-
	    list(deviance = mydeviance(fit), df.resid = n - edf,
		 change = change, AIC = bAIC)
	if(!is.null(keep)) keep.list[[nm]] <- keep(fit, bAIC)
    }
    if(!is.null(keep)) fit$keep <- re.arrange(keep.list[seq(nm)])
    step.results(models = models[seq(nm)], fit, object, usingCp)
}

extractAIC <- function(fit, scale, k = 2, ...) UseMethod("extractAIC")

extractAIC.coxph <- function(fit, scale, k = 2, ...)
{
    edf <- length(fit$coef)
    if(edf > 0)
        c(edf, -2 * fit$loglik[2] + k * edf)
    else
        c(0, -2 * fit$loglik)
}

extractAIC.survreg <- function(fit, scale, k = 2, ...)
{
    n <- length(fit$residuals)
    edf <- n  - fit$df.residual
    c(edf, -2 * fit$loglik[2] + k * edf)
}

extractAIC.glm <- function(fit, scale = 0, k = 2, ...)
{
    n <- length(fit$residuals)
    edf <- n  - fit$df.residual
    aic <- fit$aic
    c(edf, aic + (k-2) * edf)
}

extractAIC.lm <- function(fit, scale = 0, k = 2, ...)
{
    n <- length(fit$residuals)
    edf <- n  - fit$df.residual
    RSS <- deviance.lm(fit)
    dev <- if(scale > 0) RSS/scale - n else n * log(RSS/n)
    c(edf, dev + k * edf)
}
extractAIC.aov <- extractAIC.lm

extractAIC.negbin <- function(fit, scale, k = 2, ...)
{
    n <- length(fit$residuals)
    edf <- n - fit$df.residual
    c(edf, -fit$twologlik + k * edf)
}
aggregate <- function(x, ...) UseMethod("aggregate")

aggregate.default <- function(x, ...) {
    if(is.ts(x))
        aggregate.ts(as.ts(x), ...)
    else
        aggregate.data.frame(as.data.frame(x), ...)
}

aggregate.data.frame <- function(x, by, FUN, ...) {
    if(!is.data.frame(x))
        x <- as.data.frame(x)
    if(!is.list(by))
        stop(paste(sQuote("by"), "must be a list"))
    if(is.null(names(by)))
        names(by) <- paste("Group", seq(along = by), sep = ".")
    else {
        nam <- names(by)
        ind <- which(nchar(nam) == 0)
        names(by)[ind] <- paste("Group", ind, sep = ".")
    }
    y <- lapply(x, tapply, by, FUN, ..., simplify = FALSE)
    if(any(sapply(unlist(y, recursive = FALSE), length) > 1))
        stop(paste(sQuote("FUN"), "must always return a scalar"))
    z <- y[[1]]
    d <- dim(z)
    w <- NULL
    for (i in seq(along = d)) {
        j <- rep.int(rep.int(seq(1 : d[i]),
                     prod(d[seq(length = i - 1)]) * rep.int(1, d[i])),
                 prod(d[seq(from = i + 1, length = length(d) - i)]))
        w <- cbind(w, dimnames(z)[[i]][j])
    }
    w <- w[which(!unlist(lapply(z, is.null))), ]
    y <- data.frame(w, lapply(y, unlist, use.names = FALSE))
    names(y) <- c(names(by), names(x))
    y
}

aggregate.ts <- function(x, nfrequency = 1, FUN = sum, ndeltat = 1,
                         ts.eps = getOption("ts.eps"), ...)
{
    x <- as.ts(x)
    ofrequency <- tsp(x)[3]
    ## Set up the new frequency, and make sure it is an integer.
    if(missing(nfrequency))
        nfrequency <- 1 / ndeltat
    if((nfrequency > 1) &&
        (abs(nfrequency - round(nfrequency)) < ts.eps))
        nfrequency <- round(nfrequency)

    if(nfrequency == ofrequency)
        return(x)
    if(abs(ofrequency %% nfrequency) > ts.eps)
        stop(paste("cannot change frequency from",
                   ofrequency, "to", nfrequency))
    ## The desired result is obtained by applying FUN to blocks of
    ## length ofrequency/nfrequency, for each of the variables in x.
    ## We first get the new start and end right, and then break x into
    ## such blocks by reshaping it into an array and setting dim.
    len <- ofrequency %/% nfrequency
    mat <- is.matrix(x)
    if(mat) cn <- colnames(x)
#    nstart <- ceiling(tsp(x)[1] * nfrequency) / nfrequency
#    x <- as.matrix(window(x, start = nstart))
    nstart <- tsp(x)[1]
    # Can't use nstart <- start(x) as this causes problems if
    # you get a vector of length 2.
    x <- as.matrix(x)
    nend <- floor(nrow(x) / len) * len
    x <- apply(array(c(x[1 : nend, ]),
                     dim = c(len, nend / len, ncol(x))),
               MARGIN = c(2, 3), FUN = FUN, ...)
    if(!mat) x <- as.vector(x)
    else colnames(x) <- cn
    ts(x, start = nstart, frequency = nfrequency)
}
all.equal <- function(target, current, ...) UseMethod("all.equal")

all.equal.default <- function(target, current, ...)
{
    ## Really a dispatcher given mode() of args :
    ## use data.class as unlike class it does not give "Integer"
    if(is.language(target) || is.function(target))
	return(all.equal.language(target, current, ...))
    if(is.recursive(target))
	return(all.equal.list(target, current, ...))
    msg <- c(attr.all.equal(target, current, ...),
	     if(is.numeric(target)) {
		 all.equal.numeric(target, current, ...)
	     } else
	     switch (mode(target),
		     logical = ,
		     complex = ,
		     numeric = all.equal.numeric(target, current, ...),
		     character = all.equal.character(target, current, ...),
		      if(data.class(target) != data.class(current)) {
		 paste("target is ", data.class(target), ", current is ",
		       data.class(current), sep = "")
	     } else NULL))
    if(is.null(msg)) TRUE else msg
}

all.equal.numeric <-
function(target, current, tolerance = .Machine$double.eps ^ .5,
         scale=NULL, ...)
{
    if(data.class(target) != data.class(current))
        return(paste("target is ", data.class(target), ", current is ",
		       data.class(current), sep = ""))
    lt <- length(target)
    lc <- length(current)
    cplx <- is.complex(target)
    if(lt != lc)
	return(paste(if(cplx)"Complex" else "Numeric",
                     ": lengths (", lt, ", ", lc, ") differ", sep = ""))
    target <- as.vector(target)
    current <- as.vector(current)
    out <- is.na(target)
    if(any(out != is.na(current)))
	return(paste("`is.NA' value mismatches:", sum(is.na(current)),
		     "in current,", sum(out), " in target"))
    out <- out | target == current
    if(all(out)) return(TRUE)
    target <- target[!out]
    current <- current[!out]
    xy <- mean((if(cplx)Mod else abs)(target - current))
    what <-
	if(is.null(scale)) {
	    xn <- mean(abs(target))
	    if(is.finite(xn) && xn > tolerance) {
		xy <- xy/xn
		"relative"
	    } else "absolute"
	} else {
	    xy <- xy/scale
	    "scaled"
	}
    if(is.na(xy) || xy > tolerance)
	paste("Mean", what, if(cplx)"Mod", "difference:", format(xy)) else TRUE
}

all.equal.character <- function(target, current, ...)
{
    if(data.class(target) != data.class(current))
        return(paste("target is ", data.class(target), ", current is ",
		       data.class(current), sep = ""))
    lt <- length(target)
    lc <- length(current)
    if(lt != lc) {
	msg <- paste("Lengths (", lt, ", ", lc,
		     ") differ (string compare on first ", ll <- min(lt, lc),
		     ")", sep = "")
	ll <- seq(length = ll)
	target <- target[ll]
	current <- current[ll]
    } else msg <- NULL
    nas <- is.na(target)
    if (any(nas != is.na(current)))
        return(paste("`is.NA' value mismatches:", sum(is.na(current)),
                     "in current,", sum(nas), " in target"))
    ne <- !nas & (target != current)
    if(!any(ne) && is.null(msg)) TRUE
    else if(any(ne)) c(msg, paste(sum(ne), "string mismatches"))
    else msg
}

all.equal.factor <- function(target, current, ...)
{
    if(!inherits(current, "factor"))
	return("`current' is not a factor")
    msg <- attr.all.equal(target, current)
    class(target) <- class(current) <- NULL
    nax <- is.na(target)
    nay <- is.na(current)
    if(n <- sum(nax != nay))
	msg <- c(msg, paste("NA mismatches:", n))
    else {
	target <- levels(target)[target[!nax]]
	current <- levels(current)[current[!nay]]
	if(is.character(n <- all.equal(target, current)))
	    msg <- c(msg, n)
    }
    if(is.null(msg)) TRUE else msg
}

all.equal.formula <- function(target, current, ...)
{
    if(length(target) != length(current))
	return(paste("target, current differ in having response: ",
		     length(target) == 3, ", ", length(current) == 3))
    if(all(deparse(target) != deparse(current)))
	"formulas differ in contents"
    else TRUE
}

all.equal.language <- function(target, current, ...)
{
    mt <- mode(target)
    mc <- mode(current)
    if(mt == "expression" && mc == "expression")
	return(all.equal.list(target, current, ...))
    ttxt <- paste(deparse(target), collapse = "\n")
    ctxt <- paste(deparse(current), collapse = "\n")
    msg <- c(if(mt != mc)
	     paste("Modes of target, current: ", mt, ", ", mc, sep = ""),
	     if(ttxt != ctxt) {
		 if(pmatch(ttxt, ctxt, FALSE))
		     "target a subset of current"
		 else if(pmatch(ctxt, ttxt, FALSE))
		     "current a subset of target"
		 else	"target, current don't match when deparsed"
	     })
    if(is.null(msg)) TRUE else msg
}

all.equal.list <- function(target, current, ...)
{
    msg <- attr.all.equal(target, current, ...)
#    nt <- names(target)
    nc <- names(current)
    iseq <-
        ## <FIXME>
        ## Commenting this eliminates PR#674, and assumes that lists are
        ## regarded as generic vectors, so that they are equal iff they
        ## have identical names attributes and all components are equal.
        ## if(length(nt) && length(nc)) {
        ##     if(any(not.in <- (c.in.t <- match(nc, nt, 0)) == 0))
        ## 	msg <- c(msg, paste("Components not in target:",
        ## 			    paste(nc[not.in], collapse = ", ")))
        ##     if(any(not.in <- match(nt, nc, 0) == 0))
        ## 	msg <- c(msg, paste("Components not in current:",
        ## 			    paste(nt[not.in], collapse = ", ")))
        ##     nt[c.in.t]
        ## } else
        ## </FIXME>
        if(length(target) == length(current)) {
	    seq(along = target)
	} else {
	    nc <- min(length(target), length(current))
	    msg <- c(msg, paste("Length mismatch: comparison on first",
				nc, "components"))
	    seq(length = nc)
	}
    for(i in iseq) {
	mi <- all.equal(target[[i]], current[[i]], ...)
	if(is.character(mi))
	    msg <- c(msg, paste("Component ", i, ": ", mi, sep=""))
    }
    if(is.null(msg)) TRUE else msg
}


attr.all.equal <- function(target, current, ...)
{
    ##--- "all.equal(.)" for attributes ---
    ##---  Auxiliary in all.equal(.) methods --- return NULL or character()
    msg <- NULL
    if(mode(target) != mode(current))
	msg <- paste("Modes: ", mode(target), ", ", mode(current), sep = "")
    if(length(target) != length(current))
	msg <- c(msg, paste("Lengths: ", length(target), ", ",
			    length(current), sep = ""))
    ax <- attributes(target)
    ay <- attributes(current)
    nx <- names(target)
    ny <- names(current)
    if((lx <- length(nx)) | (ly <- length(ny))) {
	## names() treated now; hence NOT with attributes()
	ax$names <- ay$names <- NULL
	if(lx && ly) {
	    if(is.character(m <- all.equal.character(nx, ny)))
		msg <- c(msg, paste("Names:", m))
	} else if(lx)
	    msg <- c(msg, "names for target but not for current")
	else msg <- c(msg, "names for current but not for target")
    }
    if(length(ax) || length(ay)) {# some (more) attributes
	## order by names before comparison:
	nx <- names(ax)
	ny <- names(ay)
	if(length(nx))	    ax <- ax[order(nx)]
	if(length(ny))	    ay <- ay[order(ny)]
	tt <- all.equal(ax, ay, ...)
	if(is.character(tt)) msg <- c(msg, paste("Attributes: <", tt, ">"))
    }
    msg # NULL or character
}

all.names <- function(expr, functions = TRUE, max.names = 200, unique = FALSE)
    .Internal(all.names(expr, functions, max.names, unique))

all.vars <- function(expr, functions = FALSE, max.names = 200, unique = TRUE)
    .Internal(all.names(expr, functions, max.names, unique))
## *ANY* print method should return its argument invisibly!


##-     nn <- names(x)
##-
##-     for (i in 1:NCOL(x)) {
##- 	xr <- x[[i]]
##- 	if (substr(nn[i],1,2) == "Pr") {
##- 	    x[[i]] <- format.pval(xr, digits = max(1, min(5, digits - 1)), na="")
##- 	    if(signif.stars)
##- 		x$Signif <- c(symnum(xr[!is.na(xr)], corr = FALSE,
##- 				     cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1),
##- 				     symbols = c("***", "**", "*", ".", " ")),
##- 			      "") ## 'nterms' ~= 'Residuals' have no P-value
##-
##- 	} else if (!is.factor(xr) && is.numeric(xr)) {
##- 	    cxr <- format(zapsmall(xr, digits=digits), digits=digits)
##- 	    cxr[is.na(xr)] <- ""
##- 	    x[[i]] <- cxr
##- 	}
##-     }
##-     print.data.frame(x)


aov <- function(formula, data = NULL, projections = FALSE, qr = TRUE,
                contrasts = NULL, ...)
{
    Terms <- if(missing(data)) terms(formula, "Error")
    else terms(formula, "Error", data = data)
    indError <- attr(Terms, "specials")$Error
    if(length(indError) > 1)
        stop(paste("There are", length(indError),
                   "Error terms: only 1 is allowed"))
    lmcall <- Call <- match.call()
    lmcall[[1]] <- as.name("lm")
    lmcall$singular.ok <- TRUE          # not currently used in R
    if(projections) qr <- lmcall$qr <- TRUE
    lmcall$projections <- NULL
    if(is.null(indError)) {
        ## no Error term
        fit <- eval(lmcall, parent.frame())
        if(projections) fit$projections <- proj(fit)
        class(fit) <- if(inherits(fit, "mlm"))
            c("maov", "aov", oldClass(fit)) else c("aov", oldClass(fit))
        fit$call <- Call
        return(fit)
    } else {
        ##  helmert contrasts can be helpful: do we want to force them?
        ##  this version does for the Error model.
        opcons <- options("contrasts")
        options(contrasts=c("contr.helmert", "contr.poly"))
        on.exit(options(opcons))
        allTerms <- Terms
        errorterm <-  attr(Terms, "variables")[[1 + indError]]
        eTerm <- deparse(errorterm[[2]], width = 500, backtick = TRUE)
        intercept <- attr(Terms, "intercept")
        ecall <- lmcall
        ecall$formula <-
            as.formula(paste(deparse(formula[[2]], width = 500,
                                     backtick = TRUE), "~", eTerm,
                             if(!intercept) "- 1"),
                       env=environment(formula))

        ecall$method <- "qr"
        ecall$qr <- TRUE
        ecall$contrasts <- NULL
        er.fit <- eval(ecall, parent.frame())
        options(opcons)
        nmstrata <- attr(terms(er.fit), "term.labels")
        ## remove backticks from simple labels for strata (only)
        nmstrata <- sub("^`(.*)`$", "\\1", nmstrata)
        if(intercept) nmstrata <- c("(Intercept)", nmstrata)
        qr.e <- er.fit$qr
        rank.e <- er.fit$rank
        qty <- er.fit$resid
        maov <- is.matrix(qty)
        asgn.e <- er.fit$assign[qr.e$piv[1:rank.e]]
        ## we want this to label the rows of qtx, not cols of x.
        nobs <- NROW(qty)
        if(nobs > rank.e) {
            result <- vector("list", max(asgn.e) + 2)
            asgn.e[(rank.e+1):nobs] <- max(asgn.e) + 1
            nmstrata <- c(nmstrata, "Within")
        } else result <- vector("list", max(asgn.e) + 1)
        names(result) <- nmstrata
        lmcall$formula <- form <-
            update(formula, paste(". ~ .-", deparse(errorterm, width = 500,
                                                    backtick = TRUE)))
        Terms <- terms(form)
        lmcall$method <- "model.frame"
        mf <- eval(lmcall, parent.frame())
        xvars <- as.character(attr(Terms, "variables"))[-1]
        if ((yvar <- attr(Terms, "response")) > 0)
            xvars <- xvars[-yvar]
        if (length(xvars) > 0) {
            xlev <- lapply(mf[xvars], levels)
            xlev <- xlev[!sapply(xlev, is.null)]
        } else xlev <- NULL
        resp <- model.response(mf)
        qtx <- model.matrix(Terms, mf, contrasts)
        cons <- attr(qtx, "contrasts")
        dnx <- colnames(qtx)
        asgn.t <- attr(qtx, "assign")
        if(length(wts <- model.weights(mf))) {
            wts <- sqrt(wts)
            resp <- resp * wts
            qtx <- qtx * wts
        }
        qty <- as.matrix(qr.qty(qr.e, resp))
        if((nc <- ncol(qty)) > 1) {
            dny <- colnames(resp)
            if(is.null(dny)) dny <- paste("Y", 1:nc, sep="")
            dimnames(qty) <- list(seq(nrow(qty)), dny)
        } else dimnames(qty) <- list(seq(nrow(qty)), NULL)
        qtx <- qr.qty(qr.e, qtx)
        dimnames(qtx) <- list(seq(nrow(qtx)) , dnx)
        for(i in seq(along=nmstrata)) {
            select <- asgn.e==(i-1)
            ni <- sum(select)
            if(!ni) next
            ## helpful to drop constant columns.
            xi <- qtx[select, , drop = FALSE]
            cols <- colSums(xi^2) > 1e-5
            if(any(cols)) {
                xi <- xi[, cols, drop = FALSE]
                attr(xi, "assign") <- asgn.t[cols]
                fiti <- lm.fit(xi, qty[select,,drop=FALSE])
                fiti$terms <- Terms
            } else {
                y <- qty[select,,drop=FALSE]
                fiti <- list(coefficients = numeric(0), residuals = y,
                             fitted.values = 0 * y, weights = wts, rank = 0,
                             df.residual = NROW(y))
            }
            if(projections) fiti$projections <- proj(fiti)
            class(fiti) <- c(if(maov) "maov", "aov", oldClass(er.fit))
            result[[i]] <- fiti
        }
        class(result) <- c("aovlist", "listof")
        if(qr) attr(result, "error.qr") <- qr.e
        attr(result, "call") <- Call
        if(length(wts)) attr(result, "weights") <- wts
        attr(result, "terms") <- allTerms
        attr(result, "contrasts") <- cons
        attr(result, "xlevels") <- xlev
        result
    }
}

print.aov <-
function(x, intercept = FALSE, tol = .Machine$double.eps^0.5, ...)
{
    if(!is.null(cl <- x$call)) {
        cat("Call:\n   ")
        dput(cl)
    }
    asgn <- x$assign[x$qr$pivot[1:x$rank]]
    effects <- x$effects
    if(!is.null(effects))
        effects <- as.matrix(effects)[seq(along=asgn),,drop=FALSE]
    rdf <- x$df.resid
    resid <- as.matrix(x$residuals)
    wt <- x$weights
    if(!is.null(wt)) resid <- resid * wt^0.5
    RSS <- colSums(resid^2)
    uasgn <- unique(asgn)
    nmeffect <- c("(Intercept)", attr(x$terms, "term.labels"))[1+uasgn]
    nterms <- length(uasgn)
    nresp <- NCOL(effects)
    df <- numeric(nterms)
    ss <- matrix(NA, nterms, nresp)
    if(nterms) {
        for(i in seq(nterms)) {
            ai <- asgn==uasgn[i]
            df[i] <- sum(ai)
            ef <- effects[ai,, drop=FALSE]
            ss[i,] <- if(sum(ai) > 1) colSums(ef^2) else ef^2
        }
        keep <- df > 0
        if(!intercept && uasgn[1] == 0) keep[1] <- FALSE
        nmeffect <- nmeffect[keep]
        df <- df[keep]
        ss <- ss[keep,,drop=FALSE]
        nterms <- length(df)
    }
    cat("\nTerms:\n")
    if(nterms == 0) {
        ## empty model
        if(rdf > 0) {
            ss <- RSS
            ssp <- sapply(ss, format)
            if(!is.matrix(ssp)) ssp <- t(ssp)
            tmp <- as.matrix(c(ssp, format(rdf)))
            if(length(ss) > 1) {
                rn <- colnames(x$fitted)
                if(is.null(rn)) rn <- paste("resp", 1:length(ss))
            } else rn <- "Sum of Squares"
            dimnames(tmp) <- list(c(rn, "Deg. of Freedom"), "Residuals")
            print(tmp, quote = FALSE, right = TRUE)
            cat("\n")
            cat("Residual standard error:", sapply(sqrt(ss/rdf), format), "\n")
        } else
        print(matrix(0, 2, 1, dimnames=
                     list(c("Sum of Squares", "Deg. of Freedom"), "<empty>")))
    } else {
        if(rdf > 0) {
            nterms <- nterms + 1
            df <- c(df, rdf)
            ss <- rbind(ss, RSS)
            nmeffect <- c(nmeffect, "Residuals")
        }
        ssp <- apply(zapsmall(ss), 2, format)
        tmp <- t(cbind(ssp, format(df)))
        if(ncol(effects) > 1) {
            rn <- colnames(x$coef)
            if(is.null(rn)) rn <- paste("resp", seq(ncol(effects)))
        } else rn <- "Sum of Squares"
        dimnames(tmp) <- list(c(rn, "Deg. of Freedom"), nmeffect)
        print(tmp, quote = FALSE, right = TRUE)
        rank <- x$rank
#        int <- attr(x$terms, "intercept")
#        nobs <- NROW(x$residuals) - !(is.null(int) || int == 0)
        cat("\n")
        if(rdf > 0) {
            rs <- sqrt(RSS/rdf)
            cat("Residual standard error:", sapply(rs, format), "\n")
        }
        coef <- as.matrix(x$coef)[,1]
        R <- x$qr$qr
        R <- R[1:min(dim(R)), ,drop=FALSE]
        R[lower.tri(R)] <- 0
        if(rank < (nc <- length(coef))) {
            cat(paste(nc - rank, "out of", nc, "effects not estimable\n"))
            R <- R[, 1:rank, drop = FALSE]
        }
        d2 <- sum(abs(diag(R)))
        diag(R) <- 0
        if(sum(abs(R))/d2 > tol)
            cat("Estimated effects may be unbalanced\n")
        else cat("Estimated effects are balanced\n")
    }
    invisible(x)
}

summary.aov <- function(object, intercept = FALSE, split,
                        expand.split = TRUE, keep.zero.df = TRUE, ...)
{
    splitInteractions <- function(split, factors, names, asgn, df.names)
    {
        ns <- names(split)
        for(i in unique(asgn)) {
            if(i == 0 || names[i+1] %in% ns) next
            f <- rownames(factors)[factors[, i] > 0]
            sp <- f %in% ns
            if(any(sp)) {              # some marginal terms are split
                if(sum(sp) > 1) {
                    old <- split[ f[sp] ]
                    nn <- f[sp]
                    names(nn) <- nn
                    marg <- lapply(nn, function(x)
                                   df.names[asgn == (match(x, names) - 1)])
                    term.coefs <- strsplit(df.names[asgn == i], ":")
                    ttc <- sapply(term.coefs, function(x) x[sp])
                    rownames(ttc) <- nn
                    splitnames <- apply(expand.grid(lapply(old, names)), 1,
                                        function(x) paste(x, collapse="."))
                    names(splitnames) <- splitnames
                    tmp <- sapply(nn, function(i)
                                  names(old[[i]])[match(ttc[i, ], marg[[i]])] )
                    tmp <- apply(tmp, 1, function(x) paste(x, collapse="."))
                    new <- lapply(splitnames, function(x) match(x, tmp))
                    split[[ names[i+1] ]] <-
                        new[sapply(new, function(x) length(x) > 0)]
                } else {
                    old <- split[[ f[sp] ]]
                    marg.coefs <- df.names[asgn == (match(f[sp], names) - 1)]
                    term.coefs <- strsplit(df.names[asgn == i], ":")
                    ttc <- sapply(term.coefs, function(x) x[sp])
                    new <- lapply(old, function(x)
                                  seq(along=ttc)[ttc %in% marg.coefs[x]])
                    split[[ names[i+1] ]] <- new
                }
            }
        }
        split
    }

    asgn <- object$assign[object$qr$pivot[1:object$rank]]
    uasgn <- unique(asgn)
    nterms <- length(uasgn)
    effects <- object$effects
    if(!is.null(effects))
        effects <- as.matrix(effects)[seq(along=asgn),,drop=FALSE]
    rdf <- object$df.resid
    nmeffect <- c("(Intercept)", attr(object$terms, "term.labels"))
    coef <- as.matrix(object$coef)
    resid <- as.matrix(object$residuals)
    wt <- object$weights
    if(!is.null(wt)) resid <- resid * wt^0.5
    nresp <- NCOL(resid)
    ans <- vector("list", nresp)
    if(nresp > 1) {
        names(ans) <- character(nresp)
        for (y in 1:nresp) {
            cn <- colnames(resid)[y]
            if(is.null(cn) || cn == "") cn <- y
            names(ans)[y] <- paste(" Response", cn)
        }
    }

    if(!is.null(effects) && !missing(split)) {
        ns <- names(split)
        if(!is.null(Terms <- object$terms)) {
            if(!is.list(split))
                stop("The split argument must be a list")
            if(!all(ns %in% nmeffect))
                stop("Unknown name(s) in the split list")
        }
        if(expand.split) {
            df.names <- names(coef(object))
            split <- splitInteractions(split, attr(Terms, "factors"),
                                       nmeffect, asgn, df.names)
            ns <- names(split)
        }
    }

    for (y in 1:nresp) {
        if(is.null(effects)) {
            nterms <- 0
            df <- ss <- ms <- numeric(0)
            nmrows <- character(0)
        } else {
            df <- ss <- numeric(0)
            nmrows <- character(0)
            for(i in seq(nterms)) {
                ai <- (asgn == uasgn[i])
                df <- c(df, sum(ai))
                ss <- c(ss, sum(effects[ai, y]^2))
                nmi <- nmeffect[1 + uasgn[i]]
                nmrows <- c(nmrows, nmi)
                if(!missing(split) && !is.na(int <- match(nmi, ns))) {
                    df <- c(df, unlist(lapply(split[[int]], length)))
                    if(is.null(nms <- names(split[[int]])))
                        nms <- paste("C", seq(along = split[[int]]), sep = "")
                    ss <- c(ss, unlist(lapply(split[[int]],
                                              function(i, e)
                                              sum(e[i]^2), effects[ai, y])))
                    nmrows <- c(nmrows, paste("  ", nmi, ": ", nms, sep = ""))
                }
            }
        }
        if(rdf > 0) {
            df <- c(df, rdf)
            ss <- c(ss, sum(resid[, y]^2))
            nmrows <- c(nmrows,  "Residuals")
        }
        nt <- length(df)
        ms <- ifelse(df > 0, ss/df, NA)
        x <- list(Df = df, "Sum Sq" = ss, "Mean Sq" = ms)
        if(rdf > 0) {
            TT <- ms/ms[nt]
            TP <- pf(TT, df, rdf, lower.tail = FALSE)
            TT[nt] <- TP[nt] <- NA
            x$"F value" <- TT
            x$"Pr(>F)" <- TP
            ## 'nterms' ~= 'Residuals' have no P-value
        }
        class(x) <- c("anova", "data.frame")
        row.names(x) <- format(nmrows)
        if(!keep.zero.df) x <- x[df > 0, ]
        pm <- pmatch("(Intercept)", row.names(x), 0)
        if(!intercept && pm > 0) x <- x[-pm ,]
        ans[[y]] <- x
    }
    class(ans) <- c("summary.aov", "listof")
    ans
}

print.summary.aov <-
    function(x, digits = max(3, getOption("digits") - 3), symbolic.cor = FALSE,
             signif.stars= getOption("show.signif.stars"),	...)
{
    if (length(x) == 1)  print(x[[1]], ...)
    else NextMethod()
    invisible(x)
}

coef.aov <- function(object, ...)
{
    z <- object$coef
    z[!is.na(z)]
}

alias <- function(object, ...) UseMethod("alias")

alias.formula <- function(object, data, ...)
{
    lm.obj <- if(missing(data)) aov(object) else aov(object, data)
    alias(lm.obj, ...)
}

alias.lm <- function(object, complete = TRUE, partial = FALSE,
                     partial.pattern = FALSE, ...)
{
    CompPatt <- function(x, ...) {
        x[abs(x) < 1e-6] <- 0
        if(exists("fractions", mode="function")) fractions(x)
        else {
            class(x) <- "mtable"
            x[abs(x) < 1e-6] <- NA
            x
        }
    }
    PartPatt <- function(x) {
        z <- zapsmall(x) != 0
        if(any(z)) {
            xx <- abs(signif(x[z], 2))
            ll <- length(unique(xx))
            if(ll > 10) xx <- cut(xx, 9) else if(ll == 1) x[] <- 1
            x[z] <- paste(ifelse(x[z] > 0, " ", "-"), xx, sep = "")
        }
        x[!z] <- ""
        collabs <- colnames(x)
        if(length(collabs)) {
            collabs <- abbreviate(sub("\\.", "", collabs), 3)
        } else  collabs <-1:ncol(x)
        colnames(x) <- collabs
        class(x) <- "mtable"
        x
    }
    Model <- object$terms
    attributes(Model) <- NULL
    value <- list(Model = Model)
    R <- object$qr$qr
    R <- R[1:min(dim(R)),, drop=FALSE]
    R[lower.tri(R)] <- 0
    d <- dim(R)
    rank <- object$rank
    p <- d[2]
    if(complete) {                      # full rank, no aliasing
        value$Complete <-
            if(is.null(p) || rank == p) NULL else {
                p1 <- 1:rank
                X <- R[p1, p1]
                Y <-  R[p1, -p1, drop = FALSE]
                beta12 <- as.matrix(qr.coef(qr(X), Y))
                # dimnames(beta12) <- list(dn[p1], dn[ -p1])
                CompPatt(t(beta12))
            }
    }
    if(partial) {
        tmp <- summary.lm(object)$cov.unscaled
        ses <- sqrt(diag(tmp))
        beta11 <- tmp /outer(ses, ses)
        beta11[row(beta11) >= col(beta11)] <- 0
        beta11[abs(beta11) < 1e-6] <- 0
        if(all(beta11 == 0)) beta11 <- NULL
        else if(partial.pattern) beta11 <- PartPatt(beta11)
        value$Partial <- beta11
    }
    class(value) <- "listof"
    value
}

print.aovlist <- function(x, ...)
{
    cl <- attr(x, "call")
    if(!is.null(cl)) {
        cat("\nCall:\n")
        dput(cl)
    }
    if(!is.null(attr(x, "weights")))
        cat("Note: The results below are on the weighted scale\n")
    nx <- names(x)
    if(nx[1] == "(Intercept)") {
        mn <- x[[1]]$coef
        if(is.matrix(mn)) {
            cat("\nGrand Means:\n")
            print(format(mn[1,]), quote=FALSE)
        } else cat("\nGrand Mean:", format(mn[1]), "\n")
        nx <- nx[-1]
    }
    for(ii in seq(along = nx)) {
        i <- nx[ii]
        cat("\nStratum ", ii, ": ", i, "\n", sep = "")
        xi <- x[[i]]
        print(xi, ...)
    }
    invisible(x)
}

summary.aovlist <- function(object, ...)
{
    if(!is.null(attr(object, "weights")))
        cat("Note: The results below are on the weighted scale\n")
    dots <- list(...)
    strata <- names(object)
    if(strata[1] == "(Intercept)") {
        strata <- strata[-1]
        object <- object[-1]
    }
    x <- vector(length = length(strata), mode = "list")
    names(x) <- paste("Error:", strata)
    for(i in seq(along = strata))
        x[[i]] <- do.call("summary", c(list(object = object[[i]]), dots))
    class(x) <- "summary.aovlist"
    x
}

print.summary.aovlist <- function(x, ...)
{
    nn <- names(x)
    for (i in nn) {
        cat("\n", i, "\n", sep="")
        print(x[[i]], ...)
    }
    invisible(x)
}

coef.listof <- function(object, ...)
{
    val <- vector("list", length(object))
    names(val) <- names(object)
    for(i in seq(along=object)) val[[i]] <- coef(object[[i]])
    class(val) <- "listof"
    val
}

se.contrast <- function(object, ...) UseMethod("se.contrast")

se.contrast.aov <-
    function(object, contrast.obj, coef = contr.helmert(ncol(contrast))[, 1],
             data = NULL, ...)
{
    contrast.weight.aov <- function(object, contrast)
    {
        asgn <- object$assign[object$qr$pivot[1:object$rank]]
        uasgn <- unique(asgn)
        nterms <- length(uasgn)
        nmeffect <- c("(Intercept)",
                      attr(object$terms, "term.labels"))[1 + uasgn]
        effects <- as.matrix(qr.qty(object$qr, contrast))
        res <- matrix(0, nrow = nterms, ncol = ncol(effects),
                      dimnames = list(nmeffect, colnames(contrast)))
        for(i in seq(nterms)) {
            select <- (asgn == uasgn[i])
            res[i,] <- colSums(effects[seq(along=asgn)[select], , drop = FALSE]^2)
        }
        res
    }
    if(is.null(data)) contrast.obj <- eval(contrast.obj)
    else contrast.obj <- eval(substitute(contrast.obj), data, parent.frame())
    if(!is.matrix(contrast.obj)) { # so a list
        if(!missing(coef)) {
            if(sum(coef) != 0)
                stop("coef must define a contrast, i.e., sum to 0")
            if(length(coef) != length(contrast.obj))
                stop("coef must have same length as contrast.obj")
        }
        contrast <-
            sapply(contrast.obj, function(x)
               {
                   if(!is.logical(x))
                       stop(paste("Each element of", substitute(contrasts.list),
                                  " must be\nlogical"))
                   x/sum(x)
               })
        contrast <- contrast %*% coef
        if(!any(contrast) || all(is.na(contrast)))
            stop("The contrast defined is empty (has no TRUE elements)")
    } else {
        contrast <- contrast.obj
        if(any(abs(colSums(contrast)) > 1e-8))
            stop("Columns of contrast.obj must define a contrast (sum to zero)")
        if(length(colnames(contrast)) == 0)
            colnames(contrast) <- paste("Contrast", seq(ncol(contrast)))
    }
    weights <- contrast.weight.aov(object, contrast)
    rdf <- object$df.resid
    resid <- as.matrix(object$residuals)
    wt <- object$weights
    if(!is.null(wt)) resid <- resid * wt^0.5
    rse <- sum(resid^2)/rdf
    if(!is.matrix(contrast.obj)) sqrt(sum(weights) * rse)
    else sqrt(rse * colSums(weights))
}

se.contrast.aovlist <-
    function(object, contrast.obj, coef = contr.helmert(ncol(contrast))[, 1],
             data = NULL, ...)
{
    contrast.weight.aovlist <- function(object, contrast)
    {
        e.qr <- attr(object, "error.qr")
        if(!is.qr(e.qr))
            stop("Argument does not include an error qr component")
        c.qr <- qr.qty(e.qr, contrast)
        e.assign <- attr(e.qr$qr, "assign")
        n.object <- length(object)
        e.assign <- c(e.assign,
                      rep.int(n.object - 1, nrow(c.qr) - length(e.assign)))
        res <- vector(length = n.object, mode = "list")
        names(res) <- names(object)
        for(j in seq(along=names(object))) {
            strata <- object[[j]]
            if(is.qr(strata$qr)) {
                scontrast <- c.qr[e.assign == (j - 1), , drop = FALSE]
                effects <- as.matrix(qr.qty(strata$qr, scontrast))
                asgn <- strata$assign[strata$qr$pivot[1:strata$rank]]
                uasgn <- unique(asgn)
                nm <- c("(Intercept)", attr(strata$terms, "term.labels"))
                res.i <-
                    matrix(0, length(asgn), ncol(effects),
                           dimnames = list(nm[1 + uasgn], colnames(contrast)))
                for(i in seq(along = asgn)) {
                    select <- (asgn == uasgn[i])
                    res.i[i, ] <-
                        colSums(effects[seq(along=asgn)[select], , drop = FALSE]^2)
                }
                res[[j]] <- res.i
            }
        }
        res
    }
    SS <- function(aov.object)
    {
        rdf <- aov.object$df.resid
        if(is.null(rdf)) {
            nobs <- length(aov.object$residuals)
            rank <- aov.object$rank
            rdf <- nobs - rank
        }
        resid <- as.matrix(aov.object$residuals)
        wt <- aov.object$weights
        if(!is.null(wt)) resid <- resid * wt^0.5
        sum(resid^2)/rdf
    }
    if(is.null(attr(object, "error.qr"))) {
        cat("Refitting model to allow projection\n")
        object <- update(object, qr = TRUE)
    }
    contrast.obj <-
        if(is.null(data)) eval(contrast.obj)
        else eval(substitute(contrast.obj), data, parent.frame())
    if(!is.matrix(contrast.obj)) {
        if(!missing(coef)) {
            if(sum(coef) != 0)
                stop("coef must define a contrast, i.e., sum to 0")
            if(length(coef) != length(contrast.obj))
                stop("coef must have same length as contrast.obj")
        }
        contrast <-
            sapply(contrast.obj,
                   function(x) {
                       if(!is.logical(x))
                           stop(paste("Each element of",
                                      substitute(contrast.obj),
                                      " must be\n logical"))
                       x/sum(x)
                   })
        contrast <- contrast %*% coef
        if(!any(contrast))
            stop("The contrast defined is empty (has no TRUE elements)")
    }
    else {
        contrast <- contrast.obj
        if(any(abs(colSums(contrast)) > 1e-8))
            stop("Columns of contrast.obj must define a contrast(sum to zero)")
        if(length(colnames(contrast)) == 0)
            colnames(contrast) <- paste("Contrast", seq(ncol(contrast)))
    }
    weights <- contrast.weight.aovlist(object, contrast)
    weights <- weights[-match("(Intercept)", names(weights))]
    effic <- eff.aovlist(object)
    ## Need to identify the lowest stratum where each nonzero term appears
    eff.used <- apply(effic, 2,
                      function(x, ind = seq(length(x))) {
                          temp <- (x > 0)
                          if(sum(temp) == 1) temp
                          else max(ind[temp]) == ind
                      })
    strata.nms <- rownames(effic)[row(eff.used)[eff.used]]
    var.nms <- colnames(effic)[col(eff.used)[eff.used]]
    rse.list <- sapply(object[unique(strata.nms)], SS)
    wgt <- matrix(0, nrow = length(var.nms), ncol = ncol(contrast),
                  dimnames = list(var.nms, colnames(contrast)))
    for(i in seq(length(var.nms)))
        wgt[i, ] <- weights[[strata.nms[i]]][var.nms[i], , drop = FALSE]
    rse <- rse.list[strata.nms]
    eff <- effic[eff.used]
    drop(sqrt((rse/eff^2) %*% wgt))
}
aperm <- function(a, perm, resize=TRUE)
{
    if (missing(perm))
	perm <- integer(0) # will reverse the order
    .Internal(aperm(a, perm, resize))
}
append <- function (x, values, after = length(x))
{
    lengx <- length(x)
    if (after <= 0)
	c(values, x)
    else if (after >= lengx)
	c(x, values)
    else c(x[1:after], values, x[(after + 1):lengx])
}
apply <- function(X, MARGIN, FUN, ...)
{
    FUN <- match.fun(FUN)

    ## Ensure that X is an array object
    d <- dim(X)
    dl <- length(d)
    if(dl == 0)
	stop("dim(X) must have a positive length")
    ds <- 1:dl
    if(length(oldClass(X)) > 0)
	X <- if(dl == 2) as.matrix(X) else as.array(X)
    dn <- dimnames(X)

    ## Extract the margins and associated dimnames

    s.call <- ds[-MARGIN]
    s.ans  <- ds[MARGIN]
    d.call <- d[-MARGIN]
    d.ans  <- d[MARGIN]
    dn.call<- dn[-MARGIN]
    dn.ans <- dn[MARGIN]
    ## dimnames(X) <- NULL

    ## do the calls

    d2 <- prod(d.ans)
    if(d2 == 0) {
        ## arrays with some 0 extents: return ``empty result'' trying
        ## to use proper mode and dimension:
        ## The following is still a bit `hackish': use non-empty X
        newX <- array(vector(typeof(X), 1), dim = c(prod(d.call), 1))
        ans <- FUN(if(length(d.call) < 2) newX[,1] else
                   array(newX[,1], d.call, dn.call), ...)
        return(if(is.null(ans)) ans else if(length(d.call) < 2) ans[1][-1]
               else array(ans, d.ans, dn.ans))
    }
    ## else
    newX <- aperm(X, c(s.call, s.ans))
    dim(newX) <- c(prod(d.call), d2)
    ans <- vector("list", d2)
    if(length(d.call) < 2) {# vector
        if (length(dn.call)) dimnames(newX) <- c(dn.call, list(NULL))
        for(i in 1:d2) ans[[i]] <- FUN(newX[,i], ...)
    } else
       for(i in 1:d2) ans[[i]] <- FUN(array(newX[,i], d.call, dn.call), ...)
#     if(length(d.call) == 1) {
#         X1 <- newX[,1]
#         if (length(dn.call)) names(X1) <- dn.call[[1]]
#     } else X1 <- array(newX[,1], d.call, dn.call)
#     ans <- .Internal(apply(newX, X1, FUN))

    ## answer dims and dimnames

    ans.list <- is.recursive(ans[[1]])
    l.ans <- length(ans[[1]])

    ans.names <- names(ans[[1]])
    if(!ans.list)
	ans.list <- any(unlist(lapply(ans, length)) != l.ans)
    if(!ans.list && length(ans.names)) {
        all.same <- sapply(ans, function(x) identical(names(x), ans.names))
        if (!all(all.same)) ans.names <- NULL
    }
    len.a <- if(ans.list) d2 else length(ans <- unlist(ans, recursive = FALSE))
    if(length(MARGIN) == 1 && len.a == d2) {
	names(ans) <- if(length(dn.ans[[1]])) dn.ans[[1]] # else NULL
	return(ans)
    }
    if(len.a == d2)
	return(array(ans, d.ans, dn.ans))
    if(len.a > 0 && len.a %% d2 == 0)
	return(array(ans, c(len.a %/% d2, d.ans),
                     if(is.null(dn.ans)) {
                         if(!is.null(ans.names)) list(ans.names,NULL)
                     } else c(list(ans.names), dn.ans)))
    return(ans)
}
### approx() and approxfun() are *very similar* -- keep in sync!

approx <- function(x, y = NULL, xout, method = "linear", n = 50,
                   yleft, yright, rule = 1, f = 0, ties = mean)
{
    x <- xy.coords(x, y)
    y <- x$y
    x <- x$x
    if (!is.numeric(x) || !is.numeric(y))
	stop("x and y must be numeric")
    nx <- length(x)
    if (nx != length(y))
	stop("x and y must have equal lengths")
    method <- pmatch(method, c("linear", "constant"))
    if (is.na(method))
	stop("invalid interpolation method")
    if (nx < 2 && method == "linear")
	stop("approx requires at least two values to interpolate")
    if(any(na <- is.na(x) | is.na(y))) {
	ok <- !na
	x <- x[ok]
	y <- y[ok]
	nx <- length(x)
    }
    if (!identical(ties, "ordered")) {
	if (length(ux <- unique(x)) < nx) {
	    if (missing(ties))
		warning("Collapsing to unique x values")
	    y <- as.vector(tapply(y,x,ties))# as.v: drop dim & dimn.
	    x <- sort(ux)
	    nx <- length(x)
	} else {
	    o <- order(x)
	    x <- x[o]
	    y <- y[o]
	}
    }
    if (nx < 2 && method == "linear")
	stop("need at least two unique non-missing values to interpolate")
    if (missing(yleft))
	yleft <- if (rule == 1) NA else y[1]
    if (missing(yright))
	yright <- if (rule == 1) NA else y[length(y)]
    if (missing(xout)) {
	if (n <= 0)
	    stop("approx requires n >= 1")
	xout <- seq(x[1], x[nx], length = n)
    }
    y <- .C("R_approx", as.double(x), as.double(y), nx, xout = as.double(xout),
	length(xout), as.integer(method), as.double(yleft), as.double(yright),
	as.double(f), NAOK = TRUE, PACKAGE = "base")$xout
    list(x = xout, y = y)
}

approxfun <- function(x, y = NULL, method = "linear",
                      yleft, yright, rule = 1, f = 0, ties = mean)
{
    x <- xy.coords(x, y)
    y <- x$y
    x <- x$x
    if (!is.numeric(x) || !is.numeric(y))
	stop("x and y must be numeric")
    n <- length(x)
    if (n != length(y))
	stop("x and y must have equal lengths")
    method <- pmatch(method, c("linear", "constant"))
    if (is.na(method))
	stop("invalid interpolation method")
    if (n < 2 && method == "linear")
	stop("approx requires at least two values to interpolate")
    if(any(o <- is.na(x) | is.na(y))) {
	o <- !o
	x <- x[o]
	y <- y[o]
	n <- length(x)
    }
    if (!identical(ties, "ordered")) {
	if (length(ux <- unique(x)) < n) {
	    if (missing(ties))
		warning("Collapsing to unique x values")
	    y <- as.vector(tapply(y,x,ties))# as.v: drop dim & dimn.
	    x <- sort(ux)
	    n <- length(x)
	    rm(ux)
	} else {
	    o <- order(x)
	    x <- x[o]
	    y <- y[o]
	}
    }
    if (n < 2 && method == "linear")
	stop("need at least two unique non-missing values to interpolate")
    if (missing(yleft))
	yleft <- if(rule == 1) NA else y[1]
    if (missing(yright))
	yright <- if(rule == 1) NA else y[length(y)]
    rm(o, rule)
    function(v) .C("R_approx", as.double(x), as.double(y),
		   n, xout = as.double(v), length(v), as.integer(method),
		   as.double(yleft), as.double(yright),
		   as.double(f), NAOK = TRUE, PACKAGE = "base")$xout
}

### This is a `variant' of  approx( method = "constant" ) :
findInterval <- function(x, vec, rightmost.closed = FALSE, all.inside = FALSE)
{
  ## Purpose: gives back the indices of  x in vec;  vec[] sorted
  ## -------------------------------------------------------------------------
  ## Author: Martin Maechler, Date:  4 Jan 2002, 10:16
  nx <- length(x)
  if(is.unsorted(vec))
      stop("`vec' must be sorted non-decreasingly")
  .C("find_interv_vec",
     xt = as.double(vec), n = length(vec),
     x  = as.double(x),  nx = nx,
     as.logical(rightmost.closed),
     as.logical(all.inside),
     index = integer(nx),
     DUP = FALSE,
     PACKAGE = "base")$index
}
apropos <- function (what, where = FALSE, mode = "any")
{
    if(!is.character(what))
	what <- as.character(substitute(what))
    x <- character(0)
    check.mode <- mode != "any"
    for (i in seq(search())) {
	ll <- length(li <- ls(pos = i, pattern = what, all.names = TRUE))
	if (ll) {
	    if(check.mode)
		ll <- length(li <- li[sapply(li, function(x)
					     exists(x, where = i,
						    mode = mode, inherits=FALSE))])
	    x <- c(x, if (where) structure(li, names = rep.int(i, ll)) else li)
	}
    }
    x
}

find <- function(what, mode = "any", numeric. = FALSE, simple.words=TRUE) {
    if(!is.character(what))
	what <- as.character(substitute(what))
    if(simple.words)
	what <- gsub("([.[])", "\\\\\\1", paste("^",what,"$", sep=""))
    len.s <- length(sp <- search())
    ind <- logical(len.s)
    if((check.mode <- mode != "any"))
	nam <- character(len.s)
    for (i in 1:len.s) {
	ll <- length(li <- ls(pos = i, pattern = what, all.names = TRUE))
	ind[i] <- ll > 0
	if(ll >= 2) warning(paste(ll, "occurrences in", sp[i]))
	if(check.mode && ind[i]) nam[i] <- li[1]
    }
    ## found name in  search()[ ind ]

    ii <- which(ind)
    if(check.mode && any(ind)) {
	mode.ok <- sapply(ii, function(i) exists(nam[i], where = i,
						 mode = mode, inherits=FALSE))
	ii <- ii[mode.ok]
    }
    if(numeric.) structure(ii, names=sp[ii]) else sp[ii]
}

array <-
function(data = NA, dim = length(data), dimnames = NULL)
{
    data <- as.vector(data)
    vl <- prod(dim)
    if( length(data) != vl  ) {
	t1 <- ceiling(vl/length(data))
	data <- rep.int(data,t1)
	if( length(data) != vl )
	    data <- data[1:vl]
    }
    if(length(dim))
	dim(data) <- dim
    if(is.list(dimnames) && length(dimnames))
	dimnames(data) <- dimnames
    data
}

slice.index <-
function(x, MARGIN)
{
    d <- dim(x)
    if(is.null(d))
        d <- length(x)
    n <- length(d)

    if((length(MARGIN) > 1) || (MARGIN < 1) || (MARGIN > n))
        stop("incorrect value for MARGIN")

    if(any(d == 0)) return(array(integer(0), d))

    y <- rep.int(rep.int(seq(1 : d[MARGIN]),
                 prod(d[seq(length = MARGIN - 1)]) * rep.int(1, d[MARGIN])),
             prod(d[seq(from = MARGIN + 1, length = n - MARGIN)]))
    dim(y) <- d
    y
}
arrows <- function(x0, y0, x1, y1, length=0.25, angle=30, code=2,
		   col=par("fg"), lty=NULL, lwd=par("lwd"), xpd=NULL)
{
 .Internal(arrows(x0, y0,
		  x1, y1,
		  length=length,
		  angle=angle,
		  code=code,
		  col=col,
		  lty=lty,
		  lwd=lwd,
		  xpd=xpd))
}
as.logical <- function(x,...) UseMethod("as.logical")
as.logical.default<-function(x,...) .Internal(as.vector(x,"logical"))

as.integer <- function(x,...) UseMethod("as.integer")
as.integer.default <- function(x,...) .Internal(as.vector(x,"integer"))

as.double <- function(x,...) UseMethod("as.double")
as.double.default <- function(x,...) .Internal(as.vector(x,"double"))
as.real <- as.double

as.complex <- function(x,...) UseMethod("as.complex")
as.complex.default <- function(x,...) .Internal(as.vector(x, "complex"))

as.single <- function(x,...) UseMethod("as.single")
as.single.default <- function(x,...) {
    structure(.Internal(as.vector(x,"double")), Csingle=TRUE)
}

# as.character is now internal.  The default method remains here to
# preserve the semantics that for a call with an object argument
# dispatching is done first on as.character and then on as.vector.
as.character.default <- function(x,...) .Internal(as.vector(x,"character"))

as.expression <- function(x,...) UseMethod("as.expression")
as.expression.default <- function(x,...) .Internal(as.vector(x,"expression"))

as.list <- function(x,...) UseMethod("as.list")
as.list.default <- function (x,...)
{
    if (is.function(x))
	return(c(formals(x), list(body(x))))
    if (is.expression(x)) {
	n <- length(x)
	l <- vector("list", n)
	i <- 0
	for (sub in x) l[[i <- i + 1]] <- sub
	return(l)
    }
    .Internal(as.vector(x, "list"))
}
## FIXME:  Really the above  as.vector(x, "list")  should work for data.frames!
as.list.data.frame <- function(x,...) {
    x <- unclass(x)
    attr(x,"row.names") <- NULL
    x
}

##as.vector dispatches internally so no need for a generic
as.vector <- function(x, mode="any") .Internal(as.vector(x,mode))
as.matrix <- function(x) UseMethod("as.matrix")
as.matrix.default <- function(x) {
    if (is.matrix(x))
	x
    else
	array(x, c(length(x),1),
	      if(!is.null(names(x))) list(names(x), NULL) else NULL)
}
as.null <- function(x,...) UseMethod("as.null")
as.null.default <- function(x,...) NULL

as.function <- function(x,...) UseMethod("as.function")
as.function.default <- function (x, envir = parent.frame(), ...)
    if (is.function(x)) x else .Internal(as.function.default(x, envir))

as.array <- function(x)
{
    if(is.array(x))
	return(x)
    n <- names(x)
    dim(x) <- length(x)
    if(length(n)) dimnames(x) <- list(n)
    return(x)
}

as.symbol <- function(x) .Internal(as.vector(x, "symbol"))
as.name <- as.symbol
## would work too: as.name <- function(x) .Internal(as.vector(x, "name"))

## as.call <- function(x) stop("type call cannot be assigned")
as.numeric <- as.double
as.qr <- function(x) stop("you cannot be serious")
## as.ts <- function(x) if(is.ts(x)) x else ts(x) # in ts.R
as.formula <- function(object,env=parent.frame()){
    if(inherits(object, "formula"))
           object
    else{
        rval<-formula(object,env=NULL)
        if (is.null(environment(rval)) || !missing(env))
            environment(rval)<-env
        rval
    }
}
assign <-
    function (x, value, pos = -1, envir = as.environment(pos),
              inherits = FALSE, immediate = TRUE)
    .Internal(assign(x, value, envir, inherits))
assocplot <- function(x, col = c("black", "red"), space = 0.3,
                      main = NULL, xlab = NULL, ylab = NULL)
{
    if(length(dim(x)) != 2)
        stop("x must be a 2-d contingency table")
    if(any(x < 0) || any(is.na(x)))
        stop("all entries of x must be nonnegative and finite")
    if((n <- sum(x)) == 0)
        stop("at least one entry of x must be positive")
    if(length(col) != 2)
        stop("incorrect color specification")

    f <- x[ , rev(1:NCOL(x))]           # rename for convenience;
                                        # f is observed freqs
                                        # reverse to be consistent with
                                        # mosaicplot().
    e <- outer(rowSums(f), colSums(f), "*") / n
                                        # e is expected freqs
    d <- (f - e) / sqrt(e)              # Pearson residuals
    e <- sqrt(e)
    x.w <- apply(e, 1, max)             # the widths of the x columns
    y.h <- apply(d, 2, max) - apply(d, 2, min)
                                        # the heights of the y rows
    x.delta <- mean(x.w) * space
    y.delta <- mean(y.h) * space
    xlim <- c(0, sum(x.w) + NROW(f) * x.delta)
    ylim <- c(0, sum(y.h) + NCOL(f) * y.delta)
    plot.new()
    plot.window(xlim, ylim, log = "")
    x.r <- cumsum(x.w + x.delta)
    x.m <- (c(0, x.r[-NROW(f)]) + x.r) / 2
    y.u <- cumsum(y.h + y.delta)
    y.m <- y.u - apply(pmax(d, 0), 2, max) - y.delta / 2
    z <- expand.grid(x.m, y.m)
    rect(z[, 1] - e / 2, z[, 2],
         z[, 1] + e / 2, z[, 2] + d,
         col = col[1 + (d < 0)])
    axis(1, at = x.m, labels = rownames(f), tick = FALSE)
    axis(2, at = y.m, labels = colnames(f), tick = FALSE)
    abline(h = y.m, lty = 2)
    ndn <- names(dimnames(f))
    if(length(ndn) == 2) {
        if(is.null(xlab))
            xlab <- ndn[1]
        if(is.null(ylab))
            ylab <- ndn[2]
    }
    title(main = main, xlab = xlab, ylab = ylab)
}
attach <- function(what, pos=2, name=deparse(substitute(what)))
{
    if (is.character(what) && (length(what)==1)){
        if (!file.exists(what))
            stop(paste("File", what, " not found.", sep=""))
        name<-paste("file:", what, sep="")
        value <- .Internal(attach(NULL, pos, name))
        load(what, envir=as.environment(pos))
    }
    else
        value <- .Internal(attach(what, pos, name))
    if((length(objects(envir = value, all=TRUE)) > 0)
       && .isMethodsDispatchOn())
      cacheMetaData(value, TRUE)
    invisible(value)
}

detach <- function(name, pos=2, version)
{
    if(!missing(name)) {
        name <- substitute(name)# when a name..
	pos <-
	    if(is.numeric(name))
                name
	    else {
                if (!is.character(name))
                    name <- deparse(name)
                if (!missing(version))
                    name <- manglePackageName(name, version)
                match(name, search())
            }
	if(is.na(pos))
	    stop("invalid name")
    }
    env <- as.environment(pos)
    packageName <- search()[[pos]]
    if(exists(".Last.lib", mode = "function", where = pos, inherits=FALSE)) {
        .Last.lib <- get(".Last.lib",  mode = "function", pos = pos,
                         inherits=FALSE)
        libpath <- attr(env, "path")
        if(!is.null(libpath)) try(.Last.lib(libpath))
    }
    .Internal(detach(pos))
    ## check for detaching a  package required by another package (not by .GlobalEnv
    ## because detach() can't currently fix up the .required there)
    for(pkgs in search()[-1]) {
        if(!isNamespace(as.environment(pkgs)) &&
           exists(".required", pkgs, inherits = FALSE) &&
           packageName %in% paste("package:", get(".required", pkgs, inherits = FALSE),sep=""))
            warning(packageName, " is required by ", pkgs, " (still attached)")
    }
    if(.isMethodsDispatchOn()) {
        if("package:methods" %in% search())
            cacheMetaData(env, FALSE)
        else
            .isMethodsDispatchOn(FALSE)
    }
}

ls <- objects <-
    function (name, pos = -1, envir = as.environment(pos), all.names = FALSE,
              pattern)
{
    if (!missing(name)) {
        nameValue <- try(name)
        if(identical(class(nameValue), "try-error")) {
            name <- substitute(name)
            if (!is.character(name))
                name <- deparse(name)
            pos <- name
        }
        else
            pos <- nameValue
    }
    all.names <- .Internal(ls(envir, all.names))
    if (!missing(pattern)) {
        if ((ll <- length(grep("[", pattern, fixed=TRUE))) > 0 &&
            ll != length(grep("]", pattern, fixed=TRUE))) {
            if (pattern == "[") {
                pattern <- "\\["
                warning("replaced regular expression pattern `[' by `\\\\['")
            }
            else if (length(grep("[^\\\\]\\[<-", pattern) > 0)) {
                pattern <- sub("\\[<-", "\\\\\\[<-", pattern)
                warning("replaced `[<-' by `\\\\[<-' in regular expression pattern")
            }
        }
        grep(pattern, all.names, value = TRUE)
    }
    else all.names
}
"mostattributes<-" <- function(obj, value) {
    if(length(value)) {
	if(!is.list(value)) stop("RHS must be list")
	if(h.nam <- !is.na(inam <- match("names", names(value)))) {
	    n1 <- value[[inam]];	value <- value[-inam] }
	if(h.dim <- !is.na(idin <- match("dim", names(value)))) {
	    d1 <- value[[idin]];	value <- value[-idin] }
	if(h.dmn <- !is.na(idmn <- match("dimnames", names(value)))) {
	    dn1 <- value[[idmn]];	value <- value[-idmn] }
	attributes(obj) <- value
        dm <- dim(obj)
	if(h.nam && is.null(dm) && length(obj) == length(n1))
	    names(obj) <- n1
	if(h.dim && length(obj) == prod(d1))
	    dim(obj) <- dm <- d1
	if(h.dmn && !is.null(dm)) {
            ddn <- sapply(dn1, length)
            if( all((dm == ddn)[ddn > 0]) ) dimnames(obj) <- dn1
        }
    }
    obj
}
autoload <- function(name, package, ...)
{
    if (exists(name, envir = .GlobalEnv, inherits = FALSE))
	stop("Object with that name already exists")
    m <- match.call()
    m[[1]] <- as.name("list")
    newcall <- eval(m, parent.frame())
    newcall <- as.call(c(as.name("autoloader"), newcall))
    if (is.na(match(package, .Autoloaded)))
	assign(".Autoloaded", c(package, .Autoloaded), env =.AutoloadEnv)
    assign(name, do.call("delay", list(newcall)), env = .AutoloadEnv)
    ## no longer return the result, which is a promise
    invisible()
}

autoloader <- function (name, package, ...)
{
    name <- paste(name, "", sep = "")
    rm(list = name, envir = .AutoloadEnv, inherits = FALSE)
    m <- match.call()
    m$name <- NULL
    m[[1]] <- as.name("library")
    ## load the package
    eval(m, .GlobalEnv)
    ## reset the autoloader
    autoload(name, package, ...)
    ## reevaluate the object
    where <- match(paste("package", package, sep = ":"), search())
    if (exists(name, where = where, inherits = FALSE))
	eval(as.name(name), as.environment(where))
    else
	stop(paste("autoloader didn't find `", name, "' in `", package,
                   "'.", sep = ""))
}
ave <- function (x, ..., FUN = mean)
{
    n <- length(l <- list(...))
    x[] <- if (n) {
        g <- 1
        nlv <- 1
        for (i in 1:n) {
            l[[i]] <- li <- factor(l[[i]])# maybe dropping levels
            g <- g + nlv * (as.numeric(li) - 1)
            nlv <- nlv * length(levels(li))
        }
        unlist(lapply(split(x, g), FUN))[g]
    } else FUN(x)
    x
}
axis <- function(side, at=NULL, labels=TRUE, tick=TRUE, line=NA, pos=NA,
                 outer=FALSE, font=NA, vfont=NULL,
                 lty = "solid", lwd = 1, col=NULL, ...) {
    if (!is.null(vfont))
	vfont <- c(typeface = pmatch(vfont[1], Hershey$typeface) - 1,
		   fontindex= pmatch(vfont[2], Hershey$fontindex))
    if(is.null(col) && length(list(...)) && !is.null(fg <- list(...)$fg)) {
        ## help(par) `fg' says this should work
        col <- fg
    }
    .Internal(axis(side, at, labels, tick, line, pos, outer, font, vfont,
                   lty, lwd, col, ...))
}

axTicks <- function(side, axp=NULL, usr=NULL, log=NULL) {
    ## Compute tickmark "at" values which axis(side) would use by default;
    ## using par("Xaxp") , par("usr") & par("Xlog") where X = x|y
    ## an R version of internal CreateAtVector()
    if(!(side <- as.integer(side)) %in% 1:4)
        stop("`side' must be in {1:4}")
    is.x <- side %% 2 == 1
    XY <- function(ch) paste(if(is.x) "x" else "y", ch, sep="")
    if(is.null(axp)) axp <- par(XY("axp"))
    else if(!is.numeric(axp) || length(axp) != 3) stop("invalid `axp'")
    if(is.null(log)) log <- par(XY("log"))
    else if(!is.logical(log) || any(is.na(log))) stop("invalid `log'")
    if(log && axp[3] > 0) { ## special log-scale axp[]
        if(!any((iC <- as.integer(axp[3])) == 1:3))
            stop("invalid positive axp[3]")
        if(is.null(usr)) usr <- par("usr")[if(is.x) 1:2 else 3:4]
        else if(!is.numeric(usr) || length(usr) != 2) stop("invalid `usr'")
        ii <- round(log10(axp[1:2]))
        x10 <- 10^((ii[1] - (iC >= 2)):ii[2])
	r <- switch(iC,				## axp[3]
		    x10,			## 1
		    c(outer(c(1,  5), x10))[-1],## 2
                    c(outer(c(1,2,5), x10))[-1])## 3
        r[usr[1] <= log10(r) & log10(r) <= usr[2]]
    } else { # linear
        seq(axp[1], axp[2], length = 1 + abs(axp[3]))
    }
}


bquote<-function(expr, where=parent.frame()){

    
    unquote<-function(e){

        if (length(e)<=1)
            e
        else if (e[[1]]==as.name("."))
            eval(e[[2]],where)
        else
            as.call(lapply(e,unquote))
        
    }

    unquote(substitute(expr))

}

forwardsolve <- function(l, x, k=ncol(l), upper.tri = FALSE, transpose = FALSE)
    backsolve(l,x, k=k, upper.tri= upper.tri, transpose= transpose)

backsolve <- function(r, x, k=ncol(r), upper.tri = TRUE, transpose = FALSE)
{
    r <- as.matrix(r)# nr  x  k
    storage.mode(r) <- "double"
    x.mat <- is.matrix(x)
    if(!x.mat) x <- as.matrix(x)# k  x	nb
    storage.mode(x) <- "double"
    k <- as.integer(k)
    if(k <= 0 || nrow(x) != k) stop("invalid parameters in backsolve")
    nb <- ncol(x)
    upper.tri <- as.logical(upper.tri)
    transpose <- as.logical(transpose)
    job <- as.integer((upper.tri) + 10*(transpose))
    z <- .C("bakslv",
	    t  = r, ldt= nrow(r), n  = k,
	    b  = x, ldb= k,	  nb = nb,
	    x  = matrix(0, k, nb),
	    job = job,
	    info = integer(1),
	    DUP = FALSE, PACKAGE = "base")[c("x","info")]
    if(z$info != 0)
	stop(paste("singular matrix in backsolve. First zero in diagonal [",
		   z$info,"].",sep=""))
    if(x.mat) z$x else drop(z$x)
}
#### copyright (C) 1994-2001 W. N. Venables and B. D. Ripley

#====           bandwidth selection rules              ====

bw.nrd0 <- function (x)
{
    if(length(x) < 2) stop("need at least 2 data points")
    hi <- sd(x)
    if(!(lo <- min(hi, IQR(x)/1.34)))# qnorm(.75) - qnorm(.25) = 1.34898
        (lo <- hi) || (lo <- abs(x[1])) || (lo <- 1.)
    0.9 * lo * length(x)^(-0.2)
}

bw.nrd <- function (x)
{
    if(length(x) < 2) stop("need at least 2 data points")
    r <- quantile(x, c(0.25, 0.75))
    h <- (r[2] - r[1])/1.34
    1.06 * min(sqrt(var(x)), h) * length(x)^(-1/5)
}

bw.SJ <- function(x, nb = 1000, lower = 0.1*hmax, upper = hmax,
                  method = c("ste", "dpi"))
{
    if((n <- length(x)) < 2) stop("need at least 2 data points")
    if(!is.numeric(x)) stop("invalid x")
    storage.mode(x) <- "double"
    method <- match.arg(method)

    fSD <- function(h, x, alph2, c1, n, d)
        (c1/SDh(x, alph2 * h^(5/7), n, d))^(1/5) - h
    SDh <- function(x, h, n, d)
        .C("band_phi4_bin",
           as.integer(n),
           as.integer(length(x)),
           as.double(d),
           x,
           as.double(h),
           u = double(1),
           PACKAGE="base")$u
    TDh <- function(x, h, n, d)
        .C("band_phi6_bin",
           as.integer(n),
           as.integer(length(x)),
           as.double(d),
           x,
           as.double(h),
           u = double(1),
           PACKAGE="base")$u

    Z <- .C("band_den_bin",
            as.integer(n),
            as.integer(nb),
            d = double(1),
            x,
            cnt = integer(nb),
            PACKAGE="base")
    d <- Z$d; cnt <- as.integer(Z$cnt)
    hmax <- 1.144 * sqrt(var(x)) * n^(-1/5)
    scale <- min(sqrt(var(x)), IQR(x)/1.349)
    a <- 1.24 * scale * n^(-1/7)
    b <- 1.23 * scale * n^(-1/9)
    c1 <- 1/(2*sqrt(pi)*n)
    TD  <- -TDh(cnt, b, n, d)
    if(!is.finite(TD) || TD <= 0)
        stop("sample is too sparse to find TD")
    if(method == "dpi")
        res <- (c1/SDh(cnt,(2.394/(n * TD))^(1/7) , n, d))^(1/5)
    else {
        alph2 <- 1.357*(SDh(cnt, a, n, d)/TD)^(1/7)
        if(!is.finite(alph2))
            stop("sample is too sparse to find alph2")
        if (fSD(lower, cnt, alph2, c1, n, d) *
            fSD(upper, cnt, alph2, c1, n, d) > 0)
            stop("No solution in the specified range of bandwidths")
        res <- uniroot(fSD, c(lower, upper), tol=0.1*lower,
                       x=cnt, alph2=alph2, c1=c1, n=n, d=d)$root
    }
    res
}


bw.ucv <- function(x, nb = 1000, lower = 0.1*hmax, upper = hmax)
{
    if((n <- length(x)) < 2) stop("need at least 2 data points")
    if(!is.numeric(x)) stop("invalid x")

    fucv <- function(h, x, n, d)
        .C("band_ucv_bin",
           as.integer(n),
           as.integer(length(x)),
           as.double(d),
           x,
           as.double(h),
           u = double(1),
           PACKAGE="base")$u

    hmax <- 1.144 * sqrt(var(x)) * n^(-1/5)
    storage.mode(x) <- "double"
    Z <- .C("band_den_bin",
            as.integer(n),
            as.integer(nb),
            d = double(1),
            x,
            cnt = integer(nb),
            PACKAGE="base"
            )
    d <- Z$d; cnt <- as.integer(Z$cnt)
    h <- optimize(fucv, c(lower, upper), tol=0.1*lower,
                  x=cnt, n=n, d=d)$minimum
    if(h < 1.1*lower | h > upper-0.1*lower)
        warning("minimum occurred at one end of the range")
    h
}

bw.bcv <- function(x, nb = 1000, lower = 0.1*hmax, upper = hmax)
{
    if((n <- length(x)) < 2) stop("need at least 2 data points")
    if(!is.numeric(x)) stop("invalid x")

    fbcv <- function(h, x, n, d)
        .C("band_bcv_bin",
           as.integer(n),
           as.integer(length(x)),
           as.double(d),
           x,
           as.double(h),
           u = double(1),
           PACKAGE="base")$u

    hmax <- 1.144 * sqrt(var(x)) * n^(-1/5)
    storage.mode(x) <- "double"
    Z <- .C("band_den_bin",
            as.integer(n),
            as.integer(nb),
            d = double(1),
            x,
            cnt = integer(nb),
            PACKAGE="base"
            )
    d <- Z$d; cnt <- as.integer(Z$cnt)
    h <- optimize(fbcv, c(lower, upper), tol=0.1*lower,
                  x=cnt, n=n, d=d)$minimum
    if(h < 1.1*lower | h > upper-0.1*lower)
        warning("minimum occurred at one end of the range")
    h
}
barplot <- function(height, ...) UseMethod("barplot")

barplot.default <-
function(height, width = 1, space = NULL, names.arg = NULL,
	 legend.text = NULL, beside = FALSE, horiz = FALSE,
	 density = NULL, angle = 45,
	 col = heat.colors(NR), border = par("fg"),
	 main = NULL, sub = NULL, xlab = NULL, ylab = NULL,
	 xlim = NULL, ylim = NULL, xpd = TRUE,
	 axes = TRUE, axisnames = TRUE,
	 cex.axis = par("cex.axis"), cex.names = par("cex.axis"),
	 inside = TRUE, plot = TRUE, axis.lty = 0, ...)
{
    if (!missing(inside)) .NotYetUsed("inside", error = FALSE)# -> help(.)

    if (missing(space))
	space <- if (is.matrix(height) && beside) c(0, 1) else 0.2
    space <- space * mean(width)

    if (plot && axisnames && missing(names.arg))
	names.arg <-
	    if(is.matrix(height)) colnames(height) else names(height)

    if (is.vector(height)) {
	height <- cbind(height)
	beside <- TRUE
    } else if (is.array(height) && (length(dim(height)) == 1)) {
	height <- rbind(height)
	beside <- TRUE
    } else if (!is.matrix(height))
	stop(paste(sQuote("height"), "must be a vector or a matrix"))

    if(is.logical(legend.text))
	legend.text <-
	    if(legend.text && is.matrix(height)) rownames(height)

    NR <- nrow(height)
    NC <- ncol(height)

    if (beside) {
	if (length(space) == 2)
	    space <- rep.int(c(space[2], rep.int(space[1], NR - 1)), NC)
	width <- rep(width, length = NR * NC)
    } else {
	width <- rep(width, length = NC)
	height <- rbind(0, apply(height, 2, cumsum))
    }
    delta <- width / 2
    w.r <- cumsum(space + width)
    w.m <- w.r - delta
    w.l <- w.m - delta
    if (horiz) {
	if (missing(xlim)) xlim <- range(-0.01 * height, height, na.rm=TRUE)
	if (missing(ylim)) ylim <- c(min(w.l), max(w.r))
    } else {
	if (missing(xlim)) xlim <- c(min(w.l), max(w.r))
	if (missing(ylim)) ylim <- range(-0.01 * height, height, na.rm=TRUE)
    }
    if (beside)
	w.m <- matrix(w.m, nc = NC)
    if(plot) { ##-------- Plotting :
	opar <-
	    if (horiz)	par(xaxs = "i", xpd = xpd)
	    else	par(yaxs = "i", xpd = xpd)
	on.exit(par(opar))

	plot.new()
	plot.window(xlim, ylim, log = "", ...)
	xyrect <- function(x1,y1, x2,y2, horizontal = TRUE, ...) {
	    if(horizontal)
		rect(x1,y1, x2,y2, ...)
	    else
		rect(y1,x1, y2,x2, ...)
	}
	if (beside)
	    xyrect(0, w.l, c(height), w.r, horizontal = horiz,
		   angle = angle, density = density, col = col, border = border)
	else {
	    ## noInside <- NC > 1 && !inside # outside border, but not inside
	    ## bordr <- if(noInside) 0 else border
	    for (i in 1:NC) {
		xyrect(height[1:NR, i], w.l[i], height[-1, i], w.r[i],
		       horizontal = horiz, angle = angle, density = density,
		       col = col, border = border)# = bordr
                ## if(noInside)
                ##  xyrect(min(height[, i]), w.l[i], max(height[, i]), w.r[i],
                ##         horizontal = horiz, border= border)
	    }
	}
	if (axisnames && !is.null(names.arg)) { # specified or from {col}names
	    at.l <- if (length(names.arg) != length(w.m)) {
		if (length(names.arg) == NC) # i.e. beside (!)
		    colMeans(w.m)
		else
		    stop("incorrect number of names")
	    } else w.m
	    axis(if(horiz) 2 else 1, at = at.l, labels = names.arg,
		 lty = axis.lty, cex.axis = cex.names, ...)
	}
	if(!is.null(legend.text)) {
	    legend.col <- rep(col, length = length(legend.text))
	    if((horiz & beside) || (!horiz & !beside)){
		legend.text <- rev(legend.text)
		legend.col <- rev(legend.col)
		density <- rev(density)
		angle <- rev(angle)
	    }
	    xy <- par("usr")
	    legend(xy[2] - xinch(0.1), xy[4] - yinch(0.1),
		   legend = legend.text, angle = angle, density = density,
		   fill = legend.col, xjust = 1, yjust = 1)
	}
	title(main = main, sub = sub, xlab = xlab, ylab = ylab, ...)
	if(axes) axis(if(horiz) 1 else 2, cex.axis = cex.axis, ...)
	invisible(w.m)
    } else w.m
}
lockEnvironment <- function(env, bindings = FALSE)
    .Internal(lockEnvironment(env, bindings))

environmentIsLocked <- function(env)
    .Internal(environmentIsLocked(env))

lockBinding <- function(sym, env) {
    if (is.character(sym)) sym <- as.name(sym)
    .Internal(lockBinding(sym, env))
}

bindingIsLocked <- function(sym, env) {
    if (is.character(sym)) sym <- as.name(sym)
    .Internal(bindingIsLocked(sym, env))
}

makeActiveBinding <- function(sym, fun, env) {
    if (is.character(sym)) sym <- as.name(sym)
    .Internal(makeActiveBinding(sym, fun, env))
}

bindingIsActive <- function(sym, env) {
    if (is.character(sym)) sym <- as.name(sym)
    .Internal(bindingIsActive(sym, env))
}

unlockBinding <- function(sym, env) {
    if (is.character(sym)) sym <- as.name(sym)
    .Internal(unlockBinding(sym, env))
}

qbirthday<-function(prob=0.5,classes=365,coincident=2){
  k<-coincident
  c<-classes
  p<-prob
  if (p<=0) return(1)
  if (p>=1) return(c*(k-1)+1)
  if ((k-1)*log(c)>8){
      lNapprox<-((k-1)*log(c)+lgamma(k+1)+log(-log(1-p)))/k
      N<-exp(lNapprox)
  } else{
      N<-(c^(k-1)*gamma(k+1)*log(1/(1-p)))^(1/k)
  }
  round(N)
}

pbirthday<-function(n,classes=365,coincident=2){
    k<-coincident
    c<-classes
    if (coincident<2) return(1)
    if (coincident>n) return(0)
    if (n>classes) return(1)
    eps<-1e-14
    if (qbirthday(1-eps,classes,coincident)<=n)
        return(1-eps)
    f<-function(p) qbirthday(p,c,k)-n
    ##lower<-min(n/(c^(k-1)),1-10*eps)
    lower<-0
    upper<-min(n^k/(c^(k-1)),1)
    nmin<-uniroot(f,c(lower,upper),tol=eps)
    nmin$root
}

box <- function(which="plot", lty="solid", ...)
{
    which <- pmatch(which[1], c("plot", "figure", "inner", "outer"))
    .Internal(box(which=which, lty=lty, ...))
}
boxplot <- function(x, ...) UseMethod("boxplot")

boxplot.default <-
function(x, ..., range = 1.5, width = NULL, varwidth = FALSE,
         notch = FALSE, outline = TRUE, names, boxwex = 0.8, plot = TRUE,
         border = par("fg"), col = NULL, log = "", pars = NULL,
         horizontal = FALSE, add = FALSE, at = NULL)
{
    args <- list(x, ...)
    namedargs <-
	if(!is.null(attributes(args)$names))
	    attributes(args)$names != ""
	else
	    rep(FALSE, length = length(args))
    pars <- c(args[namedargs], pars)
    groups <- if(is.list(x)) x else args[!namedargs]
    if(0 == (n <- length(groups)))
	stop("invalid first argument")
    if(length(class(groups)))
	groups <- unclass(groups)
    if(!missing(names))
	attr(groups, "names") <- names
    else {
	if(is.null(attr(groups, "names")))
	    attr(groups, "names") <- 1:n
        names <- attr(groups, "names")
    }
    for(i in 1:n)
	groups[i] <- list(boxplot.stats(groups[[i]], range)) # do.conf=notch)
    stats <- matrix(0,nr=5,nc=n)
    conf  <- matrix(0,nr=2,nc=n)
    ng <- out <- group <- numeric(0)
    ct <- 1
    for(i in groups) {
	stats[,ct] <- i$stats
        conf [,ct] <- i$conf
        ng <- c(ng, i$n)
        if((lo <- length(i$out))) {
            out   <- c(out,i$out)
            group <- c(group, rep.int(ct, lo))
        }
        ct <- ct+1
    }
    z <- list(stats = stats, n = ng, conf = conf, out = out, group = group,
              names = names)
    if(plot) {
	bxp(z, width, varwidth = varwidth, notch = notch, boxwex = boxwex,
            border = border, col = col, log = log, pars = pars,
            outline = outline, horizontal = horizontal, add = add, at = at)
	invisible(z)
    }
    else z
}

boxplot.formula <- function(formula, data = NULL, ..., subset)
{
    if(missing(formula) || (length(formula) != 3))
        stop("formula missing or incorrect")
    m <- match.call(expand.dots = FALSE)
    if(is.matrix(eval(m$data, parent.frame())))
        m$data <- as.data.frame(data)
    m$... <- NULL
    m[[1]] <- as.name("model.frame")
    mf <- eval(m, parent.frame())
    response <- attr(attr(mf, "terms"), "response")
    boxplot(split(mf[[response]], mf[-response]), ...)
}

boxplot.stats <- function(x, coef = 1.5, do.conf=TRUE, do.out=TRUE)
{
    nna <- !is.na(x)
    n <- sum(nna)                       # including +/- Inf
    stats <- fivenum(x, na.rm = TRUE)
    iqr <- diff(stats[c(2, 4)])
    if(coef < 0) stop(paste(sQuote("coef"), "must not be negative"))
    if(coef == 0)
	do.out <- FALSE
    else {                              # coef > 0
	out <- x < (stats[2] - coef * iqr) | x > (stats[4] + coef * iqr)
	if(any(out[nna])) stats[c(1, 5)] <- range(x[!out], na.rm = TRUE)
    }
    conf <- if(do.conf)
	stats[3] + c(-1.58, 1.58) * diff(stats[c(2, 4)]) / sqrt(n)
    list(stats = stats, n = n, conf = conf,
	 out = if(do.out) x[out & nna] else numeric(0))
}

bxp <- function(z, notch=FALSE, width=NULL, varwidth=FALSE,
	        outline = TRUE, notch.frac = 0.5, boxwex = 0.8,
		border=par("fg"), col=NULL, log="", pars=NULL,
                frame.plot = axes,
                horizontal = FALSE, add = FALSE, at = NULL, show.names=NULL,
                ...)
{
    pars <- c(pars, list(...))

    bplt <- function(x, wid, stats, out, conf, notch, border, col,
                     horizontal, xlog)
    {
	## Draw single box plot
	if(!any(is.na(stats))) {
            ## stats = +/- Inf:	polygon & segments should handle

            ## Compute 'x + w' -- "correctly" in log-coord. case:
            xP <-
                if(xlog) function(x,w) x * exp(w)
                else function(x,w) x + w
	    wid <- wid/2
            if (notch) {
                xx <- xP(x, wid * c(-1, 1, 1, notch.frac, 1,
                                    1, -1,-1,-notch.frac,-1))
                yy <- c(stats[c(2, 2)], conf[1], stats[3], conf[2],
                        stats[c(4, 4)], conf[2], stats[3], conf[1])
            }
            else {
                xx <- xP(x, wid * c(-1, 1, 1, -1))
                yy <- stats[c(2, 2, 4, 4)]
            }
            if(!notch) notch.frac <- 1
            wntch <- notch.frac*wid
            if (horizontal) {
                polygon(yy, xx, col = col, border = border)
                segments(stats[3], xP(x, -wntch),
                         stats[3], xP(x, +wntch), col = border)
                segments(stats[c(1, 5)], rep.int(x, 2),
                         stats[c(2, 4)], rep.int(x, 2), lty= "dashed", col= border)
                segments(stats[c(1, 5)], rep.int(xP(x, -wid/2), 2),
                         stats[c(1, 5)], rep.int(xP(x, +wid/2), 2), col = border)
                do.call("points",c(list(out, rep.int(x, length(out))), pt.pars))
            }
            else { ## vertical
                polygon(xx, yy, col=col, border=border)
                segments(xP(x, -wntch), stats[3],
                         xP(x, +wntch), stats[3], col=border)
                segments(rep.int(x,2), stats[c(1,5)],
                         rep.int(x,2), stats[c(2,4)], lty= "dashed",col= border)
                segments(rep.int(xP(x, -wid/2), 2), stats[c(1,5)],
                         rep.int(xP(x, +wid/2), 2), stats[c(1,5)], col=border)
                do.call("points",c(list(rep.int(x,length(out)), out), pt.pars))
            }
	    if(any(inf <- !is.finite(out))) {
		## FIXME: should MARK on plot !! (S-plus doesn't either)
		warning(paste("Outlier (",
			      paste(unique(out[inf]),collapse=", "),
			      ") in ", paste(x,c("st","nd","rd","th")
					     [pmin(4,x)], sep=""),
			      " boxplot are NOT drawn", sep=""))
	    }
	}
    }## bplt

    if(!is.list(z) || 0 == (n <- length(z$n)))
	stop("invalid first argument")
    if(is.null(at))
        at <- 1:n
    else if(length(at) != n)
        stop(paste(sQuote("at"), " must have same length as ",
                   sQuote("z $ n"), ", i.e. ", n,
                   sep = ""))
    ## just for compatibility with S
    if(is.null(z$out))
        z$out <- numeric()
    if(is.null(z$group) || !outline)
        z$group <- integer()
    if(is.null(pars$ylim))
	ylim <- range(z$stats[is.finite(z$stats)],
		      z$out  [is.finite(z$out)],
		      if(notch)
		      z$conf [is.finite(z$conf)])
    else {
	ylim <- pars$ylim
	pars$ylim <- NULL
    }

    if(missing(border) || length(border)==0)
	border <- par("fg")
    pt.pars <- c(pars[names(pars) %in% c("pch", "cex", "bg")], col = border)

    if (!add) {
    	plot.new()
    	## shall we switch log for horizontal with
        ## switch(log, x="y", y="x", log) ??
    	if (horizontal)
            plot.window(ylim = c(0.5, n + 0.5), xlim = ylim, log = log)
        else
            plot.window(xlim = c(0.5, n + 0.5), ylim = ylim, log = log)
    }
    xlog <- (par("ylog") && horizontal) || (par("xlog") && !horizontal)
    ## default boxwex depends on xlog
    if(missing(boxwex))
        boxwex <- 0.8 * {
            if(n <= 1) 1 else
            quantile(diff(sort(if(xlog)log(at) else at)), 0.10) }

    width <-
	if(!is.null(width)) {
	    if(length(width) != n | any(is.na(width)) | any(width <= 0))
		stop("invalid boxplot widths")
	    boxwex * width/max(width)
	}
	else if(varwidth) boxwex * sqrt(z$n/max(z$n))
	else if(n == 1) 0.5 * boxwex
	else rep.int(boxwex, n)
    for(i in 1:n)
	bplt(at[i], wid=width[i],
	     stats= z$stats[,i],
	     out  = z$out[z$group==i],
	     conf = z$conf[,i],
	     notch= notch,
	     border=border[(i-1)%%length(border)+1],
	     col = if(is.null(col)) col else col[(i-1)%%length(col)+1],
             horizontal = horizontal, xlog = xlog)

    axes <- is.null(pars$axes)
    if(!axes) { axes <- pars$axes; pars$axes <- NULL }
    if(axes) {
        ax.pars <- pars[names(pars) %in% c("xaxt", "yaxt", "las", "cex.axis")]
        if (is.null(show.names)) show.names <- n > 1
        if (show.names)
            do.call("axis", c(list(side = 1 + horizontal,
                                   at = at, labels = z$names), ax.pars))
        do.call("axis", c(list(side = 2 - horizontal), ax.pars))
    }
    do.call("title", pars)
    if(frame.plot)
        box()
    invisible(at)
}
bug.report <- function(subject = "", ccaddress = Sys.getenv("USER"),
                       method = getOption("mailer"),
                       address = "r-bugs@r-project.org",
                       file = "R.bug.report")
{
    methods <- c("mailx", "gnudoit", "none", "ess")

    method <-
	if(is.null(method)) "none"
	else methods[pmatch(method, methods)]

    body <- paste("\\n<<insert bug report here>>\\n\\n\\n\\n",
		  "--please do not edit the information below--\\n\\n",
		  "Version:\\n ",
		  paste(names(R.version),R.version, sep=" = ",collapse="\\n "),
		  "\\n\\n",
		  "Search Path:\\n ",
		  paste(search(), collapse=", "),
		  "\\n", sep="", collapse="")

    if(method == "gnudoit") {
	cmd <- paste("gnudoit -q '",
		     "(mail nil \"", address, "\")",
		     "(insert \"", body, "\")",
		     "(search-backward \"Subject:\")",
		     "(end-of-line)'",
		     sep="")
	system(cmd)
    }
    else if(method=="none"){

        disclaimer <-
            paste("# Your mailer is set to \"none\" (default on Windows),\n",
                  "# hence we cannot send the bug report directly from R.\n",
                  "# Please copy the bug report (after finishing it) to\n",
                  "# your favorite email program and send it to\n#\n",
                  "#       ", address, "\n#\n",
                  "######################################################\n",
                  "\n\n", sep = "")


        cat(disclaimer, file=file)
	body <- gsub("\\\\n", "\n", body)
	cat(body, file=file, append=TRUE)
	system(paste(getOption("editor"), file))
        cat("The unsent bug report can be found in file", file, "\n")
    }
    else if(method == "mailx"){

        if(missing(subject))
            stop("Subject missing")

	body <- gsub("\\\\n", "\n", body)
	cat(body, file=file, append=FALSE)
	system(paste(getOption("editor"), file))

        if(is.character(ccaddress) && nchar(ccaddress)>0) {
            cmdargs <- paste("-s '", subject, "' -c", ccaddress,
                             address, "<", file, "2>/dev/null")
        }
        else
            cmdargs <- paste("-s '", subject, "'", address, "<",
                             file, "2>/dev/null")

        status <- 1

        cat("Submit the bug report? ")
        answer <- readline()
        answer <- grep("y", answer, ignore.case=TRUE)
        if(length(answer)>0){
            cat("Sending email ...\n")
            status <- system(paste("mailx", cmdargs))
            if(status > 0)
                status <- system(paste("Mail", cmdargs))
            if(status > 0)
                status <- system(paste("/usr/ucb/mail", cmdargs))

            if(status==0) unlink(file)
            else{
                cat("Sending email failed!\n")
                cat("The unsent bug report can be found in file",
                    file, "\n")
            }

        }
        else
            cat("The unsent bug report can be found in file",
                file, "\n")

    }
    else if(method=="ess"){
	body <- gsub("\\\\n", "\n", body)
	cat(body)
    }
}
builtins <- function(internal=FALSE)
    .Internal(builtins(internal))
by <- function(data, INDICES, FUN, ...) UseMethod("by")

by.default <- function(data, INDICES, FUN, ...)
    by(as.data.frame(data), INDICES, FUN, ...)

by.data.frame <- function(data, INDICES, FUN, ...)
{
    if(!is.list(INDICES)) { # record the names for print.by
        IND <- vector("list", 1)
        IND[[1]] <- INDICES
        names(IND) <- deparse(substitute(INDICES))
    } else IND <- INDICES
    FUNx <- function(x) FUN(data[x,], ...)
    nd <- nrow(data)
    ans <- eval(substitute(tapply(1:nd, IND, FUNx)), data)
    attr(ans, "call") <- match.call()
    class(ans) <- "by"
    ans
}

print.by <- function(x, ..., vsep)
{
    d <- dim(x)
    dn <- dimnames(x)
    dnn <- names(dn)
    if(missing(vsep))
        vsep <- paste(rep("-", 0.75*getOption("width")), collapse = "")
    lapply(seq(along = x), function(i, x, labs, vsep, ...) {
        if(i != 1 && !is.null(vsep)) cat(vsep, "\n")
        ii <- i - 1
        for(j in seq(along = dn)) {
            iii <- ii %% d[j] + 1; ii <- ii %/% d[j]
            cat(dnn[j], ": ", dn[[j]][iii], "\n", sep = "")
        }
        print(x[[i]], ...)
    } , x, labs, vsep, ...)
    invisible(x)
}
"capture.output" <-
  function(...,file=NULL,append=FALSE){

    args<-substitute(list(...))[-1]

    if (is.null(file)){
      file<-textConnection("rval",ifelse(append,"a","w"), local=TRUE)
      sink(file)
      on.exit({sink();close(file)})
    }else if (inherits(file,"connection")){
	rval<-invisible(NULL)
	if (!isOpen(file)){
	  open(file,ifelse(append,"a","w"))
	  sink(file)
	  on.exit({sink();close(file)})  
	} else{
	   sink(file) 
	   on.exit(sink())
	}
    } else {
      file <- file(file, ifelse(append,"a","w"))
      rval <- invisible(NULL)
      sink(file)
      on.exit({sink();close(file)})
    } 
    
    pf<-parent.frame()
    evalVis<-function(expr)
      .Internal(eval.with.vis(expr, pf, NULL))

    for(i in seq(length=length(args))){
      expr<-args[[i]]
      if(mode(expr)=="expression")
        tmp<-lapply(expr, evalVis)
      else if (mode(expr)=="call")
        tmp<-list(evalVis(expr))
      else if (mode(expr)=="name")
          tmp<-list(evalVis(expr))
      else stop("Bad argument")
    
      for(item in tmp){
        if (item$visible)
          print(item$value)
      }
    }
    rval
  }
cat <- function(..., file = "", sep = " ", fill = FALSE,
                labels = NULL, append = FALSE)
{
    if(is.character(file))
        if(file == "") file <- stdout()
        else if(substring(file, 1, 1) == "|") {
            file <- pipe(substring(file, 2), "w")
            on.exit(close(file))
        } else {
            file <- file(file, ifelse(append, "a", "w"))
            on.exit(close(file))
        }
    .Internal(cat(list(...), file, sep, fill, labels, append))
}
strsplit <- function(x, split, extended = TRUE)
    .Internal(strsplit(x, as.character(split), as.logical(extended)))

substr <- function(x, start, stop)
    .Internal(substr(x, as.integer(start), as.integer(stop)))

substring <- function(text,first,last=1000000)
{
    storage.mode(text) <- "character"
    n <- max(lt <- length(text), length(first), length(last))
    if(lt < n) text <- rep(text, length = n)
    substr(text, first, last)
}

"substr<-" <- function(x, start, stop, value)
    .Internal(substrgets(x, as.integer(start), as.integer(stop), value))

"substring<-" <- function(text, first, last=1000000, value)
{
    "substr<-"(text, first, last, value)
}

abbreviate <-
    function(names.arg, minlength = 4, use.classes = TRUE, dot = FALSE)
{
    ## we just ignore use.classes
    if(minlength <= 0)
	return(rep.int("", length(names.arg)))
    names.arg <- as.character(names.arg)
    dups <- duplicated(names.arg)
    old <- names.arg
    if(any(dups))
	names.arg <- names.arg[!dups]
    dup2 <- rep.int(TRUE, length(names.arg))
    x <- these <- names.arg
    repeat {
	ans <- .Internal(abbreviate(these,minlength,use.classes))
	x[dup2] <- ans
	dup2 <- duplicated(x)
	if(!any(dup2))
	    break
	minlength <- minlength+1
	dup2 <- dup2 | match(x, x[dup2], 0)
	these <- names.arg[dup2]
    }
    if(any(dups))
	x <- x[match(old,names.arg)]
    if(dot) { # add "." where we did abbreviate:
        chgd <- x != old
	x[chgd] <- paste(x[chgd],".",sep = "")
    }
    names(x) <- old
    x
}

make.names <- function(names, unique = FALSE)
{
    names <- .Internal(make.names(as.character(names)))
    ## append `.' to keyword
    i <- is.element(names, c("for", "while", "repeat", "if",
                             "else", "function", "next", "break",
                             "TRUE", "FALSE", "NULL", "NA", "Inf", "NaN"))
    if(any(i)) names[i] <- paste(names[i], ".", sep = "")
    if(unique) names <- make.unique(names)
    names
}

# make.unique <- function (names, sep = ".")
# {
#     if (!is.character(names))
#         stop("names must be a character vector")
#     cnt <- 1
#     repeat {
#         i <- which(duplicated(names))
#         if (length(i) == 0) break
#         j <- i[!duplicated(names[i])]
#         newnames <- paste(names[j], cnt, sep=sep)
#         ok<- !(newnames %in% names) & !duplicated(newnames)
#         names[j][ok] <- newnames[ok]
#         if (identical(i, j) && all(ok)) break
#         cnt <- cnt + 1
#       }
#     names
# }

make.unique <- function (names, sep = ".") .Internal(make.unique(names, sep))

chartr <- function(old, new, x) .Internal(chartr(old, new, x))
tolower <- function(x) .Internal(tolower(x))
toupper <- function(x) .Internal(toupper(x))

casefold <- function(x, upper = FALSE)
    if(upper) toupper(x) else tolower(x)

sQuote <- function(x) {
    if(length(x) == 0) return(character())
    paste("'", x, "'", sep = "")
}
dQuote <- function(x) {
    if(length(x) == 0) return(character())
    paste("\"", x, "\"", sep = "")
}
chol <- function(x, pivot = FALSE, LINPACK = pivot)
{
    if (is.complex(x))
        stop("complex matrices not permitted at present")
    else if(!is.numeric(x))
	stop("non-numeric argument to chol")

    if(is.matrix(x)) {
	if(nrow(x) != ncol(x))
	    stop("non-square matrix in chol")
	n <- nrow(x)
    }
    else {
	if(length(x) != 1)
	    stop("non-matrix argument to chol")
	n <- as.integer(1)
    }
    if(!pivot && !LINPACK) return(.Call("La_chol", as.matrix(x), PACKAGE = "base"))

    if(!is.double(x)) storage.mode(x) <- "double"

    if(pivot) {
        xx <- x
        xx[lower.tri(xx)] <- 0
        z <- .Fortran("dchdc",
                      x = xx,
                      n,
                      n,
                      double(n),
                      piv = as.integer(rep.int(0, n)),
                      as.integer(pivot),
                      rank = integer(1),
                      DUP = FALSE, PACKAGE = "base")
        if (!pivot && z$rank < n)
            stop("matrix not positive definite")
        robj <- z$x
        if (pivot) {
            attr(robj, "pivot") <- z$piv
            attr(robj, "rank") <- z$rank
        }
        robj
    } else {
        z <- .Fortran("chol",
                      x = x,
                      n,
                      n,
                      v = matrix(0, nr=n, nc=n),
                      info = integer(1),
                      DUP = FALSE, PACKAGE = "base")
        if(z$info)
            stop("non-positive definite matrix in chol")
        z$v
    }
}

chol2inv <- function(x, size=NCOL(x), LINPACK=FALSE)
{
    if(!is.numeric(x))
	stop("non-numeric argument to chol2inv")
    if(!LINPACK) return(La.chol2inv(x, size))

    if(is.matrix(x)) {
	nr <- nrow(x)
	nc <- ncol(x)
    }
    else {
	nr <- length(x)
	nc <- as.integer(1)
    }
    size <- as.integer(size)
    if(size <= 0 || size > nr || size > nc)
	stop("invalid size argument in chol2inv")
    if(!is.double(x)) storage.mode(x) <- "double"
    z <- .Fortran("ch2inv",
		  x=x,
		  nr,
		  size,
		  v=matrix(0, nr=size, nc=size),
		  info=integer(1),
		  DUP=FALSE, PACKAGE="base")
    if(z$info)
	stop("singular matrix in chol2inv")
    z$v
}
chull <- function(x, y=NULL)
{
    X <- xy.coords(x, y, recycle = TRUE)
    x <- cbind(X$x, X$y)
    n <- nrow(x)
    if(n == 0) return(integer(0))
    z <- .C("R_chull",
	    n=as.integer(n),
	    as.double(x),
	    as.integer(n),
	    as.integer(1:n),
	    integer(n),
	    integer(n),
	    ih=integer(n),
	    nh=integer(1),
	    il=integer(n),
	    PACKAGE="base")
    rev(z$ih[1:z$nh])
}
colSums <- function(x, na.rm = FALSE, dims = 1)
{
    if(is.data.frame(x)) x <- as.matrix(x)
    if(!is.array(x) || length(dn <- dim(x)) < 2)
        stop("`x' must be an array of at least two dimensions")
    if(dims < 1 || dims > length(dn) - 1)
        stop("invalid `dims'")
    n <- prod(dn[1:dims])
    dn <- dn[-(1:dims)]
    z <- if(is.complex(x))
        .Internal(colSums(Re(x), n, prod(dn), na.rm)) +
            1i * .Internal(colSums(Im(x), n, prod(dn), na.rm))
    else .Internal(colSums(x, n, prod(dn), na.rm))
    if(length(dn) > 1) {
        dim(z) <- dn
        dimnames(z) <- dimnames(x)[-(1:dims)]
    } else names(z) <- dimnames(x)[[dims+1]]
    z
}

colMeans <- function(x, na.rm = FALSE, dims = 1)
{
    if(is.data.frame(x)) x <- as.matrix(x)
    if(!is.array(x) || length(dn <- dim(x)) < 2)
        stop("`x' must be an array of at least two dimensions")
    if(dims < 1 || dims > length(dn) - 1)
        stop("invalid `dims'")
    n <- prod(dn[1:dims])
    dn <- dn[-(1:dims)]
    z <- if(is.complex(x))
        .Internal(colMeans(Re(x), n, prod(dn), na.rm)) +
            1i * .Internal(colMeans(Im(x), n, prod(dn), na.rm))
    else .Internal(colMeans(x, n, prod(dn), na.rm))
    if(length(dn) > 1) {
        dim(z) <- dn
        dimnames(z) <- dimnames(x)[-(1:dims)]
    } else names(z) <- dimnames(x)[[dims+1]]
    z
}

rowSums <- function(x, na.rm = FALSE, dims = 1)
{
    if(is.data.frame(x)) x <- as.matrix(x)
    if(!is.array(x) || length(dn <- dim(x)) < 2)
        stop("`x' must be an array of at least two dimensions")
    if(dims < 1 || dims > length(dn) - 1)
        stop("invalid `dims'")
    p <- prod(dn[-(1:dims)])
    dn <- dn[1:dims]
    z <- if(is.complex(x))
        .Internal(rowSums(Re(x), prod(dn), p, na.rm)) +
            1i * .Internal(rowSums(Im(x), prod(dn), p, na.rm))
    else .Internal(rowSums(x, prod(dn), p, na.rm))
    if(length(dn) > 1) {
        dim(z) <- dn
        dimnames(z) <- dimnames(x)[1:dims]
    } else  names(z) <- dimnames(x)[[1]]
    z
}

rowMeans <- function(x, na.rm = FALSE, dims = 1)
{
    if(is.data.frame(x)) x <- as.matrix(x)
    if(!is.array(x) || length(dn <- dim(x)) < 2)
        stop("`x' must be an array of at least two dimensions")
    if(dims < 1 || dims > length(dn) - 1)
        stop("invalid `dims'")
    p <- prod(dn[-(1:dims)])
    dn <- dn[1:dims]
    z <- if(is.complex(x))
        .Internal(rowMeans(Re(x), prod(dn), p, na.rm)) +
            1i * .Internal(rowMeans(Im(x), prod(dn), p, na.rm))
    else .Internal(rowMeans(x, prod(dn), p, na.rm))
    if(length(dn) > 1) {
        dim(z) <- dn
        dimnames(z) <- dimnames(x)[1:dims]
    } else  names(z) <- dimnames(x)[[1]]
    z
}
colors <- function() .Internal(colors())
colours <- colors
col2rgb <- function(col) .Internal(col2rgb(col))

gray <- function(level) .Internal(gray(level))
grey <- gray

rgb <- function(red, green, blue, names=NULL, maxColorValue = 1)
{
    ## in the first case, (r,g,b) are (coerced to) integer, otherwise
    ## double.
    if(maxColorValue == 255)
        .Internal(rgb256(red, green, blue, names))
    else .Internal(rgb(red, green, blue, maxColorValue, names))
}

hsv <- function(h=1,s=1,v=1,gamma=1)
    .Internal(hsv(h,s,v,gamma))

palette <- function(value)
{
    if(missing(value)) .Internal(palette(character()))
    else invisible(.Internal(palette(value)))
}

## A quick little ``rainbow'' function -- improved by MM
## doc in	../man/palettes.Rd
rainbow <-
    function (n, s = 1, v = 1, start = 0, end = max(1,n - 1)/n, gamma = 1)
{
    if ((n <- as.integer(n[1])) > 0) {
	if(start == end || any(c(start,end) < 0)|| any(c(start,end) > 1))
	    stop("`start' and `end' must be distinct and in [0,1].")
	hsv(h = seq(start, ifelse(start > end, 1, 0) + end, length= n) %% 1,
	    s, v, gamma)
    } else character(0)
}

topo.colors <- function (n)
{
    if ((n <- as.integer(n[1])) > 0) {
	j <- n %/% 3
	k <- n %/% 3
	i <- n - j - k
	c(if(i > 0) hsv(h= seq(from = 43/60, to = 31/60, length = i)),
	  if(j > 0) hsv(h= seq(from = 23/60, to = 11/60, length = j)),
	  if(k > 0) hsv(h= seq(from = 10/60, to =  6/60, length = k),
			s= seq(from = 1,     to = 0.3,	 length = k), v = 1))
    } else character(0)
}

terrain.colors <- function (n)
{
    if ((n <- as.integer(n[1])) > 0) {
	k <- n%/%2
	h <- c(4/12, 2/12, 0/12)
	s <- c(1, 1, 0)
	v <- c(0.65, 0.9, 0.95)
	c(hsv(h = seq(h[1], h[2], length = k),
	      s = seq(s[1], s[2], length = k),
	      v = seq(v[1], v[2], length = k)),
	  hsv(h = seq(h[2], h[3], length = n - k + 1)[-1],
	      s = seq(s[2], s[3], length = n - k + 1)[-1],
	      v = seq(v[2], v[3], length = n - k + 1)[-1]))
    } else character(0)
}

heat.colors <- function (n)
{
    if ((n <- as.integer(n[1])) > 0) {
	j <- n %/% 4
	i <- n - j
	c(rainbow(i, start = 0, end = 1/6),
	  if (j > 0)
	  hsv(h = 1/6, s = seq(from= 1-1/(2*j), to= 1/(2*j), length = j),
	      v = 1))
    } else character(0)
}

cm.colors <- function (n)
{
    if ((n <- as.integer(n[1])) > 0) {
	even.n <- n %% 2 == 0
	k <- n%/%2
	l1 <- k + 1 - even.n
	l2 <- n - k + even.n
	c(if(l1 > 0)
	  hsv(h =  6/12, s= seq(.5, ifelse(even.n,.5/k,0), length = l1), v = 1),
	  if(l2 > 1)
	  hsv(h = 10/12, s= seq(0, 0.5, length = l2)[-1], v = 1))
    } else character(0)
}
complete.cases <- function(...) .Internal(complete.cases(...))
##
## Handling Conditions
##

tryCatch <- function(expr, ..., finally) {
    tryCatchList <- function(expr, names, parentenv, handlers) {
	nh <- length(names)
	if (nh > 1)
	    tryCatchOne(tryCatchList(expr, names[-nh], parentenv,
                                     handlers[-nh]),
			names[nh], parentenv, handlers[[nh]])
	else if (nh == 1)
	    tryCatchOne(expr, names, parentenv, handlers[[1]])
	else expr
    }
    tryCatchOne <- function(expr, name, parentenv, handler) {
	doTryCatch <- function(expr, name, parentenv, handler) {
	    .Internal(.addCondHands(name, list(handler), parentenv,
				    environment(), FALSE))
	    expr
	}
	value <- doTryCatch(return(expr), name, parentenv, handler)
	# The return in the call above will exit withOneRestart unless
	# the handler is invoked; we only get to this point if the handler
	# is invoked.  If we get here then the handler will have been
	# popped off the internal handler stack.
	if (is.null(value[[1]])) {
	    # a simple error; message is stored internally
	    # and call is in result; this defers all allocs until
	    # after the jump
	    msg <- .Internal(geterrmessage())
	    call <- value[[2]]
	    cond <- simpleError(msg, call)
	}
	else cond <- value[[1]]
	value[[3]](cond)
    }
    if (! missing(finally))
        on.exit(finally)
    handlers <- list(...)
    classes <- names(handlers)
    parentenv <- parent.frame()
    if (length(classes) != length(handlers))
        stop("bad handler specification")
    tryCatchList(expr, classes, parentenv, handlers)
}

withCallingHandlers <- function(expr, ...) {
    handlers <- list(...)
    classes <- names(handlers)
    parentenv <- parent.frame()
    if (length(classes) != length(handlers))
        stop("bad handler specification")
    .Internal(.addCondHands(classes, handlers, parentenv, NULL, TRUE))
    expr
}

suppressWarnings <- function(expr) {
    withCallingHandlers(expr,
                        warning=function(w)
                            invokeRestart("muffleWarning"))
}


##
## Conditions and Condition Signaling
##

simpleCondition <- function(message, call = NULL) {
    class <- c("simpleCondition", "condition")
    structure(list(message=as.character(message), call = call), class=class)
}

simpleError <- function(message, call = NULL) {
    class <- c("simpleError", "error", "condition")
    structure(list(message=as.character(message), call = call), class=class)
}

simpleWarning <- function(message, call = NULL) {
    class <- c("simpleWarning", "warning", "condition")
    structure(list(message=as.character(message), call = call), class=class)
}

conditionMessage <- function(c) UseMethod("conditionMessage")
conditionCall <- function(c) UseMethod("conditionCall")

conditionMessage.condition <- function(c) c$message
conditionCall.condition <- function(c) c$call

print.condition <- function(x, ...) {
    msg <- conditionMessage(x)
    call <- conditionCall(x)
    cl <- class(x)[1]
    if (! is.null(call))
        cat("<", cl, " in ", deparse(call), ": ", msg, ">\n", sep="")
    else
        cat("<", cl, ": ", msg, ">\n", sep="")
}

as.character.condition <- function(x, ...) {
    msg <- conditionMessage(x)
    call <- conditionCall(x)
    cl <- class(x)[1]
    if (! is.null(call))
        paste(cl, " in ", deparse(call)[1], ": ", msg, "\n", sep="")
    else
        paste(cl, ": ", msg, "\n", sep="")
}

as.character.error <- function(x, ...) {
    msg <- conditionMessage(x)
    call <- conditionCall(x)
    if (! is.null(call))
        paste("Error in ", deparse(call)[1], ": ", msg, "\n", sep="")
    else
        paste("Error: ", msg, "\n", sep="")
}

signalCondition <- function(cond) {
    if (! inherits(cond, "condition"))
        cond <- simpleCondition(cond)
    msg <- conditionMessage(cond)
    call <- conditionCall(cond)
    .Internal(.signalCondition(cond, msg, call))
}


##
##  Restarts
##

restartDescription <- function(r) r$description
restartFormals <- function(r) formals(r$handler)

print.restart <- function(x, ...)
     cat(paste("<restart:", x[[1]], ">\n"))

isRestart <- function(x) inherits(x, "restart")

findRestart <- function(name, cond = NULL) {
    i <- 1
    repeat {
        r <- .Internal(.getRestart(i))
        if (is.null(r))
            return(NULL)
        else if (name == r[[1]] &&
                 (is.null(cond) || is.null(r$test) || r$test(cond)))
            return(r)
        else i <- i + 1
    }
}

computeRestarts <- function(cond = NULL) {
    val <- NULL
    i <- 1
    repeat {
        r <- .Internal(.getRestart(i))
        if (is.null(r))
            return(val)
        else if (is.null(cond) || is.null(r$test) || r$test(cond))
            val <- c(val, list(r))
        i <- i + 1
    }
}

invokeRestart <- function(r, ...) {
    if (! isRestart(r)) {
        res <- findRestart(r)
        if (is.null(res))
            stop(paste("no restart", sQuote(r), "found"))
        r <- res
    }
    .Internal(.invokeRestart(r, list(...)))
}

invokeRestartInteractively <- function(r) {
    if (! interactive())
        stop("not an interactive session")
    if (! isRestart(r)) {
        res <- findRestart(r)
        if (is.null(res))
            stop(paste("no restart", sQuote(r), "found"))
        r <- res
    }
    if (is.null(r$interactive)) {
        pars <- names(restartFormals(r))
        args <- NULL
        if (length(pars) > 0) {
            cat("Enter values for restart arguments:\n\n")
            for (p in pars) {
            if (p == "...") {
		    prompt <- "... (a list): "
		    args <- c(args, eval(parse(prompt = prompt)))
		}
		else {
		    prompt <- paste(p, ": ", sep="")
		    args <- c(args, list(eval(parse(prompt = prompt))))
		}
	    }
	}
    }
    else args <- r$interactive()
    .Internal(.invokeRestart(r, args))
}

withRestarts <- function(expr, ...) {
    docall <- function(fun, args) {
	enquote <- function(x) as.call(list(as.name("quote"), x))
	if ((is.character(fun) && length(fun) == 1) || is.name(fun))
	    fun <- get(as.character(fun), env = parent.frame(),
                       mode = "function")
	do.call("fun", lapply(args, enquote))
    }
    makeRestart <- function(name = "",
			   handler = function(...) NULL,
			   description = "",
			   test = function(c) TRUE,
			   interactive = NULL) {
	structure(list(name = name, exit = NULL, handler = handler,
		       description = description, test = test,
		       interactive = interactive),
		  class = "restart")
    }
    makeRestartList <- function(...) {
        specs <- list(...)
        names <- names(specs)
        restarts <- vector("list", length(specs))
        for (i in seq(along = specs)) {
            spec <- specs[[i]]
            name <- names[i]
            if (is.function(spec))
                restarts[[i]] <- makeRestart(handler = spec)
            else if (is.character(spec))
                restarts[[i]] <- makeRestart(description = spec)
            else if (is.list(spec))
                restarts[[i]] <- docall("makeRestart", spec)
            else
               stop("not a valid restart specification")
            restarts[[i]]$name <- name
        }
        restarts
    }
    withOneRestart <- function(expr, restart) {
	doWithOneRestart <- function(expr, restart) {
	    restart$exit <- environment()
	    .Internal(.addRestart(restart))
	    expr
	}
	restartArgs <- doWithOneRestart(return(expr), restart)
	# The return in the call above will exit withOneRestart unless
	# the restart is invoked; we only get to this point if the restart
	# is invoked.  If we get here then the restart will have been
	# popped off the internal restart stack.
	docall(restart$handler, restartArgs)
    }
    withRestartList <- function(expr, restarts) {
	nr <- length(restarts)
	if (nr > 1)
	    withOneRestart(withRestartList(expr, restarts[-nr]),
                           restarts[[nr]])
	else if (nr == 1)
	    withOneRestart(expr, restarts[[1]])
	else expr
    }
    restarts <- makeRestartList(...)
    if (length(restarts) == 0)
        expr
    else if (length(restarts) == 1)
        withOneRestart(expr, restarts[[1]])
    else withRestartList(expr, restarts)
}


##
## Callbacks
##

.signalSimpleWarning <- function(msg, call)
    withRestarts({
           .Internal(.signalCondition(simpleWarning(msg, call), msg, call))
           .Internal(.dfltWarn(msg, call))
        }, muffleWarning = function() NULL)

.handleSimpleError <- function(h, msg, call)
    h(simpleError(msg, call))
confint <- function(object, parm, level = 0.95, ...) UseMethod("confint")

confint.lm <- function(object, parm, level = 0.95, ...)
{
    cf <- coef(object)
    pnames <- names(cf)
    if(missing(parm)) parm <- seq(along=pnames)
    else if(is.character(parm))  parm <- match(parm, pnames, nomatch = 0)
    a <- (1-level)/2
    a <- c(a, 1-a)
    pct <- paste(round(100*a, 1), "%")
    ci <- array(NA, dim = c(length(parm), 2),
                dimnames = list(pnames[parm], pct))
    ses <- sqrt(diag(vcov(object)))[parm]
    fac <- qt(a, object$df.residual)
    ci[] <- cf[parm] + ses %o% fac
    ci
}
conflicts <- function(where=search(), detail = FALSE)
{
    if(length(where) < 1) stop("argument where of length 0")
    z <- vector(length(where), mode="list")
    names(z) <- where
    for(i in seq(along=where))
	z[[i]] <- objects(pos=i)
    all <- unlist(z, use.names=FALSE)
    dups <- duplicated(all)
    dups <- all[dups]
    if(detail) {
	for(i in where)
	    z[[i]] <- z[[i]][match(dups, z[[i]], 0)]
	z[sapply(z, function(x) length(x)==0)] <- NULL
	z
    } else dups
}
stdin <- function() .Internal(stdin())
stdout <- function() .Internal(stdout())
stderr <- function() .Internal(stderr())

readLines <- function(con = stdin(), n = -1, ok = TRUE)
{
    if(is.character(con)) {
        con <- file(con, "r")
        on.exit(close(con))
    }
    .Internal(readLines(con, n, ok))
}


writeLines <- function(text, con = stdout(), sep = "\n")
{
    if(is.character(con)) {
        con <- file(con, "w")
        on.exit(close(con))
    }
    invisible(.Internal(writeLines(text, con, sep)))
}

open <- function(con, ...)
    UseMethod("open")

open.connection <- function(con, open = "r", blocking = TRUE, ...)
{
    invisible(.Internal(open(con, open, blocking)))
}

isOpen <- function(con, rw = "")
{
    rw <- pmatch(rw, c("read", "write"), 0)
    .Internal(isOpen(con, rw))
}

isIncomplete <- function(con)
    .Internal(isIncomplete(con))

isSeekable <- function(con)
    .Internal(isSeekable(con))

close <- function(con, ...)
    UseMethod("close")

close.connection <- function (con, type = "rw", ...)
    invisible(.Internal(close(con, type)))

flush <- function(con) UseMethod("flush")

flush.connection <- function (con)
    invisible(.Internal(flush(con)))

file <- function(description = "", open = "", blocking = TRUE,
                 encoding = getOption("encoding"))
    .Internal(file(description, open, blocking, encoding))

pipe <- function(description, open = "", encoding = getOption("encoding"))
    .Internal(pipe(description, open, encoding))

fifo <- function(description = "", open = "", blocking = FALSE,
                 encoding = getOption("encoding"))
    .Internal(fifo(description, open, blocking, encoding))

url <- function(description, open = "", blocking = TRUE,
                encoding = getOption("encoding"))
    .Internal(url(description, open, blocking, encoding))

gzfile <- function(description, open = "",
                   encoding = getOption("encoding"), compression = 6)
    .Internal(gzfile(description, open, encoding, compression))

unz <- function(description, filename, open = "",
                encoding = getOption("encoding"))
    .Internal(unz(paste(description, filename, sep=":"), open, encoding))

bzfile <- function(description, open = "", encoding = getOption("encoding"))
    .Internal(bzfile(description, open, encoding))

socketConnection <- function(host= "localhost", port, server = FALSE,
                             blocking = FALSE, open = "a+",
                             encoding = getOption("encoding"))
    .Internal(socketConnection(host, port, server, blocking, open, encoding))

textConnection <- function(object, open = "r", local = FALSE) {
    if (local) env <- parent.frame()
    else env <- .GlobalEnv
    .Internal(textConnection(deparse(substitute(object)), object, open, env))
}

seek <- function(con, ...)
    UseMethod("seek")

seek.connection <- function(con, where = NA, origin = "start", rw = "", ...)
{
    origin <- pmatch(origin, c("start", "current", "end"))
    rw <- pmatch(rw, c("read", "write"), 0)
    if(is.na(origin))
        stop("`origin' must be one of `start', `current` or `end'")
    .Internal(seek(con, as.integer(where), origin, rw))
}

truncate <- function(con, ...)
    UseMethod("truncate")

truncate.connection <- function(con, ...)
{
    if(!isOpen(con)) stop("can only truncate an open connection")
    .Internal(truncate(con))
}

pushBack <- function(data, connection, newLine = TRUE)
    invisible(.Internal(pushBack(data, connection, newLine)))

pushBackLength <- function(connection)
    .Internal(pushBackLength(connection))

print.connection <- function(x, ...)
{
    print(unlist(summary(x)))
    invisible(x)
}

summary.connection <- function(object, ...)
    .Internal(summary.connection(object))

showConnections <- function(all = FALSE)
{
    set <- getAllConnections()
    if(!all) set <- set[set > 2]
    ans <- matrix("", length(set), 7)
    for(i in seq(along=set)) ans[i, ] <- unlist(summary.connection(set[i]))
    rownames(ans) <- set
    colnames(ans) <- c("description", "class", "mode", "text", "isopen",
                       "can read", "can write")
    if(!all) ans[ans[, 5] == "opened", , drop = FALSE]
    else ans[, , drop = FALSE]
}

getAllConnections <- function()
    .Internal(getAllConnections())

getConnection <- function(what)
{
    set <- getAllConnections()
    if(what %in% set) structure(what, class="connection")
    else NULL
}

closeAllConnections <- function()
{
    # first re-divert any diversion of stderr.
    i <- sink.number(type = "message")
    if(i > 0) sink(stderr(), type = "message")
    # now unwind the sink diversion stack.
    n <- sink.number()
    if(n > 0) for(i in 1:n) sink()
    # get all the open connections.
    set <- getAllConnections()
    set <- set[set > 2]
    # and close all user connections.
    for(i in seq(along=set)) close(getConnection(set[i]))
    invisible()
}

readBin <- function(con, what, n = 1, size = NA, signed = TRUE,
                    endian = .Platform$endian)
{
    if(is.character(con)) {
        con <- file(con, "rb")
        on.exit(close(con))
    }
    swap <- endian != .Platform$endian
    if(!is.character(what) || length(what) != 1 
    	|| !(what %in% c("numeric", "double", "integer",
    		"int", "logical", "complex", "character"))) what <- typeof(what)
    .Internal(readBin(con, what, n, size, signed, swap))
}

writeBin <- function(object, con, size = NA, endian = .Platform$endian)
{
    swap <- endian != .Platform$endian
    if(!is.vector(object) || mode(object) == "list")
        stop("can only write vector objects")
    if(is.character(con)) {
        con <- file(con, "wb")
        on.exit(close(con))
    }
    invisible(.Internal(writeBin(object, con, size, swap)))
}

## encoding vectors
native.enc <- 0:255
# rest in Rprofile.*

readChar <- function(con, nchars)
{
    if(is.character(con)) {
        con <- file(con, "rb")
        on.exit(close(con))
    }
    .Internal(readChar(con, as.integer(nchars)))
}

writeChar <- function(object, con, nchars = nchar(object), eos = "")
{
    if(!is.character(object))
        stop("can only write character objects")
    if(is.character(con)) {
        con <- file(con, "wb")
        on.exit(close(con))
    }
    invisible(.Internal(writeChar(object, con, as.integer(nchars), eos)))
}

gzcon <- function(con, level = 6, allowNonCompressed = TRUE)
    .Internal(gzcon(con, level, allowNonCompressed))

socketSelect <- function(socklist, write = FALSE, timeout = NULL) {
    if (is.null(timeout))
        timeout <- -1
    else if (timeout < 0)
        stop("supplied timeout must be NULL or a non-negative number")
    if (length(write) < length(socklist))
        write <- rep(write, length.out = length(socklist))
    .Internal(sockSelect(socklist, write, timeout))
}
pi <- 4*atan(1)

letters <- c("a","b","c","d","e","f","g","h","i","j","k","l", "m",
	     "n","o","p","q","r","s","t","u","v","w","x","y","z")

LETTERS <- c("A","B","C","D","E","F","G","H","I","J","K","L", "M",
	     "N","O","P","Q","R","S","T","U","V","W","X","Y","Z")

month.name <-
    c("January", "February", "March", "April", "May", "June",
      "July", "August", "September", "October", "November", "December")

month.abb <- c("Jan", "Feb", "Mar", "Apr", "May", "Jun",
	       "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")

constrOptim<-function(theta,f,grad,ui,ci,mu=0.0001,control=list(),
                  method=if(is.null(grad)) "Nelder-Mead" else "BFGS",
                  outer.iterations=100,outer.eps=0.00001,...){

    if (!is.null(control$fnscale) && control$fnscale<0)
      mu<- -mu ##maximizing
  
    R<-function(theta,theta.old){
        ui.theta<-ui%*%theta
        gi<- ui.theta-ci
        if (any(gi<0)) return(NaN)
        gi.old<-ui%*%theta.old-ci
        bar<-sum( gi.old*log(gi)-ui.theta)
        if (!is.finite(bar)) bar<- -Inf
        f(theta)-mu*bar
    }
 
    dR<-function(theta,theta.old){
        ui.theta<-ui%*%theta
        gi<-drop(ui.theta-ci)
        gi.old<-drop(ui%*%theta.old-ci)
        dbar<-colSums( ui*gi.old/gi-ui)
        grad(theta)-mu*dbar
    }

    if (any(ui%*%theta-ci<=0))
        stop("initial value not feasible")
    obj<-f(theta)
    r<-R(theta,theta)
    for(i in 1:outer.iterations){
        obj.old<-obj
        r.old<-r
        theta.old<-theta
        fun<-function(theta){ R(theta,theta.old)}
        gradient<-function(theta) { dR(theta,theta.old)}
        a<-optim(theta.old, fun, gradient, control=control,method=method,...)
        r<-a$value
        if (is.finite(r) && is.finite(r.old) && abs(r-r.old)/(outer.eps+abs(r-r.old))<outer.eps)
            break
        theta<-a$par
        obj<-f(theta)
        if (obj>obj.old) break
    }
    if (i==outer.iterations){
        a$convergence<-7
        a$message<-"Barrier algorithm ran out of iterations and did not converge"
    }
    if (mu>0 && obj>obj.old){
        a$convergence<-11
        a$message<-paste("Objective function increased at outer iteration",i)
    }
    if (mu<0 && obj<obj.old){
        a$convergence<-11
        a$message<-paste("Objective function decreased at outer iteration",i)
    }

        
    a$outer.iterations<-i
    a$barrier.value<-a$value
    a$value<-f(a$par)
    a$barrier.value<-a$barrier.value-a$value
    a
    
}
contour <- function(x, ...) UseMethod("contour")

contour.default <-
function (x = seq(0, 1, len = nrow(z)), y = seq(0, 1, len = ncol(z)),
	  z,
	  nlevels = 10, levels = pretty(zlim, nlevels), labels = NULL,
	  xlim = range(x, finite = TRUE), ylim = range(y, finite = TRUE),
	  zlim = range(z, finite = TRUE),
	  labcex = 0.6, drawlabels = TRUE, method = "flattest",
          vfont = c("sans serif", "plain"),
          axes = TRUE, frame.plot = axes,
	  col = par("fg"), lty = par("lty"), lwd = par("lwd"),
	  add = FALSE, ...)
{
    if (missing(z)) {
	if (!missing(x)) {
	    if (is.list(x)) {
		z <- x$z; y <- x$y; x <- x$x
	    } else {
		z <- x
		x <- seq(0, 1, len = nrow(z))
	    }
	} else stop("no `z' matrix specified")
    } else if (is.list(x)) {
	y <- x$y
	x <- x$x
    }
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
	stop("increasing x and y values expected")
    if (!is.matrix(z) || nrow(z) <= 1 || ncol(z) <= 1)
	stop("no proper `z' matrix specified")
    if (!add) {
	plot.new()
	plot.window(xlim, ylim, "")
	title(...)
    }
    ##- don't lose  dim(.)
    if (!is.double(z)) storage.mode(z) <- "double"
    method <- pmatch(method[1], c("simple", "edge", "flattest"))
    if (!is.null(vfont))
        vfont <- c(typeface = pmatch(vfont[1], Hershey$typeface) - 1,
                   fontindex= pmatch(vfont[2], Hershey$fontindex))
    if (!is.null(labels))
        labels <- as.character(labels)
    .Internal(contour(as.double(x), as.double(y), z, as.double(levels),
		      labels, labcex, drawlabels, method, vfont,
		      col = col, lty = lty, lwd = lwd))
    if(!add) {
        if(axes) {
            axis(1)
            axis(2)
        }
        if(frame.plot) box()
    }
    invisible()
}
contr.poly <- function (n, scores = 1:n, contrasts = TRUE)
{
    make.poly <- function(n, scores)
    {
	y <- scores - mean(scores)
	X <- outer(y, seq(length=n) - 1, "^")
	QR <- qr(X)
	z <- QR$qr
	z <- z *(row(z) == col(z))
	raw <- qr.qy(QR, z)
	Z <- sweep(raw, 2, apply(raw, 2, function(x) sqrt(sum(x^2))), "/")
	colnames(Z) <- paste("^", 1:n - 1, sep="")
	Z
    }

    if (is.numeric(n) && length(n) == 1) levs <- 1:n
    else {
	levs <- n
	n <- length(levs)
    }
    if (n < 2)
	stop(paste("Contrasts not defined for", n - 1, "degrees of freedom"))
    if (n > 95)
        stop(paste("Orthogonal polynomials cannot be represented accurately enough for", n - 1, "degrees of freedom"))
    if (length(scores) != n)
        stop("scores argument is of the wrong length")
    if (!is.numeric(scores) || any(duplicated(scores)))
        stop("scores must all be different numbers")
    contr <- make.poly(n, scores)
    if (contrasts) {
	dn <- colnames(contr)
	dn[2:min(4,n)] <- c(".L", ".Q", ".C")[1:min(3, n-1)]
	colnames(contr) <- dn
	contr[, -1, drop = FALSE]
    }
    else {
	contr[, 1] <- 1
	contr
    }
}

poly <- function(x, ..., degree = 1, coefs = NULL)
{
    dots <- list(...)
    if(nd <- length(dots)) {
        if(nd == 1 && length(dots[[1]]) == 1) # unnamed degree
            degree <- dots[[1]]
        else return(polym(x, ..., degree = degree))
    }
    if(is.matrix(x)) {
        m <- unclass(as.data.frame(cbind(x, ...)))
        return(do.call("polym", c(m, degree=degree)))
    }
    if(degree < 1)
        stop("degree must be at least 1")
    n <- degree + 1
    if(is.null(coefs)) { # fitting
        if(degree >= length(x))
            stop("degree must be less than number of points")
        xbar <- mean(x)
        x <- x - xbar
        X <- outer(x, seq(length = n) - 1, "^")
        QR <- qr(X)
        z <- QR$qr
        z <- z * (row(z) == col(z))
        raw <- qr.qy(QR, z)
        norm2 <- colSums(raw^2)
        alpha <- (colSums(x*raw^2)/norm2 + xbar)[1:degree]
        Z <- raw / rep(sqrt(norm2), each = length(x))
        colnames(Z) <- 1:n - 1
        Z <- Z[, -1, drop = FALSE]
        attr(Z, "degree") <- 1:degree
        attr(Z, "coefs") <- list(alpha = alpha, norm2 = c(1, norm2))
        class(Z) <- c("poly", "matrix")
    } else {            # prediction
        alpha <- coefs$alpha; norm2 <- coefs$norm2
        Z <- matrix(, length(x), n)
        Z[, 1] <- 1
        Z[, 2] <- x - alpha[1]
        if(degree > 1)
            for(i in 2:degree)
                Z[, i+1] <- (x - alpha[i]) * Z[, i]  -
                    (norm2[i+1] / norm2[i]) * Z[, i-1]
        Z <- Z / rep(sqrt(norm2[-1]), each = length(x))
        colnames(Z) <- 0:degree
        Z <- Z[, -1, drop = FALSE]
    }
    return(Z)
}

predict.poly <- function(object, newdata, ...)
{
    if(missing(newdata)) return(object)
    poly(newdata, degree = max(attr(object, "degree")),
         coefs = attr(object, "coefs"))
}

makepredictcall.poly  <- function(var, call)
{
    if(as.character(call)[1] != "poly") return(call)
    call$coefs <- attr(var, "coefs")
    call
}

polym <- function(..., degree = 1)
{
    dots <- list(...)
    nd <- length(dots)
    if(nd == 0) stop("must supply one or more vectors")
    if(nd == 1) return(poly(dots[[1]], degree))
    n <- sapply(dots, length)
    if(any(n != n[1]))
        stop("arguments must have the same length")
    z <- do.call("expand.grid", rep.int(list(0:degree), nd))
    s <- rowSums(z)
    ind <- (s > 0) & (s <= degree)
    z <- z[ind, ]; s <- s[ind]
    res <- cbind(1, poly(dots[[1]], degree))[, 1 + z[, 1]]
    for(i in 2:nd) res <- res * cbind(1, poly(dots[[i]], degree))[, 1 + z[, i]]
    colnames(res) <- apply(z, 1, function(x) paste(x, collapse = "."))
    attr(res, "degree") <- as.vector(s)
    res
}
contrasts <-
    function (x, contrasts = TRUE)
{
    if (is.logical(x)) x <- factor(x)
    if (!is.factor(x))
	stop("contrasts apply only to factors")
    if(!contrasts)
        return(structure(diag(nlevels(x)), dimnames=list(levels(x), levels(x))))
    ctr <- attr(x, "contrasts")
    if (is.null(ctr)) {
        ctrname <- getOption("contrasts")[[if (is.ordered(x)) 2 else 1]]
	ctr <- get(ctrname, mode="function", envir=parent.frame())(levels(x), contrasts = contrasts)
	dimnames(ctr) <- list(levels(x), dimnames(ctr)[[2]])
    }
    else if (is.character(ctr))
	ctr <- get(ctr, mode="function", envir=parent.frame())(levels(x), contrasts = contrasts)
    #if(ncol(ctr)==1) dimnames(ctr) <- list(dimnames(ctr)[[1]], "")
    ctr
}

"contrasts<-" <-
    function(x, how.many, value)
{
    if (is.logical(x)) x <- factor(x)
    if(!is.factor(x))
	stop("contrasts apply only to factors")
    if(is.function(value)) value <- value(nlevels(x))
    if(is.numeric(value)) {
	value <- as.matrix(value)
	nlevs <- nlevels(x)
	if(nrow(value) != nlevs)
	    stop("wrong number of contrast matrix rows")
	n1 <- if(missing(how.many)) nlevs - 1 else how.many
	nc <- ncol(value)
	rownames(value) <- levels(x)
	if(nc  < n1) {
	    cm <- qr(cbind(1,value))
	    if(cm$rank != nc+1) stop("singular contrast matrix")
	    cm <- qr.qy(cm, diag(nlevs))[,2:nlevs]
	    cm[,1:nc] <- value
	    dimnames(cm) <- list(levels(x),NULL)
	    if(!is.null(nmcol <- dimnames(value)[[2]]))
		dimnames(cm)[[2]] <- c(nmcol, rep.int("", n1-nc))
	} else cm <- value[, 1:n1, drop=FALSE]
    }
    else if(is.character(value)) cm <- value
    else if(is.null(value)) cm <- NULL
    else stop("numeric contrasts or contrast name expected")
    attr(x, "contrasts") <- cm
    x
}

contr.helmert <-
    function (n, contrasts=TRUE)
{
    if (length(n) <= 1) {
	if(is.numeric(n) && length(n) == 1 && n > 1) levels <- 1:n
	else stop("contrasts are not defined for 0 degrees of freedom")
    } else levels <- n
    lenglev <- length(levels)
    if (contrasts) {
	cont <- array(-1, c(lenglev, lenglev-1), list(levels, NULL))
	cont[col(cont) <= row(cont) - 2] <- 0
	cont[col(cont) == row(cont) - 1] <- 1:(lenglev-1)
    } else {
	cont <- array(0, c(lenglev, lenglev), list(levels, levels))
	cont[col(cont) == row(cont)] <- 1
    }
    cont
}

contr.treatment <-
    function(n, base = 1, contrasts = TRUE)
{
    if(is.numeric(n) && length(n) == 1)
	levs <- 1:n
    else {
	levs <- n
	n <- length(n)
    }
    contr <- array(0, c(n, n), list(levs, levs))
    diag(contr) <- 1
    if(contrasts) {
	if(n < 2)
	    stop(paste("Contrasts not defined for", n - 1,
		       "degrees of freedom"))
	if (base < 1 | base > n)
	    stop("Baseline group number out of range")
	contr <- contr[, -base, drop = FALSE]
    }
    contr
}

contr.sum <-
    function (n, contrasts=TRUE)
{
    if (length(n) <= 1) {
	if (is.numeric(n) && length(n) == 1 && n > 1)
	    levels <- 1:n
	else stop("Not enough degrees of freedom to define contrasts")
    } else levels <- n
    lenglev <- length(levels)
    if (contrasts) {
	cont <- array(0, c(lenglev, lenglev - 1), list(levels, NULL))
	cont[col(cont) == row(cont)] <- 1
	cont[lenglev, ] <- -1
    } else {
	cont <- array(0, c(lenglev, lenglev), list(levels, levels))
	cont[col(cont) == row(cont)] <- 1
    }
    cont
}
contributors <- function()
{
    outFile <- tempfile()
    outConn <- file(outFile, open = "w")
    writeLines(paste("R is a project which is attempting to provide a ",
                     "modern piece of\nstatistical software for the ",
                     "GNU suite of software.\n\n",
                     "The current R is the result of a collaborative ",
                     "effort with\ncontributions from all over the ",
                     "world.\n\n",
                     sep = ""), outConn)
    writeLines(readLines(file.path(R.home(), "AUTHORS")), outConn)
    writeLines("", outConn)
    writeLines(readLines(file.path(R.home(), "THANKS")), outConn)
    close(outConn)
    file.show(outFile, delete.file = TRUE)
}
getNumCConverters <-
function() {
 .Internal(getNumRtoCConverters())
}

getCConverterDescriptions <-
function() {
 .Internal(getRtoCConverterDescriptions())
}

getCConverterStatus <-
function() {
 v <- .Internal(getRtoCConverterStatus())
 names(v) <- getCConverterDescriptions()

 v
}


setCConverterStatus <-
function(id, status)
{
  .Internal(setToCConverterActiveStatus(id, as.logical(status)))
}

removeCConverter <-
function(id)
{
  .Internal(removeToCConverterActiveStatus(id))
}

co.intervals <- function (x, number = 6, overlap = 0.5)
{
    x <- sort(x[!is.na(x)])
    n <- length(x)
    ## "from the record"
    r <- n/(number * (1 - overlap) + overlap)
    ii <- round(0:(number - 1) * (1 - overlap) * r)
    x1 <- x[1 + ii]
    xr <- x[r + ii]
    ## Omit any range of values identical with the previous range;
    ## happens e.g. when `number' is less than the number of distinct x values.
    keep <- c(TRUE, diff(x1) > 0 | diff(xr) > 0)
    ## Set eps > 0 to ensure that the endpoints of a range are never
    ## identical, allowing display of a given.values bar
    j.gt.0 <- 0 < (jump <- diff(x))
    eps <- 0.5 * if(any(j.gt.0)) min(jump[j.gt.0]) else 0
    cbind(x1[keep] - eps, xr[keep] + eps)
}

panel.smooth <- function(x, y, col = par("col"), bg = NA, pch = par("pch"),
			 cex = 1, col.smooth = "red", span = 2/3, iter = 3, ...)
{
    points(x, y, pch=pch, col=col, bg=bg, cex=cex)
    ok <- is.finite(x) & is.finite(y)
    if (any(ok))
	lines(lowess(x[ok], y[ok], f=span, iter=iter), col = col.smooth, ...)
}

coplot <-
    function(formula, data, given.values, panel=points, rows, columns,
	     show.given = TRUE, col = par("fg"), pch=par("pch"),
	     bar.bg = c(num = gray(0.8), fac = gray(0.95)),
	     xlab = c(x.name, paste("Given :", a.name)),
	     ylab = c(y.name, paste("Given :", b.name)),
	     subscripts = FALSE, axlabels = function(f) abbreviate(levels(f)),
	     number = 6, overlap = 0.5, xlim, ylim, ...)
{
    deparen <- function(expr) {
	while (is.language(expr) && !is.name(expr) && deparse(expr[[1]])== "(")
	    expr <- expr[[2]]
	expr
    }
    bad.formula <- function() stop("invalid conditioning formula")
    bad.lengths <- function() stop("incompatible variable lengths")

    ## parse and check the formula

    formula <- deparen(formula)
    if (!inherits(formula, "formula"))
	bad.formula()
    y <- deparen(formula[[2]])
    rhs <- deparen(formula[[3]])
    if (deparse(rhs[[1]]) != "|")
	bad.formula()
    x <- deparen(rhs[[2]])
    rhs <- deparen(rhs[[3]])
    if (is.language(rhs) && !is.name(rhs)
	&& (deparse(rhs[[1]]) == "*" || deparse(rhs[[1]]) == "+")) {
	have.b <- TRUE
	a <- deparen(rhs[[2]])
	b <- deparen(rhs[[3]])
    } else {
	have.b <- FALSE
	a <- rhs
    }

    ## evaluate the formulae components to get the data values

    if (missing(data))
	data <- parent.frame()
    x.name <- deparse(x)
    x <- eval(x, data, parent.frame())
    nobs <- length(x)
    y.name <- deparse(y)
    y <- eval(y, data, parent.frame())
    if(length(y) != nobs) bad.lengths()
    a.name <- deparse(a)
    a <- eval(a, data, parent.frame())
    if(length(a) != nobs) bad.lengths()
    if(is.character(a)) a <- as.factor(a)
    a.is.fac <- is.factor(a)
    if (have.b) {
	b.name <- deparse(b)
	b <- eval(b, data, parent.frame())
	if(length(b) != nobs) bad.lengths()
	if(is.character(b)) b <- as.factor(b)
        b.is.fac <- is.factor(b)
	missingrows <- which(is.na(x) | is.na(y) | is.na(a) | is.na(b))
    }
    else {
	missingrows <- which(is.na(x) | is.na(y) | is.na(a))
	b <- NULL
	b.name <- "" # for default ylab
    }

    ## generate the given value intervals

    number <- as.integer(number)
    if(length(number)==0 || any(number < 1)) stop("number must be integer >= 1")
    if(any(overlap >= 1)) stop("overlap must be < 1 (and typically >= 0).")

    bad.givens <- function() stop("invalid given.values")
    if(missing(given.values)) {
	a.intervals <-
	    if(a.is.fac) {
		i <- seq(along = a.levels <- levels(a))
		a <- as.numeric(a)
		cbind(i - 0.5, i + 0.5)
	    } else co.intervals(a,number=number[1],overlap=overlap[1])
	b.intervals <-
	    if (have.b) {
		if(b.is.fac) {
                    i <- seq(along = b.levels <- levels(b))
		    b <- as.numeric(b)
		    cbind(i - 0.5, i + 0.5)
		}
		else {
		    if(length(number)==1) number  <- rep.int(number,2)
		    if(length(overlap)==1)overlap <- rep.int(overlap,2)
		    co.intervals(b,number=number[2],overlap=overlap[2])
		}
	    }
    } else {
	if(!is.list(given.values))
	    given.values <- list(given.values)
	if(length(given.values) != (if(have.b) 2 else 1))
	    bad.givens()
	a.intervals <- given.values[[1]]
	if(a.is.fac) {
	    a.levels <- levels(a)
	    if (is.character(a.intervals))
		a.intervals <- match(a.intervals, a.levels)
	    a.intervals <- cbind(a.intervals - 0.5, a.intervals + 0.5)
	    a <- as.numeric(a)
	}
	else if(is.numeric(a)) {
	    if(!is.numeric(a.intervals)) bad.givens()
	    if(!is.matrix(a.intervals) || ncol(a.intervals) != 2)
		a.intervals <- cbind(a.intervals - 0.5, a.intervals + 0.5)
	}
	if(have.b) {
	    b.intervals <- given.values[[2]]
	    if(b.is.fac) {
		b.levels <- levels(b)
		if (is.character(b.intervals))
		    b.intervals <- match(b.intervals, b.levels)
		b.intervals <- cbind(b.intervals - 0.5, b.intervals + 0.5)
		b <- as.numeric(b)
	    }
	    else if(is.numeric(b)) {
		if(!is.numeric(b.intervals)) bad.givens()
		if(!is.matrix(b.intervals) || ncol(b.intervals) != 2)
		    b.intervals <- cbind(b.intervals - 0.5, b.intervals + 0.5)
	    }
	}
    }
    if(any(is.na(a.intervals)) || (have.b && any(is.na(b.intervals))))
	bad.givens()

    ## compute the page layout

    if (have.b) {
	rows	<- nrow(b.intervals)
	columns <- nrow(a.intervals)
	nplots <- rows * columns
	if(length(show.given) < 2) show.given <- rep.int(show.given, 2)
    }
    else {
	nplots <- nrow(a.intervals)
	if (missing(rows)) {
	    if (missing(columns)) { ## default
		rows <- ceiling(round(sqrt(nplots)))
		columns <- ceiling(nplots/rows)
	    }
	    else rows <- ceiling(nplots/columns)
	}
	else if (missing(columns))
	    columns <- ceiling(nplots/rows)
	if (rows * columns < nplots)
	    stop("rows * columns too small")
    }
    total.columns <- columns
    total.rows <- rows
    f.col <- f.row <- 1
    if(show.given[1]) {
	total.rows <- rows + 1
	f.row <- rows/total.rows
    }
    if(have.b && show.given[2]) {
	total.columns <- columns + 1
	f.col <- columns/total.columns
    }

    mar <- if(have.b) rep.int(0, 4) else c(0.5, 0, 0.5, 0)
    oma <- c(5, 6, 5, 4)
    if(have.b) { oma[2] <- 5 ; if(!b.is.fac) oma[4] <- 5 }
    if(a.is.fac && show.given[1]) oma[3] <- oma[3] - 1

    ## Start Plotting only now

    opar <- par(mfrow = c(total.rows, total.columns),
		oma = oma, mar = mar, xaxs = "r", yaxs = "r", new = FALSE)
    on.exit(par(opar))
    plot.new()
    ## as.numeric() allowing factors for x & y:
    if(missing(xlim))
	xlim <- range(as.numeric(x), finite = TRUE)
    if(missing(ylim))
	ylim <- range(as.numeric(y), finite = TRUE)
    pch <- rep(pch, length=nobs)
    col <- rep(col, length=nobs)
    do.panel <- function(index, subscripts = FALSE, id) {
	## Use `global' variables
	##	rows, columns,	total.rows, total.columns, nplots, xlim, ylim
        Paxis <- function(side, x) {
            if(nlevels(x)) {
                lab <- axlabels(x)
                axis(side, labels = lab, at = seq(lab), xpd = NA)
            } else
                axis(side, xpd = NA)
        }
	istart <- (total.rows - rows) + 1
	i <- total.rows - ((index - 1)%/%columns)
	j <- (index - 1)%%columns + 1
	par(mfg = c(i, j, total.rows, total.columns))
	plot.new()
	plot.window(xlim, ylim)
	if(any(is.na(id))) id[is.na(id)] <- FALSE
	if(any(id)) {
	    grid(lty="solid")
	    if(subscripts)
		panel(x[id], y[id], subscripts = id,
		      col = col[id], pch=pch[id], ...)
	    else
		panel(x[id], y[id], col = col[id], pch=pch[id], ...)
	}
	if((i == total.rows) && (j%%2 == 0))
	    Paxis(1, x)
	else if((i == istart || index + columns > nplots) && (j%%2 == 1))
	    Paxis(3, x)

	if((j == 1) && ((total.rows - i)%%2 == 0))
	    Paxis(2, y)
	else if((j == columns || index == nplots) && ((total.rows - i)%%2 == 1))
	    Paxis(4, y)
	box()
    }## END function do.panel()

    if(have.b) {
	count <- 1
	for(i in 1:rows) {
	    for(j in 1:columns) {
		id <- ((a.intervals[j,1] <= a) & (a <= a.intervals[j,2]) &
		       (b.intervals[i,1] <= b) & (b <= b.intervals[i,2]))
		do.panel(count, subscripts, id)
		count <- count + 1
	    }
	}
    } else {
	for (i in 1:nplots) {
	    id <- ((a.intervals[i,1] <= a) & (a <= a.intervals[i,2]))
	    do.panel(i, subscripts, id)
	}
    }
    mtext(xlab[1], side=1, at=0.5*f.col, outer=TRUE, line=3.5, xpd=NA)
    mtext(ylab[1], side=2, at=0.5*f.row, outer=TRUE, line=3.5, xpd=NA)

    if(length(xlab) == 1)
        xlab <- c(xlab, paste("Given :", a.name))
    ##mar <- par("mar")
    if(show.given[1]) {
	par(fig = c(0, f.col, f.row, 1),
            mar = mar + c(3+ !a.is.fac, 0, 0, 0), new=TRUE)
	plot.new()
	nint <- nrow(a.intervals)
        a.range <- range(a.intervals, finite=TRUE)
        ## 3% correction because axs = "r" extends by 4% :
	plot.window(a.range + c(.03,-.03)*diff(a.range), 0.5 + c(0, nint))
	rect(a.intervals[, 1], 1:nint - 0.3,
	     a.intervals[, 2], 1:nint + 0.3,
	     col = bar.bg[if(a.is.fac) "fac" else "num"])
	if(a.is.fac) {
	    text(apply(a.intervals, 1, mean), 1:nint, a.levels)
        }
        else {
            axis(3, xpd=NA)
            axis(1, labels=FALSE)
        }
	box()
	mtext(xlab[2], 3, line = 3 - a.is.fac, at=mean(par("usr")[1:2]), xpd=NA)
    }
    else { ## i. e. !show.given
	mtext(xlab[2], 3, line = 3.25, outer= TRUE, at= 0.5*f.col, xpd=NA)
    }
    if(have.b) {
	if(length(ylab) == 1)
            ylab <- c(ylab, paste("Given :", b.name))
	if(show.given[2]) {
	    par(fig = c(f.col, 1, 0, f.row),
                mar = mar + c(0, 3+ !b.is.fac, 0, 0), new=TRUE)
	    plot.new()
	    nint <- nrow(b.intervals)
            b.range <- range(b.intervals, finite=TRUE)
            ## 3% correction (see above)
            plot.window(0.5 + c(0, nint), b.range+ c(.03,-.03)*diff(b.range))
	    rect(1:nint - 0.3, b.intervals[, 1],
                 1:nint + 0.3, b.intervals[, 2],
                 col = bar.bg[if(b.is.fac)"fac" else "num"])
	    if(b.is.fac) {
                text(1:nint, apply(b.intervals, 1, mean), b.levels, srt = 90)
            }
            else {
                axis(4, xpd=NA)
                axis(2, labels=FALSE)
            }
	    box()
	    mtext(ylab[2], 4, line = 3 - b.is.fac,
                  at=mean(par("usr")[3:4]), xpd=NA)
	}
	else {
	    mtext(ylab[2], 4, line = 3.25, at=0.5*f.row, outer=TRUE, xpd=NA)
	}
    }
    if (length(missingrows) > 0) {
	cat("\nMissing rows:",missingrows,"\n")
	invisible(missingrows)
    }
}
#### cor() , cov() and var() : Based on the same C code

## cor() and cov() only differ by one single letter :
cor <-
function(x, y=NULL, use="all.obs", method = c("pearson", "kendall", "spearman"))
{
    na.method <-
        pmatch(use, c("all.obs", "complete.obs", "pairwise.complete.obs"))
    method <- match.arg(method)
    if(is.data.frame(x)) x <- as.matrix(x)
    if(is.data.frame(y)) y <- as.matrix(y)
    if(!is.matrix(x) && is.null(y))
        stop("supply both x and y or a matrix-like x")
    if(method != "pearson") {
        ## Rank transform
        Rank <- function(u) if(is.matrix(u)) apply(u, 2, rank) else rank(u)
        x <- Rank(x)
        if(!is.null(y)) y <- Rank(y)
    }
    .Internal(cor(x, y, na.method, method == "kendall"))
}

cov <-
function(x, y=NULL, use="all.obs", method = c("pearson", "kendall", "spearman"))
{
    na.method <-
        pmatch(use, c("all.obs", "complete.obs", "pairwise.complete.obs"))
    method <- match.arg(method)
    if(is.data.frame(x)) x <- as.matrix(x)
    if(is.data.frame(y)) y <- as.matrix(y)
    if(!is.matrix(x) && is.null(y))
        stop("supply both x and y or a matrix-like x")
    if(method != "pearson") {
        ## Rank transform
        Rank <- function(u) if(is.matrix(u)) apply(u, 2, rank) else rank(u)
        x <- Rank(x)
        if(!is.null(y)) y <- Rank(y)
    }
    .Internal(cov(x, y, na.method, method == "kendall"))
}

var <- function(x, y = NULL, na.rm = FALSE, use) {
    if(missing(use))
	use <- if(na.rm) "complete.obs" else "all.obs"
    na.method <- pmatch(use, c("all.obs", "complete.obs",
                               "pairwise.complete.obs"))
    if (is.data.frame(x)) x <- as.matrix(x)
    if (is.data.frame(y)) y <- as.matrix(y)
    .Internal(cov(x, y, na.method, FALSE))
}

cov2cor <- function(V)
{
    ## Purpose: Covariance matrix |--> Correlation matrix -- efficiently
    ## ----------------------------------------------------------------------
    ## Arguments: V: a covariance matrix (i.e. symmetric and positive definite)
    ## ----------------------------------------------------------------------
    ## Author: Martin Maechler, Date: 12 Jun 2003, 11:50
    p <- (d <- dim(V))[1]
    if(!is.numeric(V) || length(d) != 2 || p != d[2])
        stop("`V' is not a square numeric matrix")
    Is <- sqrt(1/diag(V)) # diag( 1/sigma_i )
    if(any(!is.finite(Is)))
        warning("diagonal has non-finite entries")
    r <- V # keep dimnames
    r[] <- Is * V * rep(Is, each = p)
    ##  == D %*% V %*% D  where D = diag(Is)
    r[cbind(1:p,1:p)] <- 1 # exact in diagonal
    r
}
cov.wt <- function(x, wt = rep(1/nrow(x), nrow(x)), cor = FALSE,
		   center = TRUE)
{
    if (is.data.frame(x))
	x <- as.matrix(x)
    else if (!is.matrix(x))
	stop("x must be a matrix or a data frame")
    if (!all(is.finite(x)))
	stop("x must contain finite values only")
    n <- nrow(x)
    if (with.wt <- !missing(wt)) {
	if (length(wt) != n)
	    stop("length of wt must equal the number of rows in x")
	if (any(wt < 0) || (s <- sum(wt)) == 0)
	    stop("weights must be non-negative and not all zero")
	wt <- wt / s
    }
    if (is.logical(center)) {
	center <- if (center)
	    colSums(wt * x)
	else 0
    } else {
	if (length(center) != ncol(x))
	    stop("length of center must equal the number of columns in x")
    }
    x <- sqrt(wt) * sweep(x, 2, center)
    cov <- (t(x) %*% x) / (1 - sum(wt^2))

    y <- list(cov = cov, center = center, n.obs = n)
    if (with.wt) y$wt <- wt
    if (cor) {
	sdinv <- diag(1 / sqrt(diag(cov)), nrow(cov))
	y$cor <- sdinv %*% cov %*% sdinv
    }
    y
}
curve <- function(expr, from, to, n=101, add=FALSE, type="l",
		  ylab=NULL, log=NULL, xlim=NULL, ...)
{
    sexpr <- substitute(expr)
    if(is.name(sexpr)) {
	fcall <- paste(sexpr, "(x)")
	expr <- parse(text=fcall)
	if(is.null(ylab)) ylab <- fcall
    } else {
	if(!(is.call(sexpr) && match("x", all.vars(sexpr), nomatch=0)))
	    stop("'expr' must be a function or an expression containing 'x'")
	expr <- sexpr
	if(is.null(ylab)) ylab <- deparse(sexpr)
    }
    lims <-
        if(is.null(xlim)) delay({pu <- par("usr")[1:2]
                                 if(par("xlog")) 10^pu else pu})
        else xlim
    if(missing(from)) from <- lims[1]
    if(missing(to))     to <- lims[2]
    lg <-
        if(length(log)) log
        else paste(if(add && par("xlog"))"x",
                   if(add && par("ylog"))"y", sep="")
    if(length(lg) == 0) lg <- ""
    x <-
	if(lg != "" && "x" %in% strsplit(lg, NULL)[[1]]) {
	    ## unneeded now: rm(list="log",envir=sys.frame(1))# else: warning
	    if(any(c(from,to) <= 0))
		stop("`from' & `to' must be > 0	 with  log=\"x\"")
	    exp(seq(log(from), log(to), length=n))
	} else seq(from,to,length=n)
    y <- eval(expr, envir=list(x = x), enclos=parent.frame())
    if(add)
	lines(x, y, type=type, ...)
    else
	plot(x, y, type=type, ylab = ylab, xlim = xlim, log=lg, ...)
}
cut <- function(x, ...) UseMethod("cut")

cut.default <- function (x, breaks, labels=NULL, include.lowest = FALSE,
			 right=TRUE, dig.lab=3, ...)
{
    if (!is.numeric(x)) stop("cut: x must be numeric")
    if (length(breaks) == 1) {
	if (is.na(breaks) | breaks < 2)
	    stop("invalid number of intervals")
	nb <- as.integer(breaks + 1)# one more than #{intervals}
	dx <- diff(rx <- range(x,na.rm=TRUE))
	if(dx==0) dx <- rx[1]
	breaks <- seq(rx[1] - dx/1000,
		      rx[2] + dx/1000, len=nb)
    } else nb <- length(breaks <- sort(breaks))
    if (any(duplicated(breaks))) stop("cut: breaks are not unique")
    codes.only <- FALSE
    if (is.null(labels)) {#- try to construct nice ones ..
	for(dig in dig.lab:12) {
	    ch.br <- formatC(breaks, digits=dig, wid=1)
	    if(ok <- all(ch.br[-1]!=ch.br[-nb])) break
	}
	labels <-
	    if(ok) paste(if(right)"(" else "[",
			 ch.br[-nb], ",", ch.br[-1],
			 if(right)"]" else ")", sep='')
	    else paste("Range", 1:(nb - 1),sep="_")
        if (ok && include.lowest) {
            if (right)
                substr(labels[1], 1,1) <- "["
            else
                substring(labels[nb-1], nchar(labels[nb-1])) <- "]"
        }
    } else if (is.logical(labels) && !labels)
        codes.only <- TRUE
    else if (length(labels) != nb-1)
        stop("labels/breaks length conflict")
    code <- .C("bincode",
	       x =     	as.double(x),
	       n =	length(x),
	       breaks =	as.double(breaks),
               nb,
	       code= 	integer(length(x)),
               right=	as.logical(right),
	       include= as.logical(include.lowest), naok = TRUE,
	       NAOK= TRUE, DUP = FALSE, PACKAGE = "base") $code
    ## NB this relies on passing NAOK in that position!
    if(codes.only) code
    else factor(code, seq(labels), labels)
}
data <-
function(..., list = character(0),
         package = .packages(), lib.loc = NULL,
         verbose = getOption("verbose"), envir = .GlobalEnv)
{
    fileExt <- function(x) sub(".*\\.", "", x)
    
    names <- c(as.character(substitute(list(...))[-1]), list)
    if(!missing(package))
        if(is.name(y <- substitute(package)))
            package <- as.character(y)

    ## Find the directories of the given packages and maybe the working
    ## directory.
    paths <- .find.package(package, lib.loc, verbose = verbose)
    if(is.null(lib.loc))
        paths <- c(.path.package(package, TRUE), getwd(), paths)
    paths <- unique(paths[file.exists(paths)])

    ## Find the directories with a 'data' subdirectory.
    paths <- paths[tools::fileTest("-d", file.path(paths, "data"))]
    ## Earlier versions remembered given packages with no 'data'
    ## subdirectory, and warned about them.

    dataExts <- tools:::.makeFileExts("data")

    if(length(names) == 0) {
        ## List all possible data sets.

        ## Build the data db.
        db <- matrix(character(0), nr = 0, nc = 4)
        noindex <- character(0)
        for(path in paths) {
            entries <- NULL
            ## Use "." as the 'package name' of the working directory.
            packageName <-
                if(tools::fileTest("-f",
                                   file.path(path, "DESCRIPTION")))
                    basename(path)
                else
                    "."
            ## Check for new-style 'Meta/data.rds', then for '00Index'.
            ## Earlier versions also used to check for 'index.doc'.
            if(tools::fileTest("-f",
                               INDEX <-
                               file.path(path, "Meta", "data.rds"))) {
                entries <- .readRDS(INDEX)
            }
            else if(tools::fileTest("-f",
                                    INDEX <-
                                    file.path(path, "data", "00Index")))
                entries <- read.00Index(INDEX)
            else {
                ## No index: check whether subdir 'data' contains data
                ## sets.  Easy if data files were not collected into a
                ## zip archive ... in any case, as data sets found are
                ## available for loading, we also list their names.
                dataDir <- file.path(path, "data")
                entries <- tools::listFilesWithType(dataDir, "data")
                if((length(entries) == 0)
                   && all(tools::fileTest("-f",
                                          file.path(dataDir,
                                                    c("Rdata.zip",
                                                      "filelist"))))) {
                    entries <- readLines(file.path(dataDir, "filelist"))
                    entries <- entries[fileExt(entries) %in% dataExts]
                }
                if(length(entries) > 0) {
                    entries <-
                        unique(tools::filePathSansExt(basename(entries)))
                    entries <- cbind(entries, "")
                }
                else
                    noindex <- c(noindex, packageName)
            }
            if(NROW(entries) > 0) {
                db <- rbind(db,
                            cbind(packageName, dirname(path),
                                  entries))
            }
        }
        colnames(db) <- c("Package", "LibPath", "Item", "Title")

        if(length(noindex) > 0) {
            if(!missing(package) && (length(package) > 0)) {
                ## Warn about given packages which do not have a data
                ## index.
                packagesWithNoIndex <- package[package %in% noindex]
                if(length(packagesWithNoIndex) > 0)
                    warning(paste("packages with data sets",
                                  "but no index:",
                                  paste(sQuote(packagesWithNoIndex),
                                        collapse = ",")))
            }
        }

        footer <- if(missing(package))
            paste("Use ",
                  sQuote(paste("data(package =",
                               ".packages(all.available = TRUE))")),
                  "\n",
                  "to list the data sets in all *available* packages.",
                  sep = "")
        else
            NULL
        y <- list(title = "Data sets", header = NULL, results = db,
                  footer = footer)
        class(y) <- "packageIQR"
        return(y)
    }

    paths <- file.path(paths, "data")
    for(name in names) {
        files <- NULL
        for(p in paths) {
            if(tools::fileTest("-f", file.path(p, "Rdata.zip"))) {
                if(tools::fileTest("-f",
                                   fp <- file.path(p, "filelist")))
                    files <-
                        c(files,
                          file.path(p, scan(fp, what="", quiet = TRUE)))
                else warning(paste(sQuote("filelist"),
                                    "is missing for dir",
                                   sQuote(p)))
            } else {
                files <- c(files, list.files(p, full = TRUE))
            }
        }
        files <- files[grep(name, files, fixed = TRUE)]
        found <- FALSE
        if(length(files) > 1) {
            ## more than one candidate
            o <- match(fileExt(files), dataExts, nomatch = 100)
            paths0 <- dirname(files)
            paths0 <- factor(paths0, levels=paths0)
            files <- files[order(paths0, o)]
        }
        if(length(files) > 0) {
            for(file in files) {
                if(verbose)
                    cat("name=", name, ":\t file= ...",
                        .Platform$file.sep, basename(file), "::\t",
                        sep = "")
                if(found)
                    break
                found <- TRUE
                ext <- fileExt(file)
                ## make sure the match is really for 'name.ext'
                ## otherwise
                if(basename(file) != paste(name, ".", ext, sep = ""))
                    found <- FALSE
                else {
                    zfile <- zip.file.extract(file, "Rdata.zip")
                    switch(ext,
                           R = , r =
                           sys.source(zfile, chdir = TRUE,
                                      envir = envir),
                           RData = , rdata = , rda =
                           load(zfile, envir = envir),
                           TXT = , txt = , tab =
                           assign(name,
                                  read.table(zfile, header = TRUE),
                                  envir = envir),
                           CSV = , csv =
                           assign(name,
                                  read.table(zfile, header = TRUE,
                                             sep = ";"),
                                  envir = envir),
                           found <- FALSE)
                    if(zfile != file) unlink(zfile)
                }
                if(verbose)
                    cat(if(!found) "*NOT* ", "found\n")
            }
        }
        if(!found)
            warning(paste("Data set", sQuote(name), "not found"))
    }
    invisible(names)
}
data.matrix <- function(frame)
{
    if(!is.data.frame(frame))
	return(as.matrix(frame))
    d <- dim(frame)
    if(all(d > 0)) {
	log <- unlist(lapply(frame, is.logical))
	num <- unlist(lapply(frame, is.numeric))
	fac <- unlist(lapply(frame, is.factor))

	if(!all(log|fac|num))
	    stop("non-numeric data type in frame")
    }
    x <- matrix(nr=d[1], nc=d[2], dimnames=dimnames(frame))
    for(i in seq(len=d[2])) {
	xi <- frame[[i]]
	x[,i] <-
	    if(is.logical(xi) || is.factor(xi)) as.numeric(xi) else xi
    }
    x
}
browseEnv <- function(envir = .GlobalEnv, pattern,
                      excludepatt = "^last\\.warning",
		      html = .Platform$OS.type != "mac",
		      expanded = TRUE, properties = NULL,
		      main = NULL, debugMe = FALSE)
{
    objlist <- ls(envir = envir, pattern = pattern)#, all.names = FALSE
    if(length(iX <- grep(excludepatt, objlist)))
        objlist <- objlist[ - iX]
    if(debugMe) { cat("envir= "); print(envir)
		  cat("objlist =\n"); print(objlist) }
    n <- length(objlist)
    if(n == 0) {
	cat("Empty environment, nothing to do!\n")
	return(invisible())
    }

    str1 <- function(obj) {
	md <- mode(obj)
	lg <- length(obj)
	objdim <- dim(obj)
	if(length(objdim) == 0)
	    dim.field <- paste("length:", lg)
	else{
	    dim.field <- "dim:"
	    for(i in 1:length(objdim))
		dim.field <- paste(dim.field,objdim[i])
	    if(is.matrix(obj))
		md <- "matrix"
	}
	obj.class <- oldClass(obj)
	if(!is.null(obj.class)) {
	    md <- obj.class[1]
	    if(inherits(obj, "factor"))
		dim.field <- paste("levels:",length(levels(obj)))
	}
	list(type = md, dim.field = dim.field)
    }

    N <- 0
    M <- n
    IDS <- rep.int(NA,n)
    NAMES <- rep.int(NA,n)
    TYPES <- rep.int(NA,n)
    DIMS <- rep.int(NA,n)

    IsRoot <- rep.int(TRUE,n)
    Container <- rep.int(FALSE,n)
    ItemsPerContainer <- rep.int(0,n)
    ParentID <- rep.int(-1,n)

    for( objNam in objlist ){
	N <- N+1
	if(debugMe) cat("  ", N,":", objNam)
	obj    <- get(objNam, envir = envir)

	sOb <- str1(obj)

	if(debugMe) cat(", type=", sOb$type,",", sOb$dim.field,"\n")

	## Fixme : put these 4 in a matrix or data.frame row:
	IDS[N] <- N
	NAMES[N] <- objNam
	TYPES[N] <- sOb$type
	DIMS[N] <- sOb$dim.field

	if(is.recursive(obj) && !is.function(obj) && !is.environment(obj)
	    ## includes "list", "expression", also "data.frame", ..
	   && (lg <- length(obj)) > 0) {
	    Container[N] <- TRUE
	    ItemsPerContainer[N] <- lg
	    nm <- names(obj)
	    if(is.null(nm)) nm <- paste("[[",format(1:lg),"]]", sep="")
	    for(i in 1:lg) {
		M <- M+1
		ParentID[M] <- N
		if(nm[i] == "") nm[i] <- paste("[[",i,"]]", sep="")

		s.l <- str1(obj[[i]])
		##cat("	   objname:",nm[i],", type=",md.l,",",dim.field.l,"\n")
		IDS   <- c(IDS,M)
		NAMES <- c(NAMES, nm[i])
		TYPES <- c(TYPES, s.l$type)
		DIMS  <- c(DIMS,  s.l$dim.field)
	    }
	}## recursive

	else if(!is.null(class(obj))) {
	    ## treat some special __non-recursive__ classes:
	    if(inherits(obj, "table")) {
		obj.nms <- attr(obj,"dimnames")
		lg <- length(obj.nms)
		if(length(names(obj.nms)) >0)
		    nm <- names(obj.nms)
		else
		    nm <- rep.int("",lg)
		Container[N] <- TRUE
		ItemsPerContainer[N] <- lg
		for(i in 1:lg){
		    M <- M+1
		    ParentID[M] <- N
		    if(nm[i] == "") nm[i] = paste("[[",i,"]]",sep="")
		    md.l  <- mode(obj.nms[[i]])
		    objdim.l <- dim(obj.nms[[i]])
		    if(length(objdim.l) == 0)
			dim.field.l <- paste("length:",length(obj.nms[[i]]))
		    else{
			dim.field.l <- "dim:"
			for(j in 1:length(objdim.l))
			    dim.field.l <- paste(dim.field.l,objdim.l[i])
		    }
		    ##cat("    objname:",nm[i],", type=",md.l,",",dim.field.l,"\n")
		    IDS <- c(IDS,M)
		    NAMES <- c(NAMES, nm[i])
		    TYPES <- c(TYPES, md.l)
		    DIMS <- c(DIMS,dim.field.l)
		}
	    }## "table"

	    else if(inherits(obj, "mts")) {

		nm <- dimnames(obj)[[2]]
		lg <- length(nm)
		Container[N] <- TRUE
		ItemsPerContainer[N] <- lg
		for(i in 1:lg){
		    M <- M+1
		    ParentID[M] <- N
		    md.l  <- mode(obj[[i]])
		    dim.field.l <- paste("length:",dim(obj)[1])
		    md.l <- "ts"
		    ##cat("    tseries:",nm[i],", type=",md.l,",",dim.field.l,"\n")
		    IDS <- c(IDS,M)
		    NAMES <- c(NAMES, nm[i])
		    TYPES <- c(TYPES, md.l)
		    DIMS <- c(DIMS,dim.field.l)
		}
	    }## "mts"

	} ## recursive or classed

    } ## "for each object"

    if(debugMe) cat(" __end {for}\n ")##; browser()

    Container	      <- c(Container,	  rep.int(FALSE, M-N))
    IsRoot	      <- c(IsRoot,	  rep.int(FALSE, M-N))
    ItemsPerContainer <- c(ItemsPerContainer, rep.int(0, M-N))

    if(is.null(main))
	main <- paste("R objects in", deparse(substitute(envir)))
    if(is.null(properties)) {
	properties <- as.list(c(date = format(Sys.time(), "%Y-%b-%d %H:%M"),
				local({
				    si <- Sys.info()
				    si[c("user","nodename","sysname")]})))
    }
    if(html)
	wsbrowser(IDS,IsRoot,Container,ItemsPerContainer, ParentID,
		  NAMES,TYPES,DIMS,
		  kind = "HTML", main = main, properties = properties,
		  expanded)
    else ## currently only for Mac:
	.Internal(wsbrowser(as.integer(IDS),IsRoot,Container,
			    as.integer(ItemsPerContainer),as.integer(ParentID),
			    NAMES,TYPES,DIMS))
}

wsbrowser <- function(IDS, IsRoot, IsContainer, ItemsPerContainer,
		      ParentID, NAMES, TYPES, DIMS, expanded=TRUE,
		      kind = "HTML",
		      main = "R Workspace", properties = list(),
		      browser = getOption("browser"))
{
    if(kind != "HTML") stop("kind `",kind,"'  not yet implemented")

    Pst <- function(...) paste(..., sep="")

    bold <- function(ch) Pst("<b>",ch,"</b>")
    ital <- function(ch) Pst("<i>",ch,"</i>")
    entry<- function(ch) Pst("<td>",ch,"</td>")
    Par	 <- function(ch) Pst("<P>",ch,"</P>")
    Trow <- function(N, ...) {
	if(length(list(...)) != N) stop("wrong number of table row entries")
	paste("<tr>", ..., "</tr>\n")
    }
    catRow <- function(...) cat(Trow(nCol, ...), file = Hfile)

#    n <- length(IDS)
    RootItems <- which(IsRoot)
    NumOfRoots <- length(RootItems)

    props <- properties
    if(length(props)) { ## translate named list into 2-column (vertical) table
	nms <- names(props)
	nms <- unlist(lapply(unlist(lapply(Pst(nms,":"),
					   bold)),
			     entry))
	props <- unlist(lapply(props, entry))
	props <-
	    paste("<table border=2>",
		  paste(Trow(1, paste(nms, props)), collapse=""),
		  "</table>", sep = "\n")
    }
    fname <- file.path(tempdir(), "wsbrowser.html")
    Hfile <- file(fname,"w")

    cat("<html>\n<title>", main, "browser</title>\n<body>",
	"<H1>",main,"</H1>\n",
	if(is.character(props)) Par(props),
	"<table border=1>\n", file = Hfile)
    nCol <- if(expanded) 4 else 3
    catRow(entry(bold("Object")),
	   if(expanded) entry(bold(ital("(components)"))),
	   entry(bold("Type")),
	   entry(bold("Property")))

    for(i in 1:NumOfRoots) {
	iid <- RootItems[i]
	catRow(entry(NAMES[iid]),
	       if(expanded) entry(""),
	       entry(ital(TYPES[iid])),
	       entry(DIMS[iid]))
	if(IsContainer[i] && expanded) {
	    items <- which(ParentID == i)
	    for(j in 1:ItemsPerContainer[i]) {
		id <- IDS[items[j]]
		catRow(entry(""),
		       entry(NAMES[id]),#was Pst("$",NAMES[id]) : ugly for [[i]]
		       entry(ital(TYPES[id])),
		       entry(DIMS[id]))
	    }
	}
    }
    cat("</table>\n</body></html>",file=Hfile)
    close(Hfile)

    switch(.Platform$OS.type,
	   windows = , ## do we need anything here?
	   unix = { url <- fname },
	   )
    if(substr(url, 1,1) != "/")
	url <- paste("/", url, sep = "")
    url <- paste("file://", url, sep = "")

    browseURL(url = url, browser = browser)
    cat(main, "environment is shown in browser",
        if(!is.null(browser))paste("`",browser, "'", sep=""),"\n")

    invisible(filename = fname)
}
row.names <- function(x) UseMethod("row.names")
row.names.data.frame <- function(x) attr(x, "row.names")
row.names.default <- function(x) if(!is.null(dim(x))) rownames(x)# else NULL

"row.names<-" <- function(x, value) UseMethod("row.names<-")
"row.names<-.data.frame" <- function(x, value) {
    if (!is.data.frame(x))
	x <- as.data.frame(x)
    old <- attr(x, "row.names")
    if (!is.null(old) && length(value) != length(old))
	stop("invalid row.names length")
    value <- as.character(value)
    if (any(duplicated(value)))
	stop("duplicate row.names are not allowed")
    if (any(is.na(value)))
	stop("missing row.names are not allowed")
    attr(x, "row.names") <- value
    x
}

"row.names<-.default" <- function(x, value) "rownames<-"(x, value)

is.na.data.frame <- function (x)
{
    y <- do.call("cbind", lapply(x, "is.na"))
    rownames(y) <- row.names(x)
    y
}

is.data.frame <- function(x) inherits(x, "data.frame")

I <- function(x) { structure(x, class = unique(c("AsIs", oldClass(x)))) }

print.AsIs <- function (x, ...)
{
    cl <- oldClass(x)
    oldClass(x) <- cl[cl != "AsIs"]
    NextMethod("print")
    invisible(x)
}

plot.data.frame <- function (x, ...) {
    if(!is.data.frame(x))
	stop("plot.data.frame applied to non data frame")
    x <- data.matrix(x)
    if(ncol(x) == 1) {
	stripchart(x, ...)
    }
    else if(ncol(x) == 2) {
	plot(x, ...)
    }
    else {
	pairs(x, ...)
    }
}

t.data.frame <- function(x) {
    x <- as.matrix(x)
    NextMethod("t")
}

dim.data.frame <- function(x) c(length(attr(x,"row.names")), length(x))

dimnames.data.frame <- function(x) list(attr(x,"row.names"), names(x))

"dimnames<-.data.frame" <- function(x, value) {
    d <- dim(x)
    if(!is.list(value) || length(value) != 2
       || d[[1]] != length(value[[1]])
       || d[[2]] != length(value[[2]]))
	stop("invalid dimnames given for data frame")
    attr(x, "row.names") <- as.character(value[[1]])
    attr(x, "names") <- as.character(value[[2]])
    x
}

as.data.frame <- function(x, row.names = NULL, optional = FALSE) {
    if(is.null(x))			# can't assign class to NULL
	return(as.data.frame(list()))
    UseMethod("as.data.frame")
}
as.data.frame.default <- function(x, row.names = NULL, optional = FALSE)
    stop(paste("can't coerce", class(x), "into a data.frame"))


###  Here are methods ensuring that the arguments to "data.frame"
###  are in a form suitable for combining into a data frame.

as.data.frame.data.frame <- function(x, row.names = NULL, optional = FALSE)
{
    cl <- oldClass(x)
    i <- match("data.frame", cl)
    if(i > 1)
	class(x) <- cl[ - (1:(i-1))]
    if(is.character(row.names)){
	if(length(row.names) == length(attr(x, "row.names")))
	    attr(x, "row.names") <- row.names
	else stop(paste("invalid row.names, length", length(row.names),
			"for a data frame with", length(attr(x, "row.names")),
			"rows"))
    }
    x
}

## prior to 1.8.0 this coerced names - PR#3280
as.data.frame.list <- function(x, row.names = NULL, optional = FALSE)
{
    ## need to protect names in x.
    cn <- names(x)
    m <- match(c("row.names", "check.rows", "check.names"), cn, 0)
    if(any(m > 0)) {
        cn[m] <- paste("..adfl.", cn[m], sep="")
        names(x) <- cn
    }
    x <- eval(as.call(c(expression(data.frame), x, check.names = !optional)))
    if(any(m > 0)) names(x) <- sub("^..adfl.", "", names(x))
    if(!is.null(row.names)) {
	row.names <- as.character(row.names)
	if(length(row.names) != dim(x)[[1]]) stop(paste(
		 "supplied", length(row.names), "row names for",
		 dim(x)[[1]], "rows"))
	attr(x, "row.names") <- row.names
    }
    x
}

as.data.frame.vector <- function(x, row.names = NULL, optional = FALSE)
{
    nrows <- length(x)
    if(is.null(row.names)) {
	if (nrows == 0)
	    row.names <- character(0)
	else if(length(row.names <- names(x)) == nrows &&
		!any(duplicated(row.names))) {}
	else if(optional) row.names <- character(nrows)
	else row.names <- as.character(1:nrows)
    }
    value <- list(x)
    if(!optional) names(value) <- deparse(substitute(x))[[1]]
    attr(value, "row.names") <- row.names
    class(value) <- "data.frame"
    value
}

as.data.frame.ts <- function(x, row.names=NULL, optional=FALSE)
{
    if(is.matrix(x))
	as.data.frame.matrix(x, row.names, optional)
    else
	as.data.frame.vector(x, row.names, optional)
}

as.data.frame.factor  <- as.data.frame.vector
as.data.frame.ordered <- as.data.frame.vector
as.data.frame.integer <- as.data.frame.vector
as.data.frame.numeric <- as.data.frame.vector
as.data.frame.complex <- as.data.frame.vector

as.data.frame.character <- function(x, row.names = NULL, optional = FALSE)
    as.data.frame.vector(factor(x), row.names, optional)

as.data.frame.logical <- as.data.frame.vector

as.data.frame.matrix <- function(x, row.names = NULL, optional = FALSE)
{
    d <- dim(x)
    nrows <- d[1]; ir <- seq(length = nrows)
    ncols <- d[2]; ic <- seq(length = ncols)
    dn <- dimnames(x)
    ## surely it cannot be right to override the supplied row.names?
    ## changed in 1.8.0
    if(missing(row.names)) row.names <- dn[[1]]
    collabs <- dn[[2]]
    if(any(empty <- nchar(collabs)==0))
	collabs[empty] <- paste("V", ic, sep = "")[empty]
    value <- vector("list", ncols)
    if(mode(x) == "character") {
	for(i in ic)
	    value[[i]] <- as.factor(x[,i])
    } else {
	for(i in ic)
	    value[[i]] <- as.vector(x[,i])
    }
    if(length(row.names) != nrows)
	row.names <- if(optional) character(nrows) else as.character(ir)
    if(length(collabs) == ncols)
	names(value) <- collabs
    else if(!optional)
	names(value) <- paste("V", ic, sep="")
    attr(value, "row.names") <- row.names
    class(value) <- "data.frame"
    value
}

as.data.frame.model.matrix <- function(x, row.names = NULL, optional = FALSE)
{
    d <- dim(x)
    nrows <- d[1]
    dn <- dimnames(x)
    row.names <- dn[[1]]
    value <- list(x)
    if(!is.null(row.names)) {
	row.names <- as.character(row.names)
	if(length(row.names) != nrows) stop(paste("supplied",
		 length(row.names), "names for a data frame with",
		 nrows, "rows"))
    }
    else if(optional) row.names <- character(nrows)
    else row.names <- as.character(1:nrows)
    if(!optional) names(value) <- deparse(substitute(x))[[1]]
    attr(value, "row.names") <- row.names
    class(value) <- "data.frame"
    value
}

## will always have a class here
"[.AsIs" <- function(x, i, ...) structure(NextMethod("["), class = class(x))

as.data.frame.AsIs <- function(x, row.names = NULL, optional = FALSE)
{
    ## why not remove class and NextMethod here?
    if(length(dim(x))==2)
	as.data.frame.model.matrix(x, row.names, optional)
    else
	as.data.frame.vector(x, row.names, optional)
}

###  This is the real "data.frame".
###  It does everything by calling the methods presented above.

data.frame <-
    function(..., row.names = NULL, check.rows = FALSE, check.names = TRUE)
{
    data.row.names <-
	if(check.rows && missing(row.names))
	    function(current, new, i) {
		new <- as.character(new)
		if(any(duplicated(new)))
		    return(current)
		if(is.null(current))
		    return(new)
		if(all(current == new) || all(current == ""))
		    return(new)
		stop(paste("mismatch of row names in elements of",
			   "\"data.frame\", item", i))
	    }
	else function(current, new, i) {
	    if(is.null(current)) {
		if(any(dup <- duplicated(new <- as.character(new)))) {
		    warning(paste("some row.names duplicated:",
				  paste(which(dup),collapse=","),
				  " --> row.names NOT used."))
		    current
		} else new
	    } else current
	}
    object <- as.list(substitute(list(...)))[-1]
    mrn <- missing(row.names)
    x <- list(...)
    n <- length(x)
    if(n < 1)
	return(structure(list(), row.names = character(0),
			 class = "data.frame"))
    vnames <- names(x)
    if(length(vnames) != n)
	vnames <- character(n)
    no.vn <- nchar(vnames) == 0
    vlist <- vnames <- as.list(vnames)
    nrows <- ncols <- integer(n)
    for(i in 1:n) {
	xi <- as.data.frame(x[[i]], optional=TRUE)
	rowsi <- attr(xi, "row.names")
	ncols[i] <- length(xi)
	namesi <- names(xi)
	if(ncols[i] > 1) {
	    if(length(namesi) == 0) namesi <- 1:ncols[i]
	    if(no.vn[i]) vnames[[i]] <- namesi
	    else vnames[[i]] <- paste(vnames[[i]], namesi, sep=".")
	}
	else {
            if(length(namesi) > 0) vnames[[i]] <- namesi
            else if (no.vn[[i]]) {
                tmpname <- deparse(object[[i]])[1]
                if( substr(tmpname,1,2) == "I(" ) {
                    ntmpn <- nchar(tmpname)
                    if(substr(tmpname, ntmpn, ntmpn) == ")")
                        tmpname <- substr(tmpname,3,ntmpn-1)
                }
                vnames[[i]] <- tmpname
            }
        } # end of ncols[i] <= 1
	nrows[i] <- length(rowsi)
	if(missing(row.names) && (nrows[i] > 0) && !(rowsi[[1]] %in% ""))
	    row.names <- data.row.names(row.names, rowsi, i)
	vlist[[i]] <- xi
    }
    nr <- max(nrows)
    for(i in (1:n)[nrows < nr]) {
	xi <- vlist[[i]]
	if(length(xi)==1 && nrows[i] > 0 && nr%%nrows[i]==0) {
            xi1 <- xi[[1]]
            if(is.vector(xi1) || is.factor(xi1)) {
                vlist[[i]] <- list(rep(xi1, length=nr))
                next
            }
            if(is.character(xi1) && class(xi1) == "AsIs") {
                ## simple char vectors only
                cl <- class(xi1) # `methods' adds a class -- Eh?
                vlist[[i]] <- list(structure(rep(xi1, length=nr), class=cl))
                next
            }
        }
	stop(paste("arguments imply differing number of rows:",
                   paste(unique(nrows), collapse = ", ")))
    }
    value <- unlist(vlist, recursive=FALSE, use.names=FALSE)
    ## unlist() drops i-th component if it has 0 columns
    vnames <- unlist(vnames[ncols > 0])
    noname <- nchar(vnames) == 0
    if(any(noname))
	vnames[noname] <- paste("Var", 1:length(vnames), sep = ".")[noname]
    if(check.names)
	vnames <- make.names(vnames)
    names(value) <- vnames
    if(!mrn) { # row.names arg was supplied
        if(length(row.names) == 1 && nr != 1) {  # one of the variables
            if(is.character(row.names))
                row.names <- match(row.names, vnames, 0)
            if(length(row.names)!=1 ||
               row.names < 1 || row.names > length(vnames))
                stop("row.names should specify one of the variables")
            i <- row.names
            row.names <- value[[i]]
            value <- value[ - i]
        } else if (length(row.names) > 0 && length(row.names) != nr)
            stop("row names supplied are of the wrong length")
    } else if(length(row.names) > 0 && length(row.names) != nr) {
        warning("row names were found from a short variable and have been discarded")
        row.names <- NULL
    }
    if(length(row.names) == 0) row.names <- seq(length = nr)
    row.names <- as.character(row.names)
    if(any(is.na(row.names)))
        stop("row names contain missing values")
    if(any(duplicated(row.names)))
	stop(paste("duplicate row.names:",
		   paste(unique(row.names[duplicated(row.names)]),
			 collapse = ", ")))
    attr(value, "row.names") <- row.names
    attr(value, "class") <- "data.frame"
    value
}


###  Subsetting and mutation methods
###  These are a little less general than S

"[.data.frame" <-
    function(x, i, j, drop = if(missing(i)) TRUE else length(cols) == 1)
{
    mdrop <- missing(drop)
    Narg <- nargs() - !mdrop  # number of arg from x,i,j that were specified

    if(Narg < 3) {  # list-like indexing or matrix indexing
        if(!mdrop) warning("drop argument will be ignored")
	if(missing(i))
	    return(x)
	if(is.matrix(i))
	    return(as.matrix(x)[i])  # desperate measures
	y <- NextMethod("[")
        nm <- names(y)
	if(any(is.na(nm))) stop("undefined columns selected")
        ## added in 1.8.0
        if(any(duplicated(nm))) names(y) <- make.unique(nm)
	return(structure(y, class = oldClass(x), row.names = row.names(x)))
    }

    ## preserve the attributes for later use ...

    rows <- attr(x, "row.names")
    cols <- names(x)
    cl <- oldClass(x) # doesn't really matter unless called directly
    class(x) <- attr(x, "row.names") <- NULL


    if(missing(i)) { # df[, j] or df[ , ]
        ## handle the column only subsetting ...
        if(!missing(j)) x <- x[j]
	cols <- names(x)
	if(any(is.na(cols))) stop("undefined columns selected")
    }
    else { # df[i, j] or df[i , ]
	if(is.character(i))
	    i <- pmatch(i, rows, duplicates.ok = TRUE)
	rows <- rows[i]
	if(!missing(j)) { # df[i, j]
	    x <- x[j]
	    cols <- names(x)
	    if(any(is.na(cols))) stop("undefined columns selected")
	}
	for(j in seq(along = x)) {
	    xj <- x[[j]]
            ## had drop = drop prior to 1.8.0
	    x[[j]] <- if(length(dim(xj)) != 2) xj[i] else xj[i, , drop = FALSE]
	}
    }
    if(drop) {
	drop <- FALSE
	n <- length(x)
	if(n == 1) {
	    x <- x[[1]]
	    drop <- TRUE
	}
	else if(n > 1) {
	    xj <- x[[1]]
	    nrow <- if(length(dim(xj)) == 2) dim(xj)[1] else length(xj)
            ## for consistency with S: don't drop (to a list)
            ## if only one row unless explicitly asked for
	    if(!mdrop && nrow == 1) {
		drop <- TRUE
		names(x) <- cols
		attr(x, "row.names") <- NULL
	    }
	}
    }
    if(!drop) { # not else as previous section might reset drop
	names(x) <- cols
        ## row names might have NAs.
	if(any(is.na(rows) | duplicated(rows))) {
            rows[is.na(rows)] <- "NA"
	    rows <- make.unique(rows)
        }
        ## new in 1.8.0  -- might have duplicate columns
        if(any(duplicated(nm <- names(x)))) names(x) <- make.unique(nm)
	attr(x, "row.names") <- rows
	class(x) <- cl
    }
    x
}

"[[.data.frame" <- function(x, ...)
{
    ## use in-line functions to refer to the 1st and 2nd ... arguments
    ## explicitly. Also will check for wrong number or empty args
    if(nargs() < 3)
	(function(x, i)
	  if(is.matrix(i))
	  as.matrix(x)[[i]]
 	  else .subset2(x,i))(x, ...)
    else
        .subset2(.subset2(x, ..1), ..2)
}

"[<-.data.frame" <- function(x, i, j, value)
{
    nA <- nargs() # value is never missing, so 3 or 4.
    if(nA == 4) { ## df[,] or df[i,] or df[, j] or df[i,j]
	has.i <- !missing(i)
	has.j <- !missing(j)
    }
    else if(nA == 3) {
        ## this collects both df[] and df[ind]
        if(missing(i) && missing(j)) { # case df[]
            i <- j <- NULL
            has.i <- has.j <- FALSE
            ## added in 1.8.0
            if(is.null(value)) return(x[logical(0)])
        } else { # case df[ind]
            ## really ambiguous, but follow common use as if list
            ## except for a full-sized logical matrix
            if(is.logical(i) && is.matrix(i) && all(dim(i) == dim(x))) {
                nreplace <- sum(i, na.rm=TRUE)
                ## allow replication of length(value) > 1 in 1.8.0
                N <- length(value)
                if(N > 0 && N < nreplace && (nreplace %% N) == 0)
                    value <- rep(value, length = nreplace)
                if(length(value) != nreplace)
                    stop("rhs is the wrong length for indexing by a logical matrix")
                n <- 0
                nv <- nrow(x)
                for(v in seq(len = dim(i)[2])) {
                    thisvar <- i[, v, drop = TRUE]
                    nv <- sum(thisvar, na.rm = TRUE)
                    if(nv) {
                        if(is.matrix(x[[v]]))
                            x[[v]][thisvar, ] <- value[n+(1:nv)]
                        else
                            x[[v]][thisvar] <- value[n+(1:nv)]
                    }
                    n <- n+nv
                }
                return(x)
            }  # end of logical matrix
            if(is.matrix(i))
                stop("only logical matrix subscripts are allowed in replacement")
            j <- i
            i <- NULL
            has.i <- FALSE
            has.j <- TRUE
        }
    }
    else {
	stop("Need 0, 1, or 2 subscripts")
    }
    ## no columns specified
    if(has.j && length(j) ==0) return(x)

    cl <- oldClass(x)
    ## delete class: Version 3 idiom
    ## to avoid any special methods for [[, etc
    class(x) <- NULL
    rows <- attr(x, "row.names")
    new.cols <- NULL
    nvars <- length(x)
    nrows <- length(rows)
    if(has.i) { # df[i, ] or df[i, j]
	if(char.i <- is.character(i)) {
	    ii <- match(i, rows)
	    nextra <- sum(new.rows <- is.na(ii))
	    if(nextra > 0) {
		ii[new.rows] <- seq(from = nrows + 1, length = nextra)
		new.rows <- i[new.rows]
	    }
	    i <- ii
	}
	if(all(i >= 0) && (nn <- max(i)) > nrows) {
	    ## expand
	    if(!char.i) {
		nrr <- as.character((nrows + 1):nn)
		if(inherits(value, "data.frame") &&
		   (dim(value)[1]) >= length(nrr)) {
		    new.rows <- attr(value, "row.names")[1:length(nrr)]
		    repl <- duplicated(new.rows) | match(new.rows, rows, 0)
		    if(any(repl))
			new.rows[repl] <- nrr[repl]
		}
		else new.rows <- nrr
	    }
	    x <- xpdrows.data.frame(x, rows, new.rows)
	    rows <- attr(x, "row.names")
	    nrows <- length(rows)
	}
	iseq <- seq(along = rows)[i]
	if(any(is.na(iseq)))
	    stop("non-existent rows not allowed")
    }
    else iseq <- NULL
    if(has.j) {
	if(is.character(j)) {
	    jj <- match(j, names(x))
	    nnew <- sum(is.na(jj))
	    if(nnew > 0) {
		n <- is.na(jj)
		jj[n] <- nvars + 1:nnew
		new.cols <- j[n]
	    }
	    jseq <- jj
	}
	else if(is.logical(j) || min(j) < 0)
	    jseq <- seq(along = x)[j]
	else {
	    jseq <- j
	    if(max(jseq) > nvars) {
		new.cols <- paste("V", seq(from = nvars + 1, to = max(jseq)),
                                  sep = "")
		if(length(new.cols)  != sum(jseq > nvars))
		    stop(paste("new columns would leave holes",
			       "after existing columns"))
                ## try to use the names of a list `value'
                if(is.list(value) && !is.null(vnm <- names(value))) {
                    p <- length(jseq)
                    if(length(vnm) < p) vnm <- rep(vnm, length = p)
                    new.cols <- vnm[jseq > nvars]
                }
	    }
	}
    }
    else jseq <- seq(along = x)
    ## addition in 1.8.0
    if(any(duplicated(jseq)))
        stop("duplicate subscripts for columns")
    n <- length(iseq)
    if(n == 0) n <- nrows
    p <- length(jseq)
    m <- length(value)
    if(!is.list(value)) {
        if(p == 1) value <- list(value)
        else {
            if(m < n*p && (n*p) %% m)
                stop(paste("replacement has", m, "items, need", n*p))
            value <- matrix(value, n, p)  ## will recycle
            value <- split(value, col(value))
        }
	dimv <- c(n, p)
    } else { # a list
        ## careful, as.data.frame turns things into factors.
	## value <- as.data.frame(value)
        lens <- sapply(value, NROW)
        for(k in seq(along=lens)) {
            N <- lens[k]
            if(n != N && length(dim(value[[k]])) == 2)
                stop(paste("replacement element", k,
                           "is a matrix/data frame of", N,
                           "rows, need", n))
            if(N > 0 && N < n && n %% N)
                stop(paste("replacement element", k, "has", N,
                           "rows, need", n))
            ## these fixing-ups will not work for matrices
            if(N > 0 && N < n) value[[k]] <- rep(value[[k]], len=n)
            if(N > n) {
                warning(paste("replacement element", k, "has", N,
                              "rows to replace", n, "rows"))
                value[[k]] <- value[[k]][1:n]
            }
        }
	dimv <- c(n, length(value))
    }
    nrowv <- dimv[1]
    if(nrowv < n && nrowv > 0) {
	if(n %% nrowv == 0)
	    value <- value[rep(1:nrowv, length=n),,drop = FALSE]
	else stop(paste(nrowv, "rows in value to replace", n, "rows"))
    }
    else if(nrowv > n)
	warning(paste("replacement data has", nrowv, "rows to replace",
		      n, "rows"))
    ncolv <- dimv[2]
    jvseq <- seq(len=p)
    if(ncolv < p) jvseq <- rep(1:ncolv, length = p)
    else if(ncolv > p)
	warning(paste("provided", ncolv, "variables to replace", p,
		      "variables"))
    if(length(new.cols)) {
        ## extend and name now, as assignment of NULL may delete cols later.
        nm <- names(x)
        rows <- attr(x, "row.names")
        x <- c(x, vector("list", length(new.cols)))
        names(x) <- c(nm, new.cols)
        attr(x, "row.names") <- rows
    }
    if(has.i)
	for(jjj in seq(len=p)) {
	    jj <- jseq[jjj]
	    vjj <- value[[ jvseq[[jjj]] ]]
	    xj <- x[[jj]]
	    if(length(dim(xj)) != 2) xj[iseq] <- vjj else xj[iseq, ] <- vjj
            ## if a column exists, preserve its attributes
            if(jj <= nvars) x[[jj]][] <- xj else x[[jj]] <- xj
	}
    else if(p > 0) for(jjj in p:1) { # we might delete columns with NULL
	jj <- jseq[jjj]
	x[[jj]] <- value[[ jvseq[[jjj]] ]]
    }
    if(length(new.cols) > 0) {
        new.cols <- names(x) # we might delete columns with NULL
        ## added in 1.8.0
        if(any(duplicated(new.cols))) names(x) <- make.unique(new.cols)
    }
    class(x) <- cl
    x
}

"[[<-.data.frame"<- function(x, i, j, value)
{
    cl <- oldClass(x)
    ## delete class: Version 3 idiom
    ## to avoid any special methods for [[<-
    class(x) <- NULL
    rows <- attr(x, "row.names")
    nrows <- length(rows)
    if(nargs() < 4) {
	## really ambiguous, but follow common use as if list
        nc <- length(x)
	if(!is.null(value)) {
            N <- NROW(value)
            if(N > nrows)
                stop(paste("replacement has", N, "rows, data has", nrows))
            if(N < nrows && N > 0)
                if(nrows %% N == 0 && length(dim(value)) <= 1)
                    value <- rep(value, length = nrows)
                else
                    stop(paste("replacement has", N, "rows, data has", nrows))
	}
	x[[i]] <- value
        ## added in 1.8.0 -- make sure there is a name
        if(length(x) > nc) {
            nc <- length(x)
            if(names(x)[nc] == "") names(x)[nc] <- paste("V", nc, sep="")
            names(x) <- make.unique(names(x))
        }
	class(x) <- cl
	return(x)
    }
    if(missing(i) || missing(j))
	stop("only valid calls are x[[j]] <- value or x[[i,j]] <- value")
    nvars <- length(x)
    if(n <- is.character(i)) {
	ii <- match(i, rows)
	n <- sum(new.rows <- is.na(ii))
	if(n > 0) {
	    ii[new.rows] <- seq(from = nrows + 1, length = n)
	    new.rows <- i[new.rows]
	}
	i <- ii
    }
    if(all(i >= 0) && (nn <- max(i)) > nrows) {
	## expand
	if(n==0) {
	    nrr <- as.character((nrows + 1):nn)
	    if(inherits(value, "data.frame") &&
	       (dim(value)[1]) >= length(nrr)) {
		new.rows <- attr(value, "row.names")[1:length(nrr)]
		repl <- duplicated(new.rows) | match(new.rows, rows, 0)
		if(any(repl))
		    new.rows[repl] <- nrr[repl]
	    }
	    else new.rows <- nrr
	}
	x <- xpdrows.data.frame(x, rows, new.rows)
	rows <- attr(x, "row.names")
	nrows <- length(rows)
    }
    iseq <- seq(along = rows)[i]
    if(any(is.na(iseq)))
	stop("non-existent rows not allowed")
    if(is.character(j)) {
	jseq <- match(j, names(x))
	if(any(is.na(jseq)))
	    stop(paste("replacing element in non-existent column:",
		       j[is.na(jseq)]))
    }
    else if(is.logical(j) || min(j) < 0)
	jseq <- seq(along = x)[j]
    else {
	jseq <- j
	if(max(jseq) > nvars)
	    stop(paste("replacing element in non-existent column:",
		       jseq[jseq>nvars]))
    }
    if(length(iseq) > 1 || length(jseq) > 1)
	stop("only a single element should be replaced")
    x[[jseq]][[iseq]] <- value
    class(x) <- cl
    x
}

## added in 1.8.0
"$<-.data.frame"<- function(x, i, value)
{
    cl <- oldClass(x)
    ## delete class: Version 3 idiom
    ## to avoid any special methods for [[<-
    class(x) <- NULL
    nrows <- length(attr(x, "row.names"))
    if(!is.null(value)) {
        N <- NROW(value)
        if(N > nrows)
            stop(paste("replacement has", N, "rows, data has", nrows))
        if(N < nrows && N > 0)
            if(nrows %% N == 0 && length(dim(value)) <= 1)
                value <- rep(value, length = nrows)
            else
                stop(paste("replacement has", N, "rows, data has", nrows))
    }
    x[[i]] <- value
    class(x) <- cl
    return(x)
}

xpdrows.data.frame <- function(x, old.rows, new.rows)
{
    nc <- length(x)
    nro <- length(old.rows)
    nrn <- length(new.rows)
    nr <- nro + nrn
    for (i in 1:nc) {
	y <- x[[i]]
	dy <- dim(y)
	cy <- oldClass(y)
	class(y) <- NULL
	if (length(dy) == 2) {
	    dny <- dimnames(y)
	    if (length(dny[[1]]) > 0)
		dny[[1]] <- c(dny[[1]], new.rows)
	    z <- array(y[1], dim = c(nr, nc), dimnames = dny)
	    z[1 : nro, ] <- y
	    class(z) <- cy
	    x[[i]] <- z
	}
	else {
	    ay <- attributes(y)
	    if (length(names(y)) > 0)
		ay$names <- c(ay$names, new.rows)
	    length(y) <- nr
	    attributes(y) <- ay
	    class(y) <- cy
	    x[[i]] <- y
	}
    }
    attr(x, "row.names") <- as.character(c(old.rows, new.rows))
    x
}


### Here are the methods for rbind and cbind.

cbind.data.frame <- function(..., deparse.level = 1)
    data.frame(..., check.names = FALSE)

rbind.data.frame <- function(..., deparse.level = 1)
{
    match.names <- function(clabs, nmi)
    {
	if(all(clabs == nmi))
	    NULL
	else if(all(nii <- match(nmi, clabs, 0)))
	    nii
	else stop(paste("names don't match previous names:\n\t",
			paste(nmi[nii == 0], collapse = ", ")))
    }
    Make.row.names <- function(nmi, ri, ni, nrow)
    {
	if(nchar(nmi) > 0) {
	    if(ni > 1)
		paste(nmi, ri, sep = ".")
	    else nmi
	}
	else if(nrow > 0 && identical(ri, 1:ni))
	    seq(from = nrow + 1, length = ni)
	else ri
    }
    allargs <- list(...)
    allargs <- allargs[sapply(allargs, length) > 0]
    n <- length(allargs)
    if(n == 0)
	return(structure(list(),
			 class = "data.frame",
			 row.names = character()))
    nms <- names(allargs)
    if(is.null(nms))
	nms <- character(length(allargs))
    cl <- NULL
    perm <- rows <- rlabs <- vector("list", n)
    nrow <- 0
    value <- clabs <- NULL
    all.levs <- list()
    for(i in 1:n) {
	## check the arguments, develop row and column labels
	xi <- allargs[[i]]
	nmi <- nms[i]
        ## coerce matrix to data frame
        if(is.matrix(xi)) allargs[[i]] <- xi <- as.data.frame(xi)
	if(inherits(xi, "data.frame")) {
	    if(is.null(cl))
		cl <- oldClass(xi)
	    ri <- row.names(xi)
	    ni <- length(ri)
	    if(is.null(clabs))
		clabs <- names(xi)
	    else {
		pi <- match.names(clabs, names(xi))
		if( !is.null(pi) )
		    perm[[i]] <- pi
	    }
	    rows[[i]] <- seq(from = nrow + 1, length = ni)
	    rlabs[[i]] <- Make.row.names(nmi, ri, ni, nrow)
	    nrow <- nrow + ni
	    if(is.null(value)) {
		value <- unclass(xi)
		nvar <- length(value)
		all.levs <- vector("list", nvar)
		has.dim <- logical(nvar)
                facCol <- logical(nvar)
                ordCol <- logical(nvar)
		for(j in 1:nvar) {
		    xj <- value[[j]]
		    if( !is.null(levels(xj)) ) {
			all.levs[[j]] <- levels(xj)
                        facCol[j] <- TRUE # turn categories into factors
                    } else facCol[j] <- is.factor(xj)
                    ordCol[j] <- is.ordered(xj)
		    has.dim[j] <- length(dim(xj)) == 2
		}
	    }
	    else for(j in 1:nvar)
                if(facCol[j]) {
                    xij <- xi[[j]]
                    if(is.null(pi) || is.na(jj <- pi[[j]])) jj <- j
                    if(length(lij <- levels(xij)) > 0) {
                        all.levs[[jj]] <- unique(c(all.levs[[jj]], lij))
                        ordCol[j] <- ordCol[j] & is.ordered(xij)
                    } else if(is.character(xij))
                        all.levs[[jj]] <- unique(c(all.levs[[jj]], xij))
                }
	}
	else if(is.list(xi)) {
	    ni <- range(sapply(xi, length))
	    if(ni[1] == ni[2])
		ni <- ni[1]
	    else stop("invalid list argument: all variables should have the same length")
	    rows[[i]] <- ri <- seq(from = nrow + 1, length = ni)
	    nrow <- nrow + ni
	    rlabs[[i]] <- Make.row.names(nmi, ri, ni, nrow)
	    if(length(nmi <- names(xi)) > 0) {
		if(is.null(clabs))
		    clabs <- nmi
		else {
		    tmp<-match.names(clabs, nmi)
		    if( !is.null(tmp) )
			perm[[i]] <- tmp
		}
	    }
	}
	else if(length(xi) > 0) {
	    rows[[i]] <- nrow <- nrow + 1
	    rlabs[[i]] <- if(nchar(nmi) > 0) nmi else nrow
	}
    }
    nvar <- length(clabs)
    if(nvar == 0)
	nvar <- max(sapply(allargs, length))	# only vector args
    if(nvar == 0)
	return(structure(list(), class = "data.frame",
			 row.names = character()))
    pseq <- 1:nvar
    if(is.null(value)) {
	value <- list()
	value[pseq] <- list(logical(nrow))
    }
    names(value) <- clabs
    for(j in 1:nvar)
	if(length(lij <- all.levs[[j]]) > 0)
            value[[j]] <-
                factor(as.vector(value[[j]]), lij, ordered = ordCol[j])
    if(any(has.dim)) {
	rmax <- max(unlist(rows))
	for(i in (1:nvar)[has.dim])
	    if(!inherits(xi <- value[[i]], "data.frame")) {
		dn <- dimnames(xi)
		rn <- dn[[1]]
		if(length(rn) > 0) length(rn) <- rmax
		pi <- dim(xi)[2]
		length(xi) <- rmax * pi
		value[[i]] <- array(xi, c(rmax, pi), list(rn, dn[[2]]))
	    }
    }
    for(i in 1:n) {
	xi <- unclass(allargs[[i]])
	if(!is.list(xi))
	    if(length(xi) != nvar)
		xi <- rep(xi, length = nvar)
	ri <- rows[[i]]
	pi <- perm[[i]]
	if(is.null(pi))
	    pi <- pseq
	for(j in 1:nvar) {
	    jj <- pi[j]
            xij <- xi[[j]]
	    if(has.dim[jj])
		value[[jj]][ri,	 ] <- xij
            ## coerce factors to vectors, in case lhs is character or
            ## level set has changed
	    else value[[jj]][ri] <- if(is.factor(xij)) as.vector(xij) else xij
	}
    }
#     for(j in 1:nvar) {
# 	xj <- value[[j]]
# 	if(!has.dim[j] && !inherits(xj, "AsIs") && is.character(xj))
# 	    value[[j]] <- factor(xj)
#     }
    rlabs <- make.unique(as.character(unlist(rlabs)), sep = "")
    if(is.null(cl)) {
	as.data.frame(value, row.names = rlabs)
    } else {
	class(value) <- cl
	attr(value, "row.names") <- rlabs
	value
    }
}


### coercion and print methods

print.data.frame <-
    function(x, ..., digits = NULL, quote = FALSE, right = TRUE)
{
    if(length(x) == 0) {
	cat("NULL data frame with", length(row.names(x)), "rows\n")
    } else if(length(row.names(x)) == 0) {
	print.default(names(x), quote = FALSE)
	cat("<0 rows> (or 0-length row.names)\n")
    } else {
	## avoiding picking up e.g. format.AsIs
	print(as.matrix(format.data.frame(x, digits=digits)), ...,
              quote = quote, right = right)
    }
    invisible(x)
}

as.matrix.data.frame <- function (x)
{
    dm <- dim(x)
    dn <- dimnames(x)
    if(any(dm == 0))
	return(array(NA, dim = dm, dimnames = dn))
    p <- dm[2]
    n <- dm[1]
    collabs <- as.list(dn[[2]])
    X <- x
    class(X) <- NULL
    non.numeric <- non.atomic <- FALSE
    for (j in 1:p) {
	xj <- X[[j]]
	if(length(dj <- dim(xj)) == 2 && dj[2] > 1) {
	    if(inherits(xj, "data.frame"))
		xj <- X[[j]] <- as.matrix(X[[j]])
	    dnj <- dimnames(xj)[[2]]
	    collabs[[j]] <- paste(collabs[[j]],
				  if(length(dnj) > 0) dnj else 1:dj[2],
				  sep = ".")
	}
	if(length(levels(xj)) > 0 || !(is.numeric(xj) || is.complex(xj))
	   || (!is.null(cl <- attr(xj, "class")) && # numeric classed objects to format:
	       any(cl == c("POSIXct", "POSIXlt"))))
	    non.numeric <- TRUE
	if(!is.atomic(xj))
	    non.atomic <- TRUE
    }
    if(non.atomic) {
	for (j in 1:p) {
	    xj <- X[[j]]
	    if(is.recursive(xj)) {
	    }
	    else X[[j]] <- as.list(as.vector(xj))
	}
    } else if(non.numeric) {
	for (j in 1:p) {
	    if (is.character(X[[j]]))
		next
	    xj <- X[[j]]
            miss<-is.na(xj)
	    xj <- if(length(levels(xj))) as.vector(xj) else format(xj)
            is.na(xj)<-miss
            X[[j]]<-xj
	}
    }
    X <- unlist(X, recursive = FALSE, use.names = FALSE)
    dim(X) <- c(n, length(X)/n)
    dimnames(X) <- list(dn[[1]], unlist(collabs, use.names = FALSE))
    ##NO! don't copy buggy S-plus!  either all matrices have class or none!!
    ##NO class(X) <- "matrix"
    X
}

Math.data.frame <- function (x, ...)
{
    f <- get(.Generic, mode = "function")
    if (is.null(formals(f)))
	f <- function(x, ...) {
	}
    call <- match.call(f, sys.call())
    call[[1]] <- as.name(.Generic)
    arg <- names(formals(f))[1]
    call[[arg]] <- as.name("xx")
    encl <- parent.frame()
    var.f <- function(x) eval(call, list(xx = x), encl)
    mode.ok <- sapply(x, is.numeric) & !sapply(x, is.factor) |
	sapply(x, is.complex)
    if (all(mode.ok)) {
	r <- lapply(x, var.f)
	class(r) <- oldClass(x)
	row.names(r) <- row.names(x)
	return(r)
    }
    else {
	vnames <- names(x)
	if (is.null(vnames)) vnames <- seq(along=x)
	stop(paste("Non-numeric variable in dataframe:",vnames[!mode.ok]))
    }
}

Ops.data.frame <- function(e1, e2 = NULL)
{
    isList <- function(x) !is.null(x) && is.list(x)
    unary <- nargs() == 1
    lclass <- nchar(.Method[1]) > 0
    rclass <- !unary && (nchar(.Method[2]) > 0)
    value <- list()
    ## set up call as op(left, right)
    FUN <- get(.Generic, envir = parent.frame(),mode="function")
    f <- if (unary)
	quote(FUN(left))
    else quote(FUN(left, right))
    lscalar <- rscalar <- FALSE
    if(lclass && rclass) {
	rn <- row.names(e1)
	cn <- names(e1)
	if(any(dim(e2) != dim(e1)))
	    stop(paste(.Generic, "only defined for equally-sized data frames"))
    } else if(lclass) {
	## e2 is not a data frame, but e1 is.
	rn <- row.names(e1)
	cn <- names(e1)
	rscalar <- length(e2) <= 1 # e2 might be null
	if(isList(e2)) {
	    if(rscalar) e2 <- e2[[1]]
	    else if(length(e2) != ncol(e1))
		stop(paste("list of length", length(e2), "not meaningful"))
	} else {
	    if(!rscalar)
		e2 <- split(rep(as.vector(e2), length = prod(dim(e1))),
			    rep.int(1:ncol(e1), rep.int(nrow(e1), ncol(e1))))
	}
    } else {
	## e1 is not a data frame, but e2 is.
	rn <- row.names(e2)
	cn <- names(e2)
	lscalar <- length(e1) <= 1
	if(isList(e1)) {
	    if(lscalar) e1 <- e1[[1]]
	    else if(length(e1) != ncol(e2))
		stop(paste("list of length", length(e1), "not meaningful"))
	} else {
	    if(!lscalar)
		e1 <- split(rep(as.vector(e1), length = prod(dim(e2))),
			    rep.int(1:ncol(e2), rep.int(nrow(e2), ncol(e2))))
	}
    }
    for(j in seq(along=cn)) {
	left <- if(!lscalar) e1[[j]] else e1
	right <-if(!rscalar) e2[[j]] else e2
	value[[j]] <- eval(f)
    }
    if(any(.Generic == c("+","-","*","/","%%","%/%"))) {
	names(value) <- cn
	data.frame(value, row.names=rn)
    }
    else matrix(unlist(value,recursive = FALSE, use.names=FALSE),
		nrow=length(rn), dimnames=list(rn,cn))
}

Summary.data.frame <- function(x, ...)
{
    x <- as.matrix(x)
    if(!is.numeric(x) && !is.complex(x))
	stop("only defined on a data frame with all numeric or complex variables")
    NextMethod(.Generic)
}
Sys.time <- function()
    structure(.Internal(Sys.time()), class = c("POSIXt", "POSIXct"))

Sys.timezone <- function() as.vector(Sys.getenv("TZ"))

as.POSIXlt <- function(x, tz = "")
{
    fromchar <- function(x) {
	xx <- x[1]
        if(is.na(xx)) {
            j <- 1
            while(is.na(xx) && (j <- j+1) <= length(x))
                xx <- x[j]
            if(is.na(xx)) f <- "%Y-%m-%d" # all NAs
        }
	if(is.na(xx) ||
           !is.na(strptime(xx, f <- "%Y-%m-%d %H:%M:%S")) ||
	   !is.na(strptime(xx, f <- "%Y/%m/%d %H:%M:%S")) ||
	   !is.na(strptime(xx, f <- "%Y-%m-%d %H:%M")) ||
	   !is.na(strptime(xx, f <- "%Y/%m/%d %H:%M")) ||
	   !is.na(strptime(xx, f <- "%Y-%m-%d")) ||
	   !is.na(strptime(xx, f <- "%Y/%m/%d")))
        {
	    res <- strptime(x, f)
            if(nchar(tz)) attr(res, "tzone") <- tz
            return(res)
        }
	stop("character string is not in a standard unambiguous format")
    }

    if(inherits(x, "POSIXlt")) return(x)
    if(inherits(x, "date") || inherits(x, "dates")) x <- as.POSIXct(x)
    if(is.character(x)) return(fromchar(x))
    if(is.factor(x))	return(fromchar(as.character(x)))
    if(is.logical(x) && all(is.na(x))) x <- as.POSIXct.default(x)
    if(!inherits(x, "POSIXct"))
	stop(paste("Don't know how to convert `", deparse(substitute(x)),
		   "' to class \"POSIXlt\"", sep=""))
    .Internal(as.POSIXlt(x, tz))
}

as.POSIXct <- function(x, tz = "") UseMethod("as.POSIXct")

## convert from package date
as.POSIXct.date <- function(x, ...)
{
    if(inherits(x, "date")) {
        x <- (x - 3653) * 86400 # origin 1960-01-01
        return(structure(x, class = c("POSIXt", "POSIXct")))
    } else stop(paste("`", deparse(substitute(x)),
                      "' is not a \"dates\" object", sep=""))
}

## convert from package chron
as.POSIXct.dates <- function(x, ...)
{
    if(inherits(x, "dates")) {
        z <- attr(x, "origin")
        x <- as.numeric(x) * 86400
        if(length(z) == 3 && is.numeric(z))
            x  <- x + as.numeric(ISOdate(z[3], z[1], z[2], 0))
        return(structure(x, class = c("POSIXt", "POSIXct")))
    } else stop(paste("`", deparse(substitute(x)),
                      "' is not a \"dates\" object", sep=""))
}

as.POSIXct.POSIXlt <- function(x, tz = "")
{
    if(missing(tz) && !is.null(attr(x, "tzone"))) tz <- attr(x, "tzone")[1]
    structure(.Internal(as.POSIXct(x, tz)), class = c("POSIXt", "POSIXct"))
}

as.POSIXct.default <- function(x, tz = "")
{
    if(inherits(x, "POSIXct")) return(x)
    if(is.character(x) || is.factor(x))
	return(as.POSIXct(as.POSIXlt(x), tz))
    if(is.logical(x) && all(is.na(x)))
        return(structure(as.numeric(x), class = c("POSIXt", "POSIXct")))
    stop(paste("Don't know how to convert `", deparse(substitute(x)),
	       "' to class \"POSIXct\"", sep=""))
}

format.POSIXlt <- function(x, format = "", usetz = FALSE, ...)
{
    if(!inherits(x, "POSIXlt")) stop("wrong class")
    if(format == "") {
        ## need list [ method here.
        times <- unlist(unclass(x)[1:3])
        format <- if(all(times[!is.na(times)] == 0)) "%Y-%m-%d"
        else "%Y-%m-%d %H:%M:%S"
    }
    .Internal(format.POSIXlt(x, format, usetz))
}

strftime <- format.POSIXlt

strptime <- function(x, format)
    .Internal(strptime(x, format))


format.POSIXct <- function(x, format = "", tz = "", usetz = FALSE, ...)
{
    if(!inherits(x, "POSIXct")) stop("wrong class")
    structure(format.POSIXlt(as.POSIXlt(x, tz), format, usetz, ...),
              names=names(x))
}

print.POSIXct <- function(x, ...)
{
    print(format(x, usetz=TRUE), ...)
    invisible(x)
}

print.POSIXlt <- function(x, ...)
{
    print(format(x, usetz=TRUE), ...)
    invisible(x)
}

summary.POSIXct <- function(object, digits=15, ...)
{
    x <- summary.default(unclass(object), digits=digits, ...)
    class(x) <- oldClass(object)
    x
}

summary.POSIXlt <- function(object, digits = 15, ...)
    summary(as.POSIXct(object), digits = digits, ...)


"+.POSIXt" <- function(e1, e2)
{
    coerceTimeUnit <- function(x)
    {
        switch(attr(x,"units"),
               secs = x, mins = 60*x, hours = 60*60*x,
               days = 60*60*24*x, weeks = 60*60*24*7*x)
    }

    if (nargs() == 1) return(e1)
    # only valid if one of e1 and e2 is a scalar.
    if(inherits(e1, "POSIXt") && inherits(e2, "POSIXt"))
        stop("binary + is not defined for POSIXt objects")
    if(inherits(e1, "POSIXlt")) e1 <- as.POSIXct(e1)
    if(inherits(e2, "POSIXlt")) e2 <- as.POSIXct(e2)
    if (inherits(e1, "difftime")) e1 <- coerceTimeUnit(e1)
    if (inherits(e2, "difftime")) e2 <- coerceTimeUnit(e2)
    structure(unclass(e1) + unclass(e2), class = c("POSIXt", "POSIXct"))
}

"-.POSIXt" <- function(e1, e2)
{
    coerceTimeUnit <- function(x)
    {
        switch(attr(x,"units"),
               secs = x, mins = 60*x, hours = 60*60*x,
               days = 60*60*24*x, weeks = 60*60*24*7*x)
    }
    if(!inherits(e1, "POSIXt"))
        stop("Can only subtract from POSIXt objects")
    if (nargs() == 1) stop("unary - is not defined for POSIXt objects")
    if(inherits(e2, "POSIXt")) return(difftime(e1, e2))
    if (inherits(e2, "difftime")) e2 <- unclass(coerceTimeUnit(e2))
    if(!is.null(attr(e2, "class")))
        stop("can only subtract numbers from POSIXt objects")
    structure(unclass(as.POSIXct(e1)) - e2, class = c("POSIXt", "POSIXct"))
}

Ops.POSIXt <- function(e1, e2)
{
    if (nargs() == 1)
        stop(paste("unary", .Generic, "not defined for POSIXt objects"))
    boolean <- switch(.Generic, "<" = , ">" = , "==" = ,
                      "!=" = , "<=" = , ">=" = TRUE, FALSE)
    if (!boolean) stop(paste(.Generic, "not defined for POSIXt objects"))
    if(inherits(e1, "POSIXlt")) e1 <- as.POSIXct(e1)
    if(inherits(e2, "POSIXlt")) e2 <- as.POSIXct(e2)
    NextMethod(.Generic)
}

Math.POSIXt <- function (x, ...)
{
    stop(paste(.Generic, "not defined for POSIXt objects"))
}

Summary.POSIXct <- function (x, ...)
{
    ok <- switch(.Generic, max = , min = , range = TRUE, FALSE)
    if (!ok) stop(paste(.Generic, "not defined for POSIXct objects"))
    val <- NextMethod(.Generic)
    class(val) <- oldClass(x)
    val
}

Summary.POSIXlt <- function (x, ...)
{
    ok <- switch(.Generic, max = , min = , range = TRUE, FALSE)
    if (!ok) stop(paste(.Generic, "not defined for POSIXlt objects"))
    x <- as.POSIXct(x)
    val <- NextMethod(.Generic)
    as.POSIXlt(structure(val, class = c("POSIXt", "POSIXct")))
}

"[.POSIXct" <-
function(x, ..., drop = TRUE)
{
    cl <- oldClass(x)
    class(x) <- NULL
    val <- NextMethod("[")
    class(val) <- cl
    val
}

"[[.POSIXct" <-
function(x, ..., drop = TRUE)
{
    cl <- oldClass(x)
    class(x) <- NULL
    val <- NextMethod("[[")
    class(val) <- cl
    val
}

"[<-.POSIXct" <-
function(x, ..., value) {
    if(!as.logical(length(value))) return(x)
    value <- as.POSIXct(value)
    cl <- oldClass(x)
    class(x) <- class(value) <- NULL
    x <- NextMethod(.Generic)
    class(x) <- cl
    x
}

as.character.POSIXt <- function(x, ...) format(x, ...)

str.POSIXt <- function(object, ...) {
    cl <- oldClass(object)
    cat("`", cl[min(2, length(cl))],"', format:", sep = "")
    str(format(object), ...)
}

as.data.frame.POSIXct <- as.data.frame.vector

is.na.POSIXlt <- function(x) is.na(as.POSIXct(x))

c.POSIXct <- function(..., recursive=FALSE)
    structure(c(unlist(lapply(list(...), unclass))),
              class=c("POSIXt","POSIXct"))

## we need conversion to POSIXct as POSIXlt objects can be in different tz.
c.POSIXlt <- function(..., recursive=FALSE)
    as.POSIXlt(do.call("c", lapply(list(...), as.POSIXct)))

## force absolute comparisons
all.equal.POSIXct <- function(target, current, ..., scale=1)
    NextMethod("all.equal")


axis.POSIXct <- function(side, x, at, format, ...)
{
    mat <- missing(at)
    if(!mat) x <- as.POSIXct(at) else x <- as.POSIXct(x)
    range <- par("usr")[if(side %%2) 1:2 else 3:4]
    ## find out the scale involved
    d <- range[2] - range[1]
    z <- c(range, x[is.finite(x)])
    if(d < 1.1*60) { # seconds
        sc <- 1
        if(missing(format)) format <- "%S"
    } else if (d < 1.1*60*60) { # minutes
        sc <- 60
        if(missing(format)) format <- "%M:%S"
    } else if (d < 1.1*60*60*24) {# hours
        sc <- 60*24
        if(missing(format)) format <- "%H:%M"
    } else if (d < 2*60*60*24) {
        sc <- 60*24
        if(missing(format)) format <- "%a %H:%M"
    } else if (d < 7*60*60*24) {# days of a week
        sc <- 60*60*24
        if(missing(format)) format <- "%a"
    } else { # days, up to a couple of months
        sc <- 60*60*24
    }
    if(d < 60*60*24*50) {
        zz <- pretty(z/sc)
        z <- zz*sc
        class(z) <- c("POSIXt", "POSIXct")
        if(missing(format)) format <- "%b %d"
    } else if(d < 1.1*60*60*24*365) { # months
        class(z) <- c("POSIXt", "POSIXct")
        zz <- as.POSIXlt(z)
        zz$mday <- 1; zz$isdst <- zz$hour <- zz$min <- zz$sec <- 0
        zz$mon <- pretty(zz$mon)
        m <- length(zz$mon)
        m <- rep(zz$year[1], m)
        zz$year <- c(m, m+1)
        z <- as.POSIXct(zz)
        if(missing(format)) format <- "%b"
    } else { # years
        class(z) <- c("POSIXt", "POSIXct")
        zz <- as.POSIXlt(z)
        zz$mday <- 1; zz$isdst <- zz$mon <- zz$hour <- zz$min <- zz$sec <- 0
        zz$year <- pretty(zz$year)
        z <- as.POSIXct(zz)
        if(missing(format)) format <- "%Y"
    }
    if(!mat) z <- x[is.finite(x)] # override changes
    z <- z[z >= range[1] & z <= range[2]]
    labels <- format(z, format = format)
    axis(side, at = z, labels = labels, ...)
}

plot.POSIXct <- function(x, y, xlab = "", axes = TRUE, frame.plot = axes,
                         xaxt = par("xaxt"), ...)
{
    ## trick to remove arguments intended for title() or plot.default()
    axisInt <- function(x, main, sub, xlab, ylab, col, lty, lwd,
                        xlim, ylim, bg, pch, log, asp, ...)
        axis.POSIXct(1, x, ...)
    plot.default(x, y, xaxt = "n", xlab = xlab, axes = axes,
                 frame.plot = frame.plot, ...)
    if(axes && xaxt != "n") axisInt(x, ...)
}

plot.POSIXlt <- function(x, y, xlab = "",  axes = TRUE, frame.plot = axes,
                         xaxt = par("xaxt"), ...)
{
    ## trick to remove arguments intended for title() or plot.default()
    axisInt <- function(x, main, sub, xlab, ylab, col, lty, lwd,
                        xlim, ylim, bg, pch, log, asp, ...)
        axis.POSIXct(1, x, ...)
    x <- as.POSIXct(x)
    plot.default(x, y, xaxt = "n", xlab = xlab, axes = axes,
                 frame.plot = frame.plot, ...)
    if(axes && xaxt != "n") axisInt(x, ...)
}

ISOdatetime <- function(year, month, day, hour, min, sec, tz="")
{
    x <- paste(year, month, day, hour, min, sec)
    as.POSIXct(strptime(x, "%Y %m %d %H %M %S"), tz=tz)
}

ISOdate <- function(year, month, day, hour=12, min=0, sec=0, tz="GMT")
    ISOdatetime(year, month, day, hour, min, sec, tz)

as.matrix.POSIXlt <- function(x)
{
    as.matrix(as.data.frame(unclass(x)))
}

mean.POSIXct <- function (x, ...)
    structure(mean(unclass(x), ...), class = c("POSIXt", "POSIXct"))

mean.POSIXlt <- function (x, ...)
    as.POSIXlt(mean(as.POSIXct(x), ...))

## ----- difftime -----

difftime <-
    function(time1, time2, tz = "",
             units = c("auto", "secs", "mins", "hours", "days", "weeks"))
{
    time1 <- as.POSIXct(time1, tz = tz)
    time2 <- as.POSIXct(time2, tz = tz)
    z <- unclass(time1) - unclass(time2)
    units <- match.arg(units)
    if(units == "auto") {
        if(all(is.na(z))) units <- "secs"
        else {
            zz <- min(abs(z),na.rm=TRUE)
            if(is.na(zz) || zz < 60) units <- "secs"
            else if(zz < 3600) units <- "mins"
            else if(zz < 86400) units <- "hours"
            else units <- "days"
        }
    }
    switch(units,
           "secs" = structure(z, units="secs", class="difftime"),
           "mins" = structure(z/60, units="mins", class="difftime"),
           "hours"= structure(z/3600, units="hours", class="difftime"),
           "days" = structure(z/86400, units="days", class="difftime"),
           "weeks" = structure(z/(7*86400), units="weeks", class="difftime")
           )
}

## "difftime" constructor
## Martin Maechler, Date: 16 Sep 2002
as.difftime <- function(tim, format="%X")
{
    difftime(strptime(tim, format=format),
             strptime("0:0:0", format="%X"))
}

print.difftime <- function(x, digits = getOption("digits"), ...)
{
    if(length(x) > 1)
        cat("Time differences of ",
            paste(format(unclass(x), digits=digits), collapse = ", "), " ",
            attr(x, "units"), "\n", sep="")
    else
        cat("Time difference of ", format(unclass(x), digits=digits), " ",
            attr(x, "units"), "\n", sep="")

    invisible(x)
}

round.difftime <- function (x, digits = 0)
{
   units <- attr(x, "units")
   structure(NextMethod(), units=units, class="difftime")
}

"[.difftime" <- function(x, ..., drop = TRUE)
{
    cl <- oldClass(x)
    class(x) <- NULL
    val <- NextMethod("[")
    class(val) <- cl
    attr(val, "units") <- attr(x, "units")
    val
}

Ops.difftime <- function(e1, e2)
{
    coerceTimeUnit <- function(x)
    {
        switch(attr(x,"units"),
               secs = x, mins = 60*x, hours = 60*60*x,
               days = 60*60*24*x, weeks = 60*60*24*7*x)
    }
    if (nargs() == 1)
        stop(paste("unary", .Generic, "not defined for difftime objects"))
    boolean <- switch(.Generic, "<" = , ">" = , "==" = ,
                      "!=" = , "<=" = , ">=" = TRUE, FALSE)
    if (boolean) {
        ## assume user knows what he/she is doing if not both difftime
        if(inherits(e1, "difftime") && inherits(e2, "difftime")) {
            e1 <- coerceTimeUnit(e1)
            e2 <- coerceTimeUnit(e2)
        }
        NextMethod(.Generic)
    } else if(.Generic == "+" || .Generic == "-") {
        if(inherits(e1, "difftime") && !inherits(e2, "difftime"))
            return(structure(NextMethod(.Generic),
                             units = attr(e1, "units"), class = "difftime"))
        if(!inherits(e1, "difftime") && inherits(e2, "difftime"))
            return(structure(NextMethod(.Generic),
                             units = attr(e2, "units"), class = "difftime"))
        u1 <- attr(e1, "units")
        if(attr(e2, "units") == u1) {
            structure(NextMethod(.Generic), units=u1, class="difftime")
        } else {
            e1 <- coerceTimeUnit(e1)
            e2 <- coerceTimeUnit(e2)
            structure(NextMethod(.Generic), units="secs", class="difftime")
        }
    } else {
        ## `*' is covered by a specific method
        stop(paste(.Generic, "not defined for difftime objects"))
    }
}

"*.difftime" <- function (e1, e2)
{
    ## need one scalar, one difftime.
    if(inherits(e1, "difftime") && inherits(e2, "difftime"))
        stop("both arguments of * cannot be difftime objects")
    if(inherits(e2, "difftime")) {tmp <- e1; e1 <- e2; e2 <- tmp}
    structure(e2 * unclass(e1), units = attr(e1, "units"),
              class = "difftime")
}

"/.difftime" <- function (e1, e2)
{
    ## need one scalar, one difftime.
    if(inherits(e2, "difftime"))
        stop("second argument of / cannot be a difftime object")
    structure(unclass(e1) / e2, units = attr(e1, "units"),
              class = "difftime")
}

Math.difftime <- function (x, ...)
{
    stop(paste(.Generic, "not defined for difftime objects"))
}

Summary.difftime <- function (x, ...)
{
    coerceTimeUnit <- function(x)
    {
        switch(attr(x,"units"),
               secs = x, mins = 60*x, hours = 60*60*x,
               days = 60*60*24*x, weeks = 60*60*24*7*x)
    }
    ok <- switch(.Generic, max = , min = , range = TRUE, FALSE)
    if (!ok) stop(paste(.Generic, "not defined for difftime objects"))
    args <- lapply(list(x, ...), coerceTimeUnit)
    structure(do.call(.Generic, args), units="secs", class="difftime")
}


## ----- convenience functions -----

seq.POSIXt <-
    function(from, to, by, length.out = NULL, along.with = NULL, ...)
{
    if (missing(from)) stop("`from` must be specified")
    if (!inherits(from, "POSIXt")) stop("`from' must be a POSIXt object")
        if(length(as.POSIXct(from)) != 1) stop("`from' must be of length 1")
    if (!missing(to)) {
        if (!inherits(to, "POSIXt")) stop("`to' must be a POSIXt object")
        if (length(as.POSIXct(to)) != 1) stop("`to' must be of length 1")
        if (to <= from) stop("`to' must be later than `from'")
    }
    if (!missing(along.with)) {
        length.out <- length(along.with)
    }  else if (!missing(length.out)) {
        if (length(length.out) != 1) stop("`length.out' must be of length 1")
        length.out <- ceiling(length.out)
    }
    status <- c(!missing(to), !missing(by), !is.null(length.out))
    if(sum(status) != 2)
        stop("exactly two of `to', `by' and `length.out' / `along.with' must be specified")
    if (missing(by)) {
        from <- unclass(as.POSIXct(from))
        to <- unclass(as.POSIXct(to))
        ## Till (and incl.) 1.6.0 :
        ##- incr <- (to - from)/length.out
        ##- res <- seq.default(from, to, incr)
        res <- seq.default(from, to, length.out = length.out)
        return(structure(res, class = c("POSIXt", "POSIXct")))
    }

    if (length(by) != 1) stop("`by' must be of length 1")
    valid <- 0
    if (inherits(by, "difftime")) {
        by <- switch(attr(by,"units"), secs = 1, mins = 60, hours = 3600,
                     days = 86400, weeks = 7*86400) * unclass(by)
    } else if(is.character(by)) {
        by2 <- strsplit(by, " ")[[1]]
        if(length(by2) > 2 || length(by2) < 1)
            stop("invalid `by' string")
        valid <- pmatch(by2[length(by2)],
                        c("secs", "mins", "hours", "days", "weeks",
                          "months", "years", "DSTdays"))
        if(is.na(valid)) stop("invalid string for `by'")
        if(valid <= 5) {
            by <- c(1, 60, 3600, 86400, 7*86400)[valid]
            if (length(by2) == 2) by <- by * as.integer(by2[1])
        } else
            by <- if(length(by2) == 2) as.integer(by2[1]) else 1
    } else if(!is.numeric(by)) stop("invalid mode for `by'")
    if(is.na(by)) stop("`by' is NA")

    if(valid <= 5) {
        from <- unclass(as.POSIXct(from))
        if(!is.null(length.out))
            res <- seq.default(from, by=by, length.out=length.out)
        else {
            to <- unclass(as.POSIXct(to))
            ## defeat test in seq.default
            res <- seq.default(0, to - from, by) + from
        }
        return(structure(res, class=c("POSIXt", "POSIXct")))
    } else {  # months or years or DSTdays
        r1 <- as.POSIXlt(from)
        if(valid == 7) {
            if(missing(to)) { # years
                yr <- seq(r1$year, by = by, length = length.out)
            } else {
                to <- as.POSIXlt(to)
                yr <- seq(r1$year, to$year, by)
            }
            r1$year <- yr
            r1$isdst <- -1
            res <- as.POSIXct(r1)
        } else if(valid == 6) { # months
            if(missing(to)) {
                mon <- seq(r1$mon, by = by, length = length.out)
            } else {
                to <- as.POSIXlt(to)
                mon <- seq(r1$mon, 12*(to$year - r1$year) + to$mon, by)
            }
            r1$mon <- mon
            r1$isdst <- -1
            res <- as.POSIXct(r1)
        } else if(valid == 8) { # DSTdays
            if(!missing(to)) {
                length.out <- 1 + floor((unclass(as.POSIXct(to)) -
                                         unclass(as.POSIXct(from)))/86400)
            }
            r1$mday <- seq(r1$mday, by = by, length = length.out)
            r1$isdst <- -1
            res <- as.POSIXct(r1)
            if(!missing(to)) res <- res[res <= as.POSIXct(to)]
        }
        return(res)
    }
}

cut.POSIXt <-
    function (x, breaks, labels = NULL, start.on.monday = TRUE,
              right = FALSE, ...)
{
    if(!inherits(x, "POSIXt")) stop("`x' must be a date-time object")
    x <- as.POSIXct(x)

    if (inherits(breaks, "POSIXt")) {
	breaks <- as.POSIXct(breaks)
    } else if(is.numeric(breaks) && length(breaks) == 1) {
	## specified number of breaks
    } else if(is.character(breaks) && length(breaks) == 1) {
        by2 <- strsplit(breaks, " ")[[1]]
        if(length(by2) > 2 || length(by2) < 1)
            stop("invalid specification of `breaks'")
	valid <-
	    pmatch(by2[length(by2)],
		   c("secs", "mins", "hours", "days", "weeks",
		     "months", "years", "DSTdays"))
	if(is.na(valid)) stop("invalid specification of `breaks'")
	start <- as.POSIXlt(min(x, na.rm=TRUE))
	incr <- 1
	if(valid > 1) { start$sec <- 0; incr <- 59.99 }
	if(valid > 2) { start$min <- 0; incr <- 3600 - 1 }
	if(valid > 3) { start$hour <- 0; incr <- 86400 - 1 }
	if(valid == 5) {
	    start$mday <- start$mday - start$wday
	    if(start.on.monday)
		start$mday <- start$mday + ifelse(start$wday > 0, 1, -6)
	    incr <- 7*86400
	}
	if(valid == 6) { start$mday <- 1; incr <- 31*86400 }
	if(valid == 7) { start$mon <- 0; incr <- 366*86400 }
        if(valid == 8) incr <- 25*3600
        if (length(by2) == 2) incr <- incr * as.integer(by2[1])
	maxx <- max(x, na.rm = TRUE)
	breaks <- seq(start, maxx + incr, breaks)
	breaks <- breaks[1:(1+max(which(breaks < maxx)))]
    } else stop("invalid specification of `breaks'")
    res <- cut(unclass(x), unclass(breaks), labels = labels,
               right = right, ...)
    if(is.null(labels)) levels(res) <- as.character(breaks[-length(breaks)])
    res
}

julian <- function(x, ...) UseMethod("julian")

julian.POSIXt <- function(x, origin = as.POSIXct("1970-01-01", tz="GMT"), ...)
{
    if(length(origin) != 1) stop("`origin' must be of length one")
    res <- difftime(as.POSIXct(x), origin, units = "days")
    structure(res, "origin" = origin)
}

weekdays <- function(x, abbreviate) UseMethod("weekdays")
weekdays.POSIXt <- function(x, abbreviate = FALSE)
{
    format(x, ifelse(abbreviate, "%a", "%A"))
}

months <- function(x, abbreviate) UseMethod("months")
months.POSIXt <- function(x, abbreviate = FALSE)
{
    format(x, ifelse(abbreviate, "%b", "%B"))
}

quarters <- function(x, abbreviate) UseMethod("quarters")
quarters.POSIXt <- function(x, ...)
{
    x <- (as.POSIXlt(x)$mon)%/%3
    paste("Q", x+1, sep = "")
}

trunc.POSIXt <- function(x, units=c("secs", "mins", "hours", "days"))
{
    units <- match.arg(units)
    x <- as.POSIXlt(x)
    if(length(x$sec) > 0)
	switch(units,
	       "secs" = {x$sec <- trunc(x$sec)},
	       "mins" = {x$sec <- 0},
	       "hours"= {x$sec <- 0; x$min <- 0},
	       "days" = {x$sec <- 0; x$min <- 0; x$hour <- 0; x$isdst <- -1}
	       )
    x
}

round.POSIXt <- function(x, units=c("secs", "mins", "hours", "days"))
{
    ## this gets the default from the generic, as that has two args.
    if(is.numeric(units) && units == 0.0) units <-"secs"
    units <- match.arg(units)
    x <- as.POSIXct(x)
    x <- x + switch(units,
                    "secs" = 0.5, "mins" = 30, "hours"= 1800, "days" = 43200)
    trunc.POSIXt(x, units = units)
}

# ---- additions in 1.5.0 -----

"[.POSIXlt" <- function(x, ..., drop = TRUE)
{
    val <- lapply(x, "[", ..., drop = drop)
    attributes(val) <- attributes(x) # need to preserve timezones
    val
}

"[<-.POSIXlt" <- function(x, i, value)
{
    if(!as.logical(length(value))) return(x)
    value <- as.POSIXlt(value)
    cl <- oldClass(x)
    class(x) <- class(value) <- NULL
    for(n in names(x)) x[[n]][i] <- value[[n]]
    class(x) <- cl
    x
}

as.data.frame.POSIXlt <- function(x, row.names = NULL, optional = FALSE)
{
    value <- as.data.frame.POSIXct(as.POSIXct(x), row.names, optional)
    if (!optional)
        names(value) <- deparse(substitute(x))[[1]]
    value
}

hist.POSIXt <- function(x, breaks, ..., xlab = deparse(substitute(x)),
                        plot = TRUE, freq = FALSE,
                        start.on.monday = TRUE, format)
{
    if(!inherits(x, "POSIXt")) stop("wrong method")
    xlab
    x <- as.POSIXct(x)
    incr <- 1
    ## handle breaks ourselves
    if (inherits(breaks, "POSIXt")) {
        breaks <- as.POSIXct(breaks)
        d <- min(abs(diff(unclass(breaks))))
        if(d > 60) incr <- 60
        if(d > 3600) incr <- 3600
        if(d > 86400) incr <- 86400
        if(d > 86400*7) incr <- 86400*7
        if(d > 86400*28) incr <- 86400*28
        if(d > 86400*366) incr <- 86400*366
        num.br <- FALSE
    } else {
        num.br <- is.numeric(breaks) && length(breaks) == 1
        if(num.br) {
        ## specified number of breaks
        } else if(is.character(breaks) && length(breaks) == 1) {
            valid <-
                pmatch(breaks,
                       c("secs", "mins", "hours", "days", "weeks",
                         "months", "years"))
            if(is.na(valid)) stop("invalid specification of `breaks'")
            start <- as.POSIXlt(min(x, na.rm = TRUE))
            incr <- 1
            if(valid > 1) { start$sec <- 0; incr <- 59.99 }
            if(valid > 2) { start$min <- 0; incr <- 3600 - 1 }
            if(valid > 3) { start$hour <- 0; incr <- 86400 - 1 }
            if(valid > 4) { start$isdst <- -1}
            if(valid == 5) {
                start$mday <- start$mday - start$wday
                if(start.on.monday)
                    start$mday <- start$mday + ifelse(start$wday > 0, 1, -6)
                incr <- 7*86400
            }
            if(valid == 6) { start$mday <- 1; incr <- 31*86400 }
            if(valid == 7) { start$mon <- 0; incr <- 366*86400 }
            maxx <- max(x, na.rm = TRUE)
            breaks <- seq(start, maxx + incr, breaks)
            breaks <- breaks[1:(1+max(which(breaks < maxx)))]
        }
        else stop("invalid specification of `breaks'")
    }
    res <- hist.default(unclass(x), unclass(breaks), plot = FALSE, ...)
    res$equidist <- TRUE # years are of uneven lengths
    res$intensities <- res$intensities*incr
    res$xname <- xlab
    if(plot) {
        ## trick to swallow arguments for hist.default, separate out `axes'
        myplot <- function(res, xlab, freq, format, breaks,
                           right, include.lowest, labels = FALSE,
                           axes = TRUE, ...)
        {
            plot(res, xlab = xlab, axes = FALSE, freq = freq,
                 labels = labels, ...)
            if(axes) {
                axis(2, ...)
                if(num.br) breaks <- c.POSIXct(res$breaks)
                axis.POSIXct(1, at = breaks,  format = format, ...)
                                        # `...' : e.g. cex.axis
            }
        }
        myplot(res, xlab, freq, format, breaks, ...)
     }
    invisible(res)
}

# ---- additions in 1.8.0 -----

rep.POSIXct <- function(x, times, ...)
{
    y <- rep.int(unclass(x), times)
    structure(y, class=c("POSIXt", "POSIXct"))
}

rep.POSIXlt <- function(x, times, ...)
{
    y <- lapply(x, rep.int, times=times)
    attributes(y) <- attributes(x)
    y
}

diff.POSIXt <- function (x, lag = 1, differences = 1, ...)
{
    ismat <- is.matrix(x)
    xlen <- if (ismat) dim(x)[1] else length(x)
    if (length(lag) > 1 || length(differences) > 1 || lag < 1 || differences < 1)
        stop("`lag' and `differences' must be integers >= 1")
    if (lag * differences >= xlen)
        return(structure(numeric(0), class="difftime", units="secs"))
    r <- x
    i1 <- -1:-lag
    if (ismat) for (i in 1:differences) r <- r[i1, , drop = FALSE] -
            r[-nrow(r):-(nrow(r) - lag + 1), , drop = FALSE]
    else for (i in 1:differences)
        r <- r[i1] - r[-length(r):-(length(r) - lag + 1)]
    r
}
read.dcf <- function(file, fields = NULL)
{
    if(is.character(file)){
        file <- file(file, "r")
        on.exit(close(file))
    }
    if(!inherits(file, "connection"))
        stop(paste("argument", sQuote("file"),
                   "must be a character string or connection"))
    .Internal(readDCF(file, fields))
}

write.dcf <-
function(x, file = "", append = FALSE,
         indent = 0.1 * getOption("width"),
         width = 0.9 * getOption("width"))
{
    if(!is.data.frame(x))
        x <- data.frame(x)
    x <- as.matrix(x)
    mode(x) <- "character"

    if(file == "")
        file <- stdout()
    else if(is.character(file)) {
        file <- file(file, ifelse(append, "a", "w"))
        on.exit(close(file))
    }
    if(!inherits(file, "connection"))
        stop(paste("argument", sQuote("file"),
                   "must be a character string or connection"))

    nr <- nrow(x)
    nc <- ncol(x)

    eor <- character(nr * nc)
    eor[seq(1, nr - 1) * nc] <- "\n"    # newline for end of record

    writeLines(paste(formatDL(rep.int(colnames(x), nr), c(t(x)), style =
                     "list", width = width, indent = indent),
                     eor, sep = ""),
               file)
}
de.ncols <- function(inlist)
{
    ncols <- matrix(0, nrow=length(inlist), ncol=2)
    i <- 1
    for( telt in inlist ) {
	if( is.matrix(telt) ) {
	    ncols[i, 1] <- ncol(telt)
	    ncols[i, 2] <- 2
	}
	else if( is.list(telt) ) {
	    for( telt2 in telt )
		if( !is.vector(telt2) ) stop("wrong argument to dataentry")
	    ncols[i, 1] <- length(telt)
	    ncols[i, 2] <- 3
	}
	else if( is.vector(telt) ) {
	    ncols[i, 1] <- 1
	    ncols[i, 2] <- 1
	}
	else stop("wrong argument to dataentry")
	i <- i+1
    }
    return(ncols)
}

de.setup <- function(ilist, list.names, incols)
{
    ilen <- sum(incols)
    ivec <- vector("list", ilen)
    inames <- vector("list", ilen)
    i <- 1
    k <- 0
    for( telt in ilist ) {
	k <- k+1
	if( is.list(telt) ) {
	    y <- names(telt)
	    for( j in 1:length(telt) ) {
		ivec[[i]] <- telt[[j]]
		if( is.null(y) || y[j]=="" )
		    inames[[i]] <- paste("var", i, sep="")
		else inames[[i]] <- y[j]
		i <- i+1
	    }
	}
	else if( is.vector(telt) ) {
	    ivec[[i]] <- telt
	    inames[[i]] <- list.names[[k]]
	    i <- i+1
	}
	else if( is.matrix(telt) ) {
	    y <- dimnames(telt)[[2]]
	    for( j in 1:ncol(telt) ) {
		ivec[[i]] <- telt[, j]
		if( is.null(y) || y[j]=="" )
		    inames[[i]] <- paste("var", i, sep="")
		else inames[[i]] <- y[j]
		i <- i+1
	    }
	}
	else stop("de.setup: wrong argument to dataentry")
    }
    names(ivec) <- inames
    return(ivec)
}

de.restore <- function(inlist, ncols, coltypes, argnames, args)
{
    ## take the data in inlist and restore it
    ## to the format described by ncols and coltypes
    p <- length(ncols)
    rlist <- vector("list", length=p)
    rnames <- vector("character", length=p)
    j <- 1
    lnames <- names(inlist)
    if(p) for(i in 1:p) {
	if(coltypes[i]==2) {
	    tlen <- length(inlist[[j]])
	    x <- matrix(0, nrow=tlen, ncol=ncols[i])
	    cnames <- vector("character", ncol(x))
	    for( ind1 in 1:ncols[i]) {
		if(tlen != length(inlist[[j]]) ) {
		    warning("could not restore type information")
		    return(inlist)
		}
		x[, ind1] <- inlist[[j]]
		cnames[ind1] <- lnames[j]
		j <- j+1
	    }
	    if( dim(x) == dim(args[[i]]) )
		rn <- dimnames(args[[i]])[[1]]
	    else rn <- NULL
	    if( any(cnames!="") )
		dimnames(x) <- list(rn, cnames)
	    rlist[[i]] <- x
	    rnames[i] <- argnames[i]
	}
	else if(coltypes[i]==3) {
	    x <- vector("list", length=ncols[i])
	    cnames <- vector("character", ncols[i])
	    for( ind1 in 1:ncols[i]) {
		x[[ind1]] <- inlist[[j]]
		cnames[ind1] <- lnames[j]
		j <- j+1
	    }
	    if( any(cnames!="") )
		names(x) <- cnames
	    rlist[[i]] <- x
	    rnames[i] <- argnames[i]
	}
	else {
	    rlist[[i]] <- inlist[[j]]
	    j <- j+1
	    rnames[i] <- argnames[i]
	}
    }
    names(rlist) <- rnames
    return(rlist)
}

de <- function(..., Modes=list(), Names=NULL)
{
    sdata <- list(...)
    snames <- as.character(substitute(list(...))[-1])
    if( is.null(sdata) ) {
	if( is.null(Names) ) {
	    odata <- vector("list", length=max(1,length(Modes)))
	}
	else {
	    if( (length(Names) != length(Modes)) && length(Modes) ) {
		warning("modes argument ignored")
		Modes <- list()
	    }
	    odata <- vector("list", length=length(Names))
	    names(odata) <- Names
	}
	ncols <- rep(1, length(odata))
	coltypes <- rep(1, length(odata))
    }
    else {
	ncols <- de.ncols(sdata)
	coltypes <- ncols[, 2]
	ncols <- ncols[, 1]
	odata <- de.setup(sdata, snames, ncols)
	if(length(Names))
	    if( length(Names) != length(odata) )
		warning("names argument ignored")
	    else names(odata) <- Names
	if(length(Modes))
	    if(length(Modes) != length(odata)) {
		warning("modes argument ignored")
		Modes <- list()
	    }
    }
    rdata <- dataentry(odata, as.list(Modes))

    if(any(coltypes != 1)) {
	if(length(rdata) == sum(ncols))
	    rdata <- de.restore(rdata, ncols, coltypes, snames, sdata)
	else warning("could not restore variables properly")
    }
    return(rdata)
}

data.entry <- function(..., Modes=NULL, Names=NULL)
{
    tmp1 <- de(..., Modes=Modes, Names=Names)
    j <- 1
    nn <- names(tmp1)
    for(i in nn) {
	assign(i, tmp1[[j]], env=.GlobalEnv)
	j <- j+1
    }
    if(j==1) warning("not assigned anything!")
    invisible(nn)
}
dump.frames <- function(dumpto = "last.dump", to.file = FALSE)
{
    calls <- sys.calls()
    last.dump <- sys.frames()
    names(last.dump) <- limitedLabels(calls)
    last.dump <- last.dump[-length(last.dump)] # remove this function
    attr(last.dump, "error.message") <- geterrmessage()
    class(last.dump) <- "dump.frames"
    if(dumpto != "last.dump") assign(dumpto, last.dump)
    if (to.file) save(list=dumpto, file = paste(dumpto, "rda", sep="."))
    else assign(dumpto, last.dump, envir=.GlobalEnv)
    invisible()
}

debugger <- function(dump = last.dump)
{
    debugger.look <- function(.selection)
    {
        for(.obj in ls(envir=dump[[.selection]], all.names=TRUE))
            assign(.obj, get(.obj, envir=dump[[.selection]]))
        cat("Browsing in the environment with call:\n   ",
            calls[.selection], "\n", sep="")
        rm(.obj, .selection)
        browser()
    }
    if (class(dump) != "dump.frames") {
        cat("`dump' is not an object of class `dump.frames'\n")
        return(invisible())
    }
    err.action <- getOption("error")
    on.exit(options(error=err.action))
    if (length(msg <- attr(dump, "error.message")))
        cat("Message: ", msg)
    n <- length(dump)
    calls <- names(dump)
    repeat {
        cat("Available environments had calls:\n")
        cat(paste(1:n, ": ", calls,  sep=""), sep="\n")
        cat("\nEnter an environment number, or 0 to exit  ")
        repeat {
            ind <- .Internal(menu(as.character(calls)))
            if(ind <= n) break
        }
        if(ind == 0) return(invisible())
        debugger.look(ind)
    }
}

limitedLabels <- function(value, maxwidth = options()$width)
{
    value <- as.character(value)
    if(is.null(maxwidth) || maxwidth < 40)
        maxwidth <- 40
    if(any(nchar(value) > maxwidth)) {
        trim <- nchar(value) > maxwidth
        value[trim] <- substr(value[trim], 1, maxwidth)
    }
    value
}
      
recover <-
  function()
{
    if(.isMethodsDispatchOn()) {
        ## turn off tracing
        tState <- tracingState(FALSE)
        on.exit(tracingState(tState))
    }
    ## find an interesting environment to dump from
    calls <- sys.calls()
    from <- 0
    n <- length(calls)
    if(identical(sys.function(n), recover))
        ## options(error=recover) produces a call to this function as an object
        n <- n - 1
    for(i in rev(seq(length=n))) {
        calli <- calls[[i]]
        fname <- calli[[1]]
        if(!is.name(fname) ||
           is.na(match(as.character(fname), c("recover", "stop", "Stop")))) {
            from <- i
            break
        }
    }
    if(from > 0) {
        if(!interactive()) {
            try(dump.frames())
            message("recover called non-interactively; frames dumped, use debugger() to view")
            return(NULL)
        }
        calls <- limitedLabels(calls[1:from])
        repeat {
            which <- menu(calls, title="\nEnter a frame number, or 0 to exit  ")
            if(which > 0)
                eval(quote(browser()), envir = sys.frame(which))
            else
                break
        }
    }
    else
        cat("No suitable frames for recover()\n")
}


trace <- function(what, tracer, exit, at, print, signature, where = topenv(parent.frame())) {
    needsAttach <- nargs() > 1 && !.isMethodsDispatchOn()
    if(needsAttach) {
        ns <- try(loadNamespace("methods"))
        if(isNamespace(ns))
            methods:::message("(loaded the methods namespace)")
        else
            stop("Tracing functions requires the methods package, but unable to load methods namespace")
    }
    else if(nargs() == 1)
        return(.primTrace(what))
    tState <- tracingState(FALSE)
    ## now call the version in the methods package, to ensure we get
    ## the correct name space (e.g., correct version of class())
    call <- sys.call()
    call[[1]] <- quote(methods:::.TraceWithMethods)
    call$where <- where
    value <- eval.parent(call)
    on.exit() ## no error
    tracingState(tState)
    value
}


untrace <- function(what, signature = NULL, where = topenv(parent.frame())) {
    ## NOTE: following test is TRUE after loadNamespace("methods") (even if not in search())
    MethodsDispatchOn <- .isMethodsDispatchOn()
    if(MethodsDispatchOn) {
        tState <- tracingState(FALSE)
        on.exit(tracingState(tState))
    }
    if(is.function(what)) {
        fname <- substitute(what)
        if(is.name(fname))
            what <- as.character(fname)
        else
            stop("Argument what should be the name of a function")
    }
    else {
        what <- as.character(what)
        if(length(what) != 1) {
            for(f in what)
                untrace(f, signature)
            return(what)
        }
    }
    if(!MethodsDispatchOn)
        return(.primUntrace(what)) ## can't have called trace except in primitive form
    ## at this point we can believe that the methods namespace was successfully loaded
    f <- NULL
    if(is.null(signature)) {
        where <- methods:::findFunction(what, where = where)
        if(length(where) == 0)
            warning("No function \"", what, "\" to untrace")
        else {
            f <- methods:::getFunction(what, where = where[[1]])
            ## ensure that the version to assign is untraced (should be, but ...)
            if(methods:::is(f, "traceable")) {
                methods:::.untracedFunction(f, what, where[[1]])
            }
            else
                .primUntrace(what) # to be safe--no way to know if it's traced or not
        }
    }
    else {
        f <- methods:::getMethod(what, signature,  where)
        if(is.null(f))
            warning("No method for \"", what, "\" for this signature to untrace")
        else {
            if(is(f, "traceable"))
                methods:::.untracedFunction(f, what, where, signature)
            else
                warning("The method for \"", what, "\" for this signature was not being traced")
        }
    }
    invisible(f)
}
        

.isMethodsDispatchOn <- function(onOff = NULL)
    .Call("R_isMethodsDispatchOn", onOff, PACKAGE = "base")

tracingState <- function( on = NULL)
    .Call("R_traceOnOff", on, PACKAGE = "base")
delay <- function(x, env=.GlobalEnv)
    .Internal(delay(substitute(x), env))
density <-
    function(x, bw = "nrd0", adjust = 1,
             kernel = c("gaussian", "epanechnikov", "rectangular",
             "triangular", "biweight", "cosine", "optcosine"),
             window = kernel, width,
             give.Rkern = FALSE,
             n = 512, from, to, cut = 3, na.rm = FALSE)
{
    if(!missing(window) && missing(kernel))
        kernel <- window
    kernel <- match.arg(kernel)
    if(give.Rkern)
        ##-- sigma(K) * R(K), the scale invariant canonical bandwidth:
        return(switch(kernel,
                      gaussian = 1/(2*sqrt(pi)),
                      rectangular = sqrt(3)/6,
                      triangular  = sqrt(6)/9,
                      epanechnikov= 3/(5*sqrt(5)),
                      biweight    = 5*sqrt(7)/49,
                      cosine      = 3/4*sqrt(1/3 - 2/pi^2),
                      optcosine   = sqrt(1-8/pi^2)*pi^2/16
                      ))

    if (!is.numeric(x))
        stop("argument must be numeric")
    name <- deparse(substitute(x))
    x <- as.vector(x)
    x.na <- is.na(x)
    if (any(x.na)) {
        if (na.rm) x <- x[!x.na]
        else stop("x contains missing values")
    }
    N <- nx <- length(x)
    x.finite <- is.finite(x)
    if(any(!x.finite)) {
        x <- x[x.finite]
        nx <- sum(x.finite)
    }
    n.user <- n
    n <- max(n, 512)
    if (n > 512) n <- 2^ceiling(log2(n)) #- to be fast with FFT

    if (missing(bw) && !missing(width)) {
        if(is.numeric(width)) {
            ## S has width equal to the length of the support of the kernel
            ## except for the gaussian where it is 4 * sd.
            ## R has bw a multiple of the sd.
            fac <- switch(kernel,
                          gaussian = 4,
                          rectangular = 2*sqrt(3),
                          triangular = 2 * sqrt(6),
                          epanechnikov = 2 * sqrt(5),
                          biweight = 2 * sqrt(7),
                          cosine = 2/sqrt(1/3 - 2/pi^2),
                          optcosine = 2/sqrt(1-8/pi^2)
                          )
            bw <- width / fac
        }
        if(is.character(width)) bw <- width
    }
    if (is.character(bw)) {
        if(length(x) < 2)
            stop("need at least 2 points to select a bandwidth automatically")
        bw <- switch(tolower(bw),
                     nrd0 = bw.nrd0(x),
                     nrd = bw.nrd(x),
                     ucv = bw.ucv(x),
                     bcv = bw.bcv(x),
                     sj = , "sj-ste" = bw.SJ(x, method="ste"),
                     "sj-dpi" = bw.SJ(x, method="dpi"),
                     stop("unknown bandwidth rule"))
    }
    if (!is.finite(bw)) stop("non-finite `bw'")
    bw <- adjust * bw
    if (bw <= 0) stop("`bw' is not positive.")

    if (missing(from))
        from <- min(x) - cut * bw
    if (missing(to))
	to   <- max(x) + cut * bw
    if (!is.finite(from)) stop("non-finite `from'")
    if (!is.finite(to)) stop("non-finite `to'")
    lo <- from - 4 * bw
    up <- to + 4 * bw
    y <- .C("massdist",
	    x = as.double(x),
	    nx = nx,
	    xlo = as.double(lo),
	    xhi = as.double(up),
	    y = double(2 * n),
	    ny = as.integer(n),
	    PACKAGE = "base")$y * (nx/N)
    kords <- seq(0, 2*(up-lo), length = 2 * n)
    kords[(n + 2):(2 * n)] <- -kords[n:2]
    kords <- switch(kernel,
		    gaussian = dnorm(kords, sd = bw),
                    ## In the following, a := bw / sigma(K0), where
                    ##	K0() is the unscaled kernel below
		    rectangular = {
                        a <- bw*sqrt(3)
                        ifelse(abs(kords) < a, .5/a, 0) },
		    triangular = {
                        a <- bw*sqrt(6) ; ax <- abs(kords)
                        ifelse(ax < a, (1 - ax/a)/a, 0) },
		    epanechnikov = {
                        a <- bw*sqrt(5) ; ax <- abs(kords)
                        ifelse(ax < a, 3/4*(1 - (ax/a)^2)/a, 0) },
		    biweight = { ## aka quartic
                        a <- bw*sqrt(7) ; ax <- abs(kords)
                        ifelse(ax < a, 15/16*(1 - (ax/a)^2)^2/a, 0) },
		    cosine = {
                        a <- bw/sqrt(1/3 - 2/pi^2)
                        ifelse(abs(kords) < a, (1+cos(pi*kords/a))/(2*a),0)},
		    optcosine = {
                        a <- bw/sqrt(1-8/pi^2)
                        ifelse(abs(kords) < a, pi/4*cos(pi*kords/(2*a))/a, 0)}
                    )
    kords <- fft( fft(y)* Conj(fft(kords)), inv=TRUE)
    kords <- Re(kords)[1:n]/length(y)
    xords <- seq(lo, up, length = n)
#    keep <- (xords >= from) & (xords <= to)
    x <- seq(from, to, length = n.user)
    structure(list(x = x, y = approx(xords, kords, x)$y, bw = bw, n = N,
		   call=match.call(), data.name=name, has.na = FALSE),
	      class="density")
}

plot.density <- function(x, main=NULL, xlab=NULL, ylab="Density", type="l",
			 zero.line = TRUE, ...)
{
    if(is.null(xlab))
	xlab <- paste("N =", x$n, "  Bandwidth =", formatC(x$bw))
    if(is.null(main)) main <- deparse(x$call)
    plot.default(x, main=main, xlab=xlab, ylab=ylab, type=type, ...)
    if(zero.line) abline(h=0, lwd=0.1, col = "gray")
    invisible(NULL)
}

print.density <- function(x, digits=NULL, ...)
{
    cat("\nCall:\n\t",deparse(x$call),
	"\n\nData: ",x$data.name," (",x$n," obs.);",
	"\tBandwidth 'bw' = ",formatC(x$bw,digits=digits), "\n\n",sep="")
    print(summary(as.data.frame(x[c("x","y")])), digits=digits, ...)
    invisible(x)
}
## det now uses Lapack and an LU decomposition.  The method argument is
##     no longer used.
## S-plus' Matrix pkg has arg. "logarithm = TRUE" and returns list
##        (which is necessary for keeping the sign when taking log ..)
## S-plus v 6.x has incorporated the Matrix pkg det as determinant

det = function(x, ...)
{
    z = determinant(x, logarithm = TRUE, ...)
    c(z$sign * exp(z$modulus))
}

determinant = function(x, logarithm = TRUE, ...) UseMethod("determinant")

determinant.matrix = function(x, logarithm = TRUE, ...)
{
    if ((n <- ncol(x)) != nrow(x))
        stop("x must be a square matrix")
    if (n < 1)
        return(list(modulus = double(0), sign = as.integer(1),
                    logarithm = logarithm))
    if (is.complex(x))
        stop("determinant not currently defined for complex matrices")
    storage.mode(x) = "double"
    .Call("det_ge_real", x, logarithm, PACKAGE = "base")
}
dev.interactive <- function()
    interactive() && .Device %in% c("X11", "GTK", "gnome", "quartz", "windows")

dev.list <- function()
{
    n <- if(exists(".Devices")) get(".Devices") else list("null device")
    n <- unlist(n)
    i <- seq(along = n)[n != ""]
    names(i) <- n[i]
    i <- i[-1]
    if(length(i) == 0) NULL else i
}

dev.cur <- function()
{
    if(!exists(".Devices"))
	.Devices <- list("null device")
    num.device <- .Internal(dev.cur())
    names(num.device) <- .Devices[[num.device]]
    num.device
}

dev.set <-
    function(which = dev.next())
{
    which <- .Internal(dev.set(as.integer(which)))
#     if(exists(".Devices")) {
# 	assign(".Device", get(".Devices")[[which]])
#     }
#     else {
# 	.Devices <- list("null device")
#     }
    names(which) <- .Devices[[which]]
    which
}

dev.next <-
    function(which = dev.cur())
{
    if(!exists(".Devices"))
	.Devices <- list("null.device")
    num.device <- .Internal(dev.next(as.integer(which)))
    names(num.device) <- .Devices[[num.device]]
    num.device
}

dev.prev <-
    function(which = dev.cur())
{
    if(!exists(".Devices"))
	.Devices <- list("null device")
    num.device <- .Internal(dev.prev(as.integer(which)))
    names(num.device) <- .Devices[[num.device]]
    num.device
}

dev.off <-
    function(which = dev.cur())
{
    if(which == 1)
	stop("Cannot shut down device 1 (the null device)")
    .Internal(dev.off(as.integer(which)))
    dev.cur()
}

dev.copy <- function(device, ..., which = dev.next())
{
    if(!missing(which) & !missing(device))
	stop("Cannot supply which and device at the same time.")
    old.device <- dev.cur()
    if(old.device == 1)
	stop("Cannot copy the null device.")
    if(missing(device)) {
	if(which == 1)
	    stop("Cannot copy to the null device.")
	else if(which == dev.cur())
	    stop("Cannot copy device to itself")
	dev.set(which)
    }
    else {
	if(!is.function(device))
	    stop("Argument 'device' should be a function")
	else device(...)
    }
    .Internal(dev.copy(old.device))
    dev.cur()
}

dev.print <- function(device = postscript, ...)
{
    current.device <- dev.cur()
    nm <- names(current.device)[1]
    if(nm == "null device") stop("no device to print from")
    if(!(nm %in% c("X11", "GTK", "gnome", "windows")))
        stop("can only print from screen device")
    oc <- match.call()
    oc[[1]] <- as.name("dev.copy")
    oc$device <- device
    din <- par("din"); w <- din[1]; h <- din[2]
    if(missing(device)) { ## safe way to recognize postscript
        if(is.null(oc$file)) oc$file <- ""
        hz0 <- oc$horizontal
        hz <- if(is.null(hz0)) ps.options()$horizontal else eval.parent(hz0)
        paper <- oc$paper
        if(is.null(paper)) paper <- ps.options()$paper
        if(paper == "default") paper <- getOption("papersize")
        paper <- tolower(paper)
        switch(paper,
               a4 = 	 {wp <- 8.27; hp <- 11.69},
               legal =	 {wp <- 8.5;  hp <- 14.0},
               executive={wp <- 7.25; hp <- 10.5},
               { wp <- 8.5; hp <- 11}) ## default is "letter"

        wp <- wp - 0.5; hp <- hp - 0.5  # allow 0.25" margin on each side.
        if(!hz && is.null(hz0) && h < wp && wp < w && w < hp) {
            ## fits landscape but not portrait
            hz <- TRUE
        } else if (hz && is.null(hz0) && w < wp && wp < h && h < hp) {
            ## fits portrait but not landscape
            hz <- FALSE
        } else {
            h0 <- ifelse(hz, wp, hp)
            if(h > h0) { w <- w * h0/h; h <- h0 }
            w0 <- ifelse(hz, hp, wp)
            if(w > w0) { h <- h * w0/w; w <- w0 }
        }
        if(is.null(oc$pointsize)) {
            pt <- ps.options()$pointsize
            oc$pointsize <- pt * w/din[1]
        }
        if(is.null(hz0)) oc$horizontal <- hz
        if(is.null(oc$width)) oc$width <- w
        if(is.null(oc$height)) oc$height <- h
    } else {
        if(is.null(oc$width))
            oc$width <- if(!is.null(oc$height)) w/h * eval.parent(oc$height) else w
        if(is.null(oc$height))
            oc$height <- if(!is.null(oc$width)) h/w * eval.parent(oc$width) else h
    }
    dev.off(eval.parent(oc))
    dev.set(current.device)
}

dev.copy2eps <- function(...)
{
    current.device <- dev.cur()
    nm <- names(current.device)[1]
    if(nm == "null device") stop("no device to print from")
    if(!(nm %in% c("X11", "GTK", "gnome", "windows")))
        stop("can only print from screen device")
    oc <- match.call()
    oc[[1]] <- as.name("dev.copy")
    oc$device <- postscript
    oc$onefile <- FALSE
    oc$horizontal <- FALSE
    if(is.null(oc$paper))
        oc$paper <- "special"
    din <- par("din"); w <- din[1]; h <- din[2]
    if(is.null(oc$width))
        oc$width <- if(!is.null(oc$height)) w/h * eval.parent(oc$height) else w
    if(is.null(oc$height))
        oc$height <- if(!is.null(oc$width)) h/w * eval.parent(oc$width) else h
    if(is.null(oc$file)) oc$file <- "Rplot.eps"
    dev.off(eval.parent(oc))
    dev.set(current.device)
}

dev.control <- function(displaylist = c("inhibit", "enable"))
{
    if(dev.cur() <= 1)
        stop("dev.control() called without an open graphics device")
    if(!missing(displaylist)) {
        displaylist <- match.arg(displaylist)
	.Internal(dev.control(displaylist == "enable"))
    } else stop("argument is missing with no default")
    invisible()
}

graphics.off <- function ()
{
    while ((which <- dev.cur()) != 1)
	dev.off(which)
}
diag <- function(x = 1, nrow, ncol = n)
{
    if (is.matrix(x) && nargs() == 1) {
        if((m <- min(dim(x))) == 0)
            return(numeric(0))

        y <- c(x)[1 + 0:(m - 1) * (dim(x)[1] + 1)]
        nms <- dimnames(x)
        if (is.list(nms) && !any(sapply(nms, is.null)) &&
            all((nm <- nms[[1]][1:m]) == nms[[2]][1:m]))
            names(y) <- nm
        return(y)
    }
    if(is.array(x) && length(dim(x)) != 1)
        stop("first argument is array, but not matrix.")

    if(missing(x))
	n <- nrow
    else if(length(x) == 1 && missing(nrow) && missing(ncol)) {
	n <- as.integer(x)
	x <- 1
    }
    else n <- length(x)
    if(!missing(nrow))
	n <- nrow
    p <- ncol
    y <- array(0, c(n, p))
    if((m <- min(n, p)) > 0) y[1 + 0:(m - 1) * (n + 1)] <- x
    y
}

"diag<-" <- function(x, value)
{
    dx <- dim(x)
    if(length(dx) != 2 || prod(dx) != length(x))
	stop("only matrix diagonals can be replaced")
    i <- seq(length=min(dx))
    if(length(value) != 1 && length(value) != length(i))
	stop("replacement diagonal has wrong length")
    if(length(i) > 0) x[cbind(i, i)] <- value
    x
}
diff <- function(x, ...) UseMethod("diff")

diff.default <- function(x, lag = 1, differences = 1, ...)
{
    ismat <- is.matrix(x)
    xlen <- if(ismat) dim(x)[1] else length(x)
    if (length(lag) > 1 || length(differences) > 1 ||
        lag < 1 || differences < 1)
	stop("`lag' and `differences' must be integers >= 1")
    if (lag * differences >= xlen)
	return(x[0]) # empty of proper mode
    r <- unclass(x)  # don't want class-specific subset methods
    i1 <- -1:-lag
    if (ismat)
	for (i in 1:differences)
	    r <- r[i1, , drop = FALSE] -
                r[-nrow(r):-(nrow(r)-lag+1), , drop = FALSE]
    else
        for (i in 1:differences)
            r <- r[i1] - r[-length(r):-(length(r)-lag+1)]
    class(r) <- oldClass(x)
    r
}
dexp <- function(x, rate=1, log = FALSE) .Internal(dexp(x, 1/rate, log))
pexp <- function(q, rate=1, lower.tail = TRUE, log.p = FALSE)
    .Internal(pexp(q, 1/rate, lower.tail, log.p))
qexp <- function(p, rate=1, lower.tail = TRUE, log.p = FALSE)
    .Internal(qexp(p, 1/rate, lower.tail, log.p))
rexp <- function(n, rate=1) .Internal(rexp(n, 1/rate))

dunif <- function(x, min=0, max=1, log = FALSE)
    .Internal(dunif(x, min, max, log))
punif <- function(q, min=0, max=1, lower.tail = TRUE, log.p = FALSE)
    .Internal(punif(q, min, max, lower.tail, log.p))
qunif <- function(p, min=0, max=1, lower.tail = TRUE, log.p = FALSE)
    .Internal(qunif(p, min, max, lower.tail, log.p))
runif <- function(n, min=0, max=1) .Internal(runif(n, min, max))

dnorm <- function(x, mean=0, sd=1, log=FALSE) .Internal(dnorm(x, mean, sd, log))
pnorm <- function(q, mean=0, sd=1, lower.tail = TRUE, log.p = FALSE)
    .Internal(pnorm(q, mean, sd, lower.tail, log.p))
qnorm <- function(p, mean=0, sd=1, lower.tail = TRUE, log.p = FALSE)
    .Internal(qnorm(p, mean, sd, lower.tail, log.p))
rnorm <- function(n, mean=0, sd=1) .Internal(rnorm(n, mean, sd))

dcauchy <- function(x, location=0, scale=1, log = FALSE)
    .Internal(dcauchy(x, location, scale, log))
pcauchy <-
    function(q, location=0, scale=1, lower.tail = TRUE, log.p = FALSE)
    .Internal(pcauchy(q, location, scale, lower.tail, log.p))
qcauchy <-
    function(p, location=0, scale=1, lower.tail = TRUE, log.p = FALSE)
    .Internal(qcauchy(p, location, scale, lower.tail, log.p))
rcauchy <-
    function(n, location=0, scale=1) .Internal(rcauchy(n, location, scale))

dgamma <- function(x, shape, rate = 1, scale = 1/rate, log = FALSE)
{
    if(any(shape <= 0)) stop("shape must be strictly positive")
    .Internal(dgamma(x, shape, scale, log))
}
pgamma <- function(q, shape, rate = 1, scale = 1/rate,
                   lower.tail = TRUE, log.p = FALSE)
{
    if(any(shape <= 0)) stop("shape must be strictly positive")
    .Internal(pgamma(q, shape, scale, lower.tail, log.p))
}
qgamma <- function(p, shape, rate = 1, scale = 1/rate,
                   lower.tail = TRUE, log.p = FALSE)
{
    if(any(shape <= 0)) stop("shape must be strictly positive")
    .Internal(qgamma(p, shape, scale, lower.tail, log.p))
}
rgamma <- function(n, shape, rate = 1, scale = 1/rate)
{
    if(any(shape <= 0)) stop("shape must be strictly positive")
    .Internal(rgamma(n, shape, scale))
}

dlnorm <- function(x, meanlog=0, sdlog=1, log=FALSE)
    .Internal(dlnorm(x, meanlog, sdlog, log))
plnorm <- function(q, meanlog=0, sdlog=1, lower.tail = TRUE, log.p = FALSE)
    .Internal(plnorm(q, meanlog, sdlog, lower.tail, log.p))
qlnorm <- function(p, meanlog=0, sdlog=1, lower.tail = TRUE, log.p = FALSE)
    .Internal(qlnorm(p, meanlog, sdlog, lower.tail, log.p))
rlnorm <- function(n, meanlog=0, sdlog=1) .Internal(rlnorm(n, meanlog, sdlog))

dlogis <- function(x, location=0, scale=1, log = FALSE)
    .Internal(dlogis(x, location, scale, log))
plogis <- function(q, location=0, scale=1, lower.tail = TRUE, log.p = FALSE)
    .Internal(plogis(q, location, scale, lower.tail, log.p))
qlogis <- function(p, location=0, scale=1, lower.tail = TRUE, log.p = FALSE)
    .Internal(qlogis(p, location, scale, lower.tail, log.p))
rlogis <- function(n, location=0, scale=1) .Internal(rlogis(n, location, scale))

dweibull <- function(x, shape, scale=1, log = FALSE)
    .Internal(dweibull(x, shape, scale, log))
pweibull <- function(q, shape, scale=1, lower.tail = TRUE, log.p = FALSE)
    .Internal(pweibull(q, shape, scale, lower.tail, log.p))
qweibull <- function(p, shape, scale=1, lower.tail = TRUE, log.p = FALSE)
    .Internal(qweibull(p, shape, scale, lower.tail, log.p))
rweibull <- function(n, shape, scale=1) .Internal(rweibull(n, shape, scale))

dbeta <- function(x, shape1, shape2, ncp=0, log = FALSE) {
    if(missing(ncp)) .Internal(dbeta(x, shape1, shape2, log))
    else .Internal(dnbeta(x, shape1, shape2, ncp, log))
}
pbeta <- function(q, shape1, shape2, ncp=0, lower.tail = TRUE, log.p = FALSE) {
    if(missing(ncp)) .Internal(pbeta(q, shape1, shape2, lower.tail, log.p))
    else .Internal(pnbeta(q, shape1, shape2, ncp, lower.tail, log.p))
}
qbeta <- function(p, shape1, shape2, lower.tail = TRUE, log.p = FALSE)
    .Internal(qbeta(p, shape1, shape2, lower.tail, log.p))
rbeta <- function(n, shape1, shape2) .Internal(rbeta(n, shape1, shape2))

dbinom <- function(x, size, prob, log = FALSE)
    .Internal(dbinom(x, size, prob, log))
pbinom <- function(q, size, prob, lower.tail = TRUE, log.p = FALSE)
    .Internal(pbinom(q, size, prob, lower.tail, log.p))
qbinom <- function(p, size, prob, lower.tail = TRUE, log.p = FALSE)
    .Internal(qbinom(p, size, prob, lower.tail, log.p))
rbinom <- function(n, size, prob) .Internal(rbinom(n, size, prob))

## Multivariate: that's why there's no C interface (yet) for d...():
dmultinom <- function(x, size=NULL, prob, log = FALSE)
{
    K <- length(prob)
    if(length(x) != K) stop("x[] and prob[] must be equal length vectors.")
    if(any(prob < 0) || (s <- sum(prob)) == 0)
	stop("probabilities cannot be negative nor all 0.")
    prob <- prob / s

    x <- as.integer(x + 0.5)
    if(any(x < 0)) stop("`x' must be non-negative")
    N <- sum(x)
    if(is.null(size)) size <- N
    else if (size != N) stop("size != sum(x), i.e. one is wrong")

    i0 <- prob == 0
    if(any(i0)) {
	if(any(x[i0] != 0))
            ##  prob[j] ==0 and x[j] > 0 ==>  "impossible" => P = 0
	    return(if(log)-Inf else 0)
	## otherwise : `all is fine': prob[j]= 0 = x[j] ==> drop j and continue
	if(all(i0)) return(if(log)0 else 1)
	## else
	x <- x[!i0]
	prob <- prob[!i0]
    }
    r <- lgamma(size+1) + sum(x*log(prob) - lgamma(x+1))
    if(log) r else exp(r)
}
rmultinom <- function(n, size, prob) .Internal(rmultinom(n, size, prob))

dchisq <- function(x, df, ncp=0, log = FALSE) {
    if(missing(ncp)) .Internal(dchisq(x, df, log))
    else .Internal(dnchisq(x, df, ncp, log))
}
pchisq <- function(q, df, ncp=0, lower.tail = TRUE, log.p = FALSE) {
    if(missing(ncp)) .Internal(pchisq(q, df, lower.tail, log.p))
    else .Internal(pnchisq(q, df, ncp, lower.tail, log.p))
}
qchisq <- function(p, df, ncp=0, lower.tail = TRUE, log.p = FALSE) {
    if(missing(ncp)) .Internal(qchisq(p, df, lower.tail, log.p))
    else .Internal(qnchisq(p, df, ncp, lower.tail, log.p))
}
rchisq <- function(n, df, ncp=0) {
    if(missing(ncp)) .Internal(rchisq(n, df))
    else .Internal(rnchisq(n, df, ncp))
}

df <- function(x, df1, df2, log = FALSE) .Internal(df(x, df1, df2, log))
pf <- function(q, df1, df2, ncp=0, lower.tail = TRUE, log.p = FALSE) {
    if(missing(ncp)) .Internal(pf(q, df1, df2, lower.tail, log.p))
    else .Internal(pnf(q, df1, df2, ncp, lower.tail, log.p))
}
qf <- function(p, df1, df2, lower.tail = TRUE, log.p = FALSE)
    .Internal(qf(p, df1, df2, lower.tail, log.p))
rf <- function(n, df1, df2) .Internal(rf(n, df1, df2))

dgeom <- function(x, prob, log = FALSE) .Internal(dgeom(x, prob, log))
pgeom <- function(q, prob, lower.tail = TRUE, log.p = FALSE)
    .Internal(pgeom(q, prob, lower.tail, log.p))
qgeom <- function(p, prob, lower.tail = TRUE, log.p = FALSE)
    .Internal(qgeom(p, prob, lower.tail, log.p))
rgeom <- function(n, prob) .Internal(rgeom(n, prob))

dhyper <- function(x, m, n, k, log = FALSE) .Internal(dhyper(x, m, n, k, log))
phyper <- function(q, m, n, k, lower.tail = TRUE, log.p = FALSE)
    .Internal(phyper(q, m, n, k, lower.tail, log.p))
qhyper <- function(p, m, n, k, lower.tail = TRUE, log.p = FALSE)
    .Internal(qhyper(p, m, n, k, lower.tail, log.p))
rhyper <- function(nn, m, n, k) .Internal(rhyper(nn, m, n, k))

dnbinom <- function(x, size, prob, mu, log = FALSE)
{
    if (!missing(mu)) {
        if (!missing(prob)) stop("prob and mu both specified")
        prob <- size/(size + mu)
    }
    .Internal(dnbinom(x, size, prob, log))
}
pnbinom <- function(q, size, prob, mu, lower.tail = TRUE, log.p = FALSE)
{
    if (!missing(mu)) {
        if (!missing(prob)) stop("prob and mu both specified")
        prob <- size/(size + mu)
    }
    .Internal(pnbinom(q, size, prob, lower.tail, log.p))
}
qnbinom <- function(p, size, prob, mu, lower.tail = TRUE, log.p = FALSE)
{
    if (!missing(mu)) {
        if (!missing(prob)) stop("prob and mu both specified")
        prob <- size/(size + mu)
    }
    .Internal(qnbinom(p, size, prob, lower.tail, log.p))
}
rnbinom <- function(n, size, prob, mu)
{
    if (!missing(mu)) {
        if (!missing(prob)) stop("prob and mu both specified")
        prob <- size/(size + mu)
    }
    .Internal(rnbinom(n, size, prob))
}

dpois <- function(x, lambda, log = FALSE) .Internal(dpois(x, lambda, log))
ppois <- function(q, lambda, lower.tail = TRUE, log.p = FALSE)
    .Internal(ppois(q, lambda, lower.tail, log.p))
qpois <- function(p, lambda, lower.tail = TRUE, log.p = FALSE)
    .Internal(qpois(p, lambda, lower.tail, log.p))
rpois <- function(n, lambda) .Internal(rpois(n, lambda))

dt <- function(x, df, ncp=0, log = FALSE) {
    if(missing(ncp))
	.Internal(dt(x, df, log))
    else
	.Internal(dnt(x, df, ncp, log))
}

pt <- function(q, df, ncp=0, lower.tail = TRUE, log.p = FALSE) {
    if(missing(ncp))
	.Internal(pt(q, df, lower.tail, log.p))
    else
	.Internal(pnt(q, df, ncp, lower.tail, log.p))
}
qt <- function(p, df, lower.tail = TRUE, log.p = FALSE)
    .Internal(qt(p, df, lower.tail, log.p))
rt <- function(n, df) .Internal(rt(n, df))

ptukey <- function(q, nmeans, df, nranges=1, lower.tail = TRUE, log.p = FALSE)
    .Internal(ptukey(q, nranges, nmeans, df, lower.tail, log.p))
qtukey <- function(p, nmeans, df, nranges=1, lower.tail = TRUE, log.p = FALSE)
    .Internal(qtukey(p, nranges, nmeans, df, lower.tail, log.p))

dwilcox <- function(x, m, n, log = FALSE)
{
    on.exit(.C("wilcox_free", PACKAGE = "base"))
    .Internal(dwilcox(x, m, n, log))
}
pwilcox <- function(q, m, n, lower.tail = TRUE, log.p = FALSE)
{
    on.exit(.C("wilcox_free", PACKAGE = "base"))
    .Internal(pwilcox(q, m, n, lower.tail, log.p))
}
qwilcox <- function(p, m, n, lower.tail = TRUE, log.p = FALSE)
{
    on.exit(.C("wilcox_free", PACKAGE = "base"))
    .Internal(qwilcox(p, m, n, lower.tail, log.p))
}
rwilcox <- function(nn, m, n) .Internal(rwilcox(nn, m, n))

dsignrank <- function(x, n, log = FALSE)
{
    on.exit(.C("signrank_free", PACKAGE = "base"))
    .Internal(dsignrank(x, n, log))
}
psignrank <- function(q, n, lower.tail = TRUE, log.p = FALSE)
{
    on.exit(.C("signrank_free", PACKAGE = "base"))
    .Internal(psignrank(q, n, lower.tail, log.p))
}
qsignrank <- function(p, n, lower.tail = TRUE, log.p = FALSE)
{
    on.exit(.C("signrank_free", PACKAGE = "base"))
    .Internal(qsignrank(p, n, lower.tail, log.p))
}
rsignrank <- function(nn, n) .Internal(rsignrank(nn, n))
dotchart <-
function(x, labels = NULL, groups = NULL, gdata = NULL, cex = par("cex"),
	 pch = 21, gpch = 21, bg = par("bg"), color = par("fg"),
	 gcolor = par("fg"), lcolor = "gray",
	 xlim = range(x[is.finite(x)]),
	 main = NULL, xlab = NULL, ylab = NULL, ...)
{
    opar <- par("mar", "cex", "yaxs")
    on.exit(par(opar))
    par(cex = cex, yaxs = "i")

    n <- length(x)
    if (is.matrix(x)) {
	if (is.null(labels))
	    labels <- rownames(x)
	if (is.null(labels))
	    labels <- as.character(1:nrow(x))
	labels <- rep(labels, length = n)
	if (is.null(groups))
	    groups <- col(x, as.factor = TRUE)
	glabels <- levels(groups)
    }
    else {
	if (is.null(labels))
	    labels <- names(x)
	glabels <- if(!is.null(groups)) levels(groups)
    }

    plot.new() # for strwidth()

    linch <-
	if(!is.null(labels)) max(strwidth(labels, "inch"), na.rm = TRUE) else 0
    if (is.null(glabels)) {
	ginch <- 0
	goffset <- 0
    }
    else {
	ginch <- max(strwidth(glabels, "inch"), na.rm = TRUE)
	goffset <- 0.4
    }
    lheight <- strheight("M", "inch")
    if (!(is.null(labels) && is.null(glabels))) {
	nmar <- par("mar")
	nmar[2] <- nmar[4] + (max(linch + goffset, ginch) + 0.1)/lheight
	par(mar = nmar)
    }

    if (is.null(groups)) {
	o <- 1:n
	y <- o
	ylim <- c(0, n + 1)
    }
    else {
	o <- sort.list(as.numeric(groups), decreasing = TRUE)
	x <- x[o]
	groups <- groups[o]
	color <- rep(color, length=length(groups))[o]
	lcolor <- rep(lcolor, length=length(groups))[o]
	offset <- cumsum(c(0, diff(as.numeric(groups)) != 0))
	y <- 1:n + 2 * offset
	ylim <- range(0, y + 2)
    }

    plot.window(xlim = xlim, ylim = ylim, log = "")
#    xmin <- par("usr")[1]
    if (!is.null(labels)) {
	linch <- max(strwidth(labels, "inch"), na.rm = TRUE)
	loffset <- (linch + 0.1)/lheight
	labs <- labels[o]
        mtext(labs, side = 2, line = loffset, at = y, adj = 0,
              col = color, las = 2, cex = cex, ...)
    }
    abline(h = y, lty = "dotted", col = lcolor)
    points(x, y, pch = pch, col = color, bg = bg)
    if (!is.null(groups)) {
	gpos <- rev(cumsum(rev(tapply(groups, groups, length)) + 2) - 1)
	ginch <- max(strwidth(glabels, "inch"), na.rm = TRUE)
	goffset <- (max(linch+0.2, ginch, na.rm = TRUE) + 0.1)/lheight
        mtext(glabels, side = 2, line = goffset, at = gpos,
              adj = 0, col = gcolor, las = 2, cex = cex, ...)
	if (!is.null(gdata)) {
	    abline(h = gpos, lty = "dotted")
	    points(gdata, gpos, pch = gpch, col = gcolor, bg = bg, ...)
	}
    }
    axis(1)
    box()
    title(main=main, xlab=xlab, ylab=ylab, ...)
    invisible()
}
dput <- function(x, file = "")
{
    if(is.character(file))
        if(nchar(file) > 0) {
            file <- file(file, "wt")
            on.exit(close(file))
        } else file <- stdout()
    .Internal(dput(x, file))
}

dget <- function(file)
    eval(parse(file = file))
dummy.coef <- function(object, ...) UseMethod("dummy.coef")

dummy.coef.lm <- function(object, use.na=FALSE, ...)
{
    Terms <- terms(object)
    tl <- attr(Terms, "term.labels")
    int <- attr(Terms, "intercept")
    facs <- attr(Terms, "factors")[-1, , drop=FALSE]
    Terms <- delete.response(Terms)
    vars <- all.vars(Terms)
    xl <- object$xlevels
    if(!length(xl)) {			# no factors in model
	return(as.list(coef(object)))
    }
    nxl <- rep.int(1, length(vars))
    names(nxl) <- vars
    tmp <- unlist(lapply(xl, length))
    nxl[names(tmp)] <- tmp
    lterms <- apply(facs, 2, function(x) prod(nxl[x > 0]))
    nl <- sum(lterms)
    args <- vector("list", length(vars))
    names(args) <- vars
    for(i in vars)
	args[[i]] <- if(nxl[[i]] == 1) rep.int(1, nl)
	else factor(rep.int(xl[[i]][1], nl), levels = xl[[i]])
    dummy <- do.call("data.frame", args)
    pos <- 0
    rn <- rep.int(tl, lterms)
    rnn <- rep.int("", nl)
    for(j in tl) {
	i <- vars[facs[, j] > 0]
	ifac <- i[nxl[i] > 1]
	if(length(ifac) == 0) {		# quantitative factor
	    rnn[pos+1] <- j
	} else if(length(ifac) == 1) {	# main effect
	    dummy[ pos+1:lterms[j], ifac ] <- xl[[ifac]]
	    rnn[ pos+1:lterms[j] ] <- as.character(xl[[ifac]])
	} else {			# interaction
	    tmp <- expand.grid(xl[ifac])
	    dummy[ pos+1:lterms[j], ifac ] <- tmp
	    rnn[ pos+1:lterms[j] ] <-
		apply(as.matrix(tmp), 1, function(x) paste(x, collapse=":"))
	}
	pos <- pos + lterms[j]
    }
    ## some terms like poly(x,1) will give problems here, so allow
    ## NaNs and set to NA afterwards.
    mf <- model.frame(Terms, dummy, na.action=function(x)x, xlev=xl)
    mm <- model.matrix(Terms, mf, object$contrasts, xl)
    if(any(is.na(mm))) {
        warning("Some terms will have NAs due to the limits of the method")
        mm[is.na(mm)] <- NA
    }
    coef <- object$coef
    if(!use.na) coef[is.na(coef)] <- 0
    asgn <- attr(mm,"assign")
    res <- vector("list", length(tl))
    names(res) <- tl
    for(j in seq(along=tl)) {
	keep <- asgn == j
	ans <- drop(mm[rn == tl[j], keep, drop=FALSE] %*% coef[keep])
	names(ans) <- rnn[rn == tl[j]]
	res[[j]] <- ans
    }
    if(int > 0) {
	res <- c(list(coef[int]), res)
	names(res)[1] <- "(Intercept)"
    }
    class(res) <- "dummy.coef"
    res
}

dummy.coef.aovlist <- function(object, use.na = FALSE, ...)
{
    Terms <- terms(object, specials="Error")
    err <- attr(Terms,"specials")$Error - 1
    tl <- attr(Terms, "term.labels")[-err]
    int <- attr(Terms, "intercept")
    facs <- attr(Terms, "factors")[-c(1,1+err), -err, drop=FALSE]
    vars <- rownames(facs)
    xl <- attr(object, "xlevels")
    if(!length(xl)) {			# no factors in model
	return(as.list(coef(object)))
    }
    nxl <- rep.int(1, length(vars))
    names(nxl) <- vars
    tmp <- unlist(lapply(xl, length))
    nxl[names(tmp)] <- tmp
    lterms <- apply(facs, 2, function(x) prod(nxl[x > 0]))
    nl <- sum(lterms)
    args <- vector("list", length(vars))
    names(args) <- vars
    for(i in vars)
	args[[i]] <- if(nxl[[i]] == 1) rep.int(1, nl)
	else factor(rep.int(xl[[i]][1], nl), levels = xl[[i]])
    dummy <- do.call("data.frame", args)
    pos <- 0
    rn <- rep.int(tl, lterms)
    rnn <- rep.int("", nl)
    for(j in tl) {
	i <- vars[facs[, j] > 0]
	ifac <- i[nxl[i] > 1]
	if(length(ifac) == 0) {		# quantitative factor
	    rnn[pos + 1] <- j
	} else if(length(ifac) == 1) {	# main effect
	    dummy[ pos+1:lterms[j], ifac ] <- xl[[ifac]]
	    rnn[ pos+1:lterms[j] ] <- as.character(xl[[ifac]])
	} else {			# interaction
	    tmp <- expand.grid(xl[ifac])
	    dummy[ pos+1:lterms[j], ifac ] <- tmp
	    rnn[ pos+1:lterms[j] ] <-
		apply(as.matrix(tmp), 1, function(x) paste(x, collapse=":"))
	}
	pos <- pos + lterms[j]
    }
    form <- paste("~", paste(tl, collapse = " + "))
    if (!int) form <- paste(form, "- 1")
    mm <- model.matrix(terms(formula(form)), dummy,
		       attr(object, "contrasts"), xl)
    res <- vector("list", length(object))
    names(res) <- names(object)
    tl <- c("(Intercept)", tl)
    allasgn <- attr(mm, "assign")
    for(i in names(object)) {
	coef <- object[[i]]$coef
	if(!use.na) coef[is.na(coef)] <- 0
	asgn <- object[[i]]$assign
	uasgn <- unique(asgn)
	tll <- tl[1 + uasgn]
	mod <- vector("list", length(tll))
	names(mod) <- tll
	for(j in uasgn) {
	    if(j == 0) {
		ans <- structure(coef[asgn == j], names="(Intercept)")
	    } else {
		ans <- drop(mm[rn == tl[1+j], allasgn == j, drop=FALSE] %*%
			    coef[asgn == j])
		names(ans) <- rnn[rn == tl[1+j]]
	    }
	    mod[[tl[1+j]]] <- ans
	}
	res[[i]] <- mod
    }
    class(res) <- "dummy.coef.list"
    res
}

print.dummy.coef <- function(x, ..., title)
{
    terms <- names(x)
    n <- length(x)
    nm <- max(sapply(x, length))
    ans <- matrix("", 2*n, nm)
    rn <- rep.int("", 2*n)
    line <- 0
    for (j in seq(n)) {
	this <- x[[j]]
	n1 <- length(this)
	if(n1 > 1) {
	    line <- line + 2
	    ans[line-1, 1:n1] <- names(this)
	    ans[line, 1:n1] <- format(this, ...)
	    rn[line-1] <- paste(terms[j], ":   ", sep="")
	} else {
	    line <- line + 1
	    ans[line, 1:n1] <- format(this, ...)
	    rn[line] <- paste(terms[j], ":   ", sep="")
	}
    }
    rownames(ans) <- rn
    colnames(ans) <- rep.int("", nm)
    cat(if(missing(title)) "Full coefficients are" else title, "\n")
    print(ans[1:line, , drop=FALSE], quote=FALSE, right=TRUE)
    invisible(x)
}

print.dummy.coef.list <- function(x, ...)
{
    for(strata in names(x))
	print.dummy.coef(x[[strata]], ..., title=paste("\n     Error:", strata))
    invisible(x)
}
dump <- function (list, file = "dumpdata.R", append = FALSE,
                  envir = parent.frame())
{
    digits <- options("digits")
    on.exit(options(digits))
    options(digits = 12)
    if(is.character(file))
        if(nchar(file) > 0) {
            file <- file(file, ifelse(append, "a", "w"))
            on.exit(close(file), add = TRUE)
        } else file <- stdout()
    .Internal(dump(list, file, envir))
}

duplicated <- function(x, incomparables = FALSE, ...) UseMethod("duplicated")

duplicated.default <- function(x, incomparables = FALSE, ...)
{
    if(!is.logical(incomparables) || incomparables)
	.NotYetUsed("incomparables != FALSE")
    .Internal(duplicated(x))
}

duplicated.data.frame <- function(x, incomparables = FALSE, ...)
{
    if(!is.logical(incomparables) || incomparables)
	.NotYetUsed("incomparables != FALSE")
    duplicated(do.call("paste", c(x, sep="\r")))
}

duplicated.matrix <- duplicated.array <-
    function(x, incomparables = FALSE , MARGIN = 1, ...)
{
    if(!is.logical(incomparables) || incomparables)
	.NotYetUsed("incomparables != FALSE")
    ndim <- length(dim(x))
    if (length(MARGIN) > ndim || any(MARGIN > ndim))
        stop(paste("MARGIN = ", MARGIN, " is invalid for dim = ",
                   dim(x), sep = ""))
    temp <- apply(x, MARGIN, function(x) paste(x, collapse = "\r"))
    res <- duplicated(as.vector(temp))
    dim(res) <- dim(temp)
    dimnames(res) <- dimnames(temp)
    res
}

unique <- function(x, incomparables = FALSE, ...) UseMethod("unique")


## NB unique.default is used by factor to avoid unique.matrix,
## so it needs to handle some other cases.
unique.default <- function(x, incomparables = FALSE, ...)
{
    if(!is.logical(incomparables) || incomparables)
	.NotYetUsed("incomparables != FALSE")
    z <- .Internal(unique(x))
    if(is.factor(x))
	factor(z, levels = seq(len=nlevels(x)), labels = levels(x),
               ordered = is.ordered(x))
    else if(inherits(x, "POSIXct")) structure(z, class=class(x))
    else z
}

unique.data.frame <- function(x, incomparables = FALSE, ...)
{
    if(!is.logical(incomparables) || incomparables)
	.NotYetUsed("incomparables != FALSE")
    x[!duplicated(x),  , drop = FALSE]
}

unique.matrix <- unique.array <-
    function(x, incomparables = FALSE , MARGIN = 1, ...)
{
    if(!is.logical(incomparables) || incomparables)
	.NotYetUsed("incomparables != FALSE")
    ndim <- length(dim(x))
    if (length(MARGIN) > 1 || any(MARGIN > ndim))
        stop(paste("MARGIN = ", MARGIN, " is invalid for dim = ",
                   dim(x), sep = ""))
    temp <- apply(x, MARGIN, function(x) paste(x, collapse = "\r"))
    args <- rep(alist(a=), ndim)
    names(args) <- NULL
    args[[MARGIN]] <- !duplicated(as.vector(temp))
    do.call("[", c(list(x=x), args, list(drop=FALSE)))
}
##dyn.load <- function(x)
##{
##	x <- as.character(x)
##	y <- substr(x, 1, 1)
##	if (y == "/") {
##		.Internal(dyn.load(x))
##	}
##	else {
##		.Internal(dyn.load(
##		paste(system("pwd", intern = TRUE), x, sep = "/", collapse="")))
##	}
##}
dyn.load <- function(x, local=TRUE, now=TRUE)
    .Internal(dyn.load(x, as.logical(local), as.logical(now)))

dyn.unload <- function(x)
    .Internal(dyn.unload(x))

getNativeSymbolInfo <- function(name, PACKAGE)
{
    if(missing(PACKAGE)) PACKAGE <- ""
    v <- .Call("R_getSymbolInfo", as.character(name), as.character(PACKAGE),
               PACKAGE = "base")
    if(is.null(v)) {
        msg <- paste("no such symbol",name)
        if(length(PACKAGE) && nchar(PACKAGE[1]))
            msg <- paste(msg, "in package",PACKAGE[1])
        stop(msg)
    }
    names(v) <- c("name", "address", "package", "numParameters")[1:length(v)]
    v
}
edit <- function(name,...)UseMethod("edit")

edit.default <-
    function (name = NULL, file = "", editor = getOption("editor"), ...)
{
    if(is.matrix(name) && 
       (mode(name) == "numeric" || mode(name) == "character"))
        edit.matrix(name=name, ...)
    else .Internal(edit(name, file, editor))
}

edit.data.frame <-
    function(name, factor.mode = c("character", "numeric"),
             edit.row.names =  any(row.names(name) != 1:nrow(name)), ...)
{
    if (.Platform$OS.type == "unix"  && .Platform$GUI != "AQUA")
        if(.Platform$GUI == "unknown" || Sys.getenv("DISPLAY")=="" )
            return (edit.default(name, ...))

    is.vector.unclass <- function(x) is.vector(unclass(x))
    if (length(name) > 0 && !all(sapply(name, is.vector.unclass)
                                 | sapply(name, is.factor)))
        stop("Can only handle vector and factor elements")

    factor.mode <- match.arg(factor.mode)

    as.num.or.char <- function(x)
    {
        ## Would as.character be a better default?  BDR 2000/5/3
        if (is.character(x)) x
        else if (is.logical(x) || (is.factor(x) && factor.mode == "character")) as.character(x)
        else as.numeric(x)
    }

    attrlist <- lapply(name, attributes)
    datalist <- lapply(name, as.num.or.char)
    factors <- if (length(name) > 0)
        which(sapply(name, is.factor))
    else
        numeric(0)

    logicals <- if (length(name) > 0)
    	which(sapply(name, is.logical))
    else
    	numeric(0)

    modes <- lapply(datalist, mode)
    if (edit.row.names) {
        datalist <- c(list(row.names=row.names(name)), datalist)
        modes <- c(list(row.names="character"), modes)
    }
    out <- .Internal(dataentry(datalist, modes))
    lengths <- sapply(out, length)
    maxlength <- max(lengths)
    if (edit.row.names) rn <- out[[1]]
    for (i in which(lengths != maxlength))
         out[[i]] <- c(out[[i]], rep.int(NA, maxlength - lengths[i]))
    if (edit.row.names) {
        out <- out[-1]
        if((ln <- length(rn)) < maxlength)
            rn <- c(rn, paste("row", (ln+1):maxlength, sep=""))
    }
    for (i in factors) {
        if(mode(out[[i]]) == "numeric") next # user might have switched mode
        a <- attrlist[[i]]
        if (factor.mode == "numeric") {
            o <- as.integer(out[[i]])
            ok <- is.na(o) | (o > 0 & o <= length(a$levels))
            if (any(!ok)) {
                warning(paste("invalid factor levels in", names(out)[i]))
                o[!ok] <- NA
            }
	    attributes(o) <- a
        } else {
            o <- out[[i]]
            if (any(new <- is.na(match(o, c(a$levels, NA))))) {
                new <- unique(o[new])
                warning(paste("added factor levels in", names(out)[i]))
                o <- factor(o, levels=c(a$levels, new), ordered=is.ordered(o))
            } else {
                o <- match(o, a$levels)
                attributes(o) <- a
            }
        }
        out[[i]] <- o
    }
    for (i in logicals) out[[i]] <- as.logical(out[[i]])

    out <- as.data.frame(out) # will convert cols switched to char into factors
    if (edit.row.names) {
        if(any(duplicated(rn)))
            warning("edited row names contain duplicates and will be ignored")
        else row.names(out) <- rn
    }
    out
}

edit.matrix <-
    function(name, edit.row.names = any(rownames(name) != 1:nrow(name)), ...)
{
    if (.Platform$OS.type == "unix" && .Platform$GUI != "AQUA")
        if(.Platform$GUI == "unknown" || Sys.getenv("DISPLAY")=="" )
            return (edit.default(name, ...))
    if(!is.matrix(name) ||
       !(mode(name) == "numeric" || mode(name) == "character" || mode(name) == "logical")
       || any(dim(name) < 1))
        stop("invalid input matrix")
    logicals <- is.logical(name)
    if (logicals) mode(name) <- "character"
    dn <- dimnames(name)
    if(is.null(dn[[1]])) edit.row.names <- FALSE
    datalist <- split(name, col(name))
    if(!is.null(dn[[2]])) names(datalist) <- dn[[2]]
    else names(datalist) <- paste("col", 1:ncol(name), sep = "")
    modes <- as.list(rep.int(mode(name), ncol(name)))
    if (edit.row.names) {
        datalist <- c(list(row.names=dn[[1]]), datalist)
        modes <- c(list(row.names="character"), modes)
    }
    out <- .Internal(dataentry(datalist, modes))
    lengths <- sapply(out, length)
    maxlength <- max(lengths)
    if (edit.row.names) rn <- out[[1]]
    for (i in which(lengths != maxlength))
         out[[i]] <- c(out[[i]], rep.int(NA, maxlength - lengths[i]))
    if (edit.row.names) {
        out <- out[-1]
        if((ln <- length(rn)) < maxlength)
            rn <- c(rn, paste("row", (ln+1):maxlength, sep=""))
    }
    out <- do.call("cbind", out)
    if (edit.row.names) rownames(out) <- rn
    else if(!is.null(dn[[1]]))  rownames(out) <- dn[[1]]
    if(!is.null(dn[[2]]))  colnames(out) <- dn[[2]]
    if (logicals) mode(out) <- "logical"
    out
}

vi <- function(name=NULL, file="")
    edit.default(name, file, editor="vi")

emacs <- function(name=NULL, file="")
    edit.default(name, file, editor="emacs")

xemacs <- function(name=NULL, file="")
    edit.default(name, file, editor="xemacs")

xedit <- function(name=NULL, file="")
    edit.default(name, file, editor="xedit")

pico <- function(name=NULL, file="")
    edit.default(name, file, editor="pico")

eigen <- function(x, symmetric, only.values = FALSE, EISPACK = FALSE)
{
    x <- as.matrix(x)
    dimnames(x) <- list(NULL, NULL)  # or they appear on eigenvectors
    n <- nrow(x)
    if (!n)
        stop("0 x 0 matrix")
    if (n != ncol(x))
	stop("non-square matrix in eigen")

    complex.x <- is.complex(x)

    if (any(is.na(x))){
        if (complex.x)
            return(list(values = as.complex(rep(NA, n)),
                    vectors = if (!only.values) as.complex(matrix(NA, n,n))))
        else
            return(list(values = as.numeric(rep(NA, n)),
                    vectors = if (!only.values) as.numeric(matrix(NA, n,n))))
    }

    if(complex.x) {
	if(missing(symmetric)) {
            test <- all.equal.numeric(x, Conj(t(x)), 100*.Machine$double.eps)
	    symmetric <- is.logical(test) && test
        }
    }
    else if(is.numeric(x)) {
	storage.mode(x) <- "double"
	if(missing(symmetric)) {
            test <- all.equal.numeric(x, t(x), 100*.Machine$double.eps)
	    symmetric <- is.logical(test) && test
        }
    }
    else stop("numeric or complex values required in eigen")
    if (!EISPACK) {
        if (symmetric) {
            z <- if(!complex.x)
                .Call("La_rs", x, only.values, "dsyevr", PACKAGE = "base")
            else
                .Call("La_rs_cmplx", x, only.values, PACKAGE = "base")
            ord <- rev(seq(along = z$values))
        } else {
            z <- if(!complex.x)
                .Call("La_rg", x, only.values, PACKAGE = "base")
            else
                .Call("La_rg_cmplx", x, only.values, PACKAGE = "base")
            ord <- sort.list(Mod(z$values), decreasing = TRUE)
        }
        return(list(values = z$values[ord],
                    vectors = if (!only.values) z$vectors[, ord, drop = FALSE]))
    }

    dbl.n <- double(n)
    if(symmetric) {##--> real values
	if(complex.x) {
	    xr <- Re(x)
	    xi <- Im(x)
	    z <- .Fortran("ch",
			  n,
			  n,
			  xr,
			  xi,
			  values = dbl.n,
			  !only.values,
			  vectors = xr,
			  ivectors = xi,
			  dbl.n,
			  dbl.n,
			  double(2*n),
			  ierr = integer(1),
                          PACKAGE="base")
	    if (z$ierr)
		stop(paste("ch returned code ", z$ierr, " in eigen"))
	    if(!only.values)
		z$vectors <- matrix(complex(re=z$vectors,
					    im=z$ivectors), nc=n)
	}
	else {
	    z <- .Fortran("rs",
			  n,
			  n,
			  x,
			  values = dbl.n,
			  !only.values,
			  vectors = x,
			  dbl.n,
			  dbl.n,
			  ierr = integer(1),
                          PACKAGE="base")
	    if (z$ierr)
		stop(paste("rs returned code ", z$ierr, " in eigen"))
	}
	ord <- sort.list(z$values, decreasing = TRUE)
    }
    else {##- Asymmetric :
	if(complex.x) {
	    xr <- Re(x)
	    xi <- Im(x)
	    z <- .Fortran("cg",
			  n,
			  n,
			  xr,
			  xi,
			  values = dbl.n,
			  ivalues = dbl.n,
			  !only.values,
			  vectors = xr,
			  ivectors = xi,
			  dbl.n,
			  dbl.n,
			  dbl.n,
			  ierr = integer(1),
                          PACKAGE="base")
	    if (z$ierr)
		stop(paste("cg returned code ", z$ierr, " in eigen"))
	    z$values <- complex(re=z$values,im=z$ivalues)
	    if(!only.values)
		z$vectors <- matrix(complex(re=z$vectors,
					    im=z$ivectors), nc=n)
	}
	else {
	    z <- .Fortran("rg",
			  n,
			  n,
			  x,
			  values = dbl.n,
			  ivalues = dbl.n,
			  !only.values,
			  vectors = x,
			  integer(n),
			  dbl.n,
			  ierr = integer(1),
                          PACKAGE="base")
	    if (z$ierr)
		stop(paste("rg returned code ", z$ierr, " in eigen"))
	    ind <- z$ivalues > 0
	    if(any(ind)) {#- have complex (conjugated) values
		ind <- seq(n)[ind]
		z$values <- complex(re=z$values,im=z$ivalues)
		if(!only.values) {
		    z$vectors[, ind] <- complex(re=z$vectors[,ind],
						im=z$vectors[,ind+1])
		    z$vectors[, ind+1] <- Conj(z$vectors[,ind])
		}
	    }
	}
	ord <- sort.list(Mod(z$values), decreasing = TRUE)
    }
    list(values = z$values[ord],
	 vectors = if(!only.values) z$vectors[,ord, drop = FALSE])
}
environment <- function(fun=NULL) .Internal(environment(fun))
.GlobalEnv <- environment()
parent.frame <- function(n = 1) .Internal(parent.frame(n))

eval <-
    function(expr, envir = parent.frame(),
	     enclos = if(is.list(envir) || is.pairlist(envir))
                       parent.frame())
    .Internal(eval(expr, envir,enclos))

eval.parent <- function(expr, n = 1){
    p <- parent.frame(n + 1)
    eval(expr , p)
}

evalq <-
    function (expr, envir, enclos)
    eval.parent(substitute(eval(quote(expr), envir, enclos)))

new.env <- function (hash=FALSE, parent=parent.frame())
    .Internal(new.env(hash, parent))

parent.env <- function(env)
    .Internal(parent.env(env))

"parent.env<-" <- function(env, value)
    .Internal("parent.env<-"(env, value))

local <-
    function (expr, envir = new.env())
    eval.parent(substitute(eval(quote(expr), envir)))

Recall <- function(...) .Internal(Recall(...))

with <- function(data, expr, ...) UseMethod("with")

with.default <- function(data, expr, ...)
    eval(substitute(expr), data, enclos=parent.frame())

force <- function(x) x
exists <-
    function (x, where = -1,
              envir = if(missing(frame)) as.environment(where) else sys.frame(frame),
              frame, mode = "any", inherits = TRUE)
    .Internal(exists(x, envir, mode, inherits))
expand.grid <- function(...)
{
    ## x should either be a list or a set of vectors or factors
    nargs <- length(args <- list(...))
    if(! nargs) return(as.data.frame(list()))
    if(nargs == 1 && is.list(a1 <- args[[1]]))
        nargs <- length(args <- a1)
    if(nargs == 0) return(as.data.frame(list()))
    cargs <- args
    nmc <- paste("Var", 1:nargs, sep="")
    nm <- names(args)
    if(is.null(nm)) nm <- nmc
    if(any(ng0 <- nchar(nm) > 0)) nmc[ng0] <- nm[ng0]
    names(cargs) <- nmc
    rep.fac <- 1
    orep <- prod(sapply(args, length))
    for(i in 1:nargs) {
	x <- args[[i]]
	## avoid sorting the levels of character variates
	nx <- length(x)
	orep <- orep/nx
	x <- rep.int(rep.int(x, rep.int(rep.fac, nx)), orep)
	## avoid sorting the levels of character variates
	if(!is.factor(x) && is.character(x)) x <- factor(x, levels = unique(x))
	cargs[[i]] <- x
	rep.fac <- rep.fac * nx
    }
    do.call("cbind.data.frame", cargs)
}
expand.model.frame <- function(model, extras,
                               envir=environment(formula(model)),
                               na.expand=FALSE)
{
    ## don't use model$call$formula -- it might be a variable name
    f <- formula(model)
    data <- eval(model$call$data, envir)

    # new formula (there must be a better way...)
    ff <- foo ~ bar + baz
    if (is.call(extras))
        gg <- extras
    else
        gg <- parse(text=paste("~", paste(extras, collapse="+")))[[1]]
    ff[[2]] <- f[[2]]
    ff[[3]][[2]] <- f[[3]]
    ff[[3]][[3]] <- gg[[2]]

    if (!na.expand){
        naa <- model$call$na.action
        subset <- model$call$subset
        rval <- eval(call("model.frame",ff, data = data, subset = subset, 
                      na.action = naa),envir )
    } else {
        subset <- model$call$subset
        rval <- eval(call("model.frame",ff, data = data, subset = subset, 
                          na.action = I), envir)
        oldmf <- model.frame(model)
        keep <- match(rownames(oldmf), rownames(rval))
        rval <- rval[keep, ]
        class(rval) <- "data.frame" # drop "AsIs"
    }

    return(rval)
}
factor <- function (x, levels = sort(unique.default(x), na.last = TRUE),
		    labels=levels, exclude = NA, ordered = is.ordered(x))
{
    if(is.null(x))
	x <- list()
    exclude <- as.vector(exclude, typeof(x))
    levels <- levels[is.na(match(levels, exclude))]
    f <- match(x, levels)
    names(f) <- names(x)
    nl <- length(labels)
    attr(f, "levels") <-
	if (nl == length(levels))
	    as.character(labels)
	else if(nl == 1)
	    paste(labels, seq(along = levels), sep = "")
	else
	    stop(paste("invalid labels; length", nl,
		       "should be 1 or",length(levels)))
    class(f) <- c(if(ordered)"ordered", "factor")
    f
}

is.factor <- function(x) inherits(x, "factor")
as.factor <- function(x) if (is.factor(x)) x else factor(x)

## Help old S users:
category <- function(...) .Defunct()

levels <- function(x) attr(x, "levels")
nlevels <- function(x) length(levels(x))

"levels<-" <- function(x, value) UseMethod("levels<-")

"levels<-.default" <- function(x, value)
{
    attr(x, "levels") <- value
    x
}

"levels<-.factor" <- function(x, value)
{
    xlevs <- levels(x)
    if (is.list(value)) {
        nlevs <- rep.int(names(value), lapply(value, length))
        value <- unlist(value)
        m <- match(value, xlevs, nomatch=0)
        xlevs[m] <- nlevs[m > 0]
    } else {
        if (length(xlevs) > length(value))
            stop("number of levels differs")
        nlevs <- xlevs <- as.character(value)
    }
    factor(xlevs[x], levels = unique(nlevs))
}

as.vector.factor <- function(x, mode="any")
{
    if(mode== "any" || mode== "character" || mode== "logical" || mode== "list")
	as.vector(levels(x)[x], mode)
    else
	as.vector(unclass(x), mode)
}

as.character.factor <- function(x,...)
{
    cx <- levels(x)[x]
    if("NA" %in% levels(x)) cx[is.na(x)] <- "<NA>"
    cx
}

## for `factor' *and* `ordered' :
print.factor <- function (x, quote = FALSE, max.levels = NULL,
                          width = getOption("width"), ...)
{
    ord <- is.ordered(x)
    if (length(x) <= 0)
        cat(if(ord)"ordered" else "factor","(0)\n",sep="")
    else
        print(as.character(x), quote = quote, ...)
    maxl <- if(is.null(max.levels)) TRUE else max.levels
    if (maxl) {
        n <- length(lev <- levels(x))
        colsep <- if(ord) " < " else " "
        T0 <- "Levels: "
        if(is.logical(maxl))
            maxl <- { ## smart default
                width <- width - (nchar(T0) + 3 + 1 + 3)# 3='...', 3=#lev, 1=extra
                lenl <- cumsum(nchar(lev) + nchar(colsep))# + ifelse(quote,2,0))
                if(n <= 1 || lenl[n] <= width) n
                else max(1, which(lenl > width)[1] - 1)
            }
        drop <- n > maxl
        cat(if(drop)paste(format(n),""), T0,
            paste(if(drop)c(lev[1:max(1,maxl-1)],"...",if(maxl > 1) lev[n])
                      else lev, collapse= colsep), "\n", sep="")
    }
    invisible(x)
}


Math.factor <- function(x, ...) {
    stop(paste('"',.Generic,'"', " not meaningful for factors", sep=""))
}
Summary.factor <- function(x, ...) {
    stop(paste('"',.Generic,'"', " not meaningful for factors", sep=""))
}
Ops.factor <- function(e1, e2)
{
    ok <- switch(.Generic, "=="=, "!="=TRUE, FALSE)
    if(!ok) {
	warning('"',.Generic,'"', " not meaningful for factors")
	return(rep.int(NA, max(length(e1), if(!missing(e2))length(e2))))
    }
    nas <- is.na(e1) | is.na(e2)
    if (nchar(.Method[1])) {
	l1 <- levels(e1)
	e1 <- l1[e1]
    }
    if (nchar(.Method[2])) {
	l2 <- levels(e2)
	e2 <- l2[e2]
    }
    if (all(nchar(.Method)) && (length(l1) != length(l2) ||
				!all(sort(l2) == sort(l1))))
	stop("Level sets of factors are different")
    value <- NextMethod(.Generic)
    value[nas] <- NA
    value
}

"[.factor" <- function(x, i, drop=FALSE)
{
    y <- NextMethod("[")
    class(y) <- oldClass(x)
    attr(y,"contrasts")<-attr(x,"contrasts")
    attr(y,"levels")<-attr(x,"levels")
    if ( drop ) factor(y) else y
}

"[<-.factor" <- function(x, i, value)
{
    lx <- levels(x)
    cx <- oldClass(x)
#    nas <- is.na(x) # unused
    if (is.factor(value))
	value <- levels(value)[value]
    m <- match(value, lx)
    if (any(is.na(m) & !is.na(value)))
	warning("invalid factor level, NAs generated")
    class(x) <- NULL
    if (missing(i))
	x[] <- m
    else
        x[i] <- m
    attr(x,"levels") <- lx
    class(x) <- cx
    x
}

## ordered factors ...

ordered <- function(x, ...) factor(x, ..., ordered=TRUE)

is.ordered <- function(x) inherits(x, "ordered")
as.ordered <- function(x) if(is.ordered(x)) x else ordered(x)

Ops.ordered <-
function (e1, e2)
{
    ok <- switch(.Generic,
		 "<" = , ">" = , "<=" = , ">=" = ,"=="=, "!=" =TRUE,
		 FALSE)
    if(!ok) {
	warning('"',.Generic,'"', " not meaningful for ordered factors")
	return(rep.int(NA, max(length(e1), if(!missing(e2))length(e2))))
    }
    if (.Generic %in% c("==", "!="))
      return(NextMethod(.Generic))  ##not S-PLUS compatible, but saner
    nas <- is.na(e1) | is.na(e2)
    ord1 <- FALSE
    ord2 <- FALSE
    if (nchar(.Method[1])) {
	l1 <- levels(e1)
	ord1 <- TRUE
    }
    if (nchar(.Method[2])) {
	l2 <- levels(e2)
	ord2 <- TRUE
    }
    if (all(nchar(.Method)) && (length(l1) != length(l2) || !all(l2 == l1)))
	stop("Level sets of factors are different")
    if (ord1 && ord2) {
	e1 <- as.integer(e1) # was codes, but same thing for ordered factor.
	e2 <- as.integer(e2)
    }
    else if (!ord1) {
	e1 <- match(e1, l2)
	e2 <- as.integer(e2)
    }
    else if (!ord2) {
	e2 <- match(e2, l1)
	e1 <- as.integer(e1)
    }
    value <- get(.Generic, mode = "function")(e1, e2)
    value[nas] <- NA
    value
}

"is.na<-.factor" <- function(x, value)
{
    lx <- levels(x)
    cx <- oldClass(x)
    class(x) <- NULL
    x[value] <- NA
    structure(x, levels = lx, class = cx)
}
family <- function(object, ...) UseMethod("family")

print.family <- function(x, ...)
{
    cat("\nFamily:", x$family, "\n")
    cat("Link function:", x$link, "\n\n")
}

power <- function(lambda = 1) {
    if(lambda <= 0)
	make.link("log")
    else if(lambda == 1)
        make.link("identity")
    else
        make.link(lambda)
}

## Written by Simon Davies Dec 1995
## Modified by Thomas Lumley 26 Apr 97
## added valideta(eta) function..
make.link <- function (link)
{
    if (is.character(link) && length(grep("^power", link) > 0))
        return(eval(parse(text = link)))
    else if(!is.character(link) && !is.na(lambda <- as.numeric(link))) {
        linkfun <- function(mu) mu^lambda
        linkinv <- function(eta)
            pmax(.Machine$double.eps, eta^(1/lambda))
        mu.eta <- function(eta)
            pmax(.Machine$double.eps, (1/lambda) * eta^(1/lambda - 1))
        valideta <- function(eta) all(eta>0)
    }
    else
        switch(link,
               "logit" = {
                   linkfun <- function(mu) log(mu/(1 - mu))
                   linkinv <- function(eta) {
                       thresh <- -log(.Machine$double.eps)
                       eta <- pmin(thresh, pmax(eta, -thresh))
                       exp(eta)/(1 + exp(eta))
                   }
                   mu.eta <- function(eta) {
                       thresh <- -log(.Machine$double.eps)
                       res <- rep.int(.Machine$double.eps, length(eta))
                       res[abs(eta) < thresh] <-
                           (exp(eta)/(1 + exp(eta))^2)[abs(eta) < thresh]
                       res
                   }
                   valideta <- function(eta) TRUE
               },
               "probit" = {
                   linkfun <- function(mu) qnorm(mu)
                   linkinv <- function(eta) {
                       thresh <- - qnorm(.Machine$double.eps)
                       eta <- pmin(thresh, pmax(eta, -thresh))
                       pnorm(eta)
                   }
                   mu.eta <- function(eta)
                       pmax(dnorm(eta),.Machine$double.eps)
                   valideta <- function(eta) TRUE
               },
               "cloglog" = {
                   linkfun <- function(mu) log(-log(1 - mu))
                   linkinv <- function(eta)
                       pmax(.Machine$double.eps,
                            pmin(1 - .Machine$double.eps, - expm1(-exp(eta))))
                   mu.eta <- function(eta) {
                       eta <- pmin(eta, 700)
                       pmax(.Machine$double.eps, exp(eta) * exp(-exp(eta)))
                   }
                   valideta <- function(eta) TRUE
               },
               "identity" = {
                   linkfun <- function(mu) mu
                   linkinv <- function(eta) eta
                   mu.eta <- function(eta) rep.int(1, length(eta))
                   valideta <- function(eta) TRUE
               },
               "log" = {
                   linkfun <- function(mu) log(mu)
                   linkinv <- function(eta)
                       pmax(.Machine$double.eps, exp(eta))
                   mu.eta <- function(eta)
                       pmax(.Machine$double.eps, exp(eta))
                   valideta <- function(eta) TRUE
               },
               "sqrt" = {
                   linkfun <- function(mu) mu^0.5
                   linkinv <- function(eta) eta^2
                   mu.eta <- function(eta) 2 * eta
                   valideta <- function(eta) all(eta>0)
               },
               "1/mu^2" = {
                   linkfun <- function(mu) 1/mu^2
                   linkinv <- function(eta) 1/eta^0.5
                   mu.eta <- function(eta) -1/(2 * eta^1.5)
                   valideta <- function(eta) all(eta>0)
               },
               "inverse" = {
                   linkfun <- function(mu) 1/mu
                   linkinv <- function(eta) 1/eta
                   mu.eta <- function(eta) -1/(eta^2)
                   valideta <- function(eta) all(eta!=0)
               },
               ## else :
               stop(paste(link, "link not recognised"))
               )# end switch(.)
    list(linkfun = linkfun, linkinv = linkinv,
	 mu.eta = mu.eta, valideta = valideta)
}

poisson <- function (link = "log")
{
    linktemp <- substitute(link)
    ## this is a function used in  glm().
    ## It holds everything personal to the family,
    ## converts link into character string
    if (!is.character(linktemp)) {
	linktemp <- deparse(linktemp)
	if (linktemp == "link")
	    linktemp <- eval(link)
    }
    if (any(linktemp == c("log", "identity", "sqrt")))
	stats <- make.link(linktemp)
    else stop(paste(linktemp, "link not available for poisson",
		    "family; available links are",
		    '"identity", "log" and "sqrt"'))
    variance <- function(mu) mu
    validmu <- function(mu) all(mu>0)
    dev.resids <- function(y, mu, wt)
	2 * wt * (y * log(ifelse(y == 0, 1, y/mu)) - (y - mu))
    aic <- function(y, n, mu, wt, dev)
#	2*sum((mu-y*log(mu)+lgamma(y+1))*wt)
	-2*sum(dpois(y, mu, log=TRUE)*wt)
    initialize <- expression({
	if (any(y < 0))
	    stop(paste("Negative values not allowed for",
		       "the Poisson family"))
	n <- rep.int(1, nobs)
	mustart <- y + 0.1
    })
    structure(list(family = "poisson",
		   link = linktemp,
		   linkfun = stats$linkfun,
		   linkinv = stats$linkinv,
		   variance = variance,
		   dev.resids = dev.resids,
		   aic = aic,
		   mu.eta = stats$mu.eta,
		   initialize = initialize,
		   validmu = validmu,
		   valideta = stats$valideta),
	      class = "family")
}

quasipoisson <- function (link = "log")
{
    linktemp <- substitute(link)
    ## this is a function used in  glm().
    ## It holds everything personal to the family,
    ## converts link into character string
    if (!is.character(linktemp)) {
	linktemp <- deparse(linktemp)
	if (linktemp == "link")
	    linktemp <- eval(link)
    }
    if (any(linktemp == c("log", "identity", "sqrt")))
	stats <- make.link(linktemp)
    else stop(paste(linktemp, "link not available for poisson",
		    "family; available links are",
		    '"identity", "log" and "sqrt"'))
    variance <- function(mu) mu
    validmu <- function(mu) all(mu>0)
    dev.resids <- function(y, mu, wt)
	2 * wt * (y * log(ifelse(y == 0, 1, y/mu)) - (y - mu))
    aic <- function(y, n, mu, wt, dev) NA
    initialize <- expression({
	if (any(y < 0))
	    stop(paste("Negative values not allowed for",
		       "the quasiPoisson family"))
	n <- rep.int(1, nobs)
	mustart <- y + 0.1
    })
    structure(list(family = "quasipoisson",
		   link = linktemp,
		   linkfun = stats$linkfun,
		   linkinv = stats$linkinv,
		   variance = variance,
		   dev.resids = dev.resids,
		   aic = aic,
		   mu.eta = stats$mu.eta,
		   initialize = initialize,
		   validmu = validmu,
		   valideta = stats$valideta),
	      class = "family")
}

gaussian <- function (link = "identity")
{
    linktemp <- substitute(link)
    ## This is a function used in  glm();
    ## it holds everything personal to the family
    ## converts link into character string
    if (!is.character(linktemp)) {
	linktemp <- deparse(linktemp)
	if (linktemp == "link")
	    linktemp <- eval(link)
    }
    if (any(linktemp == c("inverse", "log", "identity")))
	stats <- make.link(linktemp)
    else stop(paste(linktemp, "link not available for gaussian",
		    "family, available links are \"inverse\", ",
		    "\"log\" and \"identity\""))
    structure(list(family = "gaussian",
		   link = linktemp,
		   linkfun = stats$linkfun,
		   linkinv = stats$linkinv,
		   variance = function(mu) rep.int(1, length(mu)),
		   dev.resids = function(y, mu, wt) wt * ((y - mu)^2),
		   aic =	function(y, n, mu, wt, dev)
		   sum(wt)*(log(dev/sum(wt)*2*pi)+1)+2,
		   mu.eta = stats$mu.eta,
		   initialize = expression({
		       n <- rep.int(1, nobs)
		       mustart <- y }),
		   validmu = function(mu) TRUE
		   ),
	      class = "family")
}

binomial <- function (link = "logit")
{
    linktemp <- substitute(link)
    ## this is a function used in  glm();
    ## it holds everything personal to the family
    ## converts link into character string
    if (!is.character(linktemp)) {
	linktemp <- deparse(linktemp)
	if (linktemp == "link")
	    linktemp <- eval(link)
    }
    if (any(linktemp == c("logit", "probit", "cloglog", "log")))
	stats <- make.link(linktemp)
    else stop(paste(linktemp, "link not available for binomial",
		    "family, available links are \"logit\", ",
		    "\"probit\", \"cloglog\" and \"log\""))
    variance <- function(mu) mu * (1 - mu)
    validmu <- function(mu) all(mu>0) && all(mu<1)
    dev.resids <- function(y, mu, wt)
	2 * wt * (y * log(ifelse(y == 0, 1, y/mu)) +
		  (1 - y) * log(ifelse(y == 1, 1, (1 - y)/(1 - mu))))
    aic <- function(y, n, mu, wt, dev) {
#	-2*sum((lchoose(n, n*y) + n*(y*log(mu) + (1-y)*log(1-mu)))*wt/n)
        m <- if(any(n > 1)) n else wt
	-2*sum(ifelse(m > 0, (wt/m), 0)*
               dbinom(round(m*y), round(m), mu, log=TRUE))
    }
    initialize <- expression({
	if (NCOL(y) == 1) {
	    ## allow factors as responses
	    ## added BDR 29/5/98
	    if (is.factor(y)) y <- y != levels(y)[1]
	    n <- rep.int(1, nobs)
	    if (any(y < 0 | y > 1))
		stop("y values must be 0 <= y <= 1")
            mustart <- (weights * y + 0.5)/(weights + 1)
            m <- weights * y
            if(any(abs(m - round(m)) > 1e-3))
                warning("non-integer #successes in a binomial glm!")
	}
	else if (NCOL(y) == 2) {
            if(any(abs(y - round(y)) > 1e-3))
                warning("non-integer counts in a binomial glm!")
	    n <- y[, 1] + y[, 2]
	    y <- ifelse(n == 0, 0, y[, 1]/n)
	    weights <- weights * n
            mustart <- (n * y + 0.5)/(n + 1)
	}
	else stop(paste("For the binomial family, y must be",
			"a vector of 0 and 1\'s or a 2 column",
			"matrix where col 1 is no. successes",
			"and col 2 is no. failures"))
    })
    structure(list(family = "binomial",
		   link = linktemp,
		   linkfun = stats$linkfun,
		   linkinv = stats$linkinv,
		   variance = variance,
		   dev.resids = dev.resids,
		   aic = aic,
		   mu.eta = stats$mu.eta,
		   initialize = initialize,
		   validmu = validmu,
		   valideta = stats$valideta),
	      class = "family")
}

quasibinomial <- function (link = "logit")
{
    linktemp <- substitute(link)
    ## this is a function used in  glm();
    ## it holds everything personal to the family
    ## converts link into character string
    if (!is.character(linktemp)) {
	linktemp <- deparse(linktemp)
	if (linktemp == "link")
	    linktemp <- eval(link)
    }
    if (any(linktemp == c("logit", "probit", "cloglog", "log")))
	stats <- make.link(linktemp)
    else stop(paste(linktemp, "link not available for quasibinomial",
		    "family, available links are \"logit\", ",
		    "\"probit\" and \"cloglog\""))
    variance <- function(mu) mu * (1 - mu)
    validmu <- function(mu) all(mu>0) && all(mu<1)
    dev.resids <- function(y, mu, wt)
	2 * wt * (y * log(ifelse(y == 0, 1, y/mu)) +
		  (1 - y) * log(ifelse(y == 1, 1, (1 - y)/(1 - mu))))
    aic <- function(y, n, mu, wt, dev) NA
    initialize <- expression({
	if (NCOL(y) == 1) {
	    if (is.factor(y)) y <- y != levels(y)[1]
	    n <- rep.int(1, nobs)
	    if (any(y < 0 | y > 1))
		stop("y values must be 0 <= y <= 1")
            mustart <- (weights * y + 0.5)/(weights + 1)
	}
	else if (NCOL(y) == 2) {
	    n <- y[, 1] + y[, 2]
	    y <- ifelse(n == 0, 0, y[, 1]/n)
	    weights <- weights * n
            mustart <- (n * y + 0.5)/(n + 1)
	}
	else stop(paste("For the quasibinomial family, y must be",
			"a vector of 0 and 1\'s or a 2 column",
			"matrix where col 1 is no. successes",
			"and col 2 is no. failures"))
    })
    structure(list(family = "quasibinomial",
		   link = linktemp,
		   linkfun = stats$linkfun,
		   linkinv = stats$linkinv,
		   variance = variance,
		   dev.resids = dev.resids,
		   aic = aic,
		   mu.eta = stats$mu.eta,
		   initialize = initialize,
		   validmu = validmu,
		   valideta = stats$valideta),
	      class = "family")
}

Gamma <- function (link = "inverse")
{
    linktemp <- substitute(link)
    ## This is a function used in  glm();
    ## it holds everything personal to the family
    ## converts link into character string
    if (!is.character(linktemp)) {
	linktemp <- deparse(linktemp)
	if (linktemp == "link")
	    linktemp <- eval(link)
    }
    if (any(linktemp == c("inverse", "log", "identity")))
	stats <- make.link(linktemp)
    else stop(paste(linktemp, "link not available for gamma",
		    "family, available links are \"inverse\", ",
		    "\"log\" and \"identity\""))
    variance <- function(mu) mu^2
    validmu <- function(mu) all(mu>0)
    dev.resids <- function(y, mu, wt)
	-2 * wt * (log(ifelse(y == 0, 1, y/mu)) - (y - mu)/mu)
    aic <- function(y, n, mu, wt, dev){
	n <- sum(wt)
	disp <- dev/n
#	2*((sum(wt*(y/mu+log(mu)-log(y)))+n*log(disp))/disp+
#	   n*lgamma(1/disp)+sum(log(y)*wt)+1)
	-2*sum(dgamma(y, 1/disp, scale=mu*disp, log=TRUE)*wt) + 2
    }
    initialize <- expression({
	if (any(y <= 0))
	    stop(paste("Non-positive values not",
		       "allowed for the gamma family"))
	n <- rep.int(1, nobs)
	mustart <- y
    })
    structure(list(family = "Gamma",
		   link = linktemp,
		   linkfun = stats$linkfun,
		   linkinv = stats$linkinv,
		   variance = variance,
		   dev.resids = dev.resids,
		   aic = aic,
		   mu.eta = stats$mu.eta,
		   initialize = initialize,
		   validmu = validmu,
		   valideta = stats$valideta),
	      class = "family")
}

inverse.gaussian <- function(link = "1/mu^2")
{
    linktemp <- substitute(link)
    ## This is a function used in  glm();
    ## it holds everything personal to the family
    ## converts link into character string
    if (!is.character(linktemp)) {
	linktemp <- deparse(linktemp)
	if (linktemp == "link")
	    linktemp <- eval(link)
    }
    if (any(linktemp == c("inverse", "log", "identity", "1/mu^2")))
	stats <- make.link(linktemp)
    else stop(paste(linktemp, "link not available for inverse gauss",
		    "family, available links are \"inverse\", ",
		    "\"1/mu^2\" \"log\" and \"identity\""))
    ##	stats <- make.link("1/mu^2")
    variance <- function(mu) mu^3
    dev.resids <- function(y, mu, wt)  wt*((y - mu)^2)/(y*mu^2)
    aic <- function(y, n, mu, wt, dev)
	sum(wt)*(log(dev/sum(wt)*2*pi)+1)+3*sum(log(y)*wt)+2
    initialize <- expression({
	if(any(y <= 0))
	    stop(paste("Positive values only allowed for",
		       "the inverse.gaussian family"))
	n <- rep.int(1, nobs)
	mustart <- y
    })
    validmu <- function(mu) TRUE

    structure(list(family = "inverse.gaussian",
		   link = "1/mu^2",
		   linkfun = stats$linkfun,
		   linkinv = stats$linkinv,
		   variance = variance,
		   dev.resids = dev.resids,
		   aic = aic,
		   mu.eta = stats$mu.eta,
		   initialize = initialize,
		   validmu = validmu,
		   valideta = stats$valideta),
	      class = "family")
}

quasi <- function (link = "identity", variance = "constant")
{
    linktemp <- substitute(link)
    ##this is a function used in  glm()
    ##it holds everything personal to the family
    ##converts link into character string
    if ( is.expression(linktemp) || is.call(linktemp) )
        linktemp <- link
    else if (!is.character(linktemp))
        linktemp <- deparse(linktemp)
    if( is.character(linktemp) )
        stats <- make.link(linktemp)
    else
        stats <- linktemp
    ##converts variance into character string
    variancetemp <- substitute(variance)
    if (!is.character(variancetemp)) {
	variancetemp <- deparse(variancetemp)
	if (linktemp == "variance")
	    variancetemp <- eval(variance)
    }
    switch(variancetemp,
	   "constant" = {
	       variance <- function(mu) rep.int(1, length(mu))
	       dev.resids <- function(y, mu, wt) wt * ((y - mu)^2)
	       validmu <- function(mu) TRUE
	   },
	   "mu(1-mu)" = {
	       variance <- function(mu) mu * (1 - mu)
	       validmu <- function(mu) all(mu>0) && all(mu<1)
	       dev.resids <- function(y, mu, wt)
		   2 * wt * (y * log(ifelse(y == 0, 1, y/mu)) +
			     (1 - y) * log(ifelse(y == 1, 1, (1 - y)/(1 - mu))))
	   },
	   "mu" = {
	       variance <- function(mu) mu
	       validmu <- function(mu) all(mu>0)
	       dev.resids <- function(y, mu, wt)
		   2 * wt * (y * log(ifelse(y == 0, 1, y/mu)) - (y - mu))
	   },
	   "mu^2" = {
	       variance <- function(mu) mu^2
	       validmu <- function(mu) all(mu>0)
	       dev.resids <- function(y, mu, wt)
		   pmax(-2 * wt * (log(ifelse(y == 0, 1, y)/mu) - (y - mu)/mu), 0)
	   },
	   "mu^3" = {
	       variance <- function(mu) mu^3
	       validmu <- function(mu) all(mu>0)
	       dev.resids <- function(y, mu, wt)
		   wt * ((y - mu)^2)/(y * mu^2)
	   },
	   stop(paste(variancetemp, "not recognised, possible variances",
		      'are "mu(1-mu)", "mu", "mu^2", "mu^3" and "constant"'))
	   )# end switch(.)
# 0.1 fudge here matches poisson: S has 1/6.
    initialize <- expression({ n <- rep.int(1, nobs); mustart <- y + 0.1 *(y == 0)})
    aic <- function(y, n, mu, wt, dev) NA
    structure(list(family = "quasi",
		   link = linktemp,
		   linkfun = stats$linkfun,
		   linkinv = stats$linkinv,
		   variance = variance,
		   dev.resids = dev.resids,
		   aic = aic,
		   mu.eta = stats$mu.eta,
		   initialize = initialize,
		   validmu = validmu,
		   valideta = stats$valideta,
                   ## character form of the var fun is needed for gee
                   varfun = variancetemp),
	      class = "family")
}
fft <- function(z, inverse=FALSE)
    .Internal(fft(z, inverse))

mvfft <- function(z, inverse=FALSE)
    .Internal(mvfft(z, inverse))

nextn <- function(n, factors=c(2,3,5))
    .Internal(nextn(n, factors))

convolve <- function(x, y, conj=TRUE, type=c("circular","open","filter")) {
    type <- match.arg(type)
    n <- length(x)
    ny <- length(y)
    Real <- is.numeric(x) && is.numeric(y)
    ## switch(type, circular = ..., )
    if(type == "circular") {
        if(ny != n)
            stop("length mismatch in convolution")
    }
    else { ## "open" or "filter": Pad with zeros
        n1 <- ny - 1
        x <- c(rep.int(0, n1), x)
        n <- length(y <- c(y, rep.int(0, n - 1)))# n = nx+ny-1
    }
    x <- fft(fft(x)* (if(conj)Conj(fft(y)) else fft(y)), inv=TRUE)
    if(type == "filter")
        (if(Real) Re(x) else x)[-c(1:n1, (n-n1+1):n)]/n
    else
        (if(Real) Re(x) else x)/n
}

#Platform <- function()
#.Internal(Platform())

R.home <- function()
.Internal(R.home())

file.show <-
function (..., header=rep("", nfiles), title="R Information",
          delete.file=FALSE, pager=getOption("pager"))
{
    file <- c(...)
    nfiles <- length(file)
    if(nfiles == 0)
        return(invisible(NULL))
    if(is.function(pager))
	pager(file, header, title, delete.file)
    else
        .Internal(file.show(file, header, title, delete.file, pager))
}

file.append <- function(file1, file2)
.Internal(file.append(file1, file2))

file.remove <- function(...)
.Internal(file.remove(c(...)))

file.rename <- function(from, to)
.Internal(file.rename(from, to))

list.files <- function(path=".", pattern=NULL, all.files=FALSE,
                       full.names=FALSE, recursive=FALSE)
.Internal(list.files(path, pattern, all.files, full.names, recursive))

dir <- list.files

file.path <-
function(..., fsep=.Platform$file.sep)
{
    if(any(sapply(list(...), length) == 0)) return(character())
    paste(..., sep = fsep)
}


file.exists <- function(...)
.Internal(file.exists(c(...)))

file.create <- function(...)
.Internal(file.create(c(...)))

file.choose <- function(new=FALSE)
.Internal(file.choose(new))

file.copy <- function(from, to, overwrite=FALSE)
{
    if (!(nf <- length(from))) stop("no files to copy from")
    if (!(nt <- length(to)))   stop("no files to copy to")
    if (nt == 1 && file.exists(to) && file.info(to)$isdir)
        to <- file.path(to, basename(from))
    else if (nf > nt) stop("more 'from' files than 'to' files")
    if(nt > nf) from <- rep(from, length = nt)
    if (!overwrite) okay <- !file.exists(to)
    else okay <- rep(TRUE, length(to))
    if (any(from[okay] %in% to[okay]))
        stop("file can't be copied both from and to")
    if (any(okay)) { 
    	file.create(to[okay])
    	okay[okay] <- file.append(to[okay], from[okay])
    }
    okay
}

file.symlink <- function(from, to) {
    if (!(length(from))) stop("no files to link from")
    if (!(nt <- length(to)))   stop("no files/dir to link to")
    if (nt == 1 && file.exists(to) && file.info(to)$isdir)
        to <- file.path(to, basename(from))
    .Internal(file.symlink(from, to))
}

file.info <- function(...)
{
    res <- .Internal(file.info(fn <- c(...)))
    class(res$mtime) <- class(res$ctime) <- class(res$atime) <-
        c("POSIXt", "POSIXct")
    class(res) <- "data.frame"
    row.names(res) <- fn
    res
}

file.access <- function(names, mode = 0)
{
    res <- .Internal(file.access(names, mode))
    names(res) <- names
    res
}

format.octmode <- function(x, ...)
{
    if(!inherits(x, "octmode")) stop("calling wrong method")
    isna <- is.na(x)
    y <- x[!isna]
    ans0 <- character(length(y))
    z <- NULL
    while(any(y > 0) || is.null(z)) {
        z <- y%%8
        y <- floor(y/8)
        ans0 <- paste(z, ans0, sep="")
    }
    ans <- rep(as.character(NA), length(x))
    ans[!isna] <- ans0
    ans
}
as.character.octmode <- format.octmode

print.octmode <- function(x, ...)
{
    print(format(x), ...)
    invisible(x)
}

system.file <-
function(..., package = "base", lib.loc = NULL)
{
    if(nargs() == 0)
        return(file.path(.Library, "base"))
    if(length(package) != 1)
        stop(paste("argument", sQuote("package"), "must be of length 1"))
    packagePath <- .find.package(package, lib.loc, quiet = TRUE)
    if(length(packagePath) == 0)
        return("")
    FILES <- file.path(packagePath, ...)
    present <- file.exists(FILES)
    if(any(present))
        FILES[present]
    else ""
}

getwd <- function()
    .Internal(getwd())
setwd <- function(dir)
    .Internal(setwd(dir))
basename <- function(path)
    .Internal(basename(path))
dirname <- function(path)
    .Internal(dirname(path))

Sys.info <- function()
    .Internal(Sys.info())

Sys.sleep <- function(time)
    invisible(.Internal(Sys.sleep(time)))

path.expand <- function(path)
    .Internal(path.expand(path))
filled.contour <-
function (x = seq(0, 1, len = nrow(z)),
          y = seq(0, 1, len = ncol(z)),
          z,
          xlim = range(x, finite=TRUE),
          ylim = range(y, finite=TRUE),
          zlim = range(z, finite=TRUE),
          levels = pretty(zlim, nlevels), nlevels = 20,
          color.palette = cm.colors,
          col = color.palette(length(levels) - 1),
          plot.title, plot.axes, key.title, key.axes,
          asp = NA, xaxs="i", yaxs="i", las = 1, axes = TRUE,
          frame.plot = axes, ...)
{
    if (missing(z)) {
        if (!missing(x)) {
            if (is.list(x)) {
                z <- x$z
                y <- x$y
                x <- x$x
            }
            else {
                z <- x
                x <- seq(0, 1, len = nrow(z))
            }
        }
        else stop("no `z' matrix specified")
    }
    else if (is.list(x)) {
        y <- x$y
        x <- x$x
    }
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
        stop("increasing x and y values expected")

    mar.orig <- (par.orig <- par(c("mar","las","mfrow")))$mar
    on.exit(par(par.orig))

    w <- (3 + mar.orig[2]) * par('csi') * 2.54
    layout(matrix(c(2, 1), nc=2), widths=c(1, lcm(w)))
    par(las = las)

    ## Plot the `plot key' (scale):
    mar <- mar.orig
    mar[4] <- mar[2]
    mar[2] <- 1
    par(mar = mar)
    plot.new()
    plot.window(xlim=c(0,1), ylim=range(levels), xaxs="i", yaxs="i")
    rect(0, levels[-length(levels)], 1, levels[-1], col = col)
    if (missing(key.axes)) {
        if (axes)
            axis(4)
    }
    else key.axes
    box()
    if (!missing(key.title))
	key.title

    ## Plot contour-image::
    mar <- mar.orig
    mar[4] <- 1
    par(mar=mar)
    plot.new()
    plot.window(xlim, ylim, "", xaxs=xaxs, yaxs=yaxs, asp=asp)

    if (!is.matrix(z) || nrow(z) <= 1 || ncol(z) <= 1)
        stop("no proper `z' matrix specified")
    if (!is.double(z))
        storage.mode(z) <- "double"
    .Internal(filledcontour(as.double(x),
                            as.double(y),
                            z,
                            as.double(levels),
                            col = col))
    if (missing(plot.axes)) {
        if (axes) {
            title(main="", xlab="", ylab="")
            axis(1)
            axis(2)
        }
    }
    else plot.axes
    if (frame.plot) box()
    if (missing(plot.title))
        title(...)
    else
	plot.title
    invisible()
}
fivenum <- function(x, na.rm=TRUE)
{
    xna <- is.na(x)
    if(na.rm) x <- x[!xna]
    else if(any(xna)) return(rep.int(NA,5))
    x <- sort(x)
    n <- length(x)
    if(n == 0) rep.int(NA,5)
    else {
	d <- c(1, 0.5*floor(0.5*(n+3)), 0.5*(n+1),
	       n+1-0.5*floor(0.5*(n+3)), n)
	0.5*(x[floor(d)]+x[ceiling(d)])
    }
}
"fix" <-
    function (x, ...)
{
    subx <- substitute(x)
    if (is.name(subx))
        subx <- deparse(subx)
    if (!is.character(subx) || length(subx) != 1)
        stop("fix requires a name")
    parent <- parent.frame()
    if (exists(subx, envir=parent, inherits = TRUE))
        x <- edit(get(subx, envir=parent), ...)
    else {
        x <- edit(function(){},...)
        environment(x) <- .GlobalEnv
    }
    assign(subx, x, env = .GlobalEnv)
}

formals <- function(fun = sys.function(sys.parent())) {
    if(is.character(fun))
	fun <- get(fun, mode = "function", envir = parent.frame())
    .Internal(formals(fun))
}

body <- function(fun = sys.function(sys.parent())) {
    if(is.character(fun))
	fun <- get(fun, mode = "function", envir = parent.frame())
    .Internal(body(fun))
}

alist <- function (...) as.list(sys.call())[-1]

"body<-" <- function (fun, envir = parent.frame(), value) {
    if (is.expression(value)) value <- value[[1]]
    as.function(c(formals(fun), value), envir)
}

"formals<-" <- function (fun, envir = parent.frame(), value)
    as.function(c(value, body(fun)), envir)

format <- function(x, ...) UseMethod("format")

###	 -----
###----- FIXME ----- the digits handling should rather happen in
###	 -----	     in .Internal(format(...))	in ../../../main/paste.c !
### also the 'names' should be kept dealt with there (dim, dimnames *are*) !
###
### The new (1.2) switch "character" would be faster in .Internal()
### combine with "width = ", and format.char() below!

format.default <-
    function(x, trim = FALSE, digits = NULL, nsmall = 0,
             justify = c("left", "right", "none"),
             big.mark = "", big.interval = 3,
             small.mark = "", small.interval = 5, decimal.mark = ".",
             ...)
{
    f.char <- function(x, justify) {
	if(length(x) <= 1) return(x)
	nc <- nchar(x)
        nc[is.na(nc)] <- 2
	w <- max(nc)
	sp <- substring(paste(rep.int(" ", w), collapse=""), 1, w-nc)
	res <-
	    if(justify == "left") paste(x, sp, sep="") else paste(sp, x, sep="")
	attributes(res) <- attributes(x) ## at least names, dim, dimnames
	res
    }
    if(!is.null(digits)) {
	op <- options(digits=digits)
	on.exit(options(op))
    }
    justify <- match.arg(justify)
    switch(mode(x),
	   NULL = "NULL",
	   character = switch(justify,
                              none = x,
                  	      left = f.char(x, "left"),
                              right= f.char(x, "right")),
	   list = sapply(lapply(x, function(x)
				.Internal(format(unlist(x), trim=trim))),
			 paste, collapse=", "),
	   call=, expression=, "function"=, "(" = deparse(x),
	   ## else: numeric, complex, .. :
	   { r <- prettyNum(.Internal(format(x, trim = trim, small=nsmall)),
                            big.mark = big.mark, big.interval = big.interval,
                            small.mark = small.mark,
                            small.interval = small.interval,
                            decimal.mark = decimal.mark)
             if(!is.null(a <- attributes(x)) &&
                !is.null(a <- a[names(a) != "class"]))
                 attributes(r) <- a
             r })
}
## NOTE: Currently need non-default format.dist() -> ../../mva/R/dist.R


## MM: This should also happen in C(.) :
##	.Internal(format(..) should work  with	'width =' and 'flag=.."
##		at least for the case of character arguments.
## Note that format.default now has a `justify' argument
format.char <- function(x, width = NULL, flag = "-")
{
    ## Character formatting, flag: if "-" LEFT-justify
    if (is.null(x)) return("")
    if(!is.character(x)) {
	warning("format.char: coercing 'x' to 'character'")
	x <- as.character(x)
    }
    if(is.null(width) && flag == "-")
	return(format(x))		# Left justified; width= max.width

    at <- attributes(x)
    nc <- nchar(x)			#-- string lengths
    nc[is.na(nc)] <- 2
    if(is.null(width)) width <- max(nc)
    else if(width<0) { flag <- "-"; width <- -width }
    ##- 0.90.1 and earlier:
    ##- pad <- sapply(pmax(0,width - nc),
    ##-			function(no) paste(character(no+1), collapse =" "))
    ## Speedup by Jens Oehlschlaegel:
    tab <- unique(no <- pmax(0, width - nc))
    tabpad <- sapply(tab+1, function(n) paste(character(n), collapse = " "))
    pad <- tabpad[match(no, tab)]

    r <-
	if(flag=="-")	paste(x, pad, sep="")#-- LEFT  justified
	else		paste(pad, x, sep="")#-- RIGHT justified
    if(!is.null(at))
	attributes(r) <- at
    r
}


format.pval <- function(pv, digits = max(1, getOption("digits")-2),
			eps = .Machine$double.eps, na.form = "NA")
{
    ## Format  P values; auxiliary for print.summary.[g]lm(.)

    if((has.na <- any(ina <- is.na(pv)))) pv <- pv[!ina]
    ## Better than '0.0' for very small values `is0':
    r <- character(length(is0 <- pv < eps))
    if(any(!is0)) {
	rr <- pv <- pv[!is0]
	## be smart -- differ for fixp. and expon. display:
	expo <- floor(log10(pv))
	fixp <- expo >= -3 | (expo == -4 & digits>1)
	if(any( fixp)) rr[ fixp] <- format(pv[ fixp], dig=digits)
	if(any(!fixp)) rr[!fixp] <- format(pv[!fixp], dig=digits)
	r[!is0]<- rr
    }
    if(any(is0)) {
	digits <- max(1,digits-2)
	if(any(!is0)) {
	    nc <- max(nchar(rr))
	    if(digits > 1 && digits+6 > nc)
		digits <- max(1, nc - 7)
	    sep <- if(digits==1 && nc <= 6) "" else " "
	} else sep <- if(digits==1) "" else " "
	r[is0] <- paste("<", format(eps, digits=digits), sep = sep)
    }
    if(has.na) { ## rarely...
	rok <- r
	r <- character(length(ina))
	r[!ina] <- rok
	r[ina] <- na.form
    }
    r
}

## Martin Maechler <maechler@stat.math.ethz.ch> , 1994-1998 :
formatC <- function (x, digits = NULL, width = NULL,
		     format = NULL, flag = "", mode = NULL,
                     big.mark = "", big.interval = 3,
                     small.mark = "", small.interval = 5,
                     decimal.mark = ".")
{
    blank.chars <- function(no)
	sapply(no+1, function(n) paste(character(n), collapse=" "))

    if (!(n <- length(x))) return("")
    if (is.null(mode))	  mode <- storage.mode(x)
    else if (any(mode == c("double", "real", "integer")))  {
      ## for .C call later on
	if(mode=="real") mode <- "double"
	storage.mode(x) <- mode
    }
    else stop("\"mode\" must be \"double\" (\"real\") or \"integer\"")
    if (mode == "character" || (!is.null(format) && format == "s")) {
	if (mode != "character") {
	    warning('formatC: Coercing argument to "character" for format="s"')
	    x <- as.character(x)
	}
	return(format.char(x, width=width, flag=flag))
    }
    if (missing(format) || is.null(format))
	format <- if (mode == "integer") "d" else "g"
    else {
	if (any(format == c("f", "e", "E", "g", "G", "fg"))) {
	    if (mode == "integer") mode <- storage.mode(x) <- "double"
	}
	else if (format == "d") {
	    if (mode != "integer") mode <- storage.mode(x) <- "integer"
	}
	else stop('"format" must be in {"f","e","E","g","G", "fg", "s"}')
    }
    some.special <- !all(Ok <- is.finite(x))
    if (some.special) {
	rQ <- as.character(x[!Ok])
	x[!Ok] <- as.vector(0, mode = mode)
    }
    if(is.null(width) && is.null(digits))
	width <- 1
    if (is.null(digits))
	digits <- if (mode == "integer") 2 else 4
    else if(digits < 0)
	digits <- 6
    if(is.null(width))	width <- digits + 1
    else if (width == 0)width <- digits
    i.strlen <-
	pmax(abs(width),
	     if(format == "fg"||format == "f") {
		 xEx <- as.integer(floor(log10(abs(x+ifelse(x==0,1,0)))))
		 as.integer(x < 0 | flag!="") + digits +
		     if(format == "f") {
			 2 + pmax(xEx,0)
		     } else {# format == "fg"
			 pmax(xEx, digits,digits+(-xEx)+1) +
			     ifelse(flag!="",nchar(flag),0) + 1
		     }
	     } else # format == "g" or "e":
	     rep.int(digits+8, n)
	     )
    r <- .C("str_signif",
	    x = x,
	    n = n,
	    mode   = as.character(mode),
	    width  = as.integer(width),
	    digits = as.integer(digits),
	    format = as.character(format),
	    flag   = as.character(flag),
	    result = blank.chars(i.strlen),
	    PACKAGE = "base")$result
    if (some.special)
	r[!Ok] <- format.char(rQ, width=width, flag=flag)

    if(big.mark != "" || small.mark != "" || decimal.mark != ".")
        r <- prettyNum(r, big.mark = big.mark, big.interval = big.interval,
                       small.mark = small.mark, small.interval = small.interval,
                       decimal.mark = decimal.mark)

    if (!is.null(x.atr <- attributes(x)))
	attributes(r) <- x.atr
    r
}

format.factor <- function(x, ...)
    format(as.character(x), ...)

format.data.frame <- function(x, ..., justify = "none")
{
    dims <- dim(x)
    nr <- dims[1]
    nc <- dims[2]
    rval <- vector("list", nc)
    for(i in 1:nc)
	rval[[i]] <- format(x[[i]], ..., justify = justify)
    lens <- sapply(rval, NROW)
    if(any(lens != nr)) { # corrupt data frame, must have at least one column
        warning("corrupt data frame: columns will be truncated or padded with NAs")
        for(i in 1:nc) {
            len <- NROW(rval[[i]])
            if(len == nr) next
            if(length(dim(rval[[i]])) == 2) {
                rval[[i]] <- if(len < nr)
                    rbind(rval[[i]], matrix(NA, nr-len, ncol(rval[[i]])))
                else rval[[i]][1:nr,]
            } else {
                rval[[i]] <- if(len < nr) c(rval[[i]], rep(NA, nr-len))
                else rval[[i]][1:nr]
            }
        }
    }
    dn <- dimnames(x)
    cn <- dn[[2]]
    m <- match(c("row.names", "check.rows", "check.names"), cn, 0)
    if(any(m > 0)) cn[m] <- paste("..dfd.", cn[m], sep="")
    names(rval) <- cn
    rval$check.names <- FALSE
    rval$row.names <- dn[[1]]
    x <- do.call("data.frame", rval)
    ## x will have more cols than rval if there are matrix/data.frame cols
    if(any(m > 0)) names(x) <- sub("^..dfd.", "", names(x))
    x
}

format.AsIs <- function(x, width = 12, ...)
{
    if(is.character(x)) return(format.default(x, ...))
    n <- length(x)
    rvec <- rep.int(as.character(NA), n)
    for(i in 1:n)
	rvec[i] <- toString(x[[i]], width, ...)
#    return(format.char(rvec, flag = "+"))
    ## AsIs might be around a matrix, which is not a class.
    dim(rvec) <- dim(x)
    format.default(rvec, justify = "right")
}

prettyNum <-
    function(x,
             big.mark = "", big.interval = 3,
             small.mark = "", small.interval = 5,
             decimal.mark = ".", ...)
{
    ## be fast in trivial case:
    if(!is.character(x))
        x <- sapply(x,format, ...)
    if(big.mark == "" && small.mark == "" && decimal.mark == ".")
        return(x)
    ## else
    x.sp <- strsplit(x, "\\.")
    P0 <- function(...) paste(..., sep="")
    revStr <- function(cc)
        sapply(lapply(strsplit(cc,NULL), rev), paste, collapse="")
    B. <- sapply(x.sp, "[", 1)      # Before "."
    A. <- sapply(x.sp, "[", 2)      # After  "." ; empty == NA
    if(any(iN <- is.na(A.))) A.[iN] <- ""
    if(nchar(big.mark) &&
       length(i.big <- grep(P0("[0-9]{", big.interval + 1,",}"), B.))
       ) { ## add `big.mark' in decimals before "." :
        B.[i.big] <-
            revStr(gsub(P0("([0-9]{",big.interval,"})\\B"),
                        P0("\\1",big.mark), revStr(B.[i.big])))
    }
    if(nchar(small.mark) &&
       length(i.sml <- grep(P0("[0-9]{", small.interval + 1,",}"), A.))
       ) { ## add `small.mark' in decimals after "." :
        A.[i.sml] <- gsub(P0("([0-9]{",small.interval,"})"),
                          P0("\\1",small.mark), A.[i.sml])
    }
    ## extraneous trailing dec.marks: paste(B., A., sep = decimal.mark)
    P0(B., c(decimal.mark, "")[iN+ 1:1], A.)
}
fourfoldplot <-
function(x, color = c("#99CCFF", "#6699CC"), conf.level = 0.95,
         std = c("margins", "ind.max", "all.max"), margin = c(1, 2),
         space = 0.2, main = NULL, mfrow = NULL, mfcol = NULL)
{
    ## Code for producing fourfold displays.
    ## Reference:
    ##   Friendly, M. (1994).
    ##   A fourfold display for 2 by 2 by \eqn{k} tables.
    ##   Technical Report 217, York University, Psychology Department.
    ##   http://www.math.yorku.ca/SCS/Papers/4fold/4fold.ps.gz
    ##
    ## Implementation notes:
    ##
    ##   We need plots with aspect ratio FIXED to 1 and glued together.
    ##   Hence, even if k > 1 we prefer keeping everything in one plot
    ##   region rather than using a multiple figure layout.
    ##   Each 2 by 2 pie is is drawn into a square with x/y coordinates
    ##   between -1 and 1, with row and column labels in [-1-space, -1]
    ##   and [1, 1+space], respectively.  If k > 1, strata labels are in
    ##   an area with y coordinates in [1+space, 1+(1+gamma)*space],
    ##   where currently gamma=1.25.  The pies are arranged in an nr by
    ##   nc layout, with horizontal and vertical distances between them
    ##   set to space.
    ##
    ##   The drawing code first computes the complete are of the form
    ##     [0, totalWidth] x [0, totalHeight]
    ##   needed and sets the world coordinates using plot.window().
    ##   Then, the strata are looped over, and the corresponding pies
    ##   added by filling rows or columns of the layout as specified by
    ##   the mfrow or mfcol arguments.  The world coordinates are reset
    ##   in each step by shifting the origin so that we can always plot
    ##   as detailed above.

    if(!is.array(x))
        stop("x must be an array")
    if(length(dim(x)) == 2) {
        x <- if(is.null(dimnames(x)))
            array(x, c(dim(x), 1))
        else
            array(x, c(dim(x), 1), c(dimnames(x), list(NULL)))
    }
    if(length(dim(x)) != 3)
        stop("x must be 2- or 3-dimensional")
    if(any(dim(x)[1:2] != 2))
        stop("table for each stratum must be 2 by 2")
    dnx <- dimnames(x)
    if(is.null(dnx))
        dnx <- vector("list", 3)
    for(i in which(sapply(dnx, is.null)))
        dnx[[i]] <- LETTERS[seq(length = dim(x)[i])]
    if(is.null(names(dnx)))
        i <- 1 : 3
    else
        i <- which(is.null(names(dnx)))
    if(any(i))
        names(dnx)[i] <- c("Row", "Col", "Strata")[i]
    dimnames(x) <- dnx
    k <- dim(x)[3]

    if(!((length(conf.level) == 1) && is.finite(conf.level) &&
         (conf.level >= 0) && (conf.level < 1)))
        stop("conf.level must be a single number between 0 and 1")
    if(conf.level == 0)
        conf.level <- FALSE

    std <- match.arg(std)

    findTableWithOAM <- function(or, tab) {
        ## Find a 2x2 table with given odds ratio 'or' and the margins
        ## of a given 2x2 table 'tab'.
        m <- rowSums(tab)[1]
        n <- rowSums(tab)[2]
        t <- colSums(tab)[1]
        if(or == 1)
            x <- t * n / (m + n)
        else if(or == Inf)
            x <- max(0, t - m)
        else {
            A <- or - 1
            B <- or * (m - t) + (n + t)
            C <- - t * n
            x <- (- B + sqrt(B ^ 2 - 4 * A * C)) / (2 * A)
        }
        matrix(c(t - x, x, m - t + x, n - x), nr = 2)
    }

    drawPie <- function(r, from, to, n = 500, color = NA) {
        p <- 2 * pi * seq(from, to, length = n) / 360
        x <- c(cos(p), 0) * r
        y <- c(sin(p), 0) * r
        polygon(x, y, col = color)
        invisible(NULL)
    }

    stdize <- function(tab, std, x) {
        ## Standardize the 2 x 2 table 'tab'.
        if(std == "margins") {
            if(all(sort(margin) == c(1, 2))) {
                ## standardize to equal row and col margins
                u <- sqrt(odds(tab)$or)
                u <- u / (1 + u)
                y <- matrix(c(u, 1 - u, 1 - u, u), nr = 2)
            }
            else if(margin %in% c(1, 2))
                y <- prop.table(tab, margin)
            else
                stop("incorrect margin specification")
        }
        else if(std == "ind.max")
            y <- tab / max(tab)
        else if(std == "all.max")
            y <- tab / max(x)
        y
    }

    odds <- function(x) {
        ## Given a 2 x 2 or 2 x 2 x k table 'x', return a list with
        ## components 'or' and 'se' giving the odds ratios and standard
        ## deviations of the log odds ratios.
        if(length(dim(x)) == 2) {
            dim(x) <- c(dim(x), 1)
            k <- 1
        }
        else
            k <- dim(x)[3]
        or <- double(k)
        se <- double(k)
        for(i in 1 : k) {
            f <- x[ , , i]
            if(any(f == 0))
                f <- f + 0.5
            or[i] <- (f[1, 1] * f[2, 2]) / (f[1, 2] * f[2, 1])
            se[i] <- sqrt(sum(1 / f))
        }
        list(or = or, se = se)
    }

    gamma <- 1.25                       # Scale factor for strata labels
    debug <- FALSE                      # Visualize the geometry.
                                        # Not settable by user!
    angle.f <- c( 90, 180,  0, 270)     # 'f' for 'from'
    angle.t <- c(180, 270, 90, 360)     # 't' for 'to'

    opar <- par(mar = c(0, 0, ifelse(is.null(main), 0, 2.5), 0))
    on.exit(par(opar))

    byrow <- FALSE
    if(!is.null(mfrow)) {
        nr <- mfrow[1]
        nc <- mfrow[2]
    }
    else if(!is.null(mfcol)) {
        nr <- mfcol[1]
        nc <- mfcol[2]
        byrow <- TRUE
    }
    else {
        nr <- ceiling(sqrt(k))
        nc <- ceiling(k / nr)
    }
    if(nr * nc < k)
        stop("incorrect geometry specification")
    if(byrow)
        indexMatrix <- expand.grid(1 : nc, 1 : nr)[, c(2, 1)]
    else
        indexMatrix <- expand.grid(1 : nr, 1 : nc)

    totalWidth <- nc * 2 * (1 + space) + (nc - 1) * space
    totalHeight <- if(k == 1)
        2 * (1 + space)
    else
        nr * (2 + (2 + gamma) * space) + (nr - 1) * space
    xlim <- c(0, totalWidth)
    ylim <- c(0, totalHeight)

    plot.new()
    plot.window(xlim = xlim, ylim = ylim, asp = 1)

    o <- odds(x)

    scale <- space / (2 * strheight("Ag"))
    v <- 0.95 - max(strwidth(as.character(c(x)), cex = scale)) / 2

    for(i in 1 : k) {

        tab <- x[ , , i]

        fit <- stdize(tab, std, x)

        xInd <- indexMatrix[i, 2]
        xOrig <- 2 * xInd - 1 + (3 * xInd - 2) * space
        yInd <- indexMatrix[i, 1]
        yOrig <- if(k == 1)
            (1 + space)
        else
            (totalHeight
             - (2 * yInd - 1 + ((3 + gamma) * yInd - 2) * space))
        plot.window(xlim - xOrig, ylim - yOrig, asp = 1)

        if(debug) {
            abline(h = -1 - space)
            abline(h =  1 + space)
            abline(h =  1 + (1 + gamma) * space)
            abline(v = -1 - space)
            abline(v =  1 + space)
        }

        ## drawLabels()
        u <- 1 + space / 2
        adjCorr <- 0.2
        text(0, u,
             paste(names(dimnames(x))[1],
                   dimnames(x)[[1]][1],
                   sep = ": "),
             adj = c(0.5, 0.5 - adjCorr),
             cex = scale)
        text(-u, 0,
             paste(names(dimnames(x))[2],
                   dimnames(x)[[2]][1],
                   sep = ": "),
             adj = c(0.5, 0.5 - adjCorr),
             cex = scale,
             srt = 90)
        text(0, -u,
             paste(names(dimnames(x))[1],
                   dimnames(x)[[1]][2],
                   sep = ": "),
             adj = c(0.5, 0.5 + adjCorr),
             cex = scale)
        text(u, 0,
             paste(names(dimnames(x))[2],
                   dimnames(x)[[2]][2],
                   sep = ": "),
             adj = c(0.5, 0.5 + adjCorr),
             cex = scale,
             srt = 90)
        if(k > 1) {
            text(0, 1 + (1 + gamma / 2) * space,
                 paste(names(dimnames(x))[3],
                       dimnames(x)[[3]][i],
                       sep = ": "),
                 cex = gamma * scale)
        }

        ## drawFrequencies()
        d <- odds(tab)$or
        drawPie(sqrt(fit[1,1]),  90, 180, col = color[1 + (d > 1)])
        drawPie(sqrt(fit[2,1]), 180, 270, col = color[2 - (d > 1)])
        drawPie(sqrt(fit[1,2]),   0,  90, col = color[2 - (d > 1)])
        drawPie(sqrt(fit[2,2]), 270, 360, col = color[1 + (d > 1)])
        u <- 1 - space / 2
        text(c(-v, -v,  v,  v),
             c( u, -u,  u, -u),
             as.character(c(tab)),
             cex = scale)

        ## drawConfBands()
        if(is.numeric(conf.level)) {
            or <- o$or[i]
            se <- o$se[i]
            ## lower
            theta <- or * exp(qnorm((1 - conf.level) / 2) * se)
            tau <- findTableWithOAM(theta, tab)
            r <- sqrt(c(stdize(tau, std, x)))
            for(j in 1 : 4)
                drawPie(r[j], angle.f[j], angle.t[j])
            ## upper
            theta <- or * exp(qnorm((1 + conf.level) / 2) * se)
            tau <- findTableWithOAM(theta, tab)
            r <- sqrt(c(stdize(tau, std, x)))
            for(j in 1 : 4)
                drawPie(r[j], angle.f[j], angle.t[j])
        }

        ## drawBoxes()
        polygon(c(-1,  1, 1, -1),
                c(-1, -1, 1,  1))
        lines(c(-1, 1), c(0, 0))
        for(j in seq(from = -0.8, to = 0.8, by = 0.2))
            lines(c(j, j), c(-0.02, 0.02))
        for(j in seq(from = -0.9, to = 0.9, by = 0.2))
            lines(c(j, j), c(-0.01, 0.01))
        lines(c(0, 0), c(-1, 1))
        for(j in seq(from = -0.8, to = 0.8, by = 0.2))
            lines(c(-0.02, 0.02), c(j, j))
        for(j in seq(from = -0.9, to = 0.9, by = 0.2))
            lines(c(-0.01, 0.01), c(j, j))

    }

    if(!is.null(main))
        mtext(main, cex = 1.5, adj = 0.5)

    return(invisible())
}
subset.data.frame <-
    function (x, subset, select, ...)
{
    if(missing(subset))
	r <- TRUE
    else {
	e <- substitute(subset)
	r <- eval(e, x, parent.frame())
	r <- r & !is.na(r)
    }
    if(missing(select))
	vars <- TRUE
    else {
	nl <- as.list(1:ncol(x))
	names(nl) <- names(x)
	vars <- eval(substitute(select),nl, parent.frame())
    }
    x[r,vars,drop=FALSE]
}

subset<-
    function(x, ...)
    UseMethod("subset")

subset.default <-
    function(x, subset, ...)
    x[subset & !is.na(subset)]

transform.data.frame <-
    function (x, ...)
{
    e <- eval(substitute(list(...)), x, parent.frame())
    tags <- names(e)
    inx <- match(tags, names(x))
    matched <- !is.na(inx)
    if (any(matched)) {
	x[inx[matched]] <- e[matched]
	x <- data.frame(x)
    }
    if (!all(matched))
	data.frame(x, e[!matched])
    else x
}

transform <-
    function(x,...)
    UseMethod("transform")

## Actually, I have no idea what to transform(), except dataframes.
## The default converts its argument to a dataframe and transforms
## that. This is probably marginally useful at best. --pd
transform.default <-
    function(x,...)
    transform.data.frame(data.frame(x),...)

stack.data.frame <-
    function(x, select, ...)
{
    if (!missing(select)) {
	nl <- as.list(1:ncol(x))
	names(nl) <- names(x)
	vars <- eval(substitute(select),nl, parent.frame())
        x <- x[, vars, drop=FALSE]
    }
    x <- x[, unlist(lapply(x, is.vector)), drop = FALSE]
    data.frame(values = unlist(unname(x)),
               ind = factor(rep.int(names(x), lapply(x, length))))
}

stack <-
    function(x, ...)
    UseMethod("stack")

stack.default <-
    function(x, ...)
{
    x <- as.list(x)
    x <- x[unlist(lapply(x, is.vector))]
    data.frame(values = unlist(unname(x)),
               ind = factor(rep.int(names(x), lapply(x, length))))
}

unstack.data.frame <-
    function(x, form = formula(x), ...)
{
    form <- as.formula(form)
    if (length(form) < 3)
        stop("form must be a two-sided formula")
    res <- c(tapply(eval(form[[2]], x), eval(form[[3]], x), as.vector))
    if (length(res) < 2 || any(diff(unlist(lapply(res, length))) != 0))
        return(res)
    data.frame(res)
}

unstack <-
    function(x, ...)
    UseMethod("unstack")

unstack.default <-
    function(x, form, ...)
{
    x <- as.list(x)
    form <- as.formula(form)
    if (length(form) < 3)
        stop("form must be a two-sided formula")
    res <- c(tapply(eval(form[[2]], x), eval(form[[3]], x), as.vector))
    if (length(res) < 2 || any(diff(unlist(lapply(res, length))) != 0))
        return(res)
    data.frame(res)
}
ftable <- function(x, ...) UseMethod("ftable")

ftable.default <- function(..., exclude = c(NA, NaN),
                           row.vars = NULL, col.vars = NULL) {
    args <- list(...)
    if (length(args) == 0)
        stop("Nothing to tabulate")
    x <- args[[1]]
    if(is.list(x))
        x <- table(x, exclude = exclude)
    else if(inherits(x, "ftable")) {
        x <- as.table(x)
    }
    else if(!(is.array(x) && (length(dim(x)) > 1))) {
        x <- do.call("table",
                     c(as.list(substitute(list(...)))[-1],
                       list(exclude = exclude)))
    }
    dn <- dimnames(x)
    dx <- dim(x)
    n <- length(dx)
    if(!is.null(row.vars)) {
        if(is.character(row.vars)) {
            i <- pmatch(row.vars, names(dn))
            if(any(is.na(i)))
                stop(paste("incorrect specification for",
                           sQuote("row.vars")))
            row.vars <- i
        } else if(any((row.vars < 1) | (row.vars > n)))
            stop(paste("incorrect specification for",
                       sQuote("row.vars")))
    }
    if(!is.null(col.vars)) {
        if(is.character(col.vars)) {
            i <- pmatch(col.vars, names(dn))
            if(any(is.na(i)))
                stop(paste("incorrect specification for",
                           sQuote("col.vars")))
            col.vars <- i
        } else if(any((col.vars < 1) | (col.vars > n)))
            stop(paste("incorrect specification for",
                       sQuote("col.vars")))
    }
    i <- 1 : n
    if(!is.null(row.vars) && !is.null(col.vars)) {
        all.vars <- sort(c(row.vars, col.vars))
        if (length(all.vars) < n) {
            x <- apply(x, all.vars, sum)
            row.vars <- match(row.vars, all.vars)
            col.vars <- match(col.vars, all.vars)
            dn <- dn[all.vars]
            dx <- dx[all.vars]
        }
    }
    else if(!is.null(row.vars))
        col.vars <- i[-row.vars]
    else if(!is.null(col.vars))
        row.vars <- i[-col.vars]
    else {
        row.vars <- 1 : (n-1)
        col.vars <- n
    }

    y <- aperm(x, c(rev(row.vars), rev(col.vars)))
    dim(y) <- c(prod(dx[row.vars]), prod(dx[col.vars]))
    attr(y, "row.vars") <- dn[row.vars]
    attr(y, "col.vars") <- dn[col.vars]
    class(y) <- "ftable"
    y
}

ftable.formula <- function(formula, data = NULL, subset, na.action, ...)
{
    if(missing(formula) || !inherits(formula, "formula"))
        stop("formula is incorrect or missing")
    if(length(formula) != 3)
        stop("formula must have both left and right hand sides")
    if(any(attr(terms(formula), "order") > 1))
        stop("interactions are not allowed")
    rvars <- attr(terms(formula[-2]), "term.labels")
    cvars <- attr(terms(formula[-3]), "term.labels")
    rhs.has.dot <- any(rvars == ".")
    lhs.has.dot <- any(cvars == ".")
    if(lhs.has.dot && rhs.has.dot)
        stop(paste("formula has", sQuote("."),
                   "in both left and right hand side"))
    m <- match.call(expand.dots = FALSE)
    edata <- eval(m$data, parent.frame())
    if(inherits(edata, "ftable")
       || inherits(edata, "table")
       || length(dim(edata)) > 2) {
        if(inherits(edata, "ftable")) {
            data <- as.table(data)
        }
        varnames <- names(dimnames(data))
        if(rhs.has.dot)
            rvars <- NULL
        else {
            i <- pmatch(rvars, varnames)
            if(any(is.na(i)))
                stop("incorrect variable names in rhs of formula")
            rvars <- i
        }
        if(lhs.has.dot)
            cvars <- NULL
        else {
            i <- pmatch(cvars, varnames)
            if(any(is.na(i)))
                stop("incorrect variable names in lhs of formula")
            cvars <- i
        }
        ftable(data, row.vars = rvars, col.vars = cvars)
    }
    else {
        if(is.matrix(edata))
            m$data <- as.data.frame(data)
        m$... <- NULL
        if(!is.null(data) && is.environment(data)) {
            varnames <- names(data)
            if(rhs.has.dot)
                rvars <- seq(along = varnames)[-cvars]
            if(lhs.has.dot)
                cvars <- seq(along = varnames)[-rvars]
        }
        else {
            if(lhs.has.dot || rhs.has.dot)
                stop("cannot use dots in formula with given data")
        }
        m$formula <- formula(paste("~",
                                   paste(c(rvars, cvars),
                                         collapse = "+")))
        m[[1]] <- as.name("model.frame")
        mf <- eval(m, parent.frame())
        ftable(mf, row.vars = rvars, col.vars = cvars, ...)
    }
}

as.table.ftable <- function(x, ...)
{
    if(!inherits(x, "ftable"))
        stop(paste("x must be an", sQuote("ftable")))
    xrv <- rev(attr(x, "row.vars"))
    xcv <- rev(attr(x, "col.vars"))
    x <- array(data = c(x),
               dim = c(sapply(xrv, length),
                       sapply(xcv, length)),
               dimnames = c(xrv, xcv))
    nrv <- length(xrv)
    ncv <- length(xcv)
    x <- aperm(x, c(seq(from = nrv, to = 1),
                    seq(from = nrv + ncv, to = nrv + 1)))
    class(x) <- "table"
    x
}

write.ftable <- function(x, file = "", quote = TRUE,
                         digits = getOption("digits"))
{
    if(!inherits(x, "ftable"))
        stop(paste("x must be an", sQuote("ftable")))
    ox <- x
    charQuote <- function(s)
        if(quote) paste("\"", s, "\"", sep = "") else s
    makeLabels <- function(lst) {
        lens <- sapply(lst, length)
        cplensU <- c(1, cumprod(lens))
        cplensD <- rev(c(1, cumprod(rev(lens))))
        y <- NULL
        for (i in rev(seq(along = lst))) {
            ind <- 1 + seq(from = 0, to = lens[i] - 1) * cplensD[i + 1]
            tmp <- character(length = cplensD[i])
            tmp[ind] <- charQuote(lst[[i]])
            y <- cbind(rep(tmp, times = cplensU[i]), y)
        }
        y
    }
    makeNames <- function(x) {
        nmx <- names(x)
        if(is.null(nmx))
            nmx <- rep("", length = length(x))
        nmx
    }

    xrv <- attr(x, "row.vars")
    xcv <- attr(x, "col.vars")
    LABS <- cbind(rbind(matrix("", nr = length(xcv), nc = length(xrv)),
                        charQuote(makeNames(xrv)),
                        makeLabels(xrv)),
                  c(charQuote(makeNames(xcv)),
                    rep("", times = nrow(x) + 1)))
    DATA <- rbind(t(makeLabels(xcv)),
                  rep("", times = ncol(x)),
                  format(unclass(x), digits = digits))
    x <- cbind(apply(LABS, 2, format, justify = "left"),
               apply(DATA, 2, format, justify = "right"))
    cat(t(x), file = file, sep = c(rep(" ", ncol(x) - 1), "\n"))
    invisible(ox)
}

print.ftable <- function(x, digits = getOption("digits"), ...)
    write.ftable(x, quote = FALSE, digits = digits)

read.ftable <- function(file, sep = "", quote = "\"", row.var.names,
                        col.vars, skip = 0)
{
    ## <NOTE>
    ## Currently, 'file' must really be a character string naming a
    ## file, connections are not supported.  We need to count.fields()
    ## on the whole thing, so we could extend this to connections which
    ## can seek the origin (file connections only, it seems).
    ## </NOTE>
    
    z <- count.fields(file, sep, quote, skip)
    n.row.vars <- z[max(which(z == max(z)))] - z[length(z)] + 1
    i <- which(z == n.row.vars)

    ## Open a file connection so that we do not have to play with skips.
    file <- file(file, "r")
    on.exit(close(file))
    readLines(file, skip)
    
    if((length(i) != 1) || (i == 1)) {
        ## This is not really an ftable.
        if((z[1] == 1) && z[2] == max(z)) {
            ## Case A.  File looks like
            ##
            ##                                cvar.nam
            ## rvar.1.nam   ... rvar.k.nam    cvar.lev.1 ... cvar.lev.l
            ## rvar.1.lev.1 ... rvar.k.lev.1  ...        ... ...
            ##
            n.col.vars <- 1
            col.vars <- vector("list", length = n.col.vars)
            s <- scan(file, what = "", sep = sep, quote = quote,
                      nlines = 2, quiet = TRUE)
            names(col.vars) <- s[1]
            s <- s[-1]
            row.vars <- vector("list", length = n.row.vars)
            i <- 1 : n.row.vars
            names(row.vars) <- s[i]
            col.vars[[1]] <- s[-i]
            z <- z[-(1 : 2)]
        }
        else {
            ## Case B.
            ## We cannot determine the names and levels of the column
            ## variables, and also not the names of the row variables.
            if(missing(row.var.names)) {
                ## 'row.var.names' should be a character vector (or
                ## factor) with the names of the row variables.
                stop("row.var.names missing")
            }
            n.row.vars <- length(row.var.names)
            row.vars <- vector("list", length = n.row.vars)
            names(row.vars) <- as.character(row.var.names)
            if(missing(col.vars) || !is.list(col.vars)) {
                ## 'col.vars' should be a list.
                stop("col.vars missing or incorrect")
            }
            col.vars <- lapply(col.vars, as.character)
            n.col.vars <- length(col.vars)
            if(is.null(names(col.vars)))
                names(col.vars) <-
                    paste("Factor", seq(along = col.vars), sep = ".")
            else {
                nam <- names(col.vars)
                ind <- which(nchar(nam) == 0)
                names(col.vars)[ind] <-
                    paste("Factor", ind, sep = ".")
            }
        }
    }
    else {
        ## We can figure things out ourselves.
        n.col.vars <- i - 1
        col.vars <- vector("list", length = n.col.vars)
        n <- c(1, z[1 : n.col.vars] - 1)
        for(k in seq(from = 1, to = n.col.vars)) {
            s <- scan(file, what = "", sep = sep, quote = quote,
                      nlines = 1, quiet = TRUE)
            col.vars[[k]] <- s[-1]
            names(col.vars)[k] <- s[1]
        }
        row.vars <- vector("list", length = n.row.vars)
        names(row.vars) <- scan(file, what = "", sep = sep, quote =
                                quote, nlines = 1, quiet = TRUE)
        z <- z[-(1 : (n.col.vars + 1))]
    }
    p <- 1
    n <- integer(n.row.vars)
    for(k in seq(from = 1, to = n.row.vars)) {
        n[k] <- sum(z >= max(z) - k + 1) / p
        p <- p * n[k]
    }
    is.row.lab <- rep(rep(c(TRUE, FALSE), length(z)),
                      c(rbind(z - min(z) + 1, min(z) - 1)))
    s <- scan(file, what = "", sep = sep, quote = quote, quiet = TRUE)
    values <- as.numeric(s[!is.row.lab])
    tmp <- s[is.row.lab]
    len <- length(tmp)
    for(k in seq(from = 1, to = n.row.vars)) {
        i <- seq(from = 1, to = len, by = len / n[k])
        row.vars[[k]] <- unique(tmp[i])
        tmp <- tmp[seq(from = 2, to = len / n[k])]
        len <- length(tmp)
    }
    values <- matrix(values,
                     nr = prod(sapply(row.vars, length)),
                     nc = prod(sapply(col.vars, length)),
                     byrow = TRUE)
    structure(values,
              row.vars = row.vars,
              col.vars = col.vars,
              class = "ftable")
}
get <-
    function (x, pos = -1, envir = as.environment(pos), mode = "any",
              inherits = TRUE)
    .Internal(get(x, envir, mode, inherits))
Sys.getenv <- function(x) {
    if (missing(x)) {
	x <- strsplit(.Internal(getenv(character())), "=")
	v <- n <- character(LEN <- length(x))
	for (i in 1:LEN) {
	    n[i] <- x[[i]][1]
	    v[i] <- paste(x[[i]][-1], collapse = "=")
	}
	structure(v, names = n)
    } else {
	structure(.Internal(getenv(x)), names = x)
    }
}

Sys.putenv <- function(...)
{
    x <- list(...)
    nm <- names(x)
    val <- as.character(unlist(x))
    x <- paste(nm,val, sep="=")
    invisible(.Internal(putenv(x)))
}

Sys.getpid <- function() .Internal(getpid())
## gl function of GLIM
gl <- function (n, k, length = n*k, labels=1:n, ordered=FALSE)
    factor(rep(rep.int(1:n, rep.int(k,n)), length=length),
	   levels=1:n, labels=labels, ordered=ordered)
### This function fits a generalized linear model via
### iteratively reweighted least squares for any family.
### Written by Simon Davies, Dec 1995
### glm.fit modified by Thomas Lumley, Apr 1997, and then others..

glm <- function(formula, family=gaussian, data=list(), weights=NULL,
		subset=NULL, na.action=na.fail,
		start=NULL, etastart=NULL, mustart=NULL,
		offset=NULL,
		control=glm.control(...), model=TRUE, method="glm.fit",
		x=FALSE, y=TRUE, contrasts = NULL, ...)
{
    call <- match.call()

    ## family
    if(is.character(family))
        family <- get(family, mode="function", envir=parent.frame())
    if(is.function(family)) family <- family()
    if(is.null(family$family)) {
	print(family)
	stop("`family' not recognized")
    }

    ## extract x, y, etc from the model formula and frame
#    mt <- terms(formula, data=data)
    if(missing(data)) data <- environment(formula)
    mf <- match.call(expand.dots = FALSE)
    mf$family <- mf$start <- mf$control <- mf$maxit <- NULL
    mf$model <- mf$method <- mf$x <- mf$y <- mf$contrasts <- NULL
    mf$... <- NULL
    mf$drop.unused.levels <- TRUE
    mf[[1]] <- as.name("model.frame")
    mf <- eval(mf, parent.frame())
    switch(method,
	   "model.frame" = return(mf),
	   "glm.fit"= 1,
	   "glm.fit.null"= 1,
	   ## else
	   stop("invalid `method': ", method))
    mt <- attr(mf, "terms") # allow model.frame to update it
    na.act <- attr(mf, "na.action")
    xvars <- as.character(attr(mt, "variables"))[-1]
    if((yvar <- attr(mt, "response")) > 0) xvars <- xvars[-yvar]
    xlev <- if(length(xvars) > 0) {
	xlev <- lapply(mf[xvars], levels)
	xlev[!sapply(xlev, is.null)]
    } # else NULL

    Y <- model.response(mf, "numeric")
    ## null model support
    X <- if (!is.empty.model(mt)) model.matrix(mt, mf, contrasts) else matrix(,NROW(Y),0)
    weights <- model.weights(mf)
    offset <- model.offset(mf)
    ## check weights and offset
    if( !is.null(weights) && any(weights < 0) )
	stop("Negative wts not allowed")
    if(!is.null(offset) && length(offset) != NROW(Y))
	stop("Number of offsets is ", length(offset),
	     ", should equal ", NROW(Y), " (number of observations)")

    ## fit model via iterative reweighted least squares
    fit <- glm.fit(x=X, y=Y, weights=weights, start=start,
                   etastart=etastart, mustart=mustart,
                   offset=offset, family=family, control=control,
                   intercept=attr(mt, "intercept") > 0)

    ## empty models don't have an intercept!
    if(any(offset) && attr(mt, "intercept") > 0) {
	fit$null.deviance <-
	    glm.fit(x=X[,"(Intercept)",drop=FALSE], y=Y, weights=weights,
                    offset=offset, family=family,
                    control=control, intercept=TRUE)$deviance
    }
    if(model) fit$model <- mf
    if(!is.null(na.act)) fit$na.action <- na.act
    if(x) fit$x <- X
    if(!y) fit$y <- NULL
    fit <- c(fit, list(call=call, formula=formula,
		       terms=mt, data=data,
		       offset=offset, control=control, method=method,
		       contrasts = attr(X, "contrasts"), xlevels = xlev))
    class(fit) <- c("glm", "lm")
    fit
}


glm.control <- function(epsilon = 1e-8, maxit = 25, trace = FALSE)
{
    if(!is.numeric(epsilon) || epsilon <= 0)
	stop("value of epsilon must be > 0")
    if(!is.numeric(maxit) || maxit <= 0)
	stop("maximum number of iterations must be > 0")
    list(epsilon = epsilon, maxit = maxit, trace = trace)
}

## Modified by Thomas Lumley 26 Apr 97
## Added boundary checks and step halving
## Modified detection of fitted 0/1 in binomial
## Updated by KH as suggested by BDR on 1998/06/16

glm.fit <-
    function (x, y, weights = rep(1, nobs), start = NULL,
	      etastart = NULL, mustart = NULL, offset = rep(0, nobs),
	      family = gaussian(), control = glm.control(), intercept = TRUE)
{
    x <- as.matrix(x)
    xnames <- dimnames(x)[[2]]
    ynames <- names(y)
    conv <- FALSE
    nobs <- NROW(y)
    nvars <- ncol(x)
    EMPTY <- nvars == 0
    ## define weights and offset if needed
    if (is.null(weights))
	weights <- rep.int(1, nobs)
    if (is.null(offset))
	offset <- rep.int(0, nobs)
    ## get family functions:
    variance <- family$variance
    dev.resids <- family$dev.resids
    aic <- family$aic
    linkinv <- family$linkinv
    mu.eta <- family$mu.eta
    if (!is.function(variance) || !is.function(linkinv) )
	stop("illegal `family' argument")
    valideta <- family$valideta
    if (is.null(valideta))
	valideta <- function(eta) TRUE
    validmu <- family$validmu
    if (is.null(validmu))
	validmu <- function(mu) TRUE
    if(is.null(mustart)) {
        ## calculates mustart and may change y and weights and set n (!)
        eval(family$initialize)
    } else {
        mukeep <- mustart
        eval(family$initialize)
        mustart <- mukeep
    }
    if(EMPTY) {
        eta <- rep.int(0, nobs) + offset
        if (!valideta(eta))
            stop("Invalid linear predictor values in empty model")
        mu <- linkinv(eta)
        ## calculate initial deviance and coefficient
        if (!validmu(mu))
            stop("Invalid fitted means in empty model")
        dev <- sum(dev.resids(y, mu, weights))
        w <- ((weights * mu.eta(eta)^2)/variance(mu))^0.5
        residuals <- (y - mu)/mu.eta(eta)
        good <- rep(TRUE, length(residuals))
        boundary <- conv <- TRUE
        coef <- numeric(0)
        iter <- 0
    } else {
        coefold <- NULL
        eta <-
            if(!is.null(etastart)) etastart
            else if(!is.null(start))
                if (length(start) != nvars)
                    stop("Length of start should equal ", nvars,
                         " and correspond to initial coefs for ",
                         deparse(xnames))
                else {
                    coefold <- start
                    offset + as.vector(if (NCOL(x) == 1) x * start else x %*% start)
                }
            else family$linkfun(mustart)
        mu <- linkinv(eta)
        if (!(validmu(mu) && valideta(eta)))
            stop("Can't find valid starting values: please specify some")
        ## calculate initial deviance and coefficient
        devold <- sum(dev.resids(y, mu, weights))
        boundary <- conv <- FALSE

        ##------------- THE Iteratively Reweighting L.S. iteration -----------
        for (iter in 1:control$maxit) {
            good <- weights > 0
            varmu <- variance(mu)[good]
            if (any(is.na(varmu)))
                stop("NAs in V(mu)")
            if (any(varmu == 0))
                stop("0s in V(mu)")
            mu.eta.val <- mu.eta(eta)
            if (any(is.na(mu.eta.val[good])))
                stop("NAs in d(mu)/d(eta)")
            ## drop observations for which w will be zero
            good <- (weights > 0) & (mu.eta.val != 0)

            if (all(!good)) {
                conv <- FALSE
                warning("No observations informative at iteration ", iter)
                break
            }
            z <- (eta - offset)[good] + (y - mu)[good]/mu.eta.val[good]
            w <- sqrt((weights[good] * mu.eta.val[good]^2)/variance(mu)[good])
            ngoodobs <- as.integer(nobs - sum(!good))
            ## call Fortran code
            fit <- .Fortran("dqrls",
                            qr = x[good, ] * w, n = ngoodobs,
                            p = nvars, y = w * z, ny = as.integer(1),
                            tol = min(1e-7, control$epsilon/1000),
                            coefficients = double(nvars),
                            residuals = double(ngoodobs),
                            effects = double(ngoodobs),
                            rank = integer(1),
                            pivot = 1:nvars, qraux = double(nvars),
                            work = double(2 * nvars),
                            PACKAGE = "base")
            if (any(!is.finite(fit$coefficients))) {
                conv <- FALSE
                warning("Non-finite coefficients at iteration ", iter)
                break
            }
            ## stop if not enough parameters
            if (nobs < fit$rank)
                stop("X matrix has rank ", fit$rank,
                     " but only ", nobs, " observations")
            ## calculate updated values of eta and mu with the new coef:
            start[fit$pivot] <- fit$coefficients
            eta <- drop(x %*% start)
            mu <- linkinv(eta <- eta + offset)
            dev <- sum(dev.resids(y, mu, weights))
            if (control$trace)
                cat("Deviance =", dev, "Iterations -", iter, "\n")
            ## check for divergence
            boundary <- FALSE
            if (!is.finite(dev)) {
                if(is.null(coefold))
                    stop("no valid set of coefficients has been found:please supply starting values", call. = FALSE)
                warning("Step size truncated due to divergence", call. = FALSE)
                ii <- 1
                while (!is.finite(dev)) {
                    if (ii > control$maxit)
                        stop("inner loop 1; can't correct step size")
                    ii <- ii + 1
                    start <- (start + coefold)/2
                    eta <- drop(x %*% start)
                    mu <- linkinv(eta <- eta + offset)
                    dev <- sum(dev.resids(y, mu, weights))
                }
                boundary <- TRUE
                if (control$trace)
                    cat("Step halved: new deviance =", dev, "\n")
            }
            ## check for fitted values outside domain.
            if (!(valideta(eta) && validmu(mu))) {
                warning("Step size truncated: out of bounds", call. = FALSE)
                ii <- 1
                while (!(valideta(eta) && validmu(mu))) {
                    if (ii > control$maxit)
                        stop("inner loop 2; can't correct step size")
                    ii <- ii + 1
                    start <- (start + coefold)/2
                    eta <- drop(x %*% start)
                    mu <- linkinv(eta <- eta + offset)
                }
                boundary <- TRUE
                dev <- sum(dev.resids(y, mu, weights))
                if (control$trace)
                    cat("Step halved: new deviance =", dev, "\n")
            }
            ## check for convergence
            if (abs(dev - devold)/(0.1 + abs(dev)) < control$epsilon) {
                conv <- TRUE
                coef <- start
                break
            } else {
                devold <- dev
                coef <- coefold <- start
            }
        } ##-------------- end IRLS iteration -------------------------------

        if (!conv) warning("Algorithm did not converge")
        if (boundary) warning("Algorithm stopped at boundary value")
        eps <- 10*.Machine$double.eps
        if (family$family == "binomial") {
            if (any(mu > 1 - eps) || any(mu < eps))
                warning("fitted probabilities numerically 0 or 1 occurred")
        }
        if (family$family == "poisson") {
            if (any(mu < eps))
                warning("fitted rates numerically 0 occurred")
        }
        ## If X matrix was not full rank then columns were pivoted,
        ## hence we need to re-label the names ...
        ## Original code changed as suggested by BDR---give NA rather
        ## than 0 for non-estimable parameters
        if (fit$rank < nvars) coef[fit$pivot][seq(fit$rank+1, nvars)] <- NA
        xxnames <- xnames[fit$pivot]
        residuals <- rep.int(NA, nobs)
        residuals[good] <- z - (eta - offset)[good] # z does not have offset in.
        fit$qr <- as.matrix(fit$qr)
        nr <- min(sum(good), nvars)
        if (nr < nvars) {
            Rmat <- diag(nvars)
            Rmat[1:nr, 1:nvars] <- fit$qr[1:nr, 1:nvars]
        }
        else Rmat <- fit$qr[1:nvars, 1:nvars]
        Rmat <- as.matrix(Rmat)
        Rmat[row(Rmat) > col(Rmat)] <- 0
        names(coef) <- xnames
        colnames(fit$qr) <- xxnames
        dimnames(Rmat) <- list(xxnames, xxnames)
    }
    names(residuals) <- ynames
    names(mu) <- ynames
    names(eta) <- ynames
    # for compatibility with lm, which has a full-length weights vector
    wt <- rep.int(0, nobs)
    wt[good] <- w^2
    names(wt) <- ynames
    names(weights) <- ynames
    names(y) <- ynames
    if(!EMPTY)
        names(fit$effects) <-
            c(xxnames[seq(len=fit$rank)], rep.int("", sum(good) - fit$rank))
    ## calculate null deviance -- corrected in glm() if offset and intercept
    wtdmu <-
	if (intercept) sum(weights * y)/sum(weights) else linkinv(offset)
    nulldev <- sum(dev.resids(y, wtdmu, weights))
    ## calculate df
    n.ok <- nobs - sum(weights==0)
    nulldf <- n.ok - as.integer(intercept)
    rank <- if(EMPTY) 0 else fit$rank
    resdf  <- n.ok - rank
    ## calculate AIC
    aic.model <-
	aic(y, n, mu, weights, dev) + 2*rank
	##     ^^ is only initialize()d for "binomial" [yuck!]
    list(coefficients = coef, residuals = residuals, fitted.values = mu,
	 effects = if(!EMPTY) fit$effects, R = if(!EMPTY) Rmat, rank = rank,
	 qr = if(!EMPTY) structure(fit[c("qr", "rank", "qraux", "pivot", "tol")], class="qr"),
         family = family,
	 linear.predictors = eta, deviance = dev, aic = aic.model,
	 null.deviance = nulldev, iter = iter, weights = wt,
	 prior.weights = weights, df.residual = resdf, df.null = nulldf,
	 y = y, converged = conv, boundary = boundary)
}


print.glm <- function(x, digits= max(3, getOption("digits") - 3), ...)
{
    cat("\nCall: ", deparse(x$call), "\n\n")
    if(length(coef(x))) {
        cat("Coefficients")
        if(is.character(co <- x$contrasts))
            cat("  [contrasts: ",
                apply(cbind(names(co),co), 1, paste, collapse="="), "]")
        cat(":\n")
        print.default(format(x$coefficients, digits=digits),
                      print.gap = 2, quote = FALSE)
    } else cat("No coefficients\n\n")
    cat("\nDegrees of Freedom:", x$df.null, "Total (i.e. Null); ",
        x$df.residual, "Residual\n")
    cat("Null Deviance:	   ",	format(signif(x$null.deviance, digits)),
	"\nResidual Deviance:", format(signif(x$deviance, digits)),
	"\tAIC:", format(signif(x$aic, digits)), "\n")
    invisible(x)
}


anova.glm <- function(object, ..., dispersion=NULL, test=NULL)
{
    ## check for multiple objects
    dotargs <- list(...)
    named <- if (is.null(names(dotargs)))
	rep(FALSE, length(dotargs)) else (names(dotargs) != "")
    if(any(named))
	warning("The following arguments to anova.glm(..) are invalid and dropped: ",
		paste(deparse(dotargs[named]), collapse=", "))
    dotargs <- dotargs[!named]
    is.glm <- unlist(lapply(dotargs,function(x) inherits(x,"glm")))
    dotargs <- dotargs[is.glm]
    if (length(dotargs) > 0)
	return(anova.glmlist(c(list(object), dotargs),
			     dispersion = dispersion, test=test))

    ## extract variables from model

    varlist <- attr(object$terms, "variables")
    ## must avoid partial matching here.
    x <-
	if (n <- match("x", names(object), 0))
	    object[[n]]
	else model.matrix(object)
    varseq <- attr(x, "assign")
    nvars <- max(0, varseq)
    resdev <- resdf <- NULL

    ## if there is more than one explanatory variable then
    ## recall glm.fit to fit variables sequentially

    if(nvars > 1) {
	method <- object$method
	if(!is.function(method))
	    method <- get(method, mode = "function", envir=parent.frame())
	for(i in 1:(nvars-1)) {
	    ## explanatory variables up to i are kept in the model
	    ## use method from glm to find residual deviance
	    ## and df for each sequential fit
	    fit <- method(x=x[, varseq <= i, drop = FALSE],
			  y=object$y,
			  weights=object$prior.weights,
			  start	 =object$start,
			  offset =object$offset,
			  family =object$family,
			  control=object$control)
	    resdev <- c(resdev, fit$deviance)
	    resdf <- c(resdf, fit$df.residual)
	}
    }

    ## add values from null and full model

    resdf <- c(object$df.null, resdf, object$df.residual)
    resdev <- c(object$null.deviance, resdev, object$deviance)

    ## construct table and title

    table <- data.frame(c(NA, -diff(resdf)),
			c(NA, pmax(0, -diff(resdev))), resdf, resdev)
    tl <- attr(object$terms, "term.labels")
    if (length(tl) == 0) table <- table[1,,drop=FALSE] # kludge for null model
    dimnames(table) <- list(c("NULL", tl),
			    c("Df", "Deviance", "Resid. Df", "Resid. Dev"))
    title <- paste("Analysis of Deviance Table", "\n\nModel: ",
		   object$family$family, ", link: ", object$family$link,
		   "\n\nResponse: ", as.character(varlist[-1])[1],
		   "\n\nTerms added sequentially (first to last)\n\n", sep="")

    ## calculate test statistics if needed

    df.dispersion <- Inf
    if(is.null(dispersion)) {
	dispersion <- summary(object, dispersion=dispersion)$dispersion
	df.dispersion <- if (dispersion == 1) Inf else object$df.residual
    }
    if(!is.null(test))
	table <- stat.anova(table=table, test=test, scale=dispersion,
			    df.scale=df.dispersion, n=NROW(x))
    structure(table, heading = title, class= c("anova", "data.frame"))
}


anova.glmlist <- function(object, ..., dispersion=NULL, test=NULL)
{

    ## find responses for all models and remove
    ## any models with a different response

    responses <- as.character(lapply(object, function(x) {
	deparse(formula(x)[[2]])} ))
    sameresp <- responses==responses[1]
    if(!all(sameresp)) {
	object <- object[sameresp]
	warning("Models with response ", deparse(responses[!sameresp]),
		" removed because response differs from ", "model 1")
    }

    ns <- sapply(object, function(x) length(x$residuals))
    if(any(ns != ns[1]))
	stop("models were not all fitted to the same size of dataset")

    ## calculate the number of models

    nmodels <- length(object)
    if(nmodels==1)
	return(anova.glm(object[[1]], dispersion=dispersion, test=test))

    ## extract statistics

    resdf  <- as.numeric(lapply(object, function(x) x$df.residual))
    resdev <- as.numeric(lapply(object, function(x) x$deviance))

    ## construct table and title

    table <- data.frame(resdf, resdev, c(NA, -diff(resdf)),
			c(NA, -diff(resdev)) )
    variables <- lapply(object, function(x)
			paste(deparse(formula(x)), collapse="\n") )
    dimnames(table) <- list(1:nmodels, c("Resid. Df", "Resid. Dev", "Df",
					 "Deviance"))
    title <- "Analysis of Deviance Table\n"
    topnote <- paste("Model ", format(1:nmodels),": ",
		     variables, sep="", collapse="\n")

    ## calculate test statistic if needed

    if(!is.null(test)) {
	bigmodel <- object[[order(resdf)[1]]]
	dispersion <- summary(bigmodel, dispersion=dispersion)$dispersion
	df.dispersion <- if (dispersion == 1) Inf else min(resdf)
	table <- stat.anova(table = table, test = test,
			    scale = dispersion, df.scale = df.dispersion,
			    n = length(bigmodel$residuals))
    }
    structure(table, heading = c(title, topnote),
	      class = c("anova", "data.frame"))
}


## utility for anova.FOO(), FOO in "lmlist", "glm", "glmlist":
stat.anova <- function(table, test=c("Chisq", "F", "Cp"), scale, df.scale, n)
{
    test <- match.arg(test)
    dev.col <- match("Deviance", colnames(table))
    if(is.na(dev.col)) dev.col <- match("Sum of Sq", colnames(table))
    switch(test,
	   "Chisq" = {
	       cbind(table,"P(>|Chi|)"= pchisq(abs(table[, dev.col]/scale),
			     abs(table[, "Df"]), lower.tail=FALSE))
	   },
	   "F" = {
	       Fvalue <- abs((table[, dev.col]/table[, "Df"])/scale)
	       Fvalue[table[, "Df"] == 0] <- NA
	       cbind(table, F = Fvalue,
		     "Pr(>F)" = pf(Fvalue, abs(table[, "Df"]),
		     abs(df.scale), lower.tail=FALSE))
	   },
	   "Cp" = {
	       cbind(table, Cp = table[,"Resid. Dev"] +
		     2*scale*(n - table[,"Resid. Df"]))
	   })
}

summary.glm <- function(object, dispersion = NULL,
			correlation = FALSE, symbolic.cor = FALSE, ...)
{
    est.disp <- FALSE
    df.r <- object$df.residual
    if(is.null(dispersion))	# calculate dispersion if needed
	dispersion <-
	    if(any(object$family$family == c("poisson", "binomial")))  1
	    else if(df.r > 0) {
		est.disp <- TRUE
		if(any(object$weights==0))
		    warning("observations with zero weight ",
			    "not used for calculating dispersion")
		sum(object$weights*object$residuals^2)/ df.r
	    } else Inf

    ## calculate scaled and unscaled covariance matrix

    p <- object$rank
    if (p > 0) {
        p1 <- 1:p
        Qr <- object$qr
        aliased <- is.na(coef(object))  # used in print method
        ## WATCHIT! doesn't this rely on pivoting not permuting 1:p? -- that's quaranteed
        coef.p <- object$coefficients[Qr$pivot[p1]]
        covmat.unscaled <- chol2inv(Qr$qr[p1,p1,drop=FALSE])
        dimnames(covmat.unscaled) <- list(names(coef.p),names(coef.p))
        covmat <- dispersion*covmat.unscaled
        var.cf <- diag(covmat)

        ## calculate coef table

        s.err <- sqrt(var.cf)
        tvalue <- coef.p/s.err

        dn <- c("Estimate", "Std. Error")
        if(!est.disp) {
            pvalue <- 2*pnorm(-abs(tvalue))
            coef.table <- cbind(coef.p, s.err, tvalue, pvalue)
            dimnames(coef.table) <- list(names(coef.p),
                                         c(dn, "z value","Pr(>|z|)"))
        } else if(df.r > 0) {
            pvalue <- 2*pt(-abs(tvalue), df.r)
            coef.table <- cbind(coef.p, s.err, tvalue, pvalue)
            dimnames(coef.table) <- list(names(coef.p),
                                         c(dn, "t value","Pr(>|t|)"))
        } else { ## df.r == 0
            coef.table <- cbind(coef.p, Inf)
            dimnames(coef.table) <- list(names(coef.p), dn)
        }
        df.f <- NCOL(Qr$qr)
    } else {
        coef.table <- matrix(, 0, 4)
        dimnames(coef.table) <-
            list(NULL, c("Estimate", "Std. Error", "t value", "Pr(>|t|)"))
        covmat.unscaled <- covmat <- matrix(, 0, 0)
        aliased <- is.na(coef(object))
        df.f <- length(aliased)
    }
    ## return answer

    ans <- c(object[c("call","terms","family","deviance", "aic",
		      "contrasts",
		      "df.residual","null.deviance","df.null","iter")],
	     list(deviance.resid = residuals(object, type = "deviance"),
		  coefficients = coef.table,
                  aliased = aliased,
		  dispersion = dispersion,
		  df = c(object$rank, df.r, df.f),
		  cov.unscaled = covmat.unscaled,
		  cov.scaled = covmat))

    if(correlation && p > 0) {
	dd <- sqrt(diag(covmat.unscaled))
	ans$correlation <-
	    covmat.unscaled/outer(dd,dd)
	ans$symbolic.cor <- symbolic.cor
    }
    class(ans) <- "summary.glm"
    return(ans)
}

print.summary.glm <-
    function (x, digits = max(3, getOption("digits") - 3),
	      symbolic.cor = x$symbolic.cor,
	      signif.stars = getOption("show.signif.stars"), ...)
{
    cat("\nCall:\n")
    cat(paste(deparse(x$call), sep="\n", collapse="\n"), "\n\n", sep="")
    cat("Deviance Residuals: \n")
    if(x$df.residual > 5) {
	x$deviance.resid <- quantile(x$deviance.resid,na.rm=TRUE)
	names(x$deviance.resid) <- c("Min", "1Q", "Median", "3Q", "Max")
    }
    print.default(x$deviance.resid, digits=digits, na = "", print.gap = 2)

    if(length(x$aliased) == 0) {
        cat("\nNo Coefficients\n")
    } else {
        ## df component added in 1.8.0
        if (!is.null(df<- x$df) && (nsingular <- df[3] - df[1]))
            cat("\nCoefficients: (", nsingular,
                " not defined because of singularities)\n", sep = "")
        else cat("\nCoefficients:\n")
        coefs <- x$coefficients
        if(!is.null(aliased <- x$aliased) && any(aliased)) {
            cn <- names(aliased)
            coefs <- matrix(NA, length(aliased), 4,
                            dimnames=list(cn, colnames(coefs)))
            coefs[!aliased, ] <- x$coefficients
        }
        printCoefmat(coefs, digits=digits, signif.stars=signif.stars,
                     na.print="NA", ...)
    }
    ##
    cat("\n(Dispersion parameter for ", x$family$family,
	" family taken to be ", format(x$dispersion), ")\n\n",
	apply(cbind(paste(format.char(c("Null","Residual"),width=8,flag=""),
			  "deviance:"),
		    format(unlist(x[c("null.deviance","deviance")]),
			   digits= max(5, digits+1)), " on",
		    format(unlist(x[c("df.null","df.residual")])),
		    " degrees of freedom\n"),
	      1, paste, collapse=" "),
	"AIC: ", format(x$aic, digits= max(4, digits+1)),"\n\n",
	"Number of Fisher Scoring iterations: ", x$iter,
	"\n", sep="")

    correl <- x$correlation
    if(!is.null(correl)) {
# looks most sensible not to give NAs for undefined coefficients
#         if(!is.null(aliased) && any(aliased)) {
#             nc <- length(aliased)
#             correl <- matrix(NA, nc, nc, dimnames = list(cn, cn))
#             correl[!aliased, !aliased] <- x$correl
#         }
	p <- NCOL(correl)
	if(p > 1) {
	    cat("\nCorrelation of Coefficients:\n")
	    if(is.logical(symbolic.cor) && symbolic.cor) {# NULL < 1.7.0 objects
		print(symnum(correl, abbr.col = NULL))
	    } else {
		correl <- format(round(correl, 2), nsmall = 2, digits = digits)
		correl[!lower.tri(correl)] <- ""
		print(correl[-1, -p, drop=FALSE], quote = FALSE)
	    }
	}
    }
    cat("\n")
    invisible(x)
}


## GLM Methods for Generic Functions :

coef.glm <- function(object, ...) object$coefficients
deviance.glm <- function(object, ...) object$deviance
effects.glm <- function(object, ...) object$effects
fitted.glm <- function(object, ...)
{
    if(is.null(object$na.action)) object$fitted.values
    else napredict(object$na.action, object$fitted.values)
}

family.glm <- function(object, ...) object$family

residuals.glm <-
    function(object,
	     type = c("deviance", "pearson", "working", "response", "partial"),
	     ...)
{
    type <- match.arg(type)
    y <- object$y
    r <- object$residuals
    mu	<- object$fitted.values
    wts <- object$prior.weights
    res <- switch(type,
		  deviance = if(object$df.res > 0) {
		      d.res <- sqrt(pmax((object$family$dev.resids)(y, mu, wts), 0))
		      ifelse(y > mu, d.res, -d.res)
		  } else rep.int(0, length(mu)),
		  pearson = (y-mu)*sqrt(wts)/sqrt(object$family$variance(mu)),
		  working = r,
		  response = y - mu,
		  partial = r + predict(object,type="terms")
		  )
    if(is.null(object$na.action)) res
    else naresid(object$na.action, res)
}

## KH on 1998/06/22: update.default() is now used ...

model.frame.glm <-
    function (formula, data, na.action, ...)
{
    if (is.null(formula$model)) {
	fcall <- formula$call
	fcall$method <- "model.frame"
	fcall[[1]] <- as.name("glm")
	env<-environment(fcall$formula)
	if (is.null(env)) env<-parent.frame()
	eval(fcall, env)
    }
    else formula$model
}

weights.glm <- function(object, type = c("prior", "working"), ...)
{
    type <- match.arg(type)
    res <- if(type == "prior") object$prior.weights else object$weights
    if(is.null(object$na.action)) res
    else naresid(object$na.action, res)
}
grep <-
function(pattern, x, ignore.case = FALSE, extended = TRUE, perl = FALSE,
         value = FALSE, fixed = FALSE)
{
  ## behaves like == for NA pattern 
  if (is.na(pattern)){
    if(value)
      return(rep(as.character(NA),length(x)))
    else
      return(rep(NA,length(x)))
  }
  
  if(perl)
    .Internal(grep.perl(pattern, x, ignore.case, value))
  else
    .Internal(grep(pattern, x, ignore.case, extended, value, fixed))
}

sub <-
function(pattern, replacement, x, ignore.case = FALSE, extended = TRUE,
         perl = FALSE)
{
  if (is.na(pattern))
    return(rep(as.character(NA), length(x)))
  
    if(perl)
        .Internal(sub.perl(pattern, replacement, x, ignore.case))
    else
        .Internal(sub(pattern, replacement, x, ignore.case, extended))
}

gsub <-
function(pattern, replacement, x, ignore.case = FALSE, extended = TRUE,
         perl = FALSE)
{
  if (is.na(pattern))
    return(rep(as.character(NA), length(x)))

  if(perl)
        .Internal(gsub.perl(pattern, replacement, x, ignore.case))
    else
        .Internal(gsub(pattern, replacement, x, ignore.case, extended))
}

regexpr <-
function(pattern, text, extended = TRUE, perl = FALSE, fixed = FALSE)
{
    if(perl)
        .Internal(regexpr.perl(pattern, text))
    else
        .Internal(regexpr(pattern, text, extended, fixed))
}

agrep <-
function(pattern, x, ignore.case = FALSE, value = FALSE,
         max.distance = 0.1)
{
  ## behaves like == for NA pattern 
   if (is.na(pattern)){
     if (value)
       return(rep(as.character(NA), length(x)))
     else
       return(rep(NA, length(x)))
   }
  
    if(!is.character(pattern)
       || (length(pattern) < 1)
       || ((n <- nchar(pattern)) == 0))
        stop("pattern must be a non-empty character string")

    if(!is.list(max.distance)) {
        if(!is.numeric(max.distance) || (max.distance < 0))
            stop("max.distance must be non-negative")
        if(max.distance < 1)            # transform percentages
            max.distance <- ceiling(n * max.distance)
        max.insertions <- max.deletions <- max.substitutions <-
            max.distance
    }
    else {
        ## partial matching
        table <- c("all", "deletions", "insertions", "substitutions")
        ind <- pmatch(names(max.distance), table)
        if(any(is.na(ind)))
            warning("unknown match distance components ignored")
        max.distance <- max.distance[!is.na(ind)]
        names(max.distance) <- table[ind]
        ## sanity checks
        comps <- unlist(max.distance)
        if(!all(is.numeric(comps)) || any(comps < 0))
            stop("max.distance components must be non-negative")
        ## extract restrictions
        if(is.null(max.distance$all))
            max.distance$all <- 0.1
        max.insertions <- max.deletions <- max.substitutions <-
            max.distance$all
        if(!is.null(max.distance$deletions))
            max.deletions <- max.distance$deletions
        if(!is.null(max.distance$insertions))
            max.insertions <- max.distance$insertions
        if(!is.null(max.distance$substitutions))
            max.substitutions <- max.distance$substitutions
        max.distance <- max.distance$all
        ## transform percentages
        if(max.distance < 1)
            max.distance <- ceiling(n * max.distance)
        if(max.deletions < 1)
            max.deletions <- ceiling(n * max.deletions)
        if(max.insertions < 1)
            max.insertions <- ceiling(n * max.insertions)
        if(max.substitutions < 1)
            max.substitutions <- ceiling(n * max.substitutions)
    }

    .Internal(agrep(pattern, x, ignore.case, value, max.distance,
                    max.deletions, max.insertions, max.substitutions))
}
grid <- function (nx = NULL, ny = nx, col="lightgray", lty="dotted", lwd = NULL,
                  equilogs = TRUE)
{
    if(is.null(nx) || (!is.na(nx) && nx >= 1)) {
        log <- par("xlog")
        if(is.null(nx)) { ## align to tickmarks
            ax <- par("xaxp")
            if(log && equilogs && ax[3] > 0) ax[3] <- 1
            at <- axTicks(1, axp = ax, log=log)
        } else { # equidistant, also from box borders
            U <- par("usr")
            at <- seq(U[1],U[2], len = nx+1)
            at <- (if(log) 10^at else at)[-c(1,nx+1)]
        }
        abline(v = at, col = col, lty = lty, lwd = lwd)
    }
    if(is.null(ny) || (!is.na(ny) && ny >= 1)) {
        log <- par("ylog")
        if(is.null(ny)) { ## align to tickmarks
            ax <- par("yaxp")
            if(log && equilogs && ax[3] > 0) ax[3] <- 1
            at <- axTicks(2, axp = ax, log=log)
        } else { # equidistant, also from box borders
            U <- par("usr")
            at <- seq(U[3],U[4], len = ny+1)
            at <- (if(log) 10^at else at)[-c(1,ny+1)]
        }
	abline(h = at, col = col, lty = lty, lwd = lwd)
    }
}
help.search <-
function(pattern, fields = c("alias", "concept", "title"),
	 apropos, keyword, whatis, ignore.case = TRUE,
	 package = NULL, lib.loc = NULL,
	 help.db = getOption("help.db"),
	 verbose = getOption("verbose"),
	 rebuild = FALSE, agrep = NULL)
{
    ### Argument handling.
    TABLE <- c("alias", "concept", "keyword", "name", "title")

    if(!missing(pattern)) {
	if(!is.character(pattern) || (length(pattern) > 1))
	    stop(sQuote("pattern"), " must be a single character string")
	i <- pmatch(fields, TABLE)
	if(any(is.na(i)))
	    stop("incorrect field specification")
	else
	    fields <- TABLE[i]
    } else if(!missing(apropos)) {
	if(!is.character(apropos) || (length(apropos) > 1))
	    stop(sQuote("apropos"), " must be a single character string")
	else {
	    pattern <- apropos
	    fields <- c("alias", "title")
	}
    } else if(!missing(keyword)) {
	if(!is.character(keyword) || (length(keyword) > 1))
	    stop(sQuote("keyword"), " must be a single character string")
	else {
	    pattern <- keyword
	    fields <- "keyword"
	}
    } else if(!missing(whatis)) {
	if(!is.character(whatis) || (length(whatis) > 1))
	    stop(sQuote("whatis"), " must be a single character string")
	else {
	    pattern <- whatis
	    fields <- "alias"
	}
    } else {
	stop("don't know what to search")
    }

    if(is.null(lib.loc))
	lib.loc <- .libPaths()

    ## <FIXME>
    ## Currently, the information used for help.search is stored in
    ## package-level CONTENTS files.  As it is expensive to build the
    ## help.search db, we use a global file cache for this information
    ## if possible.  This is wrong because multiple processes or threads
    ## use the same cache (no locking!), and we should really save the
    ## information in one (thread-local) global table, e.g. as a local
    ## variable in the environment of help.search(), or something that
    ## can go in a 'shelf' (but not necessarily to a specific file) if
    ## memory usage is an issue.  Argh.
    ## </FIXME>

    ### Set up the help db.
    if(is.null(help.db) || !file.exists(help.db))
	rebuild <- TRUE
    else if(!rebuild) {
	## Try using the saved help db.
        db <- try(.readRDS(file = help.db), silent = TRUE)
        if(inherits(db, "try-error"))
            load(file = help.db)
	## If not a list (pre 1.7 format), rebuild.
	if(!is.list(db) ||
        ## If no information on concepts (pre 1.8 format), rebuild.
           length(db) < 4 ||
	## Need to find out whether this has the info we need.
	## Note that when looking for packages in libraries we always
	## use the first location found.  Hence if the library search
	## path changes we might find different versions of a package.
	## Thus we need to rebuild the help db in case the specified
	## library path is different from the one used when building the
	## help db (stored as its "LibPaths" attribute).
           !identical(lib.loc, attr(db, "LibPaths")) ||
	## We also need to rebuild the help db in case an existing dir
	## in the library path was modified more recently than the db,
	## as packages might have been installed or removed.
           any(file.info(help.db)$mtime <
	       file.info(lib.loc[file.exists(lib.loc)])$mtime)
           )
	    rebuild <- TRUE
    }
    if(rebuild) {
	## Check whether we can save the help db lateron.
	save.db <- FALSE
        dir <- file.path(tempdir(), ".R")
	dbfile <- file.path(dir, "help.db")
	if((tools::fileTest("-d", dir)
            || ((unlink(dir) == 0) && dir.create(dir)))
	   && (unlink(dbfile) == 0))
	    save.db <- TRUE

        ## If we cannot save the help db only use the given packages.
        ## <FIXME>
        ## Why don't we just use the given packages?  The current logic
        ## for rebuilding cannot figure out that rebuilding is needed
        ## the next time (unless we use the same given packages) ...
        packagesInHelpDB <- if(!is.null(package) && !save.db)
            package
        else
            .packages(all.available = TRUE, lib.loc = lib.loc)
        ## </FIXME>

	## Create the help db.
	contentsDCFFields <-
	    c("Entry", "Aliases", "Description", "Keywords")
        np <- 0
	if(verbose)
	    cat("Packages:\n")

        ## Starting with R 1.8.0, prebuilt hsearch indices are available
        ## in Meta/hsearch.rds, and the code to build this from the Rd
        ## contents (as obtained from both new and old style Rd indices)
        ## has been moved to tools:::.buildHsearchIndex(), which creates
        ## a per-package list of base, aliases and keywords information.
        ## When building the global index, it again (see e.g. also the
        ## code in tools:::Rdcontents()), it seems most efficient to
        ## create a list *matrix* (dbMat below), stuff the individual
        ## indices into its rows, and finally create the base, aliases
        ## and keyword information in rbind() calls on the columns.
        ## This is *much* more efficient than building incrementally.
        dbMat <- vector("list", length(packagesInHelpDB) * 4)
        dim(dbMat) <- c(length(packagesInHelpDB), 4)

	for(p in packagesInHelpDB) {
            np <- np + 1
	    if(verbose)
		cat("", p, if((np %% 5) == 0) "\n")
	    path <- .find.package(p, lib.loc, quiet = TRUE)
	    if(length(path) == 0)
		stop("could not find package ", sQuote(p))

            if(file.exists(hsearchFile <-
                           file.path(path, "Meta", "hsearch.rds"))) {
                hDB <- .readRDS(hsearchFile)
            }
            else {
                hDB <- contents <- NULL
                ## Read the contents info from the respective Rd meta
                ## files.
                if(file.exists(contentsFile <-
                               file.path(path, "Meta", "Rd.rds"))) {
                    contents <- .readRDS(contentsFile)
                }
                else if(file.exists(contentsFile
                                    <- file.path(path, "CONTENTS"))) {
                    contents <-
                        read.dcf(contentsFile,
                                 fields = contentsDCFFields)
                }
                ## If we found Rd contents information ...
                if(!is.null(contents)) {
                    ## build the hsearch index from it;
                    hDB <- tools:::.buildHsearchIndex(contents, p,
                                                      dirname(path))
                }
                else {
                    ## otherwise, issue a warning.
                    warning("No Rd contents for package ",
                            sQuote(p), " in ", sQuote(dirname(path)))
                }
            }
            if(!is.null(hDB)) {
                ## Put the hsearch index for the np-th package into the
                ## np-th row of the matrix used for aggregating.
                dbMat[np, seq(along = hDB)] <- hDB
            }
        }

        if(verbose)
	    cat(ifelse(np %% 5 == 0, "\n", "\n\n"))

        ## Create the global base, aliases and keywords tables via calls
        ## to rbind() on the columns of the matrix used for aggregating.
        db <- list(Base = do.call("rbind", dbMat[, 1]),
                   Aliases = do.call("rbind", dbMat[, 2]),
                   Keywords = do.call("rbind", dbMat[, 3]),
                   Concepts = do.call("rbind", dbMat[, 4]))
        if(is.null(db$Concepts))
            db$Concepts <-
                matrix(character(), nc = 3,
                       dimnames = list(NULL,
                       c("Concepts", "ID", "Package")))
        ## And finally, make the IDs globally unique by prefixing them
        ## with the number of the package in the global index.
        for(i in which(sapply(db, NROW) > 0)) {
            db[[i]][, "ID"] <-
                paste(rep.int(seq(along = packagesInHelpDB),
                              sapply(dbMat[, i], NROW)),
                      db[[i]][, "ID"],
                      sep = "/")
        }

	## Maybe save the help db
	## <FIXME>
	## Shouldn't we serialize instead?
	if(save.db) {
	    attr(db, "LibPaths") <- lib.loc
	    .saveRDS(db, file = dbfile)
	    options(help.db = dbfile)
	}
	## </FIXME>
    }

    ### Matching.
    if(verbose)
	cat("Database of ",
	    NROW(db$Base), " Rd objects (",
	    NROW(db$Aliases), " aliases, ",
            NROW(db$Concepts), " concepts, ",
	    NROW(db$Keywords), " keywords),\n",
	    sep = "")
    if(!is.null(package)) {
	## Argument 'package' was given but we built a larger help db to
	## save for future invocations.	 Need to check that all given
	## packages exist, and only search the given ones.
	posInHelpDB <-
	    match(package, unique(db$Base[, "Package"]), nomatch = 0)
	if(any(posInHelpDB) == 0)
	    stop("could not find package ",
                 sQuote(package[posInHelpDB == 0][1]))
	db <-
	    lapply(db,
		   function(x) {
		       x[x[, "Package"] %in% package, , drop = FALSE]
		   })
    }

    ## <FIXME>
    ## No need continuing if there are no objects in the data base.
    ## But shouldn't we return something of class "hsearch"?
    if(!length(db$Base)) return(invisible())
    ## </FIXME>

    ## If agrep is NULL (default), we want to use fuzzy matching iff
    ## 'pattern' contains no characters special to regular expressions.
    ## We use the following crude approximation: if pattern contains
    ## only alphanumeric characters or whitespace or a '-', it is taken
    ## 'as is', and fuzzy matching is used unless turned off explicitly,
    ## or pattern has very few (currently, less than 5) characters.
    if(is.null(agrep) || is.na(agrep))
	agrep <-
	    ((regexpr("^([[:alnum:]]|[[:space:]]|-)+$", pattern) > 0)
             && (nchar(pattern) > 4))
    if(is.logical(agrep)) {
	if(agrep)
	    max.distance <- 0.1
    }
    else if(is.numeric(agrep) || is.list(agrep)) {
	max.distance <- agrep
	agrep <- TRUE
    }
    else
	stop("incorrect agrep specification")

    searchFun <- function(x) {
	if(agrep)
	    agrep(pattern, x, ignore.case = ignore.case,
		  max.distance = max.distance)
	else
	    grep(pattern, x, ignore.case = ignore.case)
    }
    dbBase <- db$Base
    searchDbField <- function(field) {
	switch(field,
	       alias = {
		   aliases <- db$Aliases
		   match(aliases[searchFun(aliases[, "Aliases"]),
                                 "ID"],
			 dbBase[, "ID"])
	       },
	       concept = {
		   concepts <- db$Concepts
		   match(concepts[searchFun(concepts[, "Concepts"]),
                                  "ID"],
			 dbBase[, "ID"])
	       },

	       keyword = {
		   keywords <- db$Keywords
		   match(keywords[searchFun(keywords[, "Keywords"]),
				  "ID"],
			 dbBase[, "ID"])
	       },
	       searchFun(db$Base[, field]))
    }

    i <- NULL
    for(f in fields) i <- c(i, searchDbField(f))
    db <- dbBase[sort(unique(i)),
		 c("topic", "title", "Package", "LibPath"),
		 drop = FALSE]
    if(verbose) cat("matched", NROW(db), "objects.\n")

    ## Retval.
    y <- list(pattern = pattern, fields = fields,
              type = if(agrep) "fuzzy" else "regexp",
              matches = db)
    class(y) <- "hsearch"
    y
}

print.hsearch <-
function(x, ...)
{
    fields <- paste(x$fields, collapse = " or ")
    type <- switch(x$type, fuzzy = "fuzzy", "regular expression")
    db <- x$matches
    if(NROW(db) > 0) {
	outFile <- tempfile()
	outConn <- file(outFile, open = "w")
	writeLines(c(strwrap(paste("Help files with", fields,
                                   "matching", sQuote(x$pattern),
                                   "using", type, "matching:")),
                     "\n\n"),
		   outConn)
	dbnam <- paste(db[ , "topic"], "(",
		       db[, "Package"], ")",
		       sep = "")
	dbtit <- paste(db[ , "title"], sep = "")
	writeLines(formatDL(dbnam, dbtit), outConn)
        writeLines(c("\n\n",
                     strwrap(paste("Type 'help(FOO, package = PKG)' to",
                                   "inspect entry 'FOO(PKG) TITLE'."))),
                   outConn)
	close(outConn)
	file.show(outFile, delete.file = TRUE)
    } else {
	writeLines(strwrap(paste("No help files found with", fields,
                                 "matching", sQuote(x$pattern),
                                 "using", type, "matching.")))
    }
}
hist <- function(x, ...) UseMethod("hist")

hist.default <-
    function (x, breaks = "Sturges", freq = NULL,
	      probability = !freq, include.lowest= TRUE,
	      right= TRUE, density = NULL, angle = 45,
	      col = NULL, border = NULL,
	      main = paste("Histogram of" , xname),
	      xlim = range(breaks), ylim = NULL,
	      xlab = xname, ylab,
	      axes = TRUE, plot = TRUE, labels = FALSE, nclass = NULL, ...)
{
    if (!is.numeric(x))
	stop("`x' must be numeric")
    xname <- deparse(substitute(x))
    n <- length(x <- x[!is.na(x)])
    use.br <- !missing(breaks)
    if(use.br) {
	if(!missing(nclass))
	    warning("`nclass' not used when `breaks' specified")
    }
    else if(!is.null(nclass) && length(nclass) == 1)
	breaks <- nclass
    use.br <- use.br && (nB <- length(breaks)) > 1
    if(use.br)
	breaks <- sort(breaks)
    else {				# construct vector of breaks
	if(!include.lowest) {
	    include.lowest <- TRUE
	    warning("include.lowest ignored as `breaks' is not a vector")
	}
	if(is.character(breaks)) {
	    breaks <- match.arg(tolower(breaks),
				c("sturges", "fd",
				  "freedman-diaconis", "scott"))
	    breaks <- switch(breaks,
			     sturges = nclass.Sturges(x),
			     "freedman-diaconis" =,
			     fd = nclass.FD(x),
			     scott = nclass.scott(x),
			     stop("Unknown breaks algorithm"))
	} else if(is.function(breaks)) {
	    breaks <- breaks(x)
	}
	if(!is.numeric(breaks) || is.na(breaks) || breaks < 2)
	    stop("invalid number of breaks")
	breaks <- pretty (range(x), n = breaks, min.n = 1)
	nB <- length(breaks)
	if(nB <= 1) ##-- Impossible !
	    stop(paste("hist.default: pretty() error, breaks=",
		       format(breaks)))
    }

    ## Do this *before* adding fuzz or logic breaks down...

    h <- diff(breaks)
    equidist <- !use.br || diff(range(h)) < 1e-7 * mean(h)
    if (!use.br && any(h <= 0))
	stop("not strictly increasing `breaks'.")
    if (is.null(freq)) {
	freq <- if(!missing(probability)) !as.logical(probability) else equidist
    } else if(!missing(probability) && any(probability == freq))
	stop("`probability' is an alias for `!freq', however they differ.")

    ## Fuzz to handle cases where points are "effectively on"
    ## the boundaries
    diddle <- 1e-7 * max(abs(range(breaks)))
    fuzz <- if(right)
	c(if(include.lowest) - diddle else diddle,
          rep.int(diddle, length(breaks) - 1))
    else
	c(rep.int(-diddle, length(breaks) - 1),
          if(include.lowest) diddle else -diddle)

    fuzzybreaks <- breaks + fuzz
    h <- diff(fuzzybreaks)

    storage.mode(x) <- "double"
    storage.mode(fuzzybreaks) <- "double"
    ## With the fuzz adjustment above, the "right" and "include"
    ## arguments are really irrelevant
    counts <- .C("bincount",
		 x,
		 n,
		 fuzzybreaks,
		 nB,
		 counts = integer(nB - 1),
		 right = as.logical(right),
		 include= as.logical(include.lowest), naok = FALSE,
		 NAOK = FALSE, DUP = FALSE, PACKAGE = "base") $counts
    if (any(counts < 0))
	stop("negative `counts'. Internal Error in C-code for \"bincount\"")
    if (sum(counts) < n)
	stop("some `x' not counted; maybe `breaks' do not span range of `x'")
    dens <- counts/(n*h)
    mids <- 0.5 * (breaks[-1] + breaks[-nB])
    r <- structure(list(breaks = breaks, counts = counts,
			intensities = dens,
			density = dens, mids = mids,
			xname = xname, equidist = equidist),
		   class="histogram")
    if (plot) {
	plot(r, freq = freq, col = col, border = border,
	     angle = angle, density = density,
	     main = main, xlim = xlim, ylim = ylim, xlab = xlab, ylab = ylab,
	     axes = axes, labels = labels, ...)
	invisible(r)
    }
    else r
}

plot.histogram <-
    function (x, freq = equidist, density = NULL, angle = 45,
	      col = NULL, border = par("fg"), lty = NULL,
	      main = paste("Histogram of", x$xname), sub = NULL,
	      xlab = x$xname, ylab,
	      xlim = range(x$breaks), ylim = NULL,
	      axes = TRUE, labels = FALSE, add = FALSE, ...)
{
    equidist <-
	if(is.logical(x$equidist)) x$equidist
	else { h <- diff(x$breaks) ; diff(range(h)) < 1e-7 * mean(h) }
    if(freq && !equidist)
	warning("the AREAS in the plot are wrong -- rather use `freq=FALSE'!")

    y <- if (freq) x$counts else { ## x$density -- would be enough, but
	## for back compatibility
	y <- x$density; if(is.null(y)) x$intensities else y}
    nB <- length(x$breaks)
    if(is.null(y) || 0 == nB) stop("`x' is wrongly structured")

    if(!add) {
	if(is.null(ylim))
	    ylim <- range(y, 0)
	if (missing(ylab))
	    ylab <- if (!freq) "Density" else "Frequency"
	plot.new()
	plot.window(xlim, ylim, "")	#-> ylim's default from 'y'
	title(main = main, sub = sub, xlab = xlab, ylab = ylab, ...)
	if(axes) {
	    axis(1, ...)
	    axis(2, ...)
	}
    }
    rect(x$breaks[-nB], 0, x$breaks[-1], y,
	 col = col, border = border,
	 angle = angle, density = density, lty = lty)
    if((logl <- is.logical(labels) && labels) || is.character(labels))
	text(x$mids, y,
	     labels = if(logl) {
		 if(freq) x$counts else round(x$density,3)
	     } else labels,
	     adj = c(0.5, -0.5))
    invisible()
}

lines.histogram <- function(x, ...) plot.histogram(x, ..., add = TRUE)

nclass.Sturges <- function(x) ceiling(log2(length(x)) + 1)

nclass.scott <- function(x)
{
    h <- 3.5 * sqrt(var(x)) * length(x)^(-1/3)
    ceiling(diff(range(x))/h)
}

nclass.FD <- function(x)
{
    r <- as.vector(quantile(x, c(0.25, 0.75)))
    h <- 2 * (r[2] - r[1]) * length(x)^(-1/3)
    ceiling(diff(range(x))/h)
}
loadhistory <- function(file=".Rhistory")
    invisible(.Internal(loadhistory(file)))

savehistory <- function(file=".Rhistory")
    invisible(.Internal(savehistory(file)))

history <- function(max.show=25, reverse=FALSE)
{
    file1 <- tempfile("Rrawhist")
    savehistory(file1)
    rawhist <- scan(file1, what = "", quiet=TRUE, sep="\n")
    unlink(file1)
    nlines <- length(rawhist)
    inds <- max(1, nlines-max.show):nlines
    if(reverse) inds <- rev(inds)
    file2 <- tempfile("hist")
    write(rawhist[inds], file2)
    file.show(file2, title="R History", delete.file=TRUE)
}
print.htest <-
function(x, digits = 4, quote = TRUE, prefix = "", ...)
{
    cat("\n")
    writeLines(strwrap(x$method, prefix = "\t"))
    cat("\n")
    cat("data: ", x$data.name, "\n")
    out <- character()
    if(!is.null(x$statistic))
        out <- c(out, paste(names(x$statistic), "=",
                            format(round(x$statistic, 4))))
    if(!is.null(x$parameter))
        out <- c(out, paste(names(x$parameter), "=",
                            format(round(x$parameter, 3))))
    if(!is.null(x$p.value))
        out <- c(out, paste("p-value =",
                            format.pval(x$p.value, digits = digits)))
    writeLines(strwrap(paste(out, collapse = ", ")))
    if(!is.null(x$alternative)) {
        cat("alternative hypothesis: ")
	if(!is.null(x$null.value)) {
	    if(length(x$null.value) == 1) {
                alt.char <-
                    switch(x$alternative,
                           two.sided = "not equal to",
                           less = "less than",
                           greater = "greater than")
		cat("true", names(x$null.value), "is", alt.char,
                    x$null.value, "\n")
	    }
	    else {
		cat(x$alternative, "\nnull values:\n")
		print(x$null.value, ...)
	    }
	}
	else cat(x$alternative, "\n")
    }
    if(!is.null(x$conf.int)) {
	cat(format(100 * attr(x$conf.int, "conf.level")),
	    "percent confidence interval:\n",
            format(c(x$conf.int[1], x$conf.int[2])), "\n")
    }
    if(!is.null(x$estimate)) {
	cat("sample estimates:\n")
	print(x$estimate, ...)
    }
    cat("\n")
    invisible(x)
}
identical <-
  function(x, y)
  .Internal(identical(x,y))
identify <- function(x, ...) UseMethod("identify")

identify.default <- function(x, y=NULL, labels=seq(along=x), pos=FALSE,
			     n=length(x), plot=TRUE, offset=0.5, ...)
{
    if(length(extras <- list(...))) {
        opar <- par(extras)
        on.exit(par(opar))
    }
    xy <- xy.coords(x, y)
    x <- xy$x
    y <- xy$y
    if (length(x)==0){
        if (pos)
            return(list(ind=numeric(0), pos=numeric(0)))
        else
            return(numeric(0))
    }
    z <- .Internal(identify(x, y, as.character(labels), n, plot, offset))
    i <- seq(z[[1]])[z[[1]]]
    if(pos) list(ind = i, pos = z[[2]][z[[1]]]) else i
}
ifelse <-
    function (test, yes, no)
{
    storage.mode(test) <- "logical"
    ans <- test
    nas <- is.na(test)
    if (any(test[!nas])) {
        ans[test] <- rep(yes, length = length(ans))[test]
    }
    if (any(!test[!nas])) {
        ans[!test] <- rep(no, length = length(ans))[!test]
    }
    ans[nas] <- NA
    ans
}
image <- function(x, ...) UseMethod("image")

image.default <- function (x = seq(0, 1, len = nrow(z)),
		   y = seq(0, 1, len = ncol(z)),
		   z,
		   zlim = range(z[is.finite(z)]),
		   xlim = range(x[is.finite(x)]),
		   ylim = range(y[is.finite(y)]),
		   col = heat.colors(12), add = FALSE,
		   xaxs = "i", yaxs = "i", xlab, ylab,
                   breaks, oldstyle=FALSE, ...)
{
    if (missing(z)) {
	if (!missing(x)) {
	    if (is.list(x)) {
		z <- x$z; y <- x$y; x <- x$x
	    } else {
		if(is.null(dim(x)))
		   stop("argument must be matrix alike")
		z <- x
		x <- seq(0, 1, len = nrow(z))
	    }
	    if (missing(xlab)) xlab <- ""
	    if (missing(ylab)) ylab <- ""
	} else stop("no `z' matrix specified")
    } else if (is.list(x)) {
	xn <- deparse(substitute(x))
	if (missing(xlab)) xlab <- paste(xn, "x", sep = "$")
	if (missing(ylab)) ylab <- paste(xn, "y", sep = "$")
	y <- x$y
	x <- x$x
    } else {
	if (missing(xlab))
	    xlab <- if (missing(x)) "" else deparse(substitute(x))
	if (missing(ylab))
	    ylab <- if (missing(y)) "" else deparse(substitute(y))
    }
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
	stop("increasing x and y values expected")
    if (!is.matrix(z))
        stop("`z' must be a matrix")
    if (length(x) > 1 && length(x) == nrow(z)) { # midpoints
        dx <- 0.5*diff(x)
        x <- c(x[1] - dx[1], x[-length(x)]+dx,
               x[length(x)]+dx[length(x)-1])
    }
    if (length(y) > 1 && length(y) == ncol(z)) { # midpoints
        dy <- 0.5*diff(y)
        y <- c(y[1] - dy[1], y[-length(y)]+dy,
               y[length(y)]+dy[length(y)-1])
    }
    if (length(x) == 1) x <- par("usr")[1:2]
    if (length(y) == 1) y <- par("usr")[3:4]
    if (length(x) != nrow(z)+1 || length(y) != ncol(z)+1)
        stop("dimensions of z are not length(x)(+1) times length(y)(+1)")

    if (missing(breaks)) {
        nc <- length(col)
        if (any(!is.finite(zlim)) || diff(zlim) < 0)
            stop("invalid z limits")
        if (diff(zlim) == 0)
            zlim <- if (zlim[1] == 0) c(-1, 1)
                    else zlim[1] + c(-.4, .4)*abs(zlim[1])
        z <- (z - zlim[1])/diff(zlim)
        zi <- if (oldstyle) floor((nc - 1) * z + 0.5)
              else floor((nc - 1e-5) * z + 1e-7)
        zi[zi < 0 | zi >= nc] <- NA
    } else {
        if (length(breaks) != length(col) + 1)
            stop("must have one more break than colour")
        if (any(!is.finite(breaks)))
            stop("breaks must all be finite")
    zi <- .C("bincode",
             as.double(z), length(z), as.double(breaks), length(breaks),
             code = integer(length(z)), as.logical(TRUE), as.logical(TRUE),
             nok = TRUE,
             NAOK = TRUE, DUP = FALSE, PACKAGE = "base") $code - 1
    }
    if (!add)
	plot(0, 0, xlim = xlim, ylim = ylim, type = "n", xaxs = xaxs,
	     yaxs = yaxs, xlab = xlab, ylab = ylab, ...)
    .Internal(image(as.double(x), as.double(y), as.integer(zi), col))
}
index.search <- function(topic, path, file = "AnIndex", type = "help")
    .Internal(index.search(topic, path, file, .Platform$file.sep, type))

read.00Index <-
function(file)
{
    if(is.character(file)) {
        if(file == "") file <- stdin()
        else {
            file <- file(file, "r")
            on.exit(close(file))
        }
    }
    if(!inherits(file, "connection"))
        stop(paste("argument", sQuote("file"),
                   "must be a character string or connection"))

    y <- matrix("", nr = 0, nc = 2)
    x <- paste(readLines(file), collapse = "\n")

    ## <FIXME>
    ## We cannot necessarily assume that the 00Index-style file to be
    ## read in was generated by @code{R CMD Rdindex} or by R using
    ## formatDL(style = "table").  In particular, some packages have
    ## 00Index files with (section) headers and footers in addition to
    ## the data base chunks which are description lists rendered in
    ## tabular form.  Hence, we need some heuristic for identifying the
    ## db chunks.  Easy to the human eye (is there a column for aligning
    ## entries?) but far from trivial ... as a first approximation we
    ## try to consider chunks containing at least one tab or three
    ## spaces a db chunk.  (A better heuristic would be the following:
    ## entries rendered in one line have item and description separated
    ## by at least 3 spaces or tabs; entries with a line break have
    ## continuation lines starting with whitespace (no test whether for
    ## alignment).  If a chunk is made of such entries only it is
    ## considered a db chunk.  But not all current packages follow this
    ## scheme.  Argh.)
    ## Clearly we need to move to something better in future versions.
    ## </FIXME>

    ## First split into paragraph chunks separated by whitespace-only
    ## lines.
    for(chunk in unlist(strsplit(x, "\n[ \t\n]*\n"))) {
        entries <- try({
            if(regexpr("\(   \|\t\)", chunk) == -1)
                NULL
            else {
                ## Combine entries with continuation lines.
                chunk <- gsub("\n[ \t]+", "\t", chunk)
                ## Split into lines and then according to whitespace.
                x <- strsplit(unlist(strsplit(chunk, "\n")), "[ \t]")
                cbind(unlist(lapply(x, "[[", 1)),
                      unlist(lapply(x, function(t) {
                          paste(t[-c(1, which(nchar(t) == 0))],
                                collapse = " ")
                      })))
            }
        })
        if(!inherits(entries, "try-error") && NCOL(entries) == 2)
            y <- rbind(y, entries)
    }
    colnames(y) <- c("Item", "Description")
    y
}

print.libraryIQR <-
function(x, ...)
{
    db <- x$results
    ## Split according to LibPath.
    out <- if(nrow(db) == 0)
        NULL
    else lapply(split(1 : nrow(db), db[, "LibPath"]),
                function(ind) db[ind, c("Package", "Title"),
                                 drop = FALSE])
    outFile <- tempfile("RlibraryIQR")
    outConn <- file(outFile, open = "w")
    first <- TRUE
    for(lib in names(out)) {
        writeLines(paste(ifelse(first, "", "\n"),
                         "Packages in library ", sQuote(lib), ":\n",
                         sep = ""),
                   outConn)
        writeLines(formatDL(out[[lib]][, "Package"],
                            out[[lib]][, "Title"]),
                   outConn)
        first <- FALSE
    }
    if(first) {
        close(outConn)
        unlink(outFile)
        writeLines("no packages found")
    }
    else {
        if(!is.null(x$footer))
            writeLines(c("\n", x$footer), outConn)
        close(outConn)
        file.show(outFile, delete.file = TRUE,
                  title = "R packages available")
    }
    invisible(x)
}

print.packageIQR <-
function(x, ...)
{
    db <- x$results
    ## Split according to Package.
    out <- if(nrow(db) == 0)
         NULL
    else
        lapply(split(1 : nrow(db), db[, "Package"]),
               function(ind) db[ind, c("Item", "Title"),
                                drop = FALSE])
    outFile <- tempfile("RpackageIQR")
    outConn <- file(outFile, open = "w")
    first <- TRUE
    for(pkg in names(out)) {
        writeLines(paste(ifelse(first, "", "\n"), x$title,
                         " in package ", sQuote(pkg), ":\n",
                         sep = ""),
                   outConn)
        writeLines(formatDL(out[[pkg]][, "Item"],
                            out[[pkg]][, "Title"]),
                   outConn)
        first <- FALSE
    }
    if(first) {
        close(outConn)
        unlink(outFile)
        writeLines(paste("no", tolower(x$title), "found"))
    }
    else {
        if(!is.null(x$footer))
            writeLines(c("\n", x$footer), outConn)
        close(outConn)
        file.show(outFile, delete.file = TRUE,
                  title = paste("R", tolower(x$title)))
    }
    invisible(x)
}
integrate<- function(f, lower, upper, subdivisions=100,
		     rel.tol = .Machine$double.eps^.25,
		     abs.tol = rel.tol, stop.on.error = TRUE,
		     keep.xy = FALSE, aux = NULL, ...)
{
    f <- match.fun(f)
    ff <- function(x) f(x, ...)
    limit <- as.integer(subdivisions)
    if (limit < 1 || (abs.tol <= 0 &&
	rel.tol < max(50*.Machine$double.eps, 0.5e-28)))
	stop("invalid parameter values")
    if(is.finite(lower) && is.finite(upper)) {
	wk <- .External("call_dqags",
			ff, rho = environment(),
			as.double(lower), as.double(upper),
			as.double(abs.tol), as.double(rel.tol),
			limit = limit,
			PACKAGE = "base")
    } else { # indefinite integral
	if(is.na(lower) || is.na(upper)) stop("a limit is missing")
	if (is.finite(lower)) {
	    inf <- 1
	    bound <- lower
	} else if (is.finite(upper)) {
	    inf <- -1
	    bound <- upper
	} else {
	    inf <- 2
	    bound <- 0.0
	}
	wk <- .External("call_dqagi",
			ff, rho = environment(),
			as.double(bound), as.integer(inf),
			as.double(abs.tol), as.double(rel.tol),
			limit = limit,
			PACKAGE = "base")
    }
    res <- wk[c("value", "abs.error", "subdivisions")]
    res$message <-
	switch(wk$ierr + 1,
	       "OK",
	       "maximum number of subdivisions reached",
	       "roundoff error was detected",
	       "extremely bad integrand behaviour",
	       "roundoff error is detected in the extrapolation table",
	       "the integral is probably divergent",
	       "the input is invalid")
    if(wk$ierr == 6 || (wk$ierr > 0 && stop.on.error)) stop(res$message)
    res$call <- match.call()
    class(res) <- "integrate"
    res
}

print.integrate <- function (x, digits=getOption("digits"), ...)
{
    if(x$message == "OK") cat(format(x$value, digits=digits),
       " with absolute error < ", format(x$abs.error, digits=2),
       "\n", sep = "")
    else cat("failed with message `", x$message, "'\n", sep = "")
    invisible(x)
}
### This is almost like the Primitive ":" for factors
### (that has no "drop = TRUE") --- it's not used anywhere in "standard R"
interaction <- function(..., drop=FALSE)
{
    args <- list(...)
    narg <- length(args)
    if (narg == 1 && is.list(args[[1]])) {
	args <- args[[1]]
	narg <- length(args)
    }
    ans <- 0
    lvs <- NULL
    for(i in narg:1) {
        f <- args[[i]]
	if (!is.factor(f))
	    f <- factor(f)
	l <- levels(f)
	ans <- ans * length(l) + as.integer(f) - 1
	lvs <- if (i == narg) l	else as.vector(outer(l, lvs, paste, sep="."))
    }
    ans <- ans + 1
    if (drop) {
	f <- unique(ans[!is.na(ans)])
	ans <- match(ans, f)
	lvs <- lvs[f]
    }
    ans <- as.integer(ans)
    levels(ans) <- lvs
    class(ans) <- "factor"
    ans
}
interaction.plot <-
    function(x.factor, trace.factor, response, fun=mean,
             type = c("l", "p"), legend = TRUE,
             trace.label=deparse(substitute(trace.factor)), fixed=FALSE,
             xlab = deparse(substitute(x.factor)), ylab = ylabel,
             ylim = range(cells, na.rm=TRUE),
             lty = nc:1, col = 1, pch = c(1:9, 0, letters),
             xpd = NULL, leg.bg = par("bg"), leg.bty = "n",
             xtick = FALSE, xaxt = par("xaxt"), axes = TRUE, ...)
{
    ylabel <- paste(deparse(substitute(fun)), "of ",
                    deparse(substitute(response)))
    type <- match.arg(type)
    cells <- tapply(response, list(x.factor, trace.factor), fun)
    nr <- nrow(cells); nc <- ncol(cells)
    xvals <- 1:nr
    ## See if the x.factor labels are a sensible scale
    if(is.ordered(x.factor)) {
        wn <- getOption("warn")
        options(warn=-1)
        xnm <- as.numeric(levels(x.factor))
        options(warn=wn)
        if(!any(is.na(xnm))) xvals <- xnm
    }
    xlabs <- rownames(cells)
    ylabs <- colnames(cells)
    nch <- max(sapply(ylabs, nchar))
    if(is.null(xlabs)) xlabs <- as.character(xvals)
    if(is.null(ylabs)) ylabs <- as.character(1:nc)
    xlim <- range(xvals)
    xleg <- xlim[2] + 0.05 * diff(xlim)
    xlim <- xlim + c(-0.2/nr, if(legend) 0.2 + 0.02*nch else 0.2/nr) * diff(xlim)
    matplot(xvals, cells, ..., type = type,  xlim = xlim, ylim = ylim,
            xlab = xlab, ylab = ylab, axes = axes, xaxt = "n",
            col = col, lty = lty, pch = pch)
    ## old (<= 1.6.x)  mtext(xlabs, 1, at = xvals)
    ## new:
    if(axes && xaxt != "n") {
        mgp. <- par("mgp") ; if(!xtick) mgp.[2] <- 0
        axis(1, at = xvals, labels = xlabs, tick = xtick, mgp = mgp., xaxt = xaxt, ...)
    }
    if(legend) {
        yrng <- diff(ylim)
        yleg <- ylim[2] - 0.1 * yrng
        if(!is.null(xpd) || { xpd. <- par("xpd")
                              !is.na(xpd.) && !xpd. && (xpd <- TRUE)}) {
            op <- par(xpd = xpd)
            on.exit(par(op))
        }
        text(xleg, ylim[2] - 0.05 * yrng, paste("  ", trace.label), adj = 0)
        if(!fixed) {
            ## sort them on the value at the last level of x.factor
            ord <- sort.list(cells[nr,  ], decreasing = TRUE)
            ylabs <- ylabs[ord]
            lty <- lty[1 + (ord - 1) %% length(lty)]
            col <- col[1 + (ord - 1) %% length(col)]
            pch <- pch[ord]
        }
        if(type == "l")
            legend(xleg, yleg, legend = ylabs, col = col, lty = lty,
                   bty = leg.bty, bg = leg.bg)
        else
            legend(xleg, yleg, legend = ylabs, col = col, pch = pch,
                   bty = leg.bty, bg = leg.bg)
    }
    invisible()
}
is.vector <- function(x, mode="any") .Internal(is.vector(x,mode))
## is.finite <- function(x) !is.na(x)

is.name <- is.symbol # which is Primitive
##Was is.symbol <- function(x) typeof(x)=="symbol"


"is.na<-" <- function(x, value) UseMethod("is.na<-")

"is.na<-.default" <- function(x, value)
{
    x[value] <- NA
    x
}
### Unimplemented Idea {for amount = NULL ?}
### Really "optimal" (e.g. for rug()), use a non-constant amount,
### e.g. use "d" = diff(xx)  BEFORE  taking min()...

jitter <- function(x, factor = 1, amount=NULL)
{
    z <- diff(r <- range(x[is.finite(x)]))
    if(z == 0) z <- abs(r[1])
    if(z == 0) z <- 1

    if(is.null(amount)) {		# default: Find 'necessary' amount
	d <- diff(xx <- unique(sort(round(x, 3 - floor(log10(z))))))
	d <- if(length(d)) min(d) else if(xx!=0) xx/10 else z/10
	amount <- factor/5 * d
    } else if(amount == 0)		# only then: S compatibility
	amount <- factor * (z/50)

    x + runif(length(x),  - amount, amount)
}
kappa <- function(z, ...) UseMethod("kappa")

kappa.lm <- function(z, ...)
{
    kappa.qr(z$qr, ...)
}

kappa.default <- function(z, exact = FALSE, ...)
{
    z <- as.matrix(z)
    if(exact) {
	s <- svd(z, nu=0, nv=0)$d
	max(s)/min(s[s > 0])
    } else if(is.qr(z)) kappa.qr(z)
    else if(nrow(z) < ncol(z)) kappa.qr(qr(t(z)))
    else kappa.qr(qr(z))
}

kappa.qr <- function(z, ...)
{
    qr <- z$qr
    R <- qr[1:min(dim(qr)), , drop = FALSE]
    R[lower.tri(R)] <- 0
    kappa.tri(R, ...)
}

kappa.tri <- function(z, exact = FALSE, ...)
{
    if(exact) kappa.default(z)
    else {
	p <- nrow(z)
	if(p != ncol(z)) stop("matrix should be square")
	1 / .Fortran("dtrco",
		     as.double(z),
		     p,
		     p,
		     k = double(1),
		     double(p),
		     as.integer(1),
                     PACKAGE="base")$k
    }
}
"kronecker" <-
function (X, Y, FUN = "*", make.dimnames = FALSE, ...)
{
    X <- as.array(X)
    Y <- as.array(Y)
    if (make.dimnames) {
      dnx <- dimnames(X)
      dny <- dimnames(Y)
    }
    dX <- dim(X)
    dY <- dim(Y)
    ld <- length(dX) - length(dY)
    if (ld < 0)
        dX <- dim(X) <- c(dX, rep.int(1, -ld))
    else if (ld > 0)
        dY <- dim(Y) <- c(dY, rep.int(1, ld))
    opobj <- outer(X, Y, FUN, ...)
    dp <- as.vector(t(matrix(1:(2*length(dX)), ncol = 2)[, 2:1]))
    opobj <- aperm(opobj, dp)
    dim(opobj) <- dX * dY

    if (make.dimnames && !(is.null(dnx) && is.null(dny))) {

        if (is.null(dnx))
            dnx <- rep.int(list(NULL), length(dX))
        else if (ld < 0)
            dnx <- c(dnx, rep.int(list(NULL), -ld))
        tmp <- which(sapply(dnx, is.null))
        dnx[tmp] <- lapply(tmp, function(i) rep.int("", dX[i]))

        if (is.null(dny))
            dny <- rep.int(list(NULL), length(dY))
        else if (ld > 0)
            dny <- c(dny, rep.int(list(NULL), ld))
        tmp <- which(sapply(dny, is.null))
        dny[tmp] <- lapply(tmp, function(i) rep.int("", dY[i]))

        k <- length(dim(opobj))
        dno <- vector("list", k)
        for (i in 1:k) {
            tmp <- outer(dnx[[i]], dny[[i]], FUN="paste", sep=":")
            dno[[i]] <- as.vector(t(tmp))
        }
        dimnames(opobj) <- dno
    }
    opobj
}

## Binary operator, hence don't simply do "%x%" <- kronecker.
"%x%" <- function(X, Y) kronecker(X, Y)
labels <- function(object, ...) UseMethod("labels")

labels.default <- function(object, ...)
{
    if(length(d <- dim(object))) {	# array or data frame
	nt <- dimnames(object)
	if(is.null(nt)) nt <- vector("list", length(d))
	for(i in 1:length(d))
	    if(!length(nt[[i]])) nt[[i]] <- as.character(seq(length = d[i]))
    } else {
	nt <- names(object)
	if(!length(nt)) nt <- as.character(seq(along = object))
    }
    nt
}

labels.terms <- function(object, ...) attr(object, "term.labels")

labels.lm <- function(object, ...)
{
    tl <- attr(object$terms, "term.labels")
    asgn <- object$asgn[object$qr$pivot[1:object$rank]]
    tl[unique(asgn)]
}
lapply <- function (X, FUN, ...)
{
    FUN <- match.fun(FUN)
    if (!is.list(X)) X <- as.list(X)
    rval <-.Internal(lapply(X, FUN))
    names(rval) <- names(X)
    return(rval)
}
if(FALSE) {
lapply <- function(X, FUN, ...) {
    FUN <- match.fun(FUN)
    if (!is.list(X))
	X <- as.list(X)
    rval <- vector("list", length(X))
    for(i in seq(along = X))
	rval[i] <- list(FUN(X[[i]], ...))
    names(rval) <- names(X)		  # keep `names' !
    return(rval)
}
}
lcm <- function(x) paste(x, "cm")#-> 3 characters (used in layout!)

layout <-
    function(mat, widths=rep(1, dim(mat)[2]),
	     heights=rep(1, dim(mat)[1]), respect=FALSE)
{
    storage.mode(mat) <- "integer"
    mat <- as.matrix(mat) # or barf
    if(!is.logical(respect)) {
	respect <- as.matrix(respect)#or barf
	if(!is.matrix(respect) || any(dim(respect) != dim(mat)))
	    stop("'respect' must be logical or matrix with same dimension as 'mat'")
    }
    num.figures <- as.integer(max(mat))
    ## check that each value in 1..n is mentioned
    for (i in 1:num.figures)
	if (match(i, mat, nomatch=0) == 0)
	    stop(paste("Layout matrix must contain at least one reference\n",
		       "  to each of the values {1..n}; here  n = ",
		       num.figures,"\n", sep=""))

    dm <- dim(mat)
    num.rows <- dm[1]
    num.cols <- dm[2]

    cm.widths  <- if (is.character(widths)) grep("cm", widths, fixed = TRUE)
    cm.heights <- if (is.character(heights)) grep("cm", heights, fixed = TRUE)

    ## pad widths/heights with 1's	and remove "cm" tags
    pad1.rm.cm <- function(v, cm.v, len) {
	if ((ll <- length(v)) < len)
	    v <- c(v, rep.int(1, len-ll))
	if (is.character(v)) {
	    wcm <- v[cm.v]
	    v[cm.v] <- substring(wcm, 1, nchar(wcm)-3)
	}
	as.numeric(v)
    }
    widths  <- pad1.rm.cm(widths, cm.widths,  len = num.cols)
    heights <- pad1.rm.cm(heights,cm.heights, len = num.rows)

    if (is.matrix(respect)) {
	respect.mat <- as.integer(respect)
	respect <- 2
    } else {# respect: logical	|--> 0 or 1
	respect.mat <- matrix(as.integer(0), num.rows, num.cols)
    }
    .Internal(layout(num.rows, num.cols,
		     mat,# integer
		     as.integer(num.figures),
		     col.widths = widths,
		     row.heights = heights,
		     cm.widths,
		     cm.heights,
		     respect = as.integer(respect),
		     respect.mat))
    invisible(num.figures)
}

layout.show <- function(n=1)
{
    ## cheat to make sure that current plot is figure 1
    oma.saved <- par("oma")
    par(oma=rep.int(0,4))
    par(oma=oma.saved)

    o.par <- par(mar=rep.int(0,4))
    on.exit(par(o.par))
    for (i in seq(length=n)) {
	plot.new()
	box()
	text(0.5, 0.5, i)
    }
}
legend <-
function(x, y = NULL, legend, fill=NULL, col = "black", lty, lwd, pch,
	 angle = NULL, density = NULL, bty = "o",
	 bg = par("bg"), pt.bg = NA, cex = 1,
	 xjust = 0, yjust = 1, x.intersp = 1, y.intersp = 1, adj = c(0, 0.5),
	 text.width = NULL, merge = do.lines && has.pch, trace = FALSE,
	 plot = TRUE, ncol = 1, horiz = FALSE)
{
    ## the 2nd arg may really be `legend'
    if(missing(legend) && !missing(y) &&
       (is.character(y) || is.expression(y))) {
        legend <- y
        y <- NULL
    }
    mfill <- !missing(fill) || !missing(density)

    xy <- xy.coords(x, y); x <- xy$x; y <- xy$y
    nx <- length(x)
    if (nx < 1 || nx > 2) stop("invalid coordinate lengths")

    xlog <- par("xlog")
    ylog <- par("ylog")

    rect2 <- function(left, top, dx, dy, density = NULL, angle, ...) {
	r <- left + dx; if(xlog) { left <- 10^left; r <- 10^r }
	b <- top  - dy; if(ylog) {  top <- 10^top;  b <- 10^b }
	rect(left, top, r, b, angle = angle, density = density, ...)
    }
    segments2 <- function(x1, y1, dx, dy, ...) {
	x2 <- x1 + dx; if(xlog) { x1 <- 10^x1; x2 <- 10^x2 }
	y2 <- y1 + dy; if(ylog) { y1 <- 10^y1; y2 <- 10^y2 }
	segments(x1, y1, x2, y2, ...)
    }
    points2 <- function(x, y, ...) {
	if(xlog) x <- 10^x
	if(ylog) y <- 10^y
	points(x, y, ...)
    }
    text2 <- function(x, y, ...) {
	##--- need to adjust  adj == c(xadj, yadj) ?? --
	if(xlog) x <- 10^x
	if(ylog) y <- 10^y
	text(x, y, ...)
    }
    if(trace)
	catn <- function(...)
	    do.call("cat", c(lapply(list(...),formatC), list("\n")))

    cin <- par("cin")
    Cex <- cex * par("cex")		# = the `effective' cex for text

    if(is.null(text.width))
	text.width <- max(strwidth(legend, units="user", cex=cex))
    else if(!is.numeric(text.width) || text.width < 0)
	stop("text.width must be numeric, >= 0")

    xc <- Cex * xinch(cin[1], warn.log=FALSE)# [uses par("usr") and "pin"]
    yc <- Cex * yinch(cin[2], warn.log=FALSE)

    xchar  <- xc
    yextra <- yc * (y.intersp - 1)
    ymax   <- max(yc, strheight(legend, units="user", cex=cex))
    ychar <- yextra + ymax
    if(trace) catn("  xchar=", xchar, "; (yextra,ychar)=", c(yextra,ychar))

    if(mfill) {
	##= sizes of filled boxes.
	xbox <- xc * 0.8
	ybox <- yc * 0.5
	dx.fill <- xbox ## + x.intersp*xchar
    }
    do.lines <- (!missing(lty) && (is.character(lty) || any(lty > 0))
		 ) || !missing(lwd)
    n.leg <- if(is.call(legend)) 1 else length(legend)

    ## legends per column:
    n.legpercol <-
	if(horiz) {
	    if(ncol != 1)
		warning(
		    "horizontal specification overrides: Number of columns := ",
			n.leg)
	    ncol <- n.leg
	    1
	} else ceiling(n.leg / ncol)

    if(has.pch <- !missing(pch)) {
	if(is.character(pch) && !is.na(pch[1]) && nchar(pch[1]) > 1) {
	    if(length(pch) > 1)
		warning("Not using pch[2..] since pch[1] has multiple chars")
	    np <- nchar(pch[1])
	    pch <- substr(rep.int(pch[1], np), 1:np, 1:np)
	}
	if(!merge) dx.pch <- x.intersp/2 * xchar
    }
    x.off <- if(merge) -0.7 else 0

    ##- Adjust (x,y) :
    if (xlog) x <- log10(x)
    if (ylog) y <- log10(y)

    if(nx == 2) {
	## (x,y) are specifiying OPPOSITE corners of the box
	x <- sort(x)
	y <- sort(y)
	left <- x[1]
	top  <- y[2]
	w <- diff(x)# width
	h <- diff(y)# height
	w0 <- w/ncol # column width

	x <- mean(x)
	y <- mean(y)
	if(missing(xjust)) xjust <- 0.5
	if(missing(yjust)) yjust <- 0.5

    }
    else {## nx == 1
	## -- (w,h) := (width,height) of the box to draw -- computed in steps
	h <- n.legpercol * ychar + yc
	w0 <- text.width + (x.intersp + 1) * xchar
	if(mfill)	w0 <- w0 + dx.fill
	if(has.pch && !merge)	w0 <- w0 + dx.pch
	if(do.lines)		w0 <- w0 + (2+x.off) * xchar
	w <- ncol*w0 + .5* xchar
	##-- (w,h) are now the final box width/height.
	left <- x      - xjust	* w
	top  <- y + (1 - yjust) * h
    }

    if (plot && bty != "n") { ## The legend box :
	if(trace)
	    catn("  rect2(",left,",",top,", w=",w,", h=",h,", ...)",sep="")
	rect2(left, top, dx = w, dy = h, col = bg, density = NULL)
    }
    ## (xt[],yt[]) := `current' vectors of (x/y) legend text
    xt <- left + xchar + (w0 * rep.int(0:(ncol-1),
                                       rep.int(n.legpercol,ncol)))[1:n.leg]
    yt <- top - (rep.int(1:n.legpercol,ncol)[1:n.leg]-1) * ychar -
        0.5 * yextra - ymax

    if (mfill) {		#- draw filled boxes -------------
	if(plot) {
	    fill <- rep(fill, length.out = n.leg)
	    rect2(left = xt, top=yt+ybox/2, dx = xbox, dy = ybox,
		  col = fill,
                  density = density, angle = angle, border = "black")
	}
	xt <- xt + dx.fill
    }
    if(plot && (has.pch || do.lines))
	col <- rep(col, length.out = n.leg)

    if (do.lines) {			#- draw lines ---------------------
	seg.len <- 2 # length of drawn segment, in xchar units
	if(missing(lty)) lty <- 1
	ok.l <- !is.na(lty) & (is.character(lty) | lty > 0)
	if(missing(lwd)) lwd <- par("lwd")
	lty <- rep(lty, length.out = n.leg)
	lwd <- rep(lwd, length.out = n.leg)
	if(trace)
	    catn("  segments2(",xt[ok.l] + x.off*xchar, ",", yt[ok.l],
		 ", dx=", seg.len*xchar, ", dy=0, ...)")
	if(plot)
	    segments2(xt[ok.l] + x.off*xchar, yt[ok.l], dx= seg.len*xchar, dy=0,
		      lty = lty[ok.l], lwd = lwd[ok.l], col = col[ok.l])
	# if (!merge)
	xt <- xt + (seg.len+x.off) * xchar
    }
    if (has.pch) {			#- draw points -------------------
	pch   <- rep(pch, length.out = n.leg)
	pt.bg <- rep(pt.bg, length.out = n.leg)
	ok <- !is.na(pch) & (is.character(pch) | pch >= 0)
	x1 <- (if(merge) xt-(seg.len/2)*xchar else xt)[ok]
	y1 <- yt[ok]
	if(trace)
	    catn("  points2(", x1,",", y1,", pch=", pch[ok],", ...)")
	if(plot)
	    points2(x1, y1, pch = pch[ok], col= col[ok], cex=cex, bg= pt.bg[ok])
	if (!merge) xt <- xt + dx.pch
    }

    xt <- xt + x.intersp * xchar
    if(plot)
	text2(xt, yt, labels = legend, adj = adj, cex = cex)

    invisible(list(rect = list(w = w, h = h, left = left, top = top),
		   text = list(x = xt, y = yt)))
}
library <-
function(package, help, pos = 2, lib.loc = NULL, character.only = FALSE,
         logical.return = FALSE, warn.conflicts = TRUE,
         keep.source = getOption("keep.source.pkgs"),
         verbose = getOption("verbose"), version)
{
    testRversion <- function(fields)
    {
        current <- paste(R.version[c("major", "minor")], collapse = ".")
        ## depends on R version?
        if(!package.dependencies(fields, check = TRUE)) {
            dep <- package.dependencies(fields)[[1]]
            o <- match("R", dep[, 1])
            stop(paste("This is R ", current, ", package ",
                       fields[1, "Package"],
                       " needs ", dep[o, 2], " ", dep[o, 3], sep=""),
                 call. = FALSE)
        }
        ## which version was this package built under?
        if(!is.na(built <- fields[1, "Built"])) {
            builtFields <- strsplit(built, ";")[[1]]
            builtunder <- substring(builtFields[1], 3)
            if(nchar(builtunder) &&
               compareVersion(current, builtunder) < 0) {
                warning(paste("package", fields[1, "Package"],
                              "was built under R version", builtunder),
                        call. = FALSE)
            }
            if(.Platform$OS.type == "unix") {
                platform <- builtFields[2]
                if(length(grep("\\w", platform))) {
                    ## allow for small mismatches, e.g. OS version number.
                    m <- agrep(platform, R.version$platform)
                    if(!length(m))
                        stop(paste("package", fields[1, "Package"],
                                   "was built for", platform),
                             call. = FALSE)
		}
            }
        }
        else
            stop(paste("This package has not been installed properly\n",
                       "See the Note in ?library"))
    }

    checkNoGenerics <- function(env)
    {
        if (exists(".noGenerics", envir = env, inherits = FALSE))
            TRUE
        else {
            ## A package will have created a generic
            ## only if it has created a formal method.
            length(objects(env, pattern="^\\.__M", all=TRUE)) == 0
        }
    }

    checkConflicts <- function(package, pkgname, pkgpath, nogenerics)
    {
        dont.mind <- c("last.dump", "last.warning", ".Last.value",
                       ".Random.seed", ".First.lib", ".Last.lib",
                       ".packageName", ".noGenerics", ".required")
        sp <- search()
        lib.pos <- match(pkgname, sp)
        ## ignore generics not defined for the package
        ob <- objects(lib.pos, all = TRUE)
        if(!nogenerics && .isMethodsDispatchOn()) {
            gen <- methods::getGenerics(lib.pos)
            gen <- gen[methods::slot(gen, "package") != ".GlobalEnv"]
            ob <- ob[!(ob %in% gen)]
        }
        fst <- TRUE
        ipos <- seq(along = sp)[-c(lib.pos, match("Autoloads", sp))]
        for (i in ipos) {
            obj.same <- match(objects(i, all = TRUE), ob, nomatch = 0)
            if (any(obj.same > 0)) {
                same <- ob[obj.same]
                same <- same[!(same %in% dont.mind)]
                Classobjs <- grep("^\\.__", same)
                if(length(Classobjs)) same <- same[-Classobjs]
                if(length(same)) {
                    if (fst) {
                        fst <- FALSE
                        cat("\nAttaching package ", sQuote(package),
                            ":\n\n", sep = "")
                    }
                    cat("\n\tThe following object(s) are masked",
                        if (i < lib.pos) "_by_" else "from", sp[i],
                        ":\n\n\t", same, "\n\n")
                }
            }
        }
    }

    libraryPkgName <- function(pkgName, sep = "_")
	unlist(strsplit(pkgName, sep))[1]

    libraryPkgVersion <- function(pkgName, sep = "_")
    {
        splitName <- unlist(strsplit(pkgName, sep))
	if (length(splitName) > 1) splitName[2] else NULL
    }

    libraryMaxVersPos <- function(vers)
    {
	## Takes in a character vector of version numbers
        ## returns the position of the maximum version utilizing
        ## compareVersion.  Can't do as.numeric due to the "-" in versions.
	max <- vers[1]

        for (ver in vers) if (compareVersion(max, ver) < 0) max <- ver
	out <- match(max, vers)
	out
    }

    if (is.null(lib.loc)) lib.loc <- .libPaths()

    if(!missing(package)) {
	if(!character.only)
	    package <- as.character(substitute(package))

	if (!missing(version)) {
	     package <- manglePackageName(package, version)
        }
	else {
	   ## Need to find the proper package to install
	   pkgDirs <- list.files(lib.loc,
                                 pattern = paste("^", package, sep=""))
           ## See if any directories in lib.loc match the pattern of
           ## 'package', if none do, just continue as it will get caught
           ## below.  Otherwise, if there is actually a 'package', use
           ## that, and if not, then use the highest versioned dir.
	   if (length(pkgDirs) > 0) {
	       if (!(package %in% pkgDirs)) {
		   ## Need to find the highest version available
		   vers <- unlist(lapply(pkgDirs, libraryPkgVersion))
		   pos <- libraryMaxVersPos(vers)
		   if (length(pos) > 0)
			   package <- pkgDirs[pos]
               }
           }
        }

        if(length(package) != 1)
            stop(paste("argument", sQuote("package"),
                       "must be of length 1"))
	pkgname <- paste("package", package, sep = ":")
	newpackage <- is.na(match(pkgname, search()))
	if(newpackage) {
            ## Check for the methods package before attaching this
            ## package.
            ## Only if it is _already_ here do we do cacheMetaData.
            ## The methods package caches all other libs when it is
            ## attached.
            ## Note for detail: this does _not_ test whether dispatch is
            ## currently on, but rather whether the package is attached
            ## (cf .isMethodsDispatchOn).
            hadMethods <- .isMethodsDispatchOn()

            pkgpath <- .find.package(package, lib.loc, quiet = TRUE,
                                     verbose = verbose)
            if(length(pkgpath) == 0) {
               txt <- paste("There is no package called",
			     sQuote(libraryPkgName(package)))
		vers <- libraryPkgVersion(package)
		if (!is.null(vers))
		   txt <- paste(txt, ", version ", vers, sep="")
                if(logical.return) {
                    warning(txt)
		    return(FALSE)
		} else stop(txt)
            }
            which.lib.loc <- dirname(pkgpath)
            descfile <- system.file("DESCRIPTION", package = package,
                                    lib.loc = which.lib.loc)
            if(!nchar(descfile))
            	stop("This is not a valid package -- no DESCRIPTION exists")

            descfields <- read.dcf(descfile, fields =
                           c("Package", "Depends", "Built"))
            testRversion(descfields)

            ## Check for inconsistent naming
            if(descfields[1, "Package"] != libraryPkgName(package)) {
            	warning(paste("Package", sQuote(package), "not found.\n",
			"Using case-insensitive match",
            		sQuote(descfields[1, "Package"]), ".\n",
			"Future versions of R will require exact matches."),
			call.=FALSE)
            	package <- descfields[1, "Package"]
            	pkgname <- paste("package", package, sep = ":")
            	newpackage <- is.na(match(pkgname, search()))
	    }
            if(is.character(pos)) {
                npos <- match(pos, search())
                if(is.na(npos)) {
                    warning(paste(sQuote(pos),
                                  "not found on search path, using",
                                  sQuote("pos=2")))
                    pos <- 2
                } else pos <- npos
            }
            if(newpackage) {
		## If the name space mechanism is available and the package
		## has a name space, then the name space loading mechanism
		## takes over.
		if (packageHasNamespace(package, which.lib.loc)) {
		    tt <- try({
			ns <- loadNamespace(package, c(which.lib.loc, lib.loc))
			env <- attachNamespace(ns, pos = pos)
		    })
		    if (inherits(tt, "try-error"))
			if (logical.return)
			    return(FALSE)
			else stop("package/namespace load failed")
		    else {
			on.exit(do.call("detach", list(name = pkgname)))
			nogenerics <- checkNoGenerics(env)
			if(warn.conflicts &&
			   !exists(".conflicts.OK", envir = env, inherits = FALSE))
                            checkConflicts(package, pkgname, pkgpath, nogenerics)

                        if(!nogenerics && hadMethods &&
                           !identical(pkgname, "package:methods"))
                            cacheMetaData(env, TRUE, searchWhere = .GlobalEnv)
			on.exit()
			if (logical.return)
			    return(TRUE)
			else
			    return(invisible(.packages()))
		    }
		}
		codeFile <- file.path(which.lib.loc, package, "R",
				      package)
		## create environment (not attached yet)
		loadenv <- new.env(hash = TRUE, parent = .GlobalEnv)
		## save the package name in the environment
		assign(".packageName", package, envir = loadenv)
		## source file into loadenv
		if(file.exists(codeFile))
		    sys.source(codeFile, loadenv, keep.source = keep.source)
		else if(verbose)
		    warning(paste("Package ", sQuote(package),
				  "contains no R code"))
		## now transfer contents of loadenv to an attached frame
		env <- attach(NULL, pos = pos, name = pkgname)
		## detach does not allow character vector args
		on.exit(do.call("detach", list(name = pkgname)))
		attr(env, "path") <- file.path(which.lib.loc, package)
		## the actual copy has to be done by C code to avoid forcing
		## promises that might have been created using delay().
		.Internal(lib.fixup(loadenv, env))

		## run .First.lib
		if(exists(".First.lib", mode = "function",
                          envir = env, inherits = FALSE)) {
		    firstlib <- get(".First.lib", mode = "function",
                                    envir = env, inherits = FALSE)
		    tt<- try(firstlib(which.lib.loc, package))
		    if(inherits(tt, "try-error"))
			if (logical.return) return(FALSE)
			else stop(".First.lib failed")
		}
		if(!is.null(firstlib <- getOption(".First.lib")[[package]])){
		    tt<- try(firstlib(which.lib.loc, package))
		    if(inherits(tt, "try-error"))
			if (logical.return) return(FALSE)
			else stop(".First.lib failed")
		}
		nogenerics <- checkNoGenerics(env)
		if(warn.conflicts &&
		   !exists(".conflicts.OK", envir = env, inherits = FALSE))
		    checkConflicts(package, pkgname, pkgpath, nogenerics)

		if(!nogenerics && hadMethods &&
		   !identical(pkgname, "package:methods"))
                    cacheMetaData(env, TRUE, searchWhere = .GlobalEnv)
		on.exit()
	    }
	}
	if (verbose && !newpackage)
            warning(paste("Package", sQuote(package),
                          "already present in search()"))
    }
    else if(!missing(help)) {
	if(!character.only)
	    help <- as.character(substitute(help))
        pkgName <- help[1]              # only give help on one package
        pkgPath <- .find.package(pkgName, lib.loc, verbose = verbose)
        docFiles <- file.path(pkgPath, c("DESCRIPTION", "INDEX"))
        ## This is a bit ugly, but in the future we might also have
        ## DESCRIPTION or INDEX files as serialized R objects ...
        if(file.exists(vignetteIndexRDS <-
                       file.path(pkgPath, "Meta", "vignette.rds")))
            docFiles <- c(docFiles, vignetteIndexRDS)
        else
            docFiles <- c(docFiles,
                          file.path(pkgPath, "doc", "00Index.dcf"))
        pkgInfo <- vector(length = 4, mode = "list")
        pkgInfo[[1]] <- paste("\n\t\tInformation on Package",
                              sQuote(pkgName))
        readDocFile <- function(f) {
            if(basename(f) %in% c("DESCRIPTION", "00Index.dcf")) {
                ## This should be in valid DCF format ...
                txt <- try(read.dcf(f))
                if(inherits(txt, "try-error")) {
                    warning(paste("file",
                                  sQuote(f),
                                  "is not in valid DCF format"))
                    return(NULL)
                }
                ## Return a list so that the print method knows to
                ## format as a description list (if non-empty).
                txt <- if(all(dim(txt) >= 1))
                    list(colnames(txt), as.character(txt[1, ]))
                else
                    NULL
            }
            else if(basename(f) %in% c("vignette.rds")) {
                txt <- .readRDS(f)
                ## New-style vignette indexes are data frames with more
                ## info than just the base name of the PDF file and the
                ## title.  For such an index, we give the names of the
                ## vignettes, their titles, and indicate whether PDFs
                ## are available.
                ## The index might have zero rows.
                txt <- if(is.data.frame(txt) && nrow(txt))
                    cbind(basename(gsub("\\.[[:alpha:]]+$", "",
                                        txt$File)),
                          paste(txt$Title,
                                paste(rep.int("(source", NROW(txt)),
                                      ifelse(txt$PDF != "",
                                             ", pdf",
                                             ""),
                                      ")", sep = "")))
                else NULL
            }
            else
                txt <- readLines(f)
            txt
        }
        for(i in which(file.exists(docFiles)))
            pkgInfo[[i+1]] <- readDocFile(docFiles[i])
        y <- list(name = pkgName, path = pkgPath, info = pkgInfo)
        class(y) <- "packageInfo"
        return(y)
    }
    else {
	## library():
        if(is.null(lib.loc))
            lib.loc <- .libPaths()
        db <- matrix(character(0), nr = 0, nc = 3)
        nopkgs <- character(0)

        for(lib in lib.loc) {
            a <- .packages(all.available = TRUE, lib.loc = lib)
            for(i in sort(a)) {
                title <- package.description(i, lib.loc = lib, field="Title")
                if(is.na(title)) title <- ""
                db <- rbind(db, cbind(i, lib, title))
            }
            if(length(a) == 0)
                nopkgs <- c(nopkgs, lib)
        }
        colnames(db) <- c("Package", "LibPath", "Title")
        if((length(nopkgs) > 0) && !missing(lib.loc)) {
            if(length(nopkgs) > 1)
                warning(paste("libraries",
                              paste(sQuote(nopkgs), collapse = ", "),
                              "contain no packages"))
            else
                warning(paste("library",
                              paste(sQuote(nopkgs)),
                              "contains no package"))
        }

        y <- list(header = NULL, results = db, footer = NULL)
        class(y) <- "libraryIQR"
        return(y)
    }

    if (logical.return)
	TRUE
    else invisible(.packages())
}

library.dynam <-
function(chname, package = .packages(), lib.loc = NULL, verbose =
         getOption("verbose"), file.ext = .Platform$dynlib.ext, ...)
{
    .Dyn.libs <- .dynLibs()
    if(missing(chname) || (ncChname <- nchar(chname)) == 0)
        return(.Dyn.libs)
    ncFileExt <- nchar(file.ext)
    if(substr(chname, ncChname - ncFileExt + 1, ncChname) == file.ext)
        chname <- substr(chname, 1, ncChname - ncFileExt)
    if(is.na(match(chname, .Dyn.libs))) {
        for(pkg in .find.package(package, lib.loc, verbose = verbose)) {
            file <- file.path(pkg, "libs",
                              paste(chname, file.ext, sep = ""))
            if(file.exists(file)) break
            else
                file <- ""
        }
        if(file == "") {
            stop(paste("shared library", sQuote(chname), "not found"))
        }
        if(verbose)
            cat("now dyn.load(", file, ") ...\n", sep = "")
        dyn.load(file, ...)
        .dynLibs(c(.Dyn.libs, chname))
    }
    invisible(.dynLibs())
}

library.dynam.unload <-
function(chname, libpath, verbose = getOption("verbose"),
         file.ext = .Platform$dynlib.ext)
{
    .Dyn.libs <- .dynLibs()
    if(missing(chname) || (ncChname <- nchar(chname)) == 0)
        stop("no shared library was specified")
    ncFileExt <- nchar(file.ext)
    if(substr(chname, ncChname - ncFileExt + 1, ncChname) == file.ext)
        chname <- substr(chname, 1, ncChname - ncFileExt)
    num <- match(chname, .Dyn.libs, 0)
    if(is.na(num))
        stop(paste("shared library", sQuote(chname), "was not loaded"))
    file <- file.path(libpath, "libs", paste(chname, file.ext, sep = ""))
    if(!file.exists(file))
        stop(paste("shared library", sQuote(chname), "not found"))
    if(verbose)
        cat("now dyn.unload(", file, ") ...\n", sep = "")
    dyn.unload(file)
    .dynLibs(.Dyn.libs[-num])
    invisible(.dynLibs())
}

require <-
function(package, quietly = FALSE, warn.conflicts = TRUE,
         keep.source = getOption("keep.source.pkgs"),
         character.only = FALSE, version, save = TRUE)
{
    if( !character.only )
        package <- as.character(substitute(package)) # allowing "require(eda)"
    if (missing(version))
        pkgName <- package
    else
        pkgName <- manglePackageName(package, version)


    if (is.na(match(paste("package", pkgName, sep = ":"), search()))) {
	if (!quietly) cat("Loading required package:", package, "\n")
	value <- library(package, character.only = TRUE, logical = TRUE,
		warn.conflicts = warn.conflicts, keep.source = keep.source,
                version = version)
    } else value <- TRUE

    if(identical(save, FALSE)) {}
    else {
        ## update the ".required" variable
        if(identical(save, TRUE)) {
            save <- topenv(parent.frame())
            ## (a package namespace, topLevelEnvironment option or
            ## .GlobalEnv)
            if(identical(save, .GlobalEnv)) {
                ## try to detect call from .First.lib in  a package
                ## <FIXME>
                ## Although the docs have long and perhaps always had
                ##   .First.lib(libname, pkgname)
                ## the majority of CRAN packages seems to use arguments
                ## 'lib' and 'pkg'.
                objectsInParentFrame <- sort(objects(parent.frame()))
                if(identical(sort(c("libname", "pkgname")),
                             objectsInParentFrame))
                    save <-
                        as.environment(paste("package:",
                                             get("pkgname",
                                                 parent.frame()),
                                             sep = ""))
                else if(identical(sort(c("lib", "pkg")),
                                  objectsInParentFrame))
                    save <-
                        as.environment(paste("package:",
                                             get("pkg",
                                                 parent.frame()),
                                             sep = ""))
                ## </FIXME>
                ## else either from prompt or in the source for install
                ## with saved image ? 
            }
        }
        else
            save <- as.environment(save)
        hasDotRequired <- exists(".required", save, inherits=FALSE)
        if(!isNamespace(save) || hasDotRequired) { ## so assignment allowed
            if(hasDotRequired)
                packages <- unique(c(package, get(".required", save)))
            else
                packages <- package
            assign(".required", packages, save)
        }
    }
    value
}

.packages <- function(all.available = FALSE, lib.loc = NULL)
{
    if(is.null(lib.loc))
        lib.loc <- .libPaths()
    if(all.available) {
	ans <- character(0)
        lib.loc <- lib.loc[file.exists(lib.loc)]
        for(lib in lib.loc) {
            a <- list.files(lib, all.files = FALSE, full.names = FALSE)
            for(nam in a) {
                if(file.exists(file.path(lib, nam, "DESCRIPTION")))
                    ans <- c(ans, nam)
            }
        }
        return(unique(ans))
    } ## else
    s <- search()
    return(invisible(substring(s[substr(s, 1, 8) == "package:"], 9)))
}

.path.package <- function(package = .packages(), quiet = FALSE)
{
    if(length(package) == 0) return(character(0))
    s <- search()
    searchpaths <-
        lapply(1:length(s), function(i) attr(as.environment(i), "path"))
    searchpaths[[length(s)]] <- system.file()
    pkgs <- paste("package", package, sep = ":")
    pos <- match(pkgs, s)
    if(any(m <- is.na(pos))) {
        if(!quiet) {
            if(all(m))
                stop(paste("none of the packages are loaded"))
            else
                warning(paste("package(s)",
                              paste(package[m], collapse=", "),
                              "are not loaded"))
        }
        pos <- pos[!m]
    }
    unlist(searchpaths[pos], use.names = FALSE)
}

.find.package <-
    function(package, lib.loc = NULL, quiet = FALSE,
             verbose = getOption("verbose"))
{
    .filePathAsAbsolute <- function(x) {
        ## Note that we cannot use tools::filePathAsAbsolute() here, as
        ## cyclic name space dependencies are not supported.  Argh.
        ## This version is simpler: we only need it for directories
        ## already known to exist.
        cwd <- getwd(); on.exit(setwd(cwd))
        setwd(path.expand(x))
        getwd()
    }
    
    useAttached <- FALSE
    if(is.null(lib.loc)) {
        useAttached <- TRUE
        lib.loc <- .libPaths()
    }

    n <- length(package)
    if(n == 0) return(character(0))

    bad <- character(0)                 # names of packages not found
    paths <- character(0)               # paths to packages found

    for(pkg in package) {
        fp <- file.path(lib.loc, pkg)
        if(useAttached)
            fp <- c(.path.package(pkg, TRUE), fp)
        ## Note that we cannot use tools::fileTest() here, as cyclic
        ## name space dependencies are not supported.  Argh.
        fp <- unique(fp[file.exists(fp) &
                        file.exists(file.path(fp, "DESCRIPTION"))])
        if(length(fp) == 0) {
            bad <- c(bad, pkg)
            next
        }
        afp <- .filePathAsAbsolute(fp[1])
        if(verbose && (length(fp) > 1))
            warning(paste("package ", sQuote(pkg),
                          " found more than once,\n",
                          "using the one found in ",
                          sQuote(dirname(afp)),
                          sep = ""))
        paths <- c(paths, afp)
    }

    if(!quiet && (length(bad) > 0)) {
        if(length(paths) == 0)
            stop("none of the packages were found")
        for(pkg in bad)
            warning(paste("there is no package called", sQuote(pkg)))
    }

    paths
}

print.packageInfo <- function(x, ...)
{
    if(!inherits(x, "packageInfo")) stop("wrong class")
    outFile <- tempfile("RpackageInfo")
    outConn <- file(outFile, open = "w")
    vignetteMsg <-
        paste("Further information is available in the following ",
              "vignettes in directory ",
              sQuote(file.path(x$path, "doc")),
              ":",
              sep = "")
    headers <- c("", "Description:\n\n", "Index:\n\n",
                 paste(paste(strwrap(vignetteMsg), collapse = "\n"),
                       "\n\n", sep = ""))
    footers <- c("\n", "\n", "\n", "")
    formatDocEntry <- function(entry) {
        if(is.list(entry) || is.matrix(entry))
            formatDL(entry, style = "list")
        else
            entry
    }
    for(i in which(!sapply(x$info, is.null))) {
        writeLines(headers[i], outConn, sep = "")
        writeLines(formatDocEntry(x$info[[i]]), outConn)
        writeLines(footers[i], outConn, sep = "")
    }
    close(outConn)
    file.show(outFile, delete.file = TRUE,
              title = paste("Documentation for package",
              sQuote(x$name)))
    invisible(x)
}

manglePackageName <- function(pkgName, pkgVersion)
    paste(pkgName, "_", pkgVersion, sep = "")
licence <- license <- function() {
    cat("\nThis software is distributed under the terms of the GNU GENERAL\n")
    cat("PUBLIC LICENSE Version 2, June 1991.  The terms of this license\n")
    cat("are in a file called COPYING which you should have received with\n")
    cat("this software.\n")
    cat("\n")
    cat("If you have not received a copy of this file, you can obtain one\n")
    cat("via WWW at http://www.gnu.org/copyleft/gpl.html, or by writing to:\n")
    cat("\n")
    cat("   The Free Software Foundation, Inc.,\n")
    cat("   59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.\n")
    cat("\n")
    cat("A small number of files (the API header files and export files,\n")
    cat("listed in R_HOME/COPYRIGHTS) are distributed under the\n")
    cat("LESSER GNU GENERAL PUBLIC LICENSE version 2.1.\n")
    cat("This can be obtained via WWW at\n")
    cat("http://www.gnu.org/copyleft/lgpl.html, or by writing to the\n")
    cat("address above\n")
    cat("\n")
    cat("``Share and Enjoy.''\n\n")
}
lines <- function(x, ...) UseMethod("lines")

lines.default <- function(x, y=NULL, type="l", col=par("col"),
                          lty=par("lty"), ...)
{
    plot.xy(xy.coords(x, y), type=type, col=col, lty=lty, ...)
}
lm <- function (formula, data = list(), subset, weights, na.action,
		method = "qr", model = TRUE, x = FALSE, y = FALSE,
		qr = TRUE, singular.ok = TRUE, contrasts = NULL,
		offset = NULL, ...)
{
    ret.x <- x
    ret.y <- y
##    mt <- terms(formula, data = data)
    cl <- match.call()
    mf <- match.call(expand.dots = FALSE)
    mf$singular.ok <- mf$model <- mf$method <- NULL
    mf$x <- mf$y <- mf$qr <- mf$contrasts <- mf$... <- NULL
    mf$drop.unused.levels <- TRUE
    mf[[1]] <- as.name("model.frame")
    mf <- eval(mf, parent.frame())
    if (method == "model.frame")
	return(mf)
    else if (method != "qr")
	warning("method = ", method, " is not supported. Using \"qr\".")
    mt <- attr(mf, "terms") # allow model.frame to update it
    na.act <- attr(mf, "na.action")
    xvars <- as.character(attr(mt, "variables"))[-1]
    if((yvar <- attr(mt, "response")) > 0) xvars <- xvars[-yvar]
    xlev <-
	if(length(xvars) > 0) {
	    xlev <- lapply(mf[xvars], levels)
	    xlev[!sapply(xlev, is.null)]
	}
    if (!singular.ok)
	warning("only `singular.ok = TRUE' is currently implemented.")
    y <- model.response(mf, "numeric")
    w <- model.weights(mf)
    offset <- model.offset(mf)
    if(!is.null(offset) && length(offset) != NROW(y))
	stop("Number of offsets is ", length(offset),
             ", should equal ", NROW(y), " (number of observations)")

    if (is.empty.model(mt)) {
	x <- NULL
	z <- list(coefficients = numeric(0), residuals = y,
		  fitted.values = 0 * y, weights = w, rank = 0,
		  df.residual = length(y))
        if(!is.null(offset)) z$fitted.values <- offset
    }
    else {
	x <- model.matrix(mt, mf, contrasts)
	z <- if(is.null(w)) lm.fit(x, y, offset = offset,
                                   singular.ok=singular.ok, ...)
	else lm.wfit(x, y, w, offset = offset, singular.ok=singular.ok, ...)
    }
    class(z) <- c(if(is.matrix(y)) "mlm", "lm")
    if(!is.null(na.act)) z$na.action <- na.act
    z$offset <- offset
    z$contrasts <- attr(x, "contrasts")
    z$xlevels <- xlev
    z$call <- cl
    z$terms <- mt
    if (model)
	z$model <- mf
    if (ret.x)
	z$x <- x
    if (ret.y)
	z$y <- y
    z
}

## lm.fit() and lm.wfit() have *MUCH* in common  [say ``code re-use !'']
lm.fit <- function (x, y, offset = NULL, method = "qr", tol = 1e-07,
                    singular.ok = TRUE, ...)
{
    if (is.null(n <- nrow(x))) stop("`x' must be a matrix")
    if(n == 0) stop("0 (non-NA) cases")
    p <- ncol(x)
    if (p == 0) {
        ## oops, null model
        return(list(coefficients = numeric(0), residuals = y,
                    fitted.values = 0 * y, rank = 0,
                    df.residual = length(y)))
    }
    ny <- NCOL(y)
    ## treat one-col matrix as vector
    if(is.matrix(y) && ny == 1)
        y <- drop(y)
    if(!is.null(offset))
        y <- y - offset
    if (NROW(y) != n)
	stop("incompatible dimensions")
    if(method != "qr")
	warning("method = ",method, " is not supported. Using \"qr\".")
    if(length(list(...)))
	warning("Extra arguments ", deparse(substitute(...)),
                " are just disregarded.")
    storage.mode(x) <- "double"
    storage.mode(y) <- "double"
    z <- .Fortran("dqrls",
		  qr = x, n = n, p = p,
		  y = y, ny = ny,
		  tol = as.double(tol),
		  coefficients = mat.or.vec(p, ny),
		  residuals = y, effects = y, rank = integer(1),
		  pivot = 1:p, qraux = double(p), work = double(2*p),
                  PACKAGE="base")
    if(!singular.ok && z$rank == 0)
        stop("singular fit encountered")
    coef <- z$coefficients
    pivot <- z$pivot
    ## careful here: the rank might be 0
    r1 <- seq(len=z$rank)
    dn <- colnames(x); if(is.null(dn)) dn <- paste("x", 1:p, sep="")
    nmeffects <- c(dn[pivot[r1]], rep.int("", n - z$rank))
    r2 <- if(z$rank < p) (z$rank+1):p else integer(0)
    if (is.matrix(y)) {
	coef[r2, ] <- NA
	coef[pivot, ] <- coef
	dimnames(coef) <- list(dn, colnames(y))
	dimnames(z$effects) <- list(nmeffects, colnames(y))
    } else {
	coef[r2] <- NA
	coef[pivot] <- coef
	names(coef) <- dn
	names(z$effects) <- nmeffects
    }
    z$coefficients <- coef
    r1 <- y - z$residuals ; if(!is.null(offset)) r1 <- r1 + offset
    qr <- z[c("qr", "qraux", "pivot", "tol", "rank")]
    colnames(qr$qr) <- colnames(x)[qr$pivot]
    c(z[c("coefficients", "residuals", "effects", "rank")],
      list(fitted.values = r1, assign = attr(x, "assign"),
	   qr = structure(qr, class="qr"),
	   df.residual = n - z$rank))
}

lm.wfit <- function (x, y, w, offset = NULL, method = "qr", tol = 1e-7,
                     singular.ok = TRUE, ...)
{
    if(is.null(n <- nrow(x))) stop("'x' must be a matrix")
    if(n == 0) stop("0 (non-NA) cases")
    ny <- NCOL(y)
    ## treat one-col matrix as vector
    if(is.matrix(y) && ny == 1)
        y <- drop(y)
    if(!is.null(offset))
        y <- y - offset
    if (NROW(y) != n | length(w) != n)
	stop("incompatible dimensions")
    if (any(w < 0 | is.na(w)))
	stop("missing or negative weights not allowed")
    if(method != "qr")
	warning("method = ",method, " is not supported. Using \"qr\".")
    if(length(list(...)))
	warning("Extra arguments ", deparse(substitute(...)),
                " are just disregarded.")
    x.asgn <- attr(x, "assign")# save
    zero.weights <- any(w == 0)
    if (zero.weights) {
	save.r <- y
	save.f <- y
	save.w <- w
	ok <- w != 0
	nok <- !ok
	w <- w[ok]
	x0 <- x[!ok, , drop = FALSE]
	x <- x[ok,  , drop = FALSE]
	n <- nrow(x)
	y0 <- if (ny > 1) y[!ok, , drop = FALSE] else y[!ok]
	y  <- if (ny > 1) y[ ok, , drop = FALSE] else y[ok]
    }
    p <- ncol(x)
    if (p == 0) {
        ## oops, null model
        return(list(coefficients = numeric(0), residuals = y,
                    fitted.values = 0 * y, weights = w, rank = 0,
                    df.residual = length(y)))
    }
    storage.mode(y) <- "double"
    wts <- sqrt(w)
    z <- .Fortran("dqrls",
		  qr = x * wts, n = n, p = p,
		  y  = y * wts, ny = ny,
		  tol = as.double(tol),
		  coefficients = mat.or.vec(p, ny), residuals = y,
		  effects = mat.or.vec(n, ny),
		  rank = integer(1), pivot = 1:p, qraux = double(p),
		  work = double(2 * p),
                  PACKAGE="base")
    if(!singular.ok && z$rank == 0)
        stop("singular fit encountered")
    coef <- z$coefficients
    pivot <- z$pivot
    r1 <- seq(len=z$rank)
    dn <- colnames(x); if(is.null(dn)) dn <- paste("x", 1:p, sep="")
    nmeffects <- c(dn[pivot[r1]], rep.int("", n - z$rank))
    r2 <- if(z$rank < p) (z$rank+1):p else integer(0)
    if (is.matrix(y)) {
	coef[r2, ] <- NA
	coef[pivot, ] <- coef
	dimnames(coef) <- list(dn, colnames(y))
	dimnames(z$effects) <- list(nmeffects,colnames(y))
    } else {
	coef[r2] <- NA
	coef[pivot] <- coef
	names(coef) <- dn
	names(z$effects) <- nmeffects
    }
    z$coefficients <- coef
    z$residuals <- z$residuals/wts
    z$fitted.values <- y - z$residuals
    z$weights <- w
    if (zero.weights) {
	coef[is.na(coef)] <- 0
	f0 <- x0 %*% coef
	if (ny > 1) {
	    save.r[ok, ] <- z$residuals
	    save.r[nok, ] <- y0 - f0
	    save.f[ok, ] <- z$fitted.values
	    save.f[nok, ] <- f0
	}
	else {
	    save.r[ok] <- z$residuals
	    save.r[nok] <- y0 - f0
	    save.f[ok] <- z$fitted.values
	    save.f[nok] <- f0
	}
	z$residuals <- save.r
	z$fitted.values <- save.f
	z$weights <- save.w
    }
    if(!is.null(offset))
        z$fitted.values <- z$fitted.values + offset
    qr <- z[c("qr", "qraux", "pivot", "tol", "rank")]
    colnames(qr$qr) <- colnames(x)[qr$pivot]
    c(z[c("coefficients", "residuals", "fitted.values", "effects",
	  "weights", "rank")],
      list(assign = x.asgn,
	   qr = structure(qr, class="qr"),
	   df.residual = n - z$rank))
}

print.lm <- function(x, digits = max(3, getOption("digits") - 3), ...)
{
    cat("\nCall:\n",deparse(x$call),"\n\n",sep="")
    if(length(coef(x))) {
        cat("Coefficients:\n")
        print.default(format(coef(x), digits=digits),
                      print.gap = 2, quote = FALSE)
    } else cat("No coefficients\n")
    cat("\n")
    invisible(x)
}

summary.lm <- function (object, correlation = FALSE, symbolic.cor = FALSE, ...)
{
    z <- object
    p <- z$rank
    if (p == 0) {
        r <- z$residuals
        n <- length(r)
        w <- z$weights
        if (is.null(w)) {
            rss <- sum(r^2)
        } else {
            rss <- sum(w * r^2)
            r <- sqrt(w) * r
        }
        resvar <- rss/(n - p)
        ans <- z[c("call", "terms")]
        class(ans) <- "summary.lm"
        ans$aliased <- is.na(coef(object))  # used in print method
        ans$residuals <- r
        ans$df <- c(0, n, length(ans$aliased))
        ans$coefficients <- matrix(NA, 0, 4)
        dimnames(ans$coefficients)<-
            list(NULL, c("Estimate", "Std. Error", "t value", "Pr(>|t|)"))
        ans$sigma <- sqrt(resvar)
        ans$r.squared <- ans$adj.r.squared <- 0
        return(ans)
    }
    Qr <- object$qr
    if (is.null(z$terms) || is.null(Qr))
	stop("invalid \'lm\' object:  no terms nor qr component")
    n <- NROW(Qr$qr)
    rdf <- n - p
    if(rdf != z$df.residual)
        warning("inconsistent residual degrees of freedom. -- please report!")
    p1 <- 1:p
    ## do not want missing values substituted here
    r <- z$residuals
    f <- z$fitted
    w <- z$weights
    if (is.null(w)) {
        mss <- if (attr(z$terms, "intercept"))
            sum((f - mean(f))^2) else sum(f^2)
        rss <- sum(r^2)
    } else {
        mss <- if (attr(z$terms, "intercept")) {
            m <- sum(w * f /sum(w))
            sum(w * (f - m)^2)
        } else sum(w * f^2)
        rss <- sum(w * r^2)
        r <- sqrt(w) * r
    }
    resvar <- rss/rdf
    R <- chol2inv(Qr$qr[p1, p1, drop = FALSE])
    se <- sqrt(diag(R) * resvar)
    est <- z$coefficients[Qr$pivot[p1]]
    tval <- est/se
    ans <- z[c("call", "terms")]
    ans$residuals <- r
    ans$coefficients <-
	cbind(est, se, tval, 2*pt(abs(tval), rdf, lower.tail = FALSE))
    dimnames(ans$coefficients)<-
	list(names(z$coefficients)[Qr$pivot[p1]],
	     c("Estimate", "Std. Error", "t value", "Pr(>|t|)"))
    ans$aliased <- is.na(coef(object))  # used in print method
    ans$sigma <- sqrt(resvar)
    ans$df <- c(p, rdf, NCOL(Qr$qr))
    if (p != attr(z$terms, "intercept")) {
	df.int <- if (attr(z$terms, "intercept")) 1 else 0
	ans$r.squared <- mss/(mss + rss)
	ans$adj.r.squared <- 1 - (1 - ans$r.squared) * ((n - df.int)/rdf)
	ans$fstatistic <- c(value = (mss/(p - df.int))/resvar,
			    numdf = p - df.int, dendf = rdf)
    } else ans$r.squared <- ans$adj.r.squared <- 0
    ans$cov.unscaled <- R
    dimnames(ans$cov.unscaled) <- dimnames(ans$coefficients)[c(1,1)]
    if (correlation) {
	ans$correlation <- (R * resvar)/outer(se, se)
	dimnames(ans$correlation) <- dimnames(ans$cov.unscaled)
        ans$symbolic.cor <- symbolic.cor
    }
    class(ans) <- "summary.lm"
    ans
}

print.summary.lm <-
    function (x, digits = max(3, getOption("digits") - 3),
              symbolic.cor = x$symbolic.cor,
	      signif.stars= getOption("show.signif.stars"),	...)
{
    cat("\nCall:\n")#S: ' ' instead of '\n'
    cat(paste(deparse(x$call), sep="\n", collapse = "\n"), "\n\n", sep="")
    resid <- x$residuals
    df <- x$df
    rdf <- df[2]
    cat(if(!is.null(x$w) && diff(range(x$w))) "Weighted ",
        "Residuals:\n", sep="")
    if (rdf > 5) {
	nam <- c("Min", "1Q", "Median", "3Q", "Max")
	rq <- if (length(dim(resid)) == 2)
	    structure(apply(t(resid), 1, quantile),
		      dimnames = list(nam, dimnames(resid)[[2]]))
	else  structure(quantile(resid), names = nam)
	print(rq, digits = digits, ...)
    }
    else if (rdf > 0) {
	print(resid, digits = digits, ...)
    } else { # rdf == 0 : perfect fit!
	cat("ALL", df[1], "residuals are 0: no residual degrees of freedom!\n")
    }
    if (length(x$aliased) == 0) {
        cat("\nNo Coefficients\n")
    } else {
        if (nsingular <- df[3] - df[1])
            cat("\nCoefficients: (", nsingular,
                " not defined because of singularities)\n", sep = "")
        else cat("\nCoefficients:\n")
        coefs <- x$coefficients
        if(!is.null(aliased <- x$aliased) && any(aliased)) {
            cn <- names(aliased)
            coefs <- matrix(NA, length(aliased), 4, dimnames=list(cn, colnames(coefs)))
            coefs[!aliased, ] <- x$coefficients
        }

        printCoefmat(coefs, digits=digits, signif.stars=signif.stars, na.print="NA", ...)
    }
    ##
    cat("\nResidual standard error:",
	format(signif(x$sigma, digits)), "on", rdf, "degrees of freedom\n")
    if (!is.null(x$fstatistic)) {
	cat("Multiple R-Squared:", formatC(x$r.squared, digits=digits))
	cat(",\tAdjusted R-squared:",formatC(x$adj.r.squared,digits=digits),
	    "\nF-statistic:", formatC(x$fstatistic[1], digits=digits),
	    "on", x$fstatistic[2], "and",
	    x$fstatistic[3], "DF,  p-value:",
	    format.pval(pf(x$fstatistic[1], x$fstatistic[2],
                           x$fstatistic[3], lower.tail = FALSE), digits=digits),
	    "\n")
    }
    correl <- x$correlation
    if (!is.null(correl)) {
	p <- NCOL(correl)
	if (p > 1) {
	    cat("\nCorrelation of Coefficients:\n")
	    if(is.logical(symbolic.cor) && symbolic.cor) {# NULL < 1.7.0 objects
		print(symnum(correl, abbr.col = NULL))
	    } else {
                correl <- format(round(correl, 2), nsmall = 2, digits = digits)
                correl[!lower.tri(correl)] <- ""
                print(correl[-1, -p, drop=FALSE], quote = FALSE)
            }
	}
    }
    cat("\n")#- not in S
    invisible(x)
}

residuals.lm <-
    function(object,
             type = c("working","response", "deviance","pearson", "partial"),
             ...)
{
    type <- match.arg(type)
    r <- object$residuals
    res <- switch(type,
                  working =, response = r,
                  deviance=, pearson =
                  if(is.null(object$weights)) r else r * sqrt(object$weights),
                  partial = r + predict(object,type="terms")
           )
    if(is.null(object$na.action)) res
    else naresid(object$na.action, res)
}

fitted.lm <- function(object, ...)
{
    if(is.null(object$na.action)) object$fitted.values
    else napredict(object$na.action, object$fitted.values)
}

coef.lm <- function(object, ...) object$coefficients

## need this for results of lm.fit() in drop1():
weights.default <- function(object, ...)
{
    if(is.null(object$na.action)) object$weights
    else naresid(object$na.action, object$weights)
}


deviance.lm <- function(object, ...)
    sum(weighted.residuals(object)^2, na.rm=TRUE)

formula.lm <- function(x, ...)
{
    form <- x$formula
    if( !is.null(form) )
        return(form)
    formula(x$terms)
}

family.lm <- function(object, ...) { gaussian() }

model.frame.lm <- function(formula, data, na.action, ...) {
    if (is.null(formula$model)) {
        fcall <- formula$call
        fcall$method <- "model.frame"
        fcall[[1]] <- as.name("lm")
	env <- environment(fcall$formula)
	if (is.null(env)) env <- parent.frame()
        eval(fcall, env)
    }
    else formula$model
}

variable.names.lm <- function(object, full=FALSE, ...)
{
    if(full)	dimnames(object$qr$qr)[[2]]
    else if(object$rank) dimnames(object$qr$qr)[[2]][seq(len=object$rank)]
    else character(0)
}

case.names.lm <- function(object, full=FALSE, ...)
{
    w <- weights(object)
    dn <- names(residuals(object))
    if(full || is.null(w)) dn else dn[w!=0]
}

anova.lm <- function(object, ...)
{
    if(length(list(object, ...)) > 1)
	return(anova.lmlist(object, ...))
    w <- object$weights
    ssr <- sum(if(is.null(w)) object$resid^2 else w*object$resid^2)
    dfr <- df.residual(object)
    p <- object$rank
    if(p > 0) {
        p1 <- 1:p
        comp <- object$effects[p1]
        asgn <- object$assign[object$qr$pivot][p1]
        nmeffects <- c("(Intercept)", attr(object$terms, "term.labels"))
        tlabels <- nmeffects[1 + unique(asgn)]
        ss <- c(unlist(lapply(split(comp^2,asgn), sum)), ssr)
        df <- c(unlist(lapply(split(asgn,  asgn), length)), dfr)
    } else {
        ss <- ssr
        df <- dfr
        tlabels <- character(0)
    }
    ms <- ss/df
    f <- ms/(ssr/dfr)
    P <- pf(f, df, dfr, lower.tail = FALSE)
    table <- data.frame(df, ss, ms, f, P)
    table[length(P), 4:5] <- NA
    dimnames(table) <- list(c(tlabels, "Residuals"),
                            c("Df","Sum Sq", "Mean Sq", "F value", "Pr(>F)"))
    if(attr(object$terms,"intercept")) table <- table[-1, ]
    structure(table, heading = c("Analysis of Variance Table\n",
		     paste("Response:", deparse(formula(object)[[2]]))),
	      class= c("anova", "data.frame"))# was "tabular"
}

anova.lmlist <- function (object, ..., scale = 0, test = "F")
{
    objects <- list(object, ...)
    responses <- as.character(lapply(objects,
				     function(x) deparse(x$terms[[2]])))
    sameresp <- responses == responses[1]
    if (!all(sameresp)) {
	objects <- objects[sameresp]
	warning("Models with response ",
                deparse(responses[!sameresp]),
                " removed because response differs from ", "model 1")
    }

    ns <- sapply(objects, function(x) length(x$residuals))
    if(any(ns != ns[1]))
        stop("models were not all fitted to the same size of dataset")

    ## calculate the number of models
    nmodels <- length(objects)
    if (nmodels == 1)
	return(anova.lm(object))

    ## extract statistics

    resdf  <- as.numeric(lapply(objects, df.residual))
    resdev <- as.numeric(lapply(objects, deviance))

    ## construct table and title

    table <- data.frame(resdf, resdev, c(NA, -diff(resdf)),
                        c(NA, -diff(resdev)) )
    variables <- lapply(objects, function(x)
                        paste(deparse(formula(x)), collapse="\n") )
    dimnames(table) <- list(1:nmodels,
                            c("Res.Df", "RSS", "Df", "Sum of Sq"))

    title <- "Analysis of Variance Table\n"
    topnote <- paste("Model ", format(1:nmodels),": ",
		     variables, sep="", collapse="\n")

    ## calculate test statistic if needed

    if(!is.null(test)) {
	bigmodel <- order(resdf)[1]
        scale <- if(scale > 0) scale else resdev[bigmodel]/resdf[bigmodel]
	table <- stat.anova(table = table, test = test,
			    scale = scale,
                            df.scale = resdf[bigmodel],
			    n = length(objects[bigmodel$residuals]))
    }
    structure(table, heading = c(title, topnote),
              class = c("anova", "data.frame"))
}


## code originally from John Maindonald 26Jul2000
predict.lm <-
    function(object, newdata, se.fit = FALSE, scale = NULL, df = Inf,
	     interval = c("none", "confidence", "prediction"),
	     level = .95,  type = c("response", "terms"),
	     terms = NULL, na.action = na.pass, ...)
{
    tt <- terms(object)
    if(missing(newdata) || is.null(newdata)) {
	mm <- X <- model.matrix(object)
	mmDone <- TRUE
	offset <- object$offset
    }
    else {
        Terms <- delete.response(tt)
        m <- model.frame(Terms, newdata, na.action = na.action,
                         xlev = object$xlevels)
        X <- model.matrix(Terms, m, contrasts = object$contrasts)
	offset <- if (!is.null(off.num <- attr(tt, "offset")))
	    eval(attr(tt, "variables")[[off.num+1]], newdata)
	else if (!is.null(object$offset))
	    eval(object$call$offset, newdata)
	mmDone <- FALSE
    }
    n <- length(object$residuals) # NROW(object$qr$qr)
    p <- object$rank
    p1 <- seq(len=p)
    piv <- object$qr$pivot[p1]
    if(p < ncol(X) && !(missing(newdata) || is.null(newdata)))
	warning("prediction from a rank-deficient fit may be misleading")
### NB: Q[p1,] %*% X[,piv] = R[p1,p1]
    beta <- object$coefficients
    predictor <- drop(X[, piv, drop = FALSE] %*% beta[piv])
    if (!is.null(offset))
	predictor <- predictor + offset
    interval <- match.arg(interval)
    type <- match.arg(type)
    if(se.fit || interval != "none") {
	res.var <-
	    if (is.null(scale)) {
		r <- object$residuals
		w <- object$weights
		rss <- sum(if(is.null(w)) r^2 else r^2 * w)
		df <- n - p
		rss/df
	    } else scale^2
	if(type != "terms") {
            if(p > 0) {
                XRinv <-
                    if(missing(newdata) && is.null(w))
                        qr.Q(object$qr)[, p1, drop = FALSE]
                    else
                        X[, piv] %*% qr.solve(qr.R(object$qr)[p1, p1])
#	NB:
#	 qr.Q(object$qr)[, p1, drop = FALSE] / sqrt(w)
#	looks faster than the above, but it's slower, and doesn't handle zero
#	weights properly
#
                ip <- drop(XRinv^2 %*% rep(res.var, p))
            } else ip <- rep(0, n)
	}
    }

    if (type == "terms") { ## type == "terms" ------------

	if(!mmDone) { mm <- model.matrix(object); mmDone <- TRUE }
	## asgn <- attrassign(mm, tt) :
	aa <- attr(mm, "assign")
	ll <- attr(tt, "term.labels")
	if (attr(tt, "intercept") > 0)
	    ll <- c("(Intercept)", ll)
	aaa <- factor(aa, labels = ll)
	asgn <- split(order(aa), aaa)
	hasintercept <- attr(tt, "intercept") > 0
	if (hasintercept) {
	    asgn$"(Intercept)" <- NULL
	    if(!mmDone) { mm <- model.matrix(object); mmDone <- TRUE }
	    avx <- colMeans(mm)
	    termsconst <- sum(avx[piv] * beta[piv])
	}
	nterms <- length(asgn)
        if(nterms > 0) {
            predictor <- matrix(ncol = nterms, nrow = NROW(X))
            dimnames(predictor) <- list(rownames(X), names(asgn))

            if (se.fit || interval != "none") {
                ip <- matrix(ncol = nterms, nrow = NROW(X))
                dimnames(ip) <- list(rownames(X), names(asgn))
                Rinv <- qr.solve(qr.R(object$qr)[p1, p1])
            }
            if(hasintercept)
                X <- sweep(X, 2, avx)
            unpiv <- rep.int(0, NCOL(X))
            unpiv[piv] <- p1
            ## Predicted values will be set to 0 for any term that
            ## corresponds to columns of the X-matrix that are
            ## completely aliased with earlier columns.
            for (i in seq(1, nterms, length = nterms)) {
                iipiv <- asgn[[i]]      # Columns of X, ith term
                ii <- unpiv[iipiv]      # Corresponding rows of Rinv
                iipiv[ii == 0] <- 0
                predictor[, i] <-
                    if(any(iipiv) > 0) X[, iipiv, drop = FALSE] %*% beta[iipiv]
                    else 0
                if (se.fit || interval != "none")
                    ip[, i] <-
                        if(any(iipiv) > 0)
                            as.matrix(X[, iipiv, drop = FALSE] %*%
                                      Rinv[ii, , drop = FALSE])^2 %*% rep.int(res.var, p)
                        else 0
            }
            if (!is.null(terms)) {
                predictor <- predictor[, terms, drop = FALSE]
                if (se.fit)
                    ip <- ip[, terms, drop = FALSE]
            }
        } else { # no terms
            predictor <- ip <- matrix(0, n,0)
        }
	attr(predictor, 'constant') <- if (hasintercept) termsconst else 0
    }

### Now construct elements of the list that will be returned

    if(interval != "none") {
	tfrac <- qt((1 - level)/2, df)
	hwid <- tfrac * switch(interval,
			       confidence = sqrt(ip),
			       prediction = sqrt(ip+res.var)
			       )
	if(type != "terms") {
	    predictor <- cbind(predictor, predictor + hwid %o% c(1, -1))
	    colnames(predictor) <- c("fit", "lwr", "upr")
	}
	else {
	    lwr <- predictor + hwid
	    upr <- predictor - hwid
	}
    }
    if(se.fit || interval != "none") se <- sqrt(ip)
    if(missing(newdata) && !is.null(na.act <- object$na.action)) {
	predictor <- napredict(na.act, predictor)
	if(se.fit) se <- napredict(na.act, se)
    }
    if(type == "terms" && interval != "none") {
	if(missing(newdata) && !is.null(na.act)) {
	    lwr <- napredict(na.act, lwr)
	    upr <- napredict(na.act, upr)
	}
	list(fit = predictor, se.fit = se, lwr = lwr, upr = upr,
	     df = df, residual.scale = sqrt(res.var))
    } else if (se.fit)
	list(fit = predictor, se.fit = se,
	     df = df, residual.scale = sqrt(res.var))
    else predictor
}

effects.lm <- function(object, set.sign = FALSE, ...)
{
    eff <- object$effects
    if(is.null(eff)) stop("object has no effects component")
    if(set.sign) {
	dd <- coef(object)
	if(is.matrix(eff)) {
	    r <- 1:dim(dd)[1]
	    eff[r,  ] <- sign(dd) * abs(eff[r,	])
	} else {
	    r <- 1:length(dd)
	    eff[r] <- sign(dd) * abs(eff[r])
	}
    }
    structure(eff, assign = object$assign, class = "coef")
}

## plot.lm --> now in ./plot.lm.R

model.matrix.lm <- function(object, ...)
{
    if(n <- match("x", names(object), 0)) object[[n]]
    else {
#         if(length(object$coefficients) == 0) {
#             rval <- matrix(ncol=0, nrow=length(object$residuals))
#             attr(rval,"assign") <- integer(0)
#             rval
#         } else {
            data <- model.frame(object, xlev = object$xlevels, ...)
            NextMethod("model.matrix", data = data,
                       contrasts = object$contrasts)
#        }
    }
}

##---> SEE ./mlm.R  for more methods, etc. !!
predict.mlm <-
    function(object, newdata, se.fit = FALSE, na.action = na.pass, ...)
{
    if(missing(newdata)) return(object$fitted)
    if(se.fit)
	stop("The 'se.fit' argument is not yet implemented for mlm objects")
    if(missing(newdata)) {
        X <- model.matrix(object)
        offset <- object$offset
    }
    else {
        tt <- terms(object)
        Terms <- delete.response(tt)
        m <- model.frame(Terms, newdata, na.action = na.action,
                         xlev = object$xlevels)
        X <- model.matrix(Terms, m, contrasts = object$contrasts)
	offset <- if (!is.null(off.num <- attr(tt, "offset")))
	    eval(attr(tt, "variables")[[off.num+1]], newdata)
	else if (!is.null(object$offset))
	    eval(object$call$offset, newdata)
    }
    piv <- object$qr$pivot[seq(object$rank)]
    pred <- X[, piv, drop = FALSE] %*% object$coefficients[piv,]
    if ( !is.null(offset) ) pred <- pred + offset
    if(inherits(object, "mlm")) pred else pred[, 1]
}
### "lm"  *and*	 "glm"	 leave-one-out influence measures

## this is mainly for back-compatibility (from "lsfit" time) -- use hatvalues()!
hat <- function(x, intercept = TRUE)
{
    if(is.qr(x)) n <- nrow(x$qr)
    else {
	if(intercept) x <- cbind(1, x)
	n <- nrow(x)
	x <- qr(x)
    }
    apply(qr.qy(x, diag(1, nrow = n, ncol = x$rank))^2, 1, sum)
}

weighted.residuals <- function(obj, drop0 = TRUE)
{
    w <- weights(obj)
    r <- residuals(obj)
    if(is.null(w))
	r
    else if(drop0)
	(sqrt(w)*r)[w != 0]
    else
	sqrt(w)*r
}

lm.influence <- function (model, do.coef = TRUE)
{
    wt.res <- if(inherits(model, "glm"))
        residuals(model, type="deviance")[model$prior.weights != 0]
    else weighted.residuals(model)
    e <- na.omit(wt.res)

    if (model$rank == 0) {
        n <- length(wt.res) # drops 0 wt, may drop NAs
        sigma <- sqrt(deviance(model)/df.residual(model))
        res <- list(hat = rep(0, n), coefficients = matrix(0, n, 0),
                    sigma = rep(sigma, n), wt.res = e)
    } else {
        ## if we have a point with hat = 1, the corresponding e should be
        ## exactly zero.  Protect against returning Inf by forcing this
        e[abs(e) < 100 * .Machine$double.eps * median(abs(e))] <- 0
        n <- as.integer(nrow(model$qr$qr))
        k <- as.integer(model$qr$rank)
        ## in na.exclude case, omit NAs; also drop 0-weight cases
        if(NROW(e) != n)
            stop("non-NA residual length does not match cases used in fitting")
        do.coef <- as.logical(do.coef)
        res <- .Fortran("lminfl",
                        model$qr$qr,
                        n,
                        n,
                        k,
                        as.integer(do.coef),
                        model$qr$qraux,
                        wt.res = e,
                        hat = double(n),
                        coefficients= if(do.coef) matrix(0, n, k) else double(0),
                        sigma = double(n),
                        tol = 10 * .Machine$double.eps,
                        DUP = FALSE, PACKAGE="base"
                        )[c("hat", "coefficients", "sigma","wt.res")]
        if(!is.null(model$na.action)) {
            hat <- naresid(model$na.action, res$hat)
            hat[is.na(hat)] <- 0       # omitted cases have 0 leverage
            res$hat <- hat
            if(do.coef) {
                coefficients <- naresid(model$na.action, res$coefficients)
                coefficients[is.na(coefficients)] <- 0 # omitted cases have 0 change
                res$coefficients <- coefficients
            }
            sigma <- naresid(model$na.action, res$sigma)
            sigma[is.na(sigma)] <- sqrt(deviance(model)/df.residual(model))
            res$sigma <- sigma
        }
    }
    res$wt.res <- naresid(model$na.action, res$wt.res)
    names(res$hat) <- names(res$sigma) <- names(res$wt.res)
    if(!do.coef) ## drop it
	res$coefficients <- NULL
    else {
        rownames(res$coefficients) <- names(res$wt.res)
        colnames(res$coefficients) <- names(coef(model))[!is.na(coef(model))]
    }
    res
}

## The following is adapted from John Fox's  "car" :
influence <- function(model, ...) UseMethod("influence")
influence.lm  <- function(model, do.coef = TRUE, ...)
    lm.influence(model, do.coef = do.coef, ...)
influence.glm <- function(model, do.coef = TRUE, ...) {
    res <- lm.influence(model, do.coef = do.coef, ...)
    pRes <- na.omit(residuals(model, type = "pearson"))[model$prior.weights != 0]
    if(!is.null(model$na.action)) pRes <- naresid(model$na.action, pRes)
    names(res)[names(res) == "wt.res"] <- "dev.res"
    c(res, list(pear.res = pRes))
}

hatvalues <- function(model, ...) UseMethod("hatvalues")
hatvalues.lm <- function(model, infl = lm.influence(model, do.coef=FALSE), ...)
{
    hat <- infl$hat
    names(hat) <- names(infl $ wt.res)
    hat
}

rstandard <- function(model, ...) UseMethod("rstandard")
rstandard.lm <- function(model, infl = lm.influence(model, do.coef=FALSE),
                         sd = sqrt(deviance(model)/df.residual(model)), ...)
    infl$wt.res / (sd * sqrt(1 - infl$hat))

## FIXME ! -- make sure we are following "the literature":
rstandard.glm <- function(model, infl = lm.influence(model, do.coef=FALSE), ...)
{
    res <- infl$wt.res # = "dev.res"  really
    res / (summary(model)$dispersion * sqrt(1 - infl$hat))
}

rstudent <- function(model, ...) UseMethod("rstudent")
rstudent.lm <- function(model, infl = lm.influence(model, do.coef=FALSE),
			res = infl$wt.res, ...)
    res / (infl$sigma * sqrt(1 - infl$hat))

rstudent.glm <- function(model, infl = influence(model, do.coef=FALSE), ...)
{
    r <- infl$dev.res
    r <- sign(r) * sqrt(r^2 + (infl$hat * infl$pear.res^2)/(1 - infl$hat))
    if (any(family(model)$family == c("binomial", "poisson")))
	r else r/infl$sigma
}

### FIXME for glm (see above) ?!?
dffits <- function(model, infl = lm.influence(model, do.coef=FALSE),
		   res = weighted.residuals(model))
    res * sqrt(infl$hat)/(infl$sigma*(1-infl$hat))


dfbeta <- function(model, ...) UseMethod("dfbeta")

dfbeta.lm <- function(model, infl = lm.influence(model, do.coef=TRUE), ...)
{
    ## for lm & glm
    b <- infl$coefficients
    dimnames(b) <- list(names(infl$wt.res), variable.names(model))
    b
}

dfbetas <- function(model, ...) UseMethod("dfbetas")

dfbetas.lm <- function (model, infl = lm.influence(model, do.coef=TRUE), ...)
{
    ## for lm & glm
    xxi <- chol2inv(model$qr$qr, model$qr$rank)
    dfbeta(model, infl) / outer(infl$sigma, sqrt(diag(xxi)))
}

covratio <- function(model, infl = lm.influence(model, do.coef=FALSE),
		     res = weighted.residuals(model))
{
    n <- nrow(model$qr$qr)
    p <- model$rank
    omh <- 1-infl$hat
    e.star <- res/(infl$sigma*sqrt(omh))
    1/(omh*(((n - p - 1)+e.star^2)/(n - p))^p)
}

cooks.distance <- function(model, ...) UseMethod("cooks.distance")

## Used in plot.lm(); allow passing of known parts; `infl' used only via `hat'
cooks.distance.lm <-
function(model, infl = lm.influence(model, do.coef=FALSE),
	 res = weighted.residuals(model),
	 sd = sqrt(deviance(model)/df.residual(model)),
	 hat = infl$hat, ...)
{
    p <- model$rank
    ((res/(sd * (1 - hat)))^2 * hat)/p
}

cooks.distance.glm <-
function(model, infl = influence(model, do.coef=FALSE),
	 res = infl$pear.res,
	 dispersion = summary(model)$dispersion, hat = infl$hat, ...)
{
    p <- model$rank
    (res/(1-hat))^2 * hat/(dispersion* p)
}

## FIXME: The following probably needs partial adapation for glm
## -----  (whenever there's an extra glm method above!)

influence.measures <- function(model)
{
    is.influential <- function(infmat, n)
    {
	## Argument is result of using influence.measures
	## Returns a matrix  of logicals structured like the argument
	k <- ncol(infmat) - 4
	if(n <= k)
	    stop("Too few cases, n < k")
	absmat <- abs(infmat)
	result <- cbind(absmat[, 1:k] > 1, # |dfbetas| > 1
			absmat[, k + 1] > 3 * sqrt(k/(n - k)), # |dffit| > ..
			abs(1 - infmat[, k + 2]) > (3*k)/(n - k),# |1-cov.r| >..
			pf(infmat[, k + 3], k, n - k) > 0.5,# "P[cook.d..]" > .5
			infmat[, k + 4] > (3 * k)/n) # hat > 3k/n
	dimnames(result) <- dimnames(infmat)
	result
    }
    infl <- lm.influence(model)
    p <- model$rank
    e <- weighted.residuals(model)
    s <- sqrt(sum(e^2, na.rm=TRUE)/df.residual(model))
    xxi <- chol2inv(model$qr$qr, model$qr$rank)
    si <- infl$sigma
    h <- infl$hat
    dfbetas <- infl$coefficients / outer(infl$sigma, sqrt(diag(xxi)))
    vn <- variable.names(model); vn[vn == "(Intercept)"] <- "1_"
    colnames(dfbetas) <- paste("dfb",abbreviate(vn),sep=".")
    dffits <- e*sqrt(h)/(si*(1-h))
    cov.ratio <- (si/s)^(2 * p)/(1 - h)
    cooks.d <- ((e/(s * (1 - h)))^2 * h)/p
#    dn <- dimnames(model$qr$qr)
    infmat <- cbind(dfbetas, dffit = dffits, cov.r = cov.ratio,
		    cook.d = cooks.d, hat=h)
    is.inf <- is.influential(infmat, sum(h>0))
    ans <- list(infmat = infmat, is.inf = is.inf, call = model$call)
    class(ans) <- "infl"
    ans
}

print.infl <- function(x, digits = max(3, getOption("digits") - 4), ...)
{
    ## `x' : as the result of  influence.measures(.)
    cat("Influence measures of\n\t", deparse(x$call),":\n\n")
    is.star <- apply(x$is.inf, 1, any, na.rm = TRUE)
    print(data.frame(x$infmat,
		     inf = ifelse(is.star, "*", " ")),
	  digits = digits, ...)
    invisible(x)
}

summary.infl <- function(object, digits = max(2, getOption("digits") - 5), ...)
{
    ## object must be as the result of	influence.measures(.)
    is.inf <- object$is.inf
    ## will have NaN values from any hat=1 rows.
    is.inf[is.na(is.inf)] <- FALSE
     is.star <- apply(is.inf, 1, any)
    is.inf <- is.inf[is.star,]
    cat("Potentially influential observations of\n\t",
	deparse(object$call),":\n")
    if(any(is.star)) {
	imat <- object $ infmat[is.star,, drop = FALSE]
	if(is.null(rownam <- dimnames(object $ infmat)[[1]]))
	    rownam <- format(seq(is.star))
	dimnames(imat)[[1]] <- rownam[is.star]
	chmat <- format(round(imat, digits = digits))
	cat("\n")
	print(array(paste(chmat,c("","_*")[1+is.inf], sep=''),
		    dimnames = dimnames(imat), dim=dim(imat)),
	      quote = FALSE)
	invisible(imat)
    } else {
	cat("NONE\n")
	numeric(0)
    }
}
load <- function (file, envir = parent.frame())
{
    if (is.character(file)) {
        ## As zlib is available just open with gzfile, whether file
        ## is compressed or not; zlib works either way.
        con <- gzfile(file)
        on.exit(close(con))
    }
    else if (inherits(file, "connection")) con <- gzcon(file)
    else stop("bad file argument")
    if(!isOpen(con)) {
        ## code below assumes that the connection is open ...
        open(con, "rb")
    }

    magic <- readChar(con, 5)

    if (regexpr("RD[AX]2\n", magic) == -1) {
        ## Not a version 2 magic number, so try the old way.
        if (is.character(file)) {
            close(con)
            on.exit()
        }
        else stop("loading from connections not compatible with magic number")
        .Internal(load(file, envir))
    }
    else .Internal(loadFromConn(con, envir))
}

save <- function(..., list = character(0),
                 file = stop("'file' must be specified"),
                 ascii = FALSE, version = NULL, envir = parent.frame(),
                 compress = FALSE)
{
    names <- as.character( substitute( list(...)))[-1]
    list<- c(list, names)
    if (! is.null(version) && version == 1)
        invisible(.Internal(save(list, file, ascii, version, envir)))
    else {
        if (is.character(file)) {
            if (file == "") stop("`file' must be non-empty string")
            if (compress && capabilities("libz")) con <- gzfile(file, "wb")
            else con <- file(file, "wb")
            on.exit(close(con))
        }
        else if (inherits(file, "connection"))
            con <- file
        else stop("bad file argument")
        invisible(.Internal(saveToConn(list, con, ascii, version, envir)))
    }
}

save.image <- function (file = ".RData", version = NULL, ascii = FALSE,
                        compress = FALSE, safe = TRUE) {
    if (! is.character(file) || file == "")
        stop("`file' must be non-empty string")

    opts <- getOption("save.image.defaults")
    if (missing(safe) && ! is.null(opts$safe))
        safe <- opts$safe
    if (missing(compress) && ! is.null(opts$compress))
        compress <- opts$compress
    if (missing(ascii) && ! is.null(opts$ascii))
        ascii <- opts$ascii
    if (missing(version)) version <- opts$version

    if (safe) {
        ## find a temporary file name in the same directory so we can
        ## rename it to the final output file on success
        outfile <- paste(file, "Tmp", sep = "")
        i <- 0;
        while (file.exists(outfile)) {
            i <- i + 1
            outfile <- paste(file, "Tmp", i, sep = "")
        }
    }
    else outfile <- file

    on.exit(file.remove(outfile))
    save(list = ls(envir = .GlobalEnv, all.names = TRUE), file = outfile,
         version = version, ascii = ascii, compress = compress,
         envir = .GlobalEnv)
    if (safe)
        if (! file.rename(outfile, file)) {
            on.exit()
            stop(paste("image could not be renamed and is left in", outfile))
        }
    on.exit()
}

sys.load.image <- function(name, quiet) {
    if (file.exists(name)) {
        load(name, envir = .GlobalEnv)
        if (! quiet)
	    cat("[Previously saved workspace restored]\n\n")
    }
}

sys.save.image <- function(name)
{
    ## Ensure that there is a reasonable chance that we can open a
    ## connection.
    closeAllConnections()
    save.image(name)
}

loadURL <- function (url, envir = parent.frame(), quiet = TRUE, ...)
{
    tmp <- tempfile("url")
    download.file(url, tmp, quiet = quiet, ...)
    on.exit(unlink(tmp))
    load(tmp, envir = envir)
}
Sys.getlocale <- function(category = "LC_ALL")
{
    category <- match(category, c("LC_ALL", "LC_COLLATE", "LC_CTYPE",
                                  "LC_MONETARY", "LC_NUMERIC", "LC_TIME"))
    if(is.na(category)) stop("invalid `category' argument")
    .Internal(getlocale(category))
}

Sys.setlocale <- function(category = "LC_ALL", locale = "")
{
    category <- match(category, c("LC_ALL", "LC_COLLATE", "LC_CTYPE",
                                  "LC_MONETARY", "LC_NUMERIC", "LC_TIME"))
    if(is.na(category)) stop("invalid `category' argument")
    .Internal(setlocale(category, locale))
}

Sys.localeconv <- function() .Internal(localeconv())
locator <- function(n = 512, type="n", ...)
{
    if(length(extras <- list(...))) {
        opar <- par(extras)
        on.exit(par(opar))
    }
    z <- .Internal(locator(n, type=type))# n <= 0 gives error
    x <- z[[1]]
    y <- z[[2]]
    if((n <- z[[3]]) > 0) list(x=x[1:n], y=y[1:n])
}
log10 <- function(x) log(x,10)
log2 <- function(x) log(x,2)
logLik <- function(object, ...) UseMethod("logLik")

print.logLik <- function(x, digits = getOption("digits"), ...)
{
    cat("`log Lik.' ",format(c(x), digits=digits),
        " (df=",format(attr(x,"df")),")\n",sep="")
    invisible(x)
}

str.logLik <- function(object, digits = max(2, getOption("digits") - 3), ...)
{
    cl <- oldClass(object)
    cat("Class", if (length(cl) > 1) "es",
        " `", paste(cl, collapse = "', `"), "' : ",
        format(c(object), digits=digits),
        " (df=",format(attr(object,"df")),")\n",sep="")
}

## rather silly (but potentially used in pkg nlme):
as.data.frame.logLik <- function (x, row.names = NULL, optional = FALSE)
    as.data.frame(c(x), row.names=row.names, optional=optional)

## >> logLik.nls() in ../../nls/R/nls.R

## from package:nlme

## log-likelihood for glm objects
logLik.glm <- function(object, ...)
{
    if(length(list(...)))
        warning("extra arguments discarded")
    fam <- family(object)$family
    p <- object$rank
    ## allow for estimated dispersion
    if(fam %in% c("gaussian", "Gamma", "inverse.gaussian")) p <- p + 1
    val <- p - object$aic / 2
    attr(val, "df") <- p
    class(val) <- "logLik"
    val
}

## log-likelihood for lm objects
logLik.lm <- function(object, REML = FALSE, ...)
{
    res <- resid(object)
    p <- object$rank
    N <- length(res)
    if(is.null(w <- object$weights)) {
        w <- rep.int(1, N)
    } else {
        excl <- w == 0			# eliminating zero weights
        if (any(excl)) {
            res <- res[!excl]
            N <- length(res)
            w <- w[!excl]
        }
    }
    N0 <- N
    if(REML) N <- N - p
    val <- .5* (sum(log(w)) - N * (log(2 * pi) + 1 - log(N) +
                                   log(sum(w*res^2))))
    if(REML) val <- val - sum(log(abs(diag(object$qr$qr)[1:p])))
    attr(val, "nall") <- N0
    attr(val, "nobs") <- N
    attr(val, "df") <- p + 1
    class(val) <- "logLik"
    val
}

loglin <- function(table, margin, start = rep(1, length(table)), fit =
                   FALSE, eps = 0.1, iter = 20, param = FALSE, print =
                   TRUE) {
    rfit <- fit

    dtab <- dim(table)
    nvar <- length(dtab)

    ncon <- length(margin)
    conf <- matrix(0, nrow = nvar, ncol = ncon)
    nmar <- 0
    varnames <- names(dimnames(table))
    for (k in seq(along = margin)) {
        tmp <- margin[[k]]
        if (is.character(tmp)) {
            ## Rewrite margin names to numbers
            tmp <- match(tmp, varnames)
            margin[[k]] <- tmp
        }
        conf[1:length(tmp), k] <- tmp
        nmar <- nmar + prod(dtab[tmp])
    }

    ntab <- length(table)

    storage.mode(conf) <- "integer"
    ## NOTE: We make no use of the arguments locmar, nmar, marg, nu, and
    ## u.  It might make sense to eliminate to simplify the unterlying C
    ## code accordingly.
    z <- .C("loglin",
            as.integer(nvar),
            as.integer(dtab),
            as.integer(ncon),
            conf,
            as.integer(ntab),
            as.double(table),
            fit = as.double(start),
            locmar = integer(ncon),
            as.integer(nmar),
            marginals = double(nmar),
            as.integer(ntab),
            u = double(ntab),
            as.double(eps),
            as.integer(iter),
            dev = double(iter),
            nlast = integer(1),
            ifault = integer(1),
            PACKAGE = "base")
    switch(z$ifault,
           stop("This should not happen"),
           stop("This should not happen"),
           warning("Algorithm did not converge"),
           stop(paste("Incorrect specification of", sQuote("table"),
                      "or", sQuote("start"))))

    if (print)
        cat(z$nlast, "iterations: deviation", z$dev[z$nlast], "\n")

    fit <- z$fit
    attributes(fit) <- attributes(table)

    ## Pearson chi-sq test statistic
    observed <- as.vector(table[start > 0])
    expected <- as.vector(fit[start > 0])
    pearson <- sum((observed - expected)^2 / expected)

    ## Likelihood Ratio Test statistic
    observed <- as.vector(table[table * fit > 0])
    expected <- as.vector(fit[table * fit > 0])
    lrt <- 2 * sum(observed * log(observed / expected))

    ## Compute degrees of freedom.
    ## Use a dyadic-style representation for the (possible) subsets B.
    ## Let u_i(B) = 1 if i is contained in B and 0 otherwise.  Then B
    ## <-> u(B) = (u_1(B),...,u_N(B)) <-> \sum_{i=1}^N u_i(B) 2^{i-1}.
    ## See also the code for 'dyadic' below which computes the u_i(B).
    subsets <- function(x) {
        y <- list(vector(mode(x), length = 0))
        for (i in seq(along = x)) {
            y <- c(y, lapply(y, "c", x[i]))
        }
        y[-1]
    }
    df <- rep.int(0, 2^nvar)
    for (k in seq(along = margin)) {
        terms <- subsets(margin[[k]])
        for (j in seq(along = terms))
            df[sum(2 ^ (terms[[j]] - 1))] <- prod(dtab[terms[[j]]] - 1)
    }

    ## Rewrite margin numbers to names if possible
    if (!is.null(varnames) && all(nchar(varnames) > 0)) {
        for (k in seq(along = margin))
            margin[[k]] <- varnames[margin[[k]]]
    } else {
        varnames <- as.character(1 : ntab)
    }

    y <- list(lrt = lrt,
              pearson = pearson,
              df = ntab - sum(df) - 1,
              margin = margin)

    if (rfit)
        y$fit <- fit

    if (param) {
        fit <- log(fit)
        terms <- seq(length(df))[df > 0]

        parlen <- length(terms) + 1
        parval <- list(parlen)
        parnam <- character(parlen)

        parval[[1]] <- mean(fit)
        parnam[1] <- "(Intercept)"
        fit <- fit - parval[[1]]

        ## Get the u_i(B) in the rows of 'dyadic', see above.
        dyadic <- NULL
        while(any(terms > 0)) {
            dyadic <- cbind(dyadic, terms %% 2)
            terms <- terms %/% 2
        }
        dyadic <- dyadic[order(apply(dyadic, 1, sum)), ]

        for (i in 2 : parlen) {
            vars <- which(dyadic[i - 1, ] > 0)
            parval[[i]] <- apply(fit, vars, mean)
            parnam[i] <- paste(varnames[vars], collapse = ".")
            fit <- sweep(fit, vars, parval[[i]])
        }

        names(parval) <- parnam
        y$param <- parval
    }

    return(y)
}
lower.tri <- function(x, diag = FALSE)
{
    x <- as.matrix(x)
    if(diag) row(x) >= col(x)
    else row(x) > col(x)
}
lowess <- function(x, y=NULL, f=2/3, iter=3, delta=.01*diff(range(xy$x[o]))) {
    xy <- xy.coords(x,y)
    if(length(xy$x) != length(xy$y)) stop("x and y lengths differ")
    n <- length(xy$x)
    if(n == 0) stop("x is empty")
    o <- order(xy$x)
    .C("lowess",
       x=as.double(xy$x[o]),
       as.double(xy$y[o]),
       n,
       as.double(f),
       as.integer(iter),
       as.double(delta),
       y=double(n),
       double(n),
       double(n), PACKAGE="base")[c("x","y")]
}
lsfit <- function(x, y, wt=NULL, intercept=TRUE, tolerance=1e-07, yname=NULL)
{
    ## find names of x variables (design matrix)

    x <- as.matrix(x)
    y <- as.matrix(y)
    xnames <- colnames(x)
    if( is.null(xnames) ) {
	if(ncol(x)==1) xnames <- "X"
	else xnames <- paste("X", 1:ncol(x), sep="")
    }
    if( intercept ) {
	x <- cbind(1, x)
	xnames <- c("Intercept", xnames)
    }

    ## find names of y variables (responses)

    if(is.null(yname) && ncol(y) > 1) yname <- paste("Y", 1:ncol(y), sep="")

    ## remove missing values

    good <- complete.cases(x, y, wt)
    dimy <- dim(as.matrix(y))
    if( any(!good) ) {
	warning(paste(sum(!good), "missing values deleted"))
	x <- as.matrix(x)[good, ]
	y <- as.matrix(y)[good, ]
	wt <- wt[good]
    }

    ## check for compatible lengths

    nrx <- NROW(x)
    ncx <- NCOL(x)
    nry <- NROW(y)
    ncy <- NCOL(y)
    nwts <- length(wt)
    if(nry != nrx) stop(paste("X matrix has", nrx, "responses, Y",
       "has", nry, "responses."))
    if(nry < ncx) stop(paste(nry, "responses, but only", ncx, "variables"))

    ## check weights if necessary

    if( !is.null(wt) ) {
	if(any(wt < 0)) stop("negative weights not allowed")
	if(nwts != nry) stop(paste("Number of weights =", nwts,
	   ", should equal", nry, "(number of responses)"))
	wtmult <- wt^0.5
	if( any(wt==0) ) {
	    xzero <- as.matrix(x)[wt==0, ]
	    yzero <- as.matrix(y)[wt==0, ]
	}
	x <- x*wtmult
	y <- y*wtmult
	invmult <- 1/ifelse(wt==0, 1, wtmult)
    }

    ## call linpack

    storage.mode(x) <- "double"
    storage.mode(y) <- "double"
    z <- .Fortran("dqrls",
		  qr=x,
		  n=nrx,
		  p=ncx,
		  y=y,
		  ny=ncy,
		  tol=tolerance,
		  coefficients=mat.or.vec(ncx, ncy),
		  residuals=mat.or.vec(nrx, ncy),
		  effects=mat.or.vec(nrx, ncy),
		  rank=integer(1),
		  pivot=as.integer(1:ncx),
		  qraux=double(ncx),
		  work=double(2*ncx),
                  PACKAGE="base")

    ## dimension and name output from linpack

    resids <- array(NA, dim=dimy)
    dim(z$residuals) <- c(nry, ncy)
    if(!is.null(wt)) {
	if(any(wt==0)) {
	    if(ncx==1) fitted.zeros <- xzero * z$coefficients
	    else fitted.zeros <- xzero %*% z$coefficients
	    z$residuals[wt==0, ] <- yzero - fitted.zeros
	}
	z$residuals <- z$residuals*invmult
    }
    resids[good, ] <- z$residuals
    if(dimy[2] == 1 && is.null(yname)) {
	resids <- as.vector(resids)
	names(z$coefficients) <- xnames
    }
    else {
	colnames(resids) <- yname
	colnames(z$effects) <- yname
	dim(z$coefficients) <- c(ncx, ncy)
	dimnames(z$coefficients) <- list(xnames, yname)
    }
    z$qr <- as.matrix(z$qr)
    colnames(z$qr) <- xnames
    output <- list(coefficients=z$coefficients, residuals=resids)

    ## if X matrix was collinear, then the columns would have been
    ## pivoted hence xnames need to be corrected

    if( z$rank != ncx ) {
	xnames <- xnames[z$pivot]
	dimnames(z$qr) <- list(NULL, xnames)
	warning("X matrix was collinear")
    }

    ## return weights if necessary

    if (!is.null(wt) ) {
	weights <- rep.int(NA, dimy[1])
	weights[good] <- wt
	output <- c(output, list(wt=weights))
    }

    ## return rest of output

    rqr <- list(qt=z$effects, qr=z$qr, qraux=z$qraux, rank=z$rank,
		pivot=z$pivot, tol=z$tol)
    oldClass(rqr) <- "qr"
    output <- c(output, list(intercept=intercept, qr=rqr))
    return(output)
}

ls.diag <- function(ls.out)
{
    resids <- as.matrix(ls.out$residuals)
    xnames <- colnames(ls.out$qr$qr)
    yname <- colnames(resids)

    ## remove any missing values

    good <- complete.cases(resids, ls.out$wt)
    if( any(!good) ) {
	warning("missing observations deleted")
	resids <- as.matrix(resids)[good, ]
    }

    ## adjust residuals if needed

    if( !is.null(ls.out$wt) ) {
	if( any(ls.out$wt[good] == 0) )
	    warning(paste("Observations with 0 weight not used in",
			  "calculating standard deviation"))
	resids <- resids * ls.out$wt[good]^0.5
    }

    ## initialize

    p <- ls.out$qr$rank
    n <- nrow(resids)
    hatdiag <- rep.int(NA, n)
    stats <- array(NA, dim = dim(resids))
    colnames(stats) <- yname
    stdres <- studres <- dfits <- Cooks <- stats

    ## calculate hat matrix diagonals

    q <- qr.qy(ls.out$qr, rbind(diag(p), matrix(0, nrow=n-p, ncol=p)))
    hatdiag[good] <- rowSums(as.matrix(q^2))

    ## calculate diagnostics

    stddev <- (colSums(as.matrix(resids^2))/(n - p))^0.5
    stddevmat <- matrix(stddev, nrow=sum(good), ncol=ncol(resids), byrow=TRUE)
    stdres[good, ] <- resids/((1-hatdiag[good])^0.5 * stddevmat)
    studres[good, ] <- (stdres[good, ]*stddevmat)/(((n-p)*stddevmat^2 -
						    resids^2/(1-hatdiag[good]))/(n-p-1))^0.5
    dfits[good, ] <- (hatdiag[good]/(1-hatdiag[good]))^0.5 * studres[good, ]
    Cooks[good, ] <- ((stdres[good, ]^2 * hatdiag[good])/p)/(1-hatdiag[good])
    if(ncol(resids)==1 && is.null(yname)) {
	stdres <- as.vector(stdres)
	Cooks <- as.vector(Cooks)
	studres <- as.vector(studres)
	dfits <- as.vector(dfits)
    }

    ## calculate unscaled covariance matrix

    qr <- as.matrix(ls.out$qr$qr[1:p, 1:p])
    qr[row(qr)>col(qr)] <- 0
    qrinv <- solve(qr)
    covmat.unscaled <- qrinv%*%t(qrinv)
    dimnames(covmat.unscaled) <- list(xnames, xnames)

    ## calculate scaled covariance matrix

    covmat.scaled <- sum(stddev^2) * covmat.unscaled

    ## calculate correlation matrix

    cormat <- covmat.scaled/
	(outer(diag(covmat.scaled), diag(covmat.scaled))^0.5)

    ## calculate standard error

    stderr <- outer(diag(covmat.unscaled)^0.5, stddev)
    dimnames(stderr) <- list(xnames, yname)

    return(list(std.dev=stddev, hat=hatdiag, std.res=stdres,
		stud.res=studres, cooks=Cooks, dfits=dfits,
		correlation=cormat, std.err=stderr,
		cov.scaled=covmat.scaled, cov.unscaled=covmat.unscaled))
}

ls.print <- function(ls.out, digits=4, print.it=TRUE)
{
    ## calculate residuals to be used

    resids <- as.matrix(ls.out$residuals)
    if( !is.null(ls.out$wt) ) {
	if(any(ls.out$wt == 0))
	    warning("Observations with 0 weights not used")
	resids <- resids * ls.out$wt^0.5
    }
    n <- apply(resids, 2, length)-colSums(is.na(resids))
    lsqr <- ls.out$qr
    p <- lsqr$rank

    ## calculate total sum sq and df

    if(ls.out$intercept) {
	if(is.matrix(lsqr$qt))
	    totss <- colSums(lsqr$qt[-1, ]^2)
	else totss <- sum(lsqr$qt[-1]^2)
	degfree <- p - 1
    } else {
	totss <- colSums(as.matrix(lsqr$qt^2))
	degfree <- p
    }

    ## calculate residual sum sq and regression sum sq

    resss <- colSums(resids^2, na.rm=TRUE)
    resse <- (resss/(n-p))^.5
    regss <- totss - resss
    rsquared <- regss/totss
    fstat <- (regss/degfree)/(resss/(n-p))
    pvalue <- pf(fstat, degfree, (n-p), lower.tail = FALSE)

    ## construct summary

    Ynames <- colnames(resids)
    summary <- cbind(format(round(resse, digits)),
		     format(round(rsquared, digits)),
		     format(round(fstat, digits)),
		     format(degfree),
		     format(n-p),
		     format(round(pvalue, digits)))
    dimnames(summary) <- list(Ynames,
			      c("Mean Sum Sq", "R Squared",
				"F-value", "Df 1", "Df 2", "Pr(>F)"))
    mat <- as.matrix(lsqr$qr[1:p, 1:p])
    mat[row(mat)>col(mat)] <- 0
    qrinv <- solve(mat)

    ## construct coef table

    m.y <- ncol(resids)
    coef.table <- as.list(1:m.y)
    if(m.y==1) coef <- matrix(ls.out$coef, nc=1)
    else coef <- ls.out$coef
    for(i in 1:m.y) {
	covmat <- (resss[i]/(n[i]-p)) * (qrinv%*%t(qrinv))
	se <- diag(covmat)^.5
	coef.table[[i]] <- cbind(coef[, i], se, coef[, i]/se,
				 2*pt(abs(coef[, i]/se), n[i]-p,
                                      lower.tail = FALSE))
	dimnames(coef.table[[i]]) <-
	    list(colnames(lsqr$qr),
		 c("Estimate", "Std.Err", "t-value", "Pr(>|t|)"))

	##-- print results --

	if(print.it) {
	    if(m.y>1)
		cat("Response:", Ynames[i], "\n\n")
	    cat(paste("Residual Standard Error=",
                      format(round(resse[i], digits)), "\nR-Square=",
                      format(round(rsquared[i], digits)), "\nF-statistic (df=",
		      format(degfree), ", ", format(n[i]-p), ")=",
		      format(round(fstat[i], digits)), "\np-value=",
		      format(round(pvalue[i], digits)), "\n\n", sep=""))
	    print(round(coef.table[[i]], digits))
	    cat("\n\n")
	}
    }
    names(coef.table) <- Ynames

    invisible(list(summary=summary, coef.table=coef.table))
}
mad <- function(x, center = median(x), constant = 1.4826,
                na.rm = FALSE, low = FALSE, high = FALSE) 
{
    if(na.rm)
	x <- x[!is.na(x)]
    n <- length(x)
    constant *
        if((low || high) && n%%2 == 0) {
            if(low && high) stop("`low' and `high' can't be both TRUE")
            n2 <- n %/% 2 + as.integer(high)
            sort(abs(x - center), partial = n2)[n2]
        }
        else median(abs(x - center))
}

mahalanobis <- function(x, center, cov, inverted=FALSE, tol.inv = 1e-7)
{
    x <- if(is.vector(x)) matrix(x, ncol=length(x)) else as.matrix(x)
    x <- sweep(x, 2, center)# = (x - center)

    ## The following would be considerably faster for  small nrow(x) and
    ## slower otherwise; probably always faster if the two t(.) weren't needed:
    ##
    ##	retval <- apply(x * if(inverted) x%*%cov
    ##	                    else    t(solve(cov,t(x), tol=tol.inv)),
    ##			1, sum)
    if(!inverted)
	cov <- solve(cov, tol = tol.inv)
    retval <- rowSums((x%*%cov) * x)
    names(retval) <- rownames(x)
    retval
}
manova <- function(...)
{
    Call <- fcall <- match.call()
    fcall[[1]] <- as.name("aov")
    result <- eval(fcall, parent.frame())
    if(inherits(result, "aovlist")) {
        for(i in seq(along=result)) {
            if(!inherits(result[[i]], "maov")) stop("need multiple response")
            class(result[[i]]) <- c("manova", oldClass(result[[i]]))
        }
        attr(result, "call") <- Call
    } else {
        if(!inherits(result, "maov")) stop("need multiple response")
        class(result) <- c("manova", oldClass(result))
        result$call <- Call
    }
    result
}

summary.manova <-
    function(object,
             test = c("Pillai", "Wilks", "Hotelling-Lawley", "Roy"),
             intercept = FALSE, ...)
{
    Pillai <- function(eig, q, df.res)
    {
        test <- sum(eig/(1 + eig))
        p <- length(eig)
        s <- min(p, q)
        n <- 0.5 * (df.res - p - 1)
        m <- 0.5 * (abs(p - q) - 1)
        tmp1 <- 2 * m + s + 1
        tmp2 <- 2 * n + s + 1
        c(test, (tmp2/tmp1 * test)/(s - test), s*tmp1, s*tmp2)
    }

    Wilks <- function(eig, q, df.res)
    {
        test <- prod(1/(1 + eig))
        p <- length(eig)
        tmp1 <- df.res - 0.5 * (p - q + 1)
        tmp2 <- (p * q - 2)/4
        tmp3 <- p^2 + q^2 - 5
        tmp3 <-  if(tmp3 > 0) sqrt(((p*q)^2 - 4)/tmp3) else 1
        c(test, ((test^(-1/tmp3) - 1) * (tmp1 * tmp3 - 2 * tmp2))/p/q,
          p * q, tmp1 * tmp3 - 2 * tmp2)
    }

    HL <- function(eig, q, df.res)
    {
        test <- sum(eig)
        p <- length(eig)
        m <- 0.5 * (abs(p - q) - 1)
        n <- 0.5 * (df.res - p - 1)
        s <- min(p, q)
        tmp1 <- 2 * m + s + 1
        tmp2 <- 2 * (s * n + 1)
        c(test, (tmp2 * test)/s/s/tmp1, s * tmp1, tmp2)
    }

    Roy <- function(eig, q, df.res)
    {
        p <- length(eig)
        test <- max(eig)
        tmp1 <- max(p, q)
        tmp2 <- df.res - tmp1 + q
        c(test, (tmp2 * test)/tmp1, tmp1, tmp2)
    }

    if(!inherits(object, "maov"))
        stop("object must be of class \"manova\" or \"maov\"")
    test <- match.arg(test)

    asgn <- object$assign[object$qr$pivot[1:object$rank]]
    uasgn <- unique(asgn)
    nterms <- length(uasgn)
    effects <- object$effects
    if (!is.null(effects))
        effects <- as.matrix(effects)[seq(along = asgn), , drop = FALSE]
    rdf <- object$df.resid
    nmeffect <- c("(Intercept)", attr(object$terms, "term.labels"))
    resid <- as.matrix(object$residuals)
    wt <- object$weights
    if (!is.null(wt)) resid <- resid * wt^0.5
    nresp <- NCOL(resid)
    if(nresp <= 1) stop("need multiple response")

    if (is.null(effects)) {
        df <- nterms <- 0
        ss <- list(0)
        nmrows <- character(0)
    } else {
        df <- numeric(nterms)
        ss <- list(nterms)
        nmrows <- character(nterms)
        for (i in seq(nterms)) {
            ai <- (asgn == uasgn[i])
            nmrows[i] <- nmeffect[1 + uasgn[i]]
            df[i] <- sum(ai)
            ss[[i]] <- crossprod(effects[ai, , drop=FALSE])
        }
    }
    pm <- pmatch("(Intercept)", nmrows, 0)
    if (!intercept && pm > 0) {
        nterms <- nterms - 1
        df <- df[-pm]
        nmrows <- nmrows[-pm]
        ss <- ss[-pm]
    }
    names(ss) <- nmrows

    nt <- nterms
    if (rdf > 0) {
        nt <- nterms + 1
        df[nt] <- rdf
        ss[[nt]] <- crossprod(resid)
        names(ss)[nt] <- nmrows[nt] <- "Residuals"
        ok <- df[-nt] > 0
        eigs <- array(NA, c(nterms, nresp))
        dimnames(eigs) <- list(nmrows[-nt], NULL)
        stats <- matrix(NA, nt, 5)
        dimnames(stats) <-  list(nmrows,
                                 c(test, "approx F", "num Df", "den Df",
                                   "Pr(>F)"))
        rss.qr <- qr(ss[[nt]])
        if(rss.qr$rank < ncol(resid))
            stop(paste("residuals have rank", rss.qr$rank,"<", ncol(resid)))
        if(!is.null(rss.qr))
            for(i in seq(len=nterms)[ok]) {
                eigs[i, ] <- Re(eigen(qr.coef(rss.qr, ss[[i]]),
                                       symmetric = FALSE)$values)
                stats[i, 1:4] <-
                    switch(test,
                           "Pillai" = Pillai(eigs[i,  ], df[i], df[nt]),
                           "Wilks" = Wilks(eigs[i,  ], df[i], df[nt]),
                           "Hotelling-Lawley" = HL(eigs[i,  ], df[i], df[nt]),
                           "Roy" = Roy(eigs[i,  ], df[i], df[nt]))
                ok <- stats[, 2] >= 0 & stats[, 3] > 0 & stats[, 4] > 0
                stats[ok, 5] <- pf(stats[ok, 2], stats[ok, 3], stats[ok, 4],
                                   lower.tail = FALSE)

            }
        x <- list(row.names = nmrows, SS = ss,
                  Eigenvalues = eigs, stats = cbind(Df=df, stats=stats))
    } else x <- list(row.names = nmrows, SS = ss, Df = df)
    class(x) <- "summary.manova"
    x
}

print.summary.manova <- function(x, digits = getOption("digits"), ...)
{
    if(length(stats <- x$stats)) {
        print.anova(stats)
    } else {
        cat("No error degrees of freedom\n\n")
        print(data.frame(Df = x$Df, row.names = x$row.names))
    }
    invisible(x)
}
mapply<-function(FUN,..., MoreArgs=NULL, SIMPLIFY=TRUE, USE.NAMES=TRUE)
{
    FUN <- match.fun(FUN)
    dots <- list(...)

    answer<-.Call("do_mapply", FUN, dots, MoreArgs, environment(),
                  PACKAGE="base")

    if (USE.NAMES && length(dots) && is.character(dots[[1]]) &&
        is.null(names(answer))) names(answer) <- dots[[1]]
    if (SIMPLIFY && length(answer) &&
        length(common.len <- unique(unlist(lapply(answer, length)))) == 1) {
        if (common.len == 1)
            unlist(answer, recursive = FALSE)
        else if (common.len > 1)
            array(unlist(answer, recursive = FALSE),
                  dim = c(common.len, max(sapply(dots,length))),
                  dimnames = list(names(answer[[1]]), names(answer)))
        else answer
    }
    else answer
}

## till R 1.1.1:
match <- function(x, table, nomatch=NA)
    .Internal(match(as.character(x), as.character(table), nomatch))
## New:
match <- function(x, table, nomatch=NA, incomparables = FALSE) {
    if(!is.logical(incomparables) || incomparables)
        .NotYetUsed("incomparables != FALSE")
    .Internal(match(if(is.factor(x)) as.character(x) else x,
                    if(is.factor(table)) as.character(table) else table,
                    nomatch))
}

match.call <-
    function(definition=NULL, call=sys.call(sys.parent()), expand.dots=TRUE)
    .Internal(match.call(definition,call,expand.dots))

pmatch <-
    function(x, table, nomatch=NA, duplicates.ok=FALSE)
{
    y <- .Internal(pmatch(x,table,duplicates.ok))
    y[y == 0] <- nomatch
    y
}

"%in%" <- function(x, table) match(x, table, nomatch = 0) > 0

match.arg <- function (arg, choices) {
    if (missing(choices)) {
	formal.args <- formals(sys.function(sys.parent()))
	choices <- eval(formal.args[[deparse(substitute(arg))]])
    }
    if (all(arg == choices)) return(choices[1])
    i <- pmatch(arg, choices)
    if (is.na(i))
	stop(paste("ARG should be one of", paste(choices, collapse = ", "),
		   sep = " "))
    if (length(i) > 1) stop("there is more than one match in match.arg")
    choices[i]
}

charmatch <-
    function(x, table, nomatch=NA)
{
    y <- .Internal(charmatch(x,table))
    y[is.na(y)] <- nomatch
    y
}

char.expand <-
    function(input, target, nomatch = stop("no match"))
{
    if(length(input) != 1)
	stop("char.expand: input must have length 1")
    if(!(is.character(input) && is.character(target)))
	stop("char.expand: input and target must be character")
    y <- .Internal(charmatch(input,target))
    if(any(is.na(y))) eval(nomatch)
    target[y]
}
### clean up FUN arguments to *apply, outer, sweep, etc.
### note that this grabs two levels back and is not designed
### to be called at top level
match.fun <- function (FUN, descend = TRUE)
{
    if ( is.function(FUN) )
        return(FUN)
    if (!(is.character(FUN) && length(FUN) == 1 || is.symbol(FUN))) {
        ## Substitute in parent 
        FUN <- eval.parent(substitute(substitute(FUN)))
        if (!is.symbol(FUN))
            stop(paste("not function, character, or symbol: \"",
                       deparse(FUN), "\"", sep = ""))
    }
    envir <- parent.frame(2)
    if( descend ) 
        FUN <- get(as.character(FUN), mode = "function", env=envir)
    else {
        FUN <- get(as.character(FUN), mode = "any", env=envir)
        if( !is.function(FUN) )
           stop(paste("found non-function: \"", FUN, "\"", sep = ""))
    }
    return(FUN)
}
## Author: Martin Maechler, Date: 27 Jun 97

matpoints <-
    function(x, y,  type = "p", lty=1:5, lwd = 1, pch=NULL, col=1:6, ...)
    matplot(x=x, y=y, type = type, lty=lty, lwd=lwd, pch=pch, col=col,
	    add=TRUE, ...)
matlines  <-
    function(x, y, type = "l", lty=1:5, lwd = 1, pch=NULL, col=1:6, ...)
    matplot(x=x, y=y, type = type, lty=lty, lwd=lwd, pch=pch, col=col,
	    add=TRUE, ...)

matplot <- function(x, y, type = "p",
		    lty = 1:5, lwd = 1, pch=NULL, col=1:6, cex=NULL,
		    xlab=NULL, ylab=NULL, xlim=NULL, ylim=NULL,
		    ..., add= FALSE, verbose = getOption("verbose"))
{
    paste.ch <- function(chv) paste('"',chv,'"', sep="", collapse=" ")
    str2vec <- function(string) {
	if(nchar(string)[1] > 1) strsplit(string[1], NULL)[[1]] else string
    }
    ## These from plot.default :
    xlabel <- if (!missing(x)) deparse(substitute(x))# else NULL
    ylabel <- if (!missing(y)) deparse(substitute(y))
    ##
    if(missing(x)) {
	if(missing(y)) stop("Must specify at least one of `x' and `y'")
	else x <- 1:NROW(y)
    } else if(missing(y)) {
	y <- x;		ylabel <- xlabel
	x <- 1:NROW(y); xlabel <- ""
    }
    kx <- ncol(x <- as.matrix(x))
    ky <- ncol(y <- as.matrix(y))
    n <- nrow(x)
    if(n != nrow(y)) stop("`x' and `y' must have same number of rows")

    if(kx > 1 && ky > 1 && kx != ky)
	stop("`x' and `y' must have only 1 or the same number of columns")
    if(kx == 1) x <- matrix(x, nrow = n, ncol = ky)
    if(ky == 1) y <- matrix(y, nrow = n, ncol = kx)
    k <- max(kx,ky)## k == kx == ky

    type <- str2vec(type)
    if(is.null(pch))
	pch <- c(paste(c(1:9,0)),letters)[1:k]
    else if(is.character(pch))
	pch <- str2vec(pch)
    ## else pch is numeric supposedly
    if(verbose)
	cat("matplot: doing ", k, " plots with ",
	    paste(" col= (", paste.ch(col), ")", sep=''),
	    paste(" pch= (", paste.ch(pch), ")", sep=''),
	    " ...\n\n")
    ii <- match("log", names(xargs <- list(...)), nomatch = 0)
    log <- if (ii != 0) xargs[[ii]]
    xy <- xy.coords(x, y, xlabel, ylabel, log=log)
    xlab <- if (is.null(xlab)) xy$xlab else xlab
    ylab <- if (is.null(ylab)) xy$ylab else ylab
    xlim <- if (is.null(xlim)) range(xy$x[is.finite(xy$x)]) else xlim
    ylim <- if (is.null(ylim)) range(xy$y[is.finite(xy$y)]) else ylim
    if(length(type)< k) type<- rep(type,length= k)
    if(length(lty) < k) lty <- rep(lty, length= k)
    if(length(lwd) < k) lwd <- rep(lwd, length= k)
    if(length(pch) < k) pch <- rep(pch, length= k)
    if(length(col) < k) col <- rep(col, length= k)
    if(length(cex) < k) cex <- rep(cex, length= k)
    ii <- 1:k
    if(!add) {
	ii <- ii[-1]
	plot(x[,1],y[,1], type=type[1], xlab=xlab, ylab=ylab,
	     xlim = xlim, ylim = ylim,
	     lty=lty[1], lwd=lwd[1], pch=pch[1], col=col[1], cex=cex[1], ...)
    }
    for (i in ii) {
	lines(x[,i], y[,i], type=type[i], lty=lty[i],
	      lwd=lwd[i], pch=pch[i], col=col[i], cex=cex[i])
    }
}
matrix <- function(data=NA, nrow=1, ncol=1, byrow=FALSE, dimnames=NULL) {
    data <- as.vector(data)
    if(missing(nrow))
        nrow <- ceiling(length(data)/ncol)
    else if(missing(ncol))
        ncol <- ceiling(length(data)/nrow)
    x <- .Internal(matrix(data, nrow, ncol, byrow))
    dimnames(x) <- dimnames
    x
}
nrow <- function(x) dim(x)[1]
ncol <- function(x) dim(x)[2]

NROW <- function(x) if(is.array(x)||is.data.frame(x)) nrow(x) else length(x)
NCOL <- function(x) if(is.array(x) && length(dim(x)) > 1||is.data.frame(x)) ncol(x) else as.integer(1)

rownames <- function(x, do.NULL = TRUE, prefix = "row")
{
    dn <- dimnames(x)
    if(!is.null(dn[[1]]))
	dn[[1]]
    else {
	if(do.NULL) NULL else paste(prefix, seq(length=NROW(x)), sep="")
    }
}

"rownames<-" <- function(x, value)
{
    dn <- dimnames(x)
    if(is.null(dn)) {
        if(is.null(value)) return(x)
        if((nd <- length(dim(x))) < 1)
            stop("attempt to set rownames on object with no dimensions")
        dn <- vector("list", nd)
    }
    if(length(dn) < 1)
        stop("attempt to set rownames on object with no dimensions")
    if(is.null(value)) dn[1] <- list(NULL) else dn[[1]] <- value
    dimnames(x) <- dn
    x
}

colnames <- function(x, do.NULL = TRUE, prefix = "col")
{
    dn <- dimnames(x)
    if(!is.null(dn[[2]]))
	dn[[2]]
    else {
	if(do.NULL) NULL else paste(prefix, seq(length=NCOL(x)), sep="")
    }
}

"colnames<-" <- function(x, value)
{
    dn <- dimnames(x)
    if(is.null(dn)) {
        if(is.null(value)) return(x)
        if((nd <- length(dim(x))) < 2)
            stop("attempt to set colnames on object with less than two dimensions")
        dn <- vector("list", nd)
    }
    if(length(dn) < 2)
        stop("attempt to set colnames on object with less than two dimensions")
    if(is.null(value)) dn[2] <- list(NULL) else dn[[2]] <- value
    dimnames(x) <- dn
    x
}

row <- function(x, as.factor=FALSE) {
    if(as.factor) factor(.Internal(row(x)), labels=rownames(x))
    else .Internal(row(x))
}

col <- function(x, as.factor=FALSE) {
    if(as.factor) factor(.Internal(col(x)), labels=colnames(x))
    else .Internal(col(x))
}

crossprod <- function(x, y=NULL) .Internal(crossprod(x,y))

t <- function(x) UseMethod("t")
## t.default is <primitive>
t.data.frame<- function(x)
{
    x <- as.matrix(x)
    NextMethod("t")
}
## as.matrix  is in "as"
max.col <- function(m)
{
    m <- as.matrix(m)
    n <- nrow(m)
    .C("R_max_col",
       as.double(m),
       n,
       ncol(m),
       rmax = integer(n),
       NAOK = TRUE,
       DUP  = FALSE,
       PACKAGE = "base")$rmax
}

mean <- function(x, ...) UseMethod("mean")

mean.default <- function(x, trim = 0, na.rm = FALSE, ...)
{
    if(!is.numeric(x) && !is.complex(x) && !is.logical(x)) {
        warning("argument is not numeric or logical: returning NA")
        return(as.numeric(NA))
    }
    if (na.rm)
	x <- x[!is.na(x)]
    trim <- trim[1]
    n <- length(x)
    if(trim > 0 && n > 0) {
	if(is.complex(x))
	    stop("trimmed means are not defined for complex data")
	if(trim >= 0.5) return(median(x, na.rm=FALSE))
	lo <- floor(n*trim)+1
	hi <- n+1-lo
	x <- sort(x, partial=unique(c(lo, hi)))[lo:hi]
	n <- hi-lo+1
    }
    ## sum(int) can overflow, so convert here.
    if(is.integer(x)) sum(as.numeric(x))/n else sum(x)/n
}

mean.data.frame <- function(x, ...) sapply(x, mean, ...)

weighted.mean <- function(x, w, na.rm = FALSE) {
    if(missing(w)) w <- rep.int(1, length(x))
    if(is.integer(w)) w <- as.numeric(w)  # avoid overflow in sum.
    if (na.rm) {
	w <- w[i <- !is.na(x)]
	x <- x[i]
    }
    sum(x*w)/sum(w)
}
median <- function(x, na.rm = FALSE) {
    if(mode(x) != "numeric")
        stop("need numeric data")
    if(na.rm)
	x <- x[!is.na(x)]
    else if(any(is.na(x)))
	return(NA)
    n <- length(x)
    if (n == 0) return(NA)
    half <- (n + 1)/2
    if(n %% 2 == 1) {
	sort(x, partial = half)[half]
    }
    else {
	sum(sort(x, partial = c(half, half + 1))[c(half, half + 1)])/2
    }
}
menu <- function(choices, graphics = FALSE, title = "")
{
    nc <- length(choices)
    cat(title, "\n")
    for (i in seq(length=nc))
	cat(i, ":", choices[i]," \n", sep = "")
    repeat {
	ind <- .Internal(menu(as.character(choices)))
	if(ind <= nc)
	    return(ind)
	cat("Enter an item from the menu, or 0 to exit\n")
    }
}
merge <- function(x, y, ...) UseMethod("merge")

merge.default <- function(x, y, ...)
    merge(as.data.frame(x), as.data.frame(y), ...)

merge.data.frame <-
    function(x, y, by = intersect(names(x), names(y)), by.x = by, by.y = by,
             all = FALSE, all.x = all, all.y = all,
             sort = TRUE, suffixes = c(".x",".y"), ...)
{
    fix.by <- function(by, df)
    {
        ## fix up `by' to be a valid set of cols by number: 0 is row.names
        by <- as.vector(by)
        nc <- ncol(df)
        if(is.character(by))
            by <- match(by, c("row.names", names(df))) - 1
        else if(is.numeric(by)) {
            if(any(by < 0) || any(by > nc))
                stop("`by' must match numbers of columns")
        } else if(is.logical(by)) {
            if(length(by) != nc) stop("`by' must match number of columns")
            by <- seq(along = by)[by]
        } else stop("`by' must specify column(s)")
        if(any(is.na(by))) stop("`by' must specify valid column(s)")
        unique(by)
    }

    nx <- nrow(x <- as.data.frame(x)); ny <- nrow(y <- as.data.frame(y))
    if (nx == 0 || ny == 0) stop("no rows to match")
    by.x <- fix.by(by.x, x)
    by.y <- fix.by(by.y, y)
    if((l.b <- length(by.x)) != length(by.y))
        stop("by.x and by.y specify different numbers of columns")
    if(l.b == 0) {
        ## was: stop("no columns to match on")
        ## return the cartesian product of x and y :
        ij <- expand.grid(1:nx, 1:ny)
        res <- cbind(x[ij[,1],], y[ij[,2],])
    }
    else {
        if(any(by.x == 0)) {
            x <- cbind(Row.names = row.names(x), x)
            by.x <- by.x + 1
        }
        if(any(by.y == 0)) {
            y <- cbind(Row.names = row.names(y), y)
            by.y <- by.y + 1
        }
        row.names(x) <- 1:nx
        row.names(y) <- 1:ny
        ## create keys from `by' columns:
        if(l.b == 1) {                  # (be faster)
            bx <- x[, by.x]; if(is.factor(bx)) bx <- as.character(bx)
            by <- y[, by.y]; if(is.factor(by)) by <- as.character(by)
        } else {
            ## Do these together for consistency in as.character.
            ## Use same set of names.
            bx <- x[, by.x, drop=FALSE]; by <- y[, by.y, drop=FALSE]
            names(bx) <- names(by) <- paste("V", 1:ncol(bx), sep="")
            bz <- do.call("paste", c(rbind(bx, by), sep = "\r"))
            bx <- bz[1:nx]
            by <- bz[nx + (1:ny)]
        }
        comm <- match(bx, by, 0)
        bxy <- bx[comm > 0]             # the keys which are in both
        xinds <- match(bx, bxy, 0)
        yinds <- match(by, bxy, 0)
        ## R-only solution {when !all.x && !all.y} :
        ##   o <- outer(xinds, yinds, function(x, y) (x > 0) & x==y)
        ##   m <- list(xi = row(o)[o], yi = col(o)[o])
        m <- .Internal(merge(xinds, yinds, all.x, all.y))
        nm <- nm.x <- names(x)[-by.x]
        nm.by <- names(x)[by.x]
        nm.y <- names(y)[-by.y]
        ncx <- ncol(x)
        if(all.x) all.x <- (nxx <- length(m$x.alone)) > 0
        if(all.y) all.y <- (nyy <- length(m$y.alone)) > 0
        lxy <- length(m$xi)             # == length(m$yi)
        ## x = [ by | x ] :
        has.common.nms <- any(cnm <- nm.x %in% nm.y)
        if(has.common.nms)
            nm.x[cnm] <- paste(nm.x[cnm], suffixes[1], sep="")
        x <- x[c(m$xi, if(all.x) m$x.alone),
               c(by.x, (1:ncx)[-by.x]), drop=FALSE]
        names(x) <- c(nm.by, nm.x)
        if(all.y) { ## add the `y.alone' rows to x[]
            ## need to have factor levels extended as well -> using [cr]bind
            ya <- y[m$y.alone, by.y, drop=FALSE]
            names(ya) <- nm.by
            x <- rbind(x, cbind(ya, matrix(NA, nyy, ncx-l.b,
                                           dimnames=list(NULL,nm.x))))
        }
        ## y (w/o `by'):
        if(has.common.nms) {
            cnm <- nm.y %in% nm
            nm.y[cnm] <- paste(nm.y[cnm], suffixes[2], sep="")
        }
        y <- y[c(m$yi, if(all.x) rep.int(1:1, nxx), if(all.y) m$y.alone),
               -by.y, drop = FALSE]
        if(all.x)
            for(i in seq(along = y))
                ## do it this way to invoke methods for e.g. factor
                is.na(y[[i]]) <- (lxy+1):(lxy+nxx)

        if(has.common.nms) names(y) <- nm.y
        res <- cbind(x, y)

        if (sort)
            res <- res[if(all.x || all.y)## does NOT work
                       do.call("order", x[, 1:l.b, drop=FALSE])
            else sort.list(bx[m$xi]),, drop=FALSE]
    }

    row.names(res) <- seq(length=nrow(res))
    res
}
## mlm := multivariate lm()
summary.mlm <- function(object, ...)
{
    coef <- coef(object)
    ny <- ncol(coef)
    if(is.null(ny)) return(NextMethod("summary"))
    effects <- object$effects
    resid <- residuals(object)
    fitted <- fitted(object)
    ynames <- colnames(coef)
    if(is.null(ynames)) {
	lhs <- object$terms[[2]]
	if(mode(lhs) == "call" && lhs[[1]] == "cbind")
	    ynames <- as.character(lhs)[-1]
	else ynames <- paste("Y", seq(ny), sep = "")
    }
    value <- vector("list", ny)
    names(value) <- paste("Response", ynames)
    cl <- oldClass(object)
    class(object) <- cl[match("mlm", cl):length(cl)][-1]
    for(i in seq(ny)) {
	object$coefficients <- coef[, i]
	object$residuals <- resid[, i]
	object$fitted.values <- fitted[, i]
	object$effects <- effects[, i]
	object$call$formula[[2]] <- object$terms[[2]] <- as.name(ynames[i])
	value[[i]] <- summary(object, ...)
    }
    class(value) <- "listof"
    value
}
## predict.mlm  is in  >> ./lm.R <<
anova.mlm <- function(object, ...)
    stop("no anova method implemented for mlm models")

deviance.mlm <- function(object, ...)
{
    res <-
	if(is.null(w <- object$weights)) object$residuals^2
	else w * object$residuals^2
    drop(rep.int(1, nrow(res)) %*% res)
}

plot.mlm <- function (x, ...) .NotYetImplemented()
mode <- function(x) {
    if(is.expression(x)) return("expression")
    if(is.call(x))
	return(switch(deparse(x[[1]])[1],
		      "(" = "(",
		      ## otherwise
		      "call"))
    if(is.name(x)) "name" else
    switch(tx <- typeof(x),
	   double=, integer= "numeric",# 'real=' dropped, 2000/Jan/14
	   closure=, builtin=, special= "function",
	   ## otherwise
	   tx)
}
"storage.mode<-" <-
"mode<-" <- function(x, value)
{
    mde <- paste("as.",value,sep="")
    atr <- attributes(x)
    x <- eval(call(mde,x), parent.frame())
    attributes(x) <- atr
    attr(x, "Csingle") <- if(value == "single") TRUE # else NULL
    x
}
storage.mode <- function(x) {
    x <- typeof(x)
    if (x == "closure" || x == "builtin" || x == "special") return("function")
    x
}
model.tables <- function(x, ...) UseMethod("model.tables")

model.tables.aov <- function(x, type = "effects", se = FALSE, cterms, ...)
{
    if(inherits(x, "maov"))
	stop("model.tables is not implemented for multiple responses")
    type <- match.arg(type, c("effects", "means", "residuals"))
    if(type == "residuals")
	stop(paste("type", type, "not implemented yet"))
    prjs <- proj(x, unweighted.scale = TRUE)
    mf <- model.frame(x)
    factors <- attr(prjs, "factors")
    dn.proj <- as.list(names(factors))
    m.factors <- factors
    names(m.factors) <- names(dn.proj) <- names(factors)
    t.factor <- attr(prjs, "t.factor")
    vars <- colnames(t.factor)
    which <- match(vars, names(dn.proj))
    which <- which[!is.na(which)]
    dn.proj <- dn.proj[which]
    m.factors <- m.factors[which]
    ## with cterms, can specify subset of tables by name
    if(!missing(cterms)) {
	if(any(is.na(match(cterms, names(factors)))))
	    stop("cterms parameter must match terms in model object")
	dn.proj <- dn.proj[cterms]
	m.factors <- m.factors[cterms]
    }
    if(type == "means") {
	dn.proj <-
	    lapply(dn.proj,
		   function(x, mat, vn)
		   c("(Intercept)",
		     vn[(t(mat) %*% (as.logical(mat[, x]) - 1)) == 0]),
		   t.factor, vars)
    }
    tables <- make.tables.aovproj(dn.proj, m.factors, prjs, mf)

    n <- replications(paste("~", paste(names(tables), collapse = "+")),
		      data = mf)
    if(se)
	if(is.list(n)) {
	    cat("Design is unbalanced - use se.contrasts for se's\n")
	    se <- FALSE
	} else se.tables <- se.aov(x, n, type = type)
    if(type == "means") {
	gmtable <- mean(prjs[,"(Intercept)"])
	class(gmtable) <- "mtable"
	tables <- c("Grand mean" = gmtable, tables)
    }
    result <- list(tables = tables, n = n)
    if(se) result$se <- se.tables
    attr(result, "type") <- type
    class(result) <- c("tables.aov", "list.of")
    result
}

se.aov <- function(object, n, type = "means")
{
    ## for balanced designs only
    rdf <- object$df.resid
    rse <- sqrt(sum(object$residuals^2)/rdf)
    if(type == "effects") result <- rse/sqrt(n)
    if(type == "means")
	result <-
	    lapply(n,
		   function(x, d) {
		       nn <- unique(x)
		       nn <- nn[!is.na(nn)]
		       mat <- outer(nn, nn, function(x, y) 1/x + 1/y)
		       dimnames(mat) <- list(paste(nn), paste(nn))
		       d * sqrt(mat)
		   }, d=rse)
    attr(result, "type") <- type
    class(result) <- "mtable"
    result
}


model.tables.aovlist <- function(x, type = "effects", se = FALSE, ...)
{
    type <- match.arg(type, c("effects", "means", "residuals"))
    if(type == "residuals")
	stop(paste("type", type, "not implemented yet"))
    prjs <- proj(x, unweighted.scale = TRUE)
    mf <- model.frame.aovlist(x)
    factors <- lapply(prjs, attr, "factors")
    dn.proj <- unlist(lapply(factors, names), recursive = FALSE)
    m.factors <- unlist(factors, recursive = FALSE)
    dn.strata <- rep.int(names(factors), unlist(lapply(factors, length)))
    names(dn.strata) <- names(m.factors) <- names(dn.proj) <- unlist(dn.proj)
    t.factor <- attr(prjs, "t.factor")
    efficiency <- FALSE
    if(type == "effects" || type == "means") {
	if(any(duplicated(names(dn.proj)[names(dn.proj)!= "Residuals"]))) {
	    efficiency <- eff.aovlist(x)
	    ## Elect to use the effects from the lowest stratum:
	    ##	usually expect this to be highest efficiency
	    eff.used <- apply(efficiency, 2,
			      function(x, ind = seq(length(x))) {
				  temp <- (x > 0)
				  if(sum(temp) == 1) temp
				  else max(ind[temp]) == ind
			      })
	}
    }
    if(any(efficiency)) {
	which <- match(outer(rownames(efficiency),
			     colnames(efficiency), paste)[eff.used],
		       paste(dn.strata, dn.proj))
	efficiency <- efficiency[eff.used]
    } else  which <- match(colnames(t.factor), names(dn.proj))
    which <- which[!is.na(which)]
    dn.proj <- dn.proj[which]
    dn.strata <- dn.strata[which]
    m.factors <- m.factors[which]
    if(type == "means")	 {
	t.factor <- t.factor[, names(dn.proj), drop = FALSE]
	dn.proj <-
	    lapply(dn.proj,
		   function(x, mat, vn)
		   vn[(t(mat) %*% (as.logical(mat[, x]) - 1)) == 0],
		   t.factor, colnames(t.factor))
    }
    tables <-
	if(any(efficiency)) {
	    names(efficiency) <- names(dn.proj)
	    make.tables.aovprojlist(dn.proj, dn.strata, m.factors, prjs, mf,
				    efficiency)
	}
	else make.tables.aovprojlist(dn.proj, dn.strata, m.factors, prjs, mf)
    if(type == "means") {
	gmtable <- mean(prjs[["(Intercept)"]])
	class(gmtable) <- "mtable"
	tables <- lapply(tables, "+", gmtable)
	tables <- c("Grand mean" = gmtable, tables)
    }
    n <- replications(attr(x, "call"), data = mf)
    if(se)
	if(type == "effects"  && is.list(n)) {
	    cat("Standard error information not returned as design is unbalanced. \nStandard errors can be obtained through se.contrast.\n")
	    se <- FALSE
	} else if(type != "effects") {
	    warning(paste("SEs for type ", type, " are not yet implemented"))
	    se <- FALSE
	} else {
	    se.tables <- se.aovlist(x, dn.proj, dn.strata, factors, mf,
				    efficiency, n, type = type)
	}
    result <- list(tables = tables, n = n)
    if(se) result$se <- se.tables
    attr(result, "type") <- type
    class(result) <- c("tables.aov", "list.of")
    result
}

se.aovlist <- function(object, dn.proj, dn.strata, factors, mf, efficiency, n,
		       type = "diff.means", ...)
{
    if(type != "effects")
	stop(paste("SEs for type ", type, " are not yet implemented"))
    RSS <- sapply(object, function(x) sum(x$residuals^2)/x$df.resid)
    res <- vector(length = length(n), mode = "list")
    names(res) <- names(n)
    for(i in names(n)) {
	sse <- RSS[[dn.strata[dn.proj[[i]]]]]
	if(any(efficiency))
	    sse <- sse/efficiency[i]
	res[[i]] <- as.vector(sqrt(sse/n[i]))
	class(res[[i]]) <- "mtable"
    }
    attr(res, "type") <- type
    res
}


make.tables.aovproj <-
    function(proj.cols, mf.cols, prjs, mf, fun = "mean", prt = FALSE, ...)
{
    tables <- vector(mode = "list", length = length(proj.cols))
    names(tables) <- names(proj.cols)
    for(i in seq(length(tables))) {
	terms <- proj.cols[[i]]
	data <-
	    if(length(terms) == 1) prjs[, terms]
	    else prjs[, terms] %*% as.matrix(rep.int(1, length(terms)))
	tables[[i]] <- tapply(data, mf[mf.cols[[i]]],
                              get(fun, mode="function"))
	class(tables[[i]]) <- "mtable"
	if(prt) print(tables[i], ..., quote = FALSE)
    }
    tables
}


make.tables.aovprojlist <-
    function(proj.cols, strata.cols, model.cols, projections, model, eff,
	     fun = "mean", prt = FALSE, ...)
{
    tables <- vector(mode = "list", length = length(proj.cols))
    names(tables) <- names(proj.cols)
    if(!missing(eff)) {
	for(i in seq(length(tables))) {
	    terms <- proj.cols[[i]]
	    if(all(is.na(eff.i <- match(terms, names(eff)))))
		eff.i <- rep.int(1, length(terms))
	    if(length(terms) == 1)
		data <- projections[[strata.cols[i]]][, terms]/ eff[eff.i]
	    else {
		if(length(strata <- unique(strata.cols[terms])) == 1)
		    data <- projections[[strata]][, terms] %*%
			as.matrix(1/eff[eff.i])
		else {
		    mat <- NULL
		    for(j in strata) {
			mat <- cbind(mat, projections[[j]][, terms[!is.na(match(terms,
										names(strata.cols)[strata.cols == j]))]])
		    }
		    data <- mat %*% as.matrix(1/eff[eff.i])
		}
	    }
	    tables[[i]] <- tapply(data, model[model.cols[[i]]],
                                  get(fun, mode="function"))
	    attr(tables[[i]], "strata") <- strata.cols[i]
	    class(tables[[i]]) <- "mtable"
	    if(prt) print(tables[i], ..., quote = FALSE)
	}
    } else for(i in seq(length(tables))) {
	terms <- proj.cols[[i]]
	if(length(terms) == 1) data <- projections[[strata.cols[i]]][, terms]
	else {
	    if(length(strata <- unique(strata.cols[terms])) == 1)
		data <- projections[[strata]][, terms] %*%
		    as.matrix(rep.int(1, length(terms)))
	    else {
		mat <- NULL
		for(j in strata) {
		    mat <- cbind(mat, projections[[j]][, terms[!is.na(match(terms,
									    names(strata.cols)[strata.cols == j]))]])
		}
		data <- mat %*% as.matrix(rep.int(1, length(terms)))
	    }
	}
	tables[[i]] <- tapply(data, model[model.cols[[i]]], get(fun))
	attr(tables[[i]], "strata") <- strata.cols[i]
	class(tables[[i]]) <- "mtable"
	if(prt) print(tables[i], ..., quote = FALSE)
    }
    tables
}

replications <- function(formula, data = NULL, na.action)
{
    if(missing(data) && inherits(formula, "data.frame")) {
	data <- formula
	formula <-  ~ .
    }
    if(!inherits(formula, "terms")) {
	formula <- as.formula(formula)
	if(length(formula) < 3) {
	    f <- y ~ x
	    f[[3]] <- formula[[2]]
	    formula <- f
	}
	formula <- terms(formula, data = data)
    }
    if(missing(na.action))
        if(!is.null(tj <- attr(data, "na.action")) && is.function(tj))
            na.action <- tj
        else {
            naa <- getOption("na.action")
            if(!is.null(naa)) na.action <- match.fun(naa)
            else  na.action <- na.fail
        }
    f <- attr(formula, "factors")
    o <- attr(formula, "order")
    labels <- attr(formula, "term.labels")
    vars <- as.character(attr(formula, "variables"))[-1]
    if(is.null(data)) {
	v <- c(as.name("data.frame"), attr(formula, "variables"))
	data <- eval(as.call(v), parent.frame())
    }
    if(!is.function(na.action)) stop("na.action must be a function")
    data <- na.action(data)
    class(data) <- NULL
    n <- length(o)
    z <- vector("list", n)
    names(z) <- labels
    dummy <- numeric(length(attr(data, "row.names")))
    notfactor <- !sapply(data, function(x) inherits(x, "factor"))
    balance <- TRUE
    for(i in seq(length = n)) {
	l <- labels[i]
	if(o[i] < 1 || substring(l, 1, 5) == "Error") { z[[l]] <- NULL; next }
	select <- vars[f[, i] > 0]
	if(any(nn <- notfactor[select])) {
	    warning(paste("non-factors ignored:",
			  paste(names(nn), collapse = ", ")))
	    next
	}
	if(length(select) > 0)
	    tble <- tapply(dummy, unclass(data[select]), length)
	nrep <- unique(tble)
	if(length(nrep) > 1) {
	    balance <- FALSE
	    tble[is.na(tble)] <- 0
	    z[[l]] <- tble
	} else z[[l]] <- as.vector(nrep)
    }
    if(balance) unlist(z) else z
}

print.tables.aov <- function(x, digits = 4, ...)
{
    tables.aov <- x$tables
    n.aov <- x$n
    se.aov <- if(se <- !is.na(match("se", names(x)))) x$se
    type <- attr(x, "type")
    switch(type,
	   effects = cat("Tables of effects\n"),
	   means = cat("Tables of means\n"),
	   residuals = if(length(tables.aov) > 1) cat(
	   "Table of residuals from each stratum\n"))
    if(!is.na(ii <- match("Grand mean", names(tables.aov)))) {
	cat("Grand mean\n")
	gmtable <- tables.aov[[ii]]
	print.mtable(gmtable, digits = digits, ...)
    }
    for(i in names(tables.aov)) {
	if(i == "Grand mean") next
	table <- tables.aov[[i]]
	cat("\n", i, "\n")
	if(!is.list(n.aov))
	    print.mtable(table, digits = digits, ...)
	else {
	    n <- n.aov[[i]]
	    if(length(dim(table)) < 2) {
		table <- rbind(table, n)
		rownames(table) <- c("", "rep")
		print(table, digits = digits, ...)
	    } else {
		ctable <- array(c(table, n), dim = c(dim(table), 2))
		dim.t <- dim(ctable)
		d <- length(dim.t)
		ctable <- aperm(ctable, c(1, d, 2:(d - 1)))
		dim(ctable) <- c(dim.t[1] * dim.t[d], dim.t[-c(1, d)])
		dimnames(ctable) <-
		    c(list(format(c(rownames(table), rep.int("rep", dim.t[1])))),
                      dimnames(table)[-1])
		ctable <- eval(parse(text = paste(
				     "ctable[as.numeric(t(matrix(seq(nrow(ctable)),ncol=2)))", paste(rep.int(", ", d - 2), collapse = " "), "]")))
		names(dimnames(ctable)) <- names(dimnames(table))
		class(ctable) <- "mtable"
		print.mtable(ctable, digits = digits, ...)
	    }
	}
    }
    if(se) {
	if(type == "residuals") rn <- "df" else rn <- "replic."
	switch(attr(se.aov, "type"),
	       effects = cat("\nStandard errors of effects\n"),
	       means = cat("\nStandard errors for differences of means\n"),
	       residuals = cat("\nStandard errors of residuals\n"))
	if(length(unlist(se.aov)) == length(se.aov)) {
	    ## the simplest case: single replication, unique se
					# kludge for NA's
	    n.aov <- n.aov[!is.na(n.aov)]
	    se.aov <- unlist(se.aov)
	    cn <- names(se.aov)
	    se.aov <- rbind(format(se.aov, digits = digits), format(n.aov))
	    dimnames(se.aov) <- list(c(" ", rn), cn)
	    print(se.aov, quote=FALSE, right=TRUE, ...)
	} else for(i in names(se.aov)) {
	    se <- se.aov[[i]]
	    if(length(se) == 1) { ## single se
		se <- rbind(se, n.aov[i])
		dimnames(se) <- list(c(i, rn), "")
		print(se, digits = digits, ...)
	    } else {		## different se
		dimnames(se)[[1]] <- ""
		cat("\n", i, "\n")
		cat("When comparing means with same levels of:\n")
		print(se, digits, ...)
		cat("replic.", n.aov[i], "\n")
	    }
	}
    }
    invisible(x)
}

eff.aovlist <- function(aovlist)
{
    Terms <- terms(aovlist)
    if(names(aovlist)[[1]] == "(Intercept)") aovlist <- aovlist[-1]
    pure.error.strata <- sapply(aovlist, function(x) is.null(x$qr))
    aovlist <- aovlist[!pure.error.strata]
    proj.len <-
	lapply(aovlist, function(x)
	   {
	       asgn <- x$assign[x$qr$pivot[1:x$rank]]
	       sp <- split(seq(along=asgn), attr(terms(x), "term.labels")[asgn])
	       sapply(sp, function(x, y) sum(y[x]), y=diag(x$qr$qr)^2)
	   })
    x.len <-
	lapply(aovlist, function(x) {
	    X <- as.matrix(qr.X(x$qr)^2)
	    asgn <- x$assign[x$qr$pivot[1:x$rank]]
	    sp <- split(seq(along=asgn), attr(terms(x), "term.labels")[asgn])
	    sapply(sp, function(x, y) sum(y[,x, drop = FALSE]), y=X)
	})
    t.labs <- attr(Terms, "term.labels")
    s.labs <- names(aovlist)
    eff <- matrix(0, ncol = length(t.labs), nrow = length(s.labs),
		  dimnames = list(s.labs, t.labs))
    ind <- NULL
    for(i in names(proj.len))
	ind <- rbind(ind, cbind(match(i, s.labs),
				match(names(proj.len[[i]]), t.labs)))
    eff[ind] <- unlist(x.len)
    x.len <- t(eff) %*% rep.int(1, length(s.labs))
    eff[ind] <- unlist(proj.len)
    eff <- sweep(eff, 2, x.len, "/")
    eff[, x.len != 0, drop = FALSE]
}


model.frame.aovlist <- function(formula, data = NULL, ...)
{
    ## formula is an aovlist object
    call <- match.call()
    oc <- attr(formula, "call")
    Terms <- attr(formula, "terms")
    rm(formula)
    indError <- attr(Terms, "specials")$Error
    errorterm <-  attr(Terms, "variables")[[1 + indError]]
    form <- update.formula(Terms, paste(". ~ .-", deparse(errorterm, width=500, backtick = TRUE),
					"+", deparse(errorterm[[2]], width=500, backtick = TRUE)))
    nargs <- as.list(call)
    oargs <- as.list(oc)
    nargs <- nargs[match(c("data", "na.action", "subset"), names(nargs), 0)]
    args <- oargs[match(c("data", "na.action", "subset"), names(oargs), 0)]
    args[names(nargs)] <- nargs
    args$formula <- form
    do.call("model.frame", args)
}

print.mtable <-
    function(x, ..., digits = getOption("digits"), quote = FALSE, right = FALSE)
{
    xxx <- x
    xx <- attr(x, "Notes")
#    nn <- names(dimnames(x))
    a.ind <- match(names(a <- attributes(x)), c("dim", "dimnames", "names"))
    a <- a[!is.na(a.ind)]
    class(x) <- attributes(x) <- NULL
    attributes(x) <- a
#    if(length(nn) > 1)
#	cat(paste("Dim ",paste(seq(length(nn)), "=", nn, collapse= ", "),"\n"))
    if(length(x) == 1 && is.null(names(x)) && is.null(dimnames(x)))
	names(x) <- rep("", length(x))
    if(length(dim(x)) && is.numeric(x)) {
	xna <- is.na(x)
	x <- format(zapsmall(x, digits))
	x[xna] <- "  "
    }
    print(x, quote = quote, right = right, ...)
    if(length(xx)) {
	cat("\nNotes:\n")
	print(xx)
    }
    invisible(xxx)
}


formula <- function(x, ...) UseMethod("formula")
formula.default <- function (x,env=parent.frame(), ...)
{
    if (!is.null(x$formula))		eval(x$formula)
    else if (!is.null(x$call$formula))	eval(x$call$formula)
    else if (!is.null(x$terms))		x$terms
    else if (!is.null(attr(x, "formula"))) attr(x, "formula")
    else {form<-switch(mode(x),
		NULL = structure(NULL, class = "formula"),
		character = formula(eval(parse(text = x)[[1]])),
		call = eval(x), stop("invalid formula"))
        environment(form)<-env
        form
    }
}
formula.formula <- function(x, ...) x
formula.terms <- function(x, ...) {
    env<- environment(x)
    attributes(x) <- list(class="formula")
    environment(x) <- env
    x
}

formula.data.frame <- function (x, ...)
{
    nm <- sapply(names(x), as.name)
    lhs <- nm[1]
    if (length(nm) > 1) {
       rhs <- nm[-1]
    }
    else {
       rhs <- nm[1]
       lhs <- NULL
    }
    ff <- parse(text = paste(lhs, paste(rhs, collapse = "+"), sep = "~"))
    ff<-eval(ff)
    environment(ff)<-parent.frame()
    ff
}

print.formula <- function(x, ...) {
    attr(x, ".Environment") <- NULL
    print.default(unclass(x), ...)
}

"[.formula" <- function(x,i) {
    ans <- NextMethod("[")
    ## as.character gives a vector.
    if(as.character(ans[[1]])[1] == "~"){
	class(ans) <- "formula"
        environment(ans)<-environment(x)
    }
    ans
}

terms <- function(x, ...) UseMethod("terms")
terms.default <- function(x, ...) {
    v <- x$terms
    if(is.null(v))
        stop("no terms component")
    return(v)
}

terms.terms <- function(x, ...) x
print.terms <- function(x, ...) print.default(unclass(x))

### do this `by hand' as previous approach was vulnerable to re-ordering.
delete.response <- function (termobj)
{
    a <- attributes(termobj)
    y <- a$response
    if(!is.null(y) && y) {
        termobj[[2]] <- NULL
        a$response <- 0
        a$variables <- a$variables[-(1+y)]
        a$predvars <- a$predvars[-(1+y)]
        if(length(a$factors))
            a$factors <- a$factors[-y, , drop = FALSE]
        if(length(a$offset))
            a$offset <- ifelse(a$offset > y, a$offset-1, a$offset)
        if(length(a$specials))
            for(i in 1:length(a$specials)) {
                b <- a$specials[[i]]
                a$specials[[i]] <- ifelse(b > y, b-1, b)
            }
        attributes(termobj) <- a
    }
    termobj
}

reformulate <- function (termlabels, response=NULL)
{
    has.resp <- !is.null(response)
    termtext <- paste(if(has.resp)"response", "~",
		      paste(termlabels, collapse = "+"),
		      collapse = "")
    rval <- eval(parse(text = termtext)[[1]])
    if(has.resp) rval[[2]] <-
        if(is.character(response)) as.symbol(response) else response
    ## response can be a symbol or call as  Surv(ftime, case)
    environment(rval) <- parent.frame()
    rval
}

drop.terms <- function(termobj, dropx=NULL, keep.response = FALSE)
{
    if (is.null(dropx))
	termobj
    else {
	newformula <- reformulate(attr(termobj, "term.labels")[-dropx],
				  if (keep.response) termobj[[2]] else NULL)
        environment(newformula)<-environment(termobj)
	terms(newformula, specials=names(attr(termobj, "specials")))
    }
}


"[.terms" <-function (termobj, i) {
        resp <- if (attr(termobj, "response"))
                termobj[[2]]
        else NULL
        newformula <- attr(termobj, "term.labels")[i]
        if (length(newformula) == 0)
                newformula <- 1
        newformula <- reformulate(newformula, resp)
        environment(newformula)<-environment(termobj)
        terms(newformula, specials = names(attr(termobj, "specials")))

}


terms.formula <- function(x, specials = NULL, abb = NULL, data = NULL,
			  neg.out = TRUE, keep.order = FALSE,
                          simplify = FALSE, ...)
{
    fixFormulaObject <- function(object) {
	tmp <- attr(terms(object), "term.labels")
	form <- formula(object)
	lhs <- if(length(form) == 2) NULL else paste(deparse(form[[2]]),collapse="")
	rhs <- if(length(tmp)) paste(tmp, collapse = " + ") else "1"
	if(!attr(terms(object), "intercept")) rhs <- paste(rhs, "- 1")
	formula(paste(lhs, "~", rhs))
    }

    if (!is.null(data) && !is.environment(data) && !is.data.frame(data))
	data <- as.data.frame(data)
    terms <- .Internal(terms.formula(x, specials, data, keep.order))
    if (simplify) {
        a <- attributes(terms)
        terms <- fixFormulaObject(terms)
        attributes(terms) <- a
    }
    environment(terms) <- environment(x)
    if(!inherits(terms, "formula"))
        class(terms) <- c(oldClass(terms), "formula")
    terms
}

coef <- function(object, ...) UseMethod("coef")
coef.default <- function(object, ...) object$coefficients
coefficients <- coef

residuals <- function(object, ...) UseMethod("residuals")
residuals.default <- function(object, ...)
{
    if(is.null(object$na.action)) object$residuals
    else naresid(object$na.action, object$residuals)
}
resid <- residuals

deviance <- function(object, ...) UseMethod("deviance")
deviance.default <- function(object, ...) object$deviance

fitted <- function(object, ...) UseMethod("fitted")
fitted.default <- function(object, ...)
{
    if(is.null(object$na.action)) object$fitted
    else napredict(object$na.action, object$fitted)
}
fitted.values <- fitted

anova <- function(object, ...)UseMethod("anova")

effects <- function(object, ...)UseMethod("effects")

weights <- function(object, ...)UseMethod("weights")

df.residual <- function(object, ...)UseMethod("df.residual")
df.residual.default <- function(object, ...) object$df.residual

variable.names <- function(object, ...) UseMethod("variable.names")
variable.names.default <- function(object, ...) colnames(object)

case.names <- function(object, ...) UseMethod("case.names")
case.names.default <- function(object, ...) rownames(object)

offset <- function(object) object
## ?


model.frame <- function(formula, ...) UseMethod("model.frame")
model.frame.default <-
    function(formula, data = NULL, subset=NULL, na.action = na.fail,
	     drop.unused.levels = FALSE, xlev = NULL,...)
{
    if(missing(formula)) {
	if(!missing(data) && inherits(data, "data.frame") &&
	   length(attr(data, "terms")) > 0)
	    return(data)
	formula <- as.formula(data)
    }
    else if(missing(data) && inherits(formula, "data.frame")) {
	if(length(attr(formula, "terms")))
	    return(formula)
	data <- formula
	formula <- as.formula(data)
    }
    if(missing(na.action)) {
	if(!is.null(naa <- attr(data, "na.action")) & mode(naa)!="numeric")
	    na.action <- naa
	else if(!is.null(naa <- getOption("na.action")))
	    na.action <- naa
    }
    if(missing(data))
	data <- environment(formula)
    else if (!is.data.frame(data) && !is.environment(data)
             && !is.null(attr(data, "class")))
        data <- as.data.frame(data)
    else if (is.array(data))
        stop("`data' must be a data.frame, not a matrix or  array")
    env <- environment(formula)
    if(!inherits(formula, "terms"))
	formula <- terms(formula, data = data)
    rownames <- attr(data, "row.names")
    vars <- attr(formula, "variables")
    predvars <- attr(formula, "predvars")
    if(is.null(predvars)) predvars <- vars
    varnames <- as.character(vars[-1])
    variables <- eval(predvars, data, env)
    if(is.null(attr(formula, "predvars"))) {
        for (i in seq(along = varnames))
            predvars[[i+1]] <- makepredictcall(variables[[i]], vars[[i+1]])
        attr(formula, "predvars") <- predvars
    }
    extranames <- names(substitute(list(...))[-1])
    extras <- substitute(list(...))
    extras <- eval(extras, data, env)
    ##if(length(extras)) { # remove NULL args
    ##    keep <- !sapply(extras, is.null)
    ##    extras <- extras[keep]
    ##    extranames <- extranames[keep]
    ##}
    subset <- eval(substitute(subset), data, env)
    data <- .Internal(model.frame(formula, rownames, variables, varnames,
				  extras, extranames, subset, na.action))
    ## fix up the levels
    if(length(xlev) > 0) {
	for(nm in names(xlev))
	    if(!is.null(xl <- xlev[[nm]])) {
		xi <- data[[nm]]
		if(is.null(nxl <- levels(xi)))
		    warning(paste("variable", nm, "is not a factor"))
		else {
		    xi <- xi[, drop= TRUE] # drop unused levels
		    if(any(m <- is.na(match(nxl, xl))))
			stop(paste("factor", nm, "has new level(s)", nxl[m]))
		    data[[nm]] <- factor(xi, levels=xl)
		}
	    }
    } else if(drop.unused.levels) {
	for(nm in names(data)) {
	    x <- data[[nm]]
	    if(is.factor(x) &&
	       length(unique(x)) < length(levels(x)))
		data[[nm]] <- data[[nm]][, drop = TRUE]
	}
    }
    data
}

model.weights <- function(x) x$"(weights)"
model.offset <- function(x) {
    offsets <- attr(attr(x, "terms"),"offset")
    if(length(offsets) > 0) {
	ans <- x$"(offset)"
        if (is.null(ans))
	   ans <- 0
	for(i in offsets) ans <- ans+x[[i]]
	ans
    }
    else x$"(offset)"
}

model.matrix <- function(object, ...) UseMethod("model.matrix")
model.matrix.default <- function(object, data = environment(object),
				 contrasts.arg = NULL, xlev = NULL, ...)
{
    t <- terms(object)
    if (is.null(attr(data, "terms")))
	data <- model.frame(object, data, xlev=xlev)
    else {
	reorder <- match(as.character(attr(t,"variables"))[-1],names(data))
	if (any(is.na(reorder)))
	    stop("model frame and formula mismatch in model.matrix()")
	data <- data[,reorder, drop=FALSE]
    }
    int <- attr(t, "response")
    if(length(data)) { # no rhs terms, so skip all this
        contr.funs <- as.character(getOption("contrasts"))
        isF <- sapply(data, function(x) is.factor(x) || is.logical(x) )
        isF[int] <- FALSE
        isOF <- sapply(data, is.ordered)
        namD <- names(data)
        for(nn in namD[isF])            # drop response
            if(is.null(attr(data[[nn]], "contrasts")))
                contrasts(data[[nn]]) <- contr.funs[1 + isOF[nn]]
        ## it might be safer to have numerical contrasts:
        ##	  get(contr.funs[1 + isOF[nn]])(nlevels(data[[nn]]))
        if (!is.null(contrasts.arg) && is.list(contrasts.arg)) {
            if (is.null(namC <- names(contrasts.arg)))
                stop("invalid contrasts argument")
            for (nn in namC) {
                if (is.na(ni <- match(nn, namD)))
                    warning(paste("Variable", nn, "absent, contrast ignored"))
                else {
                    ca <- contrasts.arg[[nn]]
                    if(is.matrix(ca)) contrasts(data[[ni]], ncol(ca)) <- ca
                    else contrasts(data[[ni]]) <- contrasts.arg[[nn]]
                }
            }
        }
    } else { # internal model.matrix needs some variable
        isF <-  FALSE
        data <- list(x=rep(0, nrow(data)))
    }
    ans <- .Internal(model.matrix(t, data))
    cons <- if(any(isF))
	lapply(data[isF], function(x) attr(x,  "contrasts"))
    else NULL
    attr(ans, "contrasts") <- cons
    ans
}

model.response <- function (data, type = "any")
{
    if (attr(attr(data, "terms"), "response")) {
	if (is.list(data) | is.data.frame(data)) {
	    v <- data[[1]]
	    if (type == "numeric" | type == "double") storage.mode(v) <- "double"
	    else if (type != "any") stop("invalid response type")
	    if (is.matrix(v) && ncol(v) == 1) dim(v) <- NULL
	    rows <- attr(data, "row.names")
	    if (nrows <- length(rows)) {
		if (length(v) == nrows) names(v) <- rows
		else if (length(dd <- dim(v)) == 2)
		    if (dd[1] == nrows && !length((dn <- dimnames(v))[[1]]))
			dimnames(v) <- list(rows, dn[[2]])
	    }
	    return(v)
	} else stop("invalid data argument")
    } else return(NULL)
}

model.extract <- function (frame, component)
{
    component <- as.character(substitute(component))
    rval <- switch(component,
		   response = model.response(frame),
		   offset = model.offset(frame), weights = frame$"(weights)",
		   start = frame$"(start)")
    if (is.null(rval)) {
	name <- paste("frame$\"(", component, ")\"", sep = "")
	rval <- eval(parse(text = name)[1])
    }
    if(!is.null(rval)){
	if (length(rval) == nrow(frame))
	    names(rval) <- attr(frame, "row.names")
	else if (is.matrix(rval) && nrow(rval) == nrow(frame)) {
	    t1 <- dimnames(rval)
	    dimnames(rval) <- list(attr(frame, "row.names"), t1[[2]])
	}
    }
    return(rval)
}

preplot <- function(object, ...) UseMethod("preplot")
update <- function(object, ...) UseMethod("update")

is.empty.model <- function (x)
{
    tt <- terms(x)
    (length(attr(tt, "factors")) == 0) & (attr(tt, "intercept")==0)
}

makepredictcall <- function(var, call) UseMethod("makepredictcall")

makepredictcall.default  <- function(var, call)
{
    if(as.character(call)[1] != "scale") return(call)
    if(!is.null(z <- attr(var, "scaled:center"))) call$center <- z
    if(!is.null(z <- attr(var, "scaled:scale"))) call$scale <- z
    call
}
## Original code copyright (C) 1998 John W. Emerson

mosaicplot <- function(x, ...) UseMethod("mosaicplot")

### Changes by MM:
## - NULL instead of NA for default arguments, etc  [R / S convention]
## - plotting at end; cosmetic; warn about unused ... since we really don't..
## - mosaic.cell():  ...(?)
### Changes by KH:
##   Shading of boxes to visualize deviations from independence by
##   displaying sign and magnitude of the standardized residuals.
### Changes by W. Fischer and U. Ligges:
## - Deparsing x in for main title. New arguments: sub, las, cex.axis
## - made to work by BDR

mosaicplot.default <-
function(x, main = deparse(substitute(x)), sub = NULL, xlab = NULL,
         ylab = NULL, sort = NULL, off = NULL, dir = NULL,
         color = FALSE, shade = FALSE, margin = NULL,
         cex.axis = 0.66, las = par("las"),
         type = c("pearson", "deviance", "FT"), ...)
{
    mosaic.cell <- function(X, x1, y1, x2, y2, srt.x, srt.y,
            adj.x, adj.y, off, dir, color, lablevx, lablevy,
            maxdim, currlev, label)
    {
        ## Recursive function doing "the job"
        ##
        ## explicitly relying on (1,1000)^2 user coordinates.
        p <- ncol(X) - 2
        if (dir[1] == "v") {            # split here on the X-axis.
            xdim <- maxdim[1]
            XP <- rep.int(0, xdim)
            for (i in 1:xdim) {
                XP[i] <- sum(X[X[,1]==i,p]) / sum(X[,p])
            }
            white <- off[1] * (x2 - x1) / max(1, xdim-1)
            x.l <- x1
            x.r <- x1 + (1 - off[1]) * XP[1] * (x2 - x1)
            if (xdim > 1) {
                for (i in 2:xdim) {
                    x.l <- c(x.l, x.r[i-1] + white)
                    x.r <- c(x.r, x.r[i-1] + white +
                             (1 - off[1]) * XP[i] * (x2 - x1))
                }
            }
            if (lablevx > 0) {
                this.lab <-
                    if (is.null(label[[1]][1])) {
                        paste(rep.int(as.character(currlev),
                                      length(currlev)),
                              as.character(1:xdim), sep=".")
                    } else label[[1]]
                text(x= x.l + (x.r - x.l) / 2,
                     y= 965 + 22 * (lablevx - 1),
                     srt=srt.x, adj=adj.x, cex=cex.axis, this.lab)
            }
            if (p > 2) {                # recursive call.
                for (i in 1:xdim) {
                    if (XP[i] > 0) {
                        Recall(X[X[,1]==i, 2:(p+2) , drop=FALSE],
                               x.l[i], y1, x.r[i], y2,
                               srt.x, srt.y, adj.x, adj.y,
                               off[-1], dir[-1], color,
                               lablevx-1, (i==1)*lablevy,
                               maxdim[-1], currlev+1, label[2:p])
                    } else {
                        segments(rep.int(x.l[i],3), y1+(y2-y1)*c(0,2,4)/5,
                                 rep.int(x.l[i],3), y1+(y2-y1)*c(1,3,5)/5)
                    }
                }
            } else { # ncol(X) <= 1 : final split polygon and segments.
                for (i in 1:xdim) {
                    if (XP[i] > 0) {
                        polygon(c(x.l[i], x.r[i], x.r[i], x.l[i]),
                                c(y1, y1, y2, y2),
                                lty = if(extended) X[i, p+1] else 1,
                                col = color[if(extended) X[i, p+2] else i])
                    } else {
                        segments(rep.int(x.l[i],3), y1+(y2-y1)*c(0,2,4)/5,
                                 rep.int(x.l[i],3), y1+(y2-y1)*c(1,3,5)/5)
                    }
                }
            }
        } else {                        # split here on the Y-axis.
            ydim <- maxdim[1]
            YP <- rep.int(0, ydim)
            for (j in 1:ydim) {
                YP[j] <- sum(X[X[,1]==j,p]) / sum(X[,p])
            }
            white <- off[1] * (y2 - y1) / (max(1, ydim - 1))
            y.b <- y2 - (1 - off[1]) * YP[1] * (y2 - y1)
            y.t <- y2
            if (ydim > 1) {
                for (j in 2:ydim) {
                    y.b <- c(y.b, y.b[j-1] - white -
                             (1 - off[1]) * YP[j] * (y2 - y1))
                    y.t <- c(y.t, y.b[j-1] - white)
                }
            }
            if (lablevy > 0) {
                this.lab <-
                    if (is.null(label[[1]][1])) {
                        paste(rep.int(as.character(currlev),
                                      length(currlev)),
                              as.character(1:ydim), sep=".")
                    } else label[[1]]
                text(x= 35 - 20 * (lablevy - 1),
                     y= y.b + (y.t - y.b) / 2,
                     srt=srt.y, adj=adj.y, cex=cex.axis, this.lab)
            }
            if (p > 2) {                # recursive call.
                for (j in 1:ydim) {
                    if (YP[j] > 0) {
                        Recall(X[X[,1]==j, 2:(p+2) , drop=FALSE],
                               x1, y.b[j], x2, y.t[j],
                               srt.x, srt.y, adj.x, adj.y,
                               off[-1], dir[-1], color,
                               (j==1)*lablevx, lablevy-1,
                               maxdim[-1], currlev+1, label[2:p])
                    } else {
                        segments(x1+(x2-x1)*c(0,2,4)/5, rep.int(y.b[j],3),
                                 x1+(x2-x1)*c(1,3,5)/5, rep.int(y.b[j],3))
                    }
                }
            } else { # ncol(X) <= 1: final split polygon and segments.
                for (j in 1:ydim) {
                    if (YP[j] > 0) {
                        polygon(c(x1,x2,x2,x1),
                                c(y.b[j],y.b[j],y.t[j],y.t[j]),
                                lty = if(extended) X[j, p+1] else 1,
                                col = color[if(extended) X[j, p+2] else j])
                    } else {
                        segments(x1+(x2-x1)*c(0,2,4)/5, rep.int(y.b[j],3),
                                 x1+(x2-x1)*c(1,3,5)/5, rep.int(y.b[j],3))
                    }
                }
            }
        }
    }

    ##-- Begin main function

    ## Calculate string rotation for different settings of las:
    srt.x <- if(las > 1) 90 else 0
    srt.y <- if(las == 0 || las == 3) 90 else 0

    if(is.null(dim(x)))
        x <- as.array(x)
    else if(is.data.frame(x))
        x <- data.matrix(x)
    dimd <- length(dx <- dim(x))
    if(dimd == 0 || any(dx == 0))
        stop(paste(sQuote("x"), "must not have 0 dimensionality"))
    if(length(list(...)))
        warning(paste("extra argument(s)",
                      paste(sQuote(names(list(...))), collapse = ", "),
                      "disregarded."))
    ##-- Set up 'Ind' matrix : to contain indices and data
    Ind <- 1:dx[1]
    if(dimd > 1) {
        Ind <- rep.int(Ind, prod(dx[2:dimd]))
        for (i in 2:dimd) {
            Ind <- cbind(Ind,
                         c(matrix(1:dx[i], byrow=TRUE,
                                  nr = prod(dx[1:(i-1)]),
                                  nc = prod(dx[i:dimd]))))
        }
    }
    Ind <- cbind(Ind, c(x))
    ## Ok, now the columns of 'Ind' are the cell indices (which could
    ## also have been created by 'expand.grid()' and the corresponding
    ## cell counts.  We add two more columns for dealing with *EXTENDED*
    ## mosaic plots which are produced unless 'shade' is FALSE, which
    ## currently is the default.  These columns have NAs for the simple
    ## case.  Otherwise, they specify the line type (1 for positive and
    ## 2 for negative residuals) and color (by giving the index in the
    ## color vector which ranges from the "most negative" to the "most
    ## positive" residuals.
    if(is.logical(shade) && !shade) {
        extended <- FALSE
        Ind <- cbind(Ind, NA, NA)
    }
    else {
        if(is.logical(shade))
            shade <- c(2, 4)
        else if(any(shade <= 0) || length(shade) > 5)
            stop("invalid shade specification")
        extended <- TRUE
        shade <- sort(shade)
        breaks <- c(-Inf, - rev(shade), 0, shade, Inf)
        color <- c(hsv(0,               # red
                       s = seq(1, to = 0, length = length(shade) + 1)),
                   hsv(4/6,             # blue
                       s = seq(0, to = 1, length = length(shade) + 1)))
        if(is.null(margin))
            margin <- as.list(1:dimd)
        ## Fit the loglinear model.
        E <- loglin(x, margin, fit = TRUE, print = FALSE)$fit
        ## Compute the residuals.
        type <- match.arg(type)
        residuals <-
            switch(type,
                   pearson = (x - E) / sqrt(E),
                   deviance = {
                       tmp <- 2 * (x * log(ifelse(x==0, 1, x/E)) - (x-E))
                       tmp <- sqrt(pmax(tmp, 0))
                       ifelse(x > E, tmp, -tmp)
                   },
                   FT = sqrt(x) + sqrt(x + 1) - sqrt(4 * E + 1))
        ## And add the information to the data matrix.
        Ind <- cbind(Ind,
                     c(1 + (residuals < 0)),
                     as.numeric(cut(residuals, breaks)))
    }

    ## The next four may all be NULL:
    label <- dimnames(x)
    nam.dn <- names(label)
    if(is.null(xlab)) xlab <- nam.dn[1]
    if(is.null(ylab)) ylab <- nam.dn[2]

    if (is.null(off) || length(off) != dimd) { # Initialize spacing.
        off <- rep(10, length=dimd)
    }
    if (is.null(dir) || length(dir) != dimd) {# Initialize directions
        dir <- rep(c("v","h"), length=dimd)
    }
    if (!is.null(sort)) {
        if(length(sort) != dimd)
            stop("length(sort) doesn't conform to dim(x)")
        ## Sort columns.
        Ind[,1:dimd] <- Ind[,sort]
        off <- off[sort]
        dir <- dir[sort]
        label <- label[sort]
    }

    ncolors <- length(tabulate(Ind[,dimd]))
    if(!extended && ((is.null(color) || length(color) != ncolors))) {
        color <-
            if (is.logical(color) && color[1])
                heat.colors(ncolors)
            else if (is.null(color) || (is.logical(color) && !color[1]))
                rep.int(0, ncolors)
            else ## recycle
                rep(color, length = ncolors)
    }

    ##-- Plotting
    plot.new()
    if(!extended) {
        opar <- par(usr = c(1, 1000, 1, 1000), mgp = c(1, 1, 0))
        on.exit(par(opar))
    }
    else {
        ## This code is extremely ugly, and certainly can be improved.
        ## In the case of extended displays, we also need to provide a
        ## legend for the shading and outline patterns.  The code works
        ## o.k. with integer breaks in 'shade'; rounding to two 2 digits
        ## will not be good enough if 'shade' has length 5.
        pin <- par("pin")
        rtxt <- "Standardized\nResiduals:"
        ## Compute cex so that the rotated legend text does not take up
        ## more than 1/12 of the of the plot region horizontally and not
        ## more than 1/4 vertically.
        rtxtCex <- min(1,
                       pin[1] / (strheight(rtxt, units = "inches") * 12),
                       pin[2] / (strwidth (rtxt, units = "inches") / 4))
        rtxtWidth <- 0.1                # unconditionally ..
        ## We put the legend to the right of the third axis.
        opar <- par(usr = c(1, 1000 * (1.1 + rtxtWidth), 1, 1000),
                    mgp = c(1, 1, 0))
        on.exit(par(opar))
        rtxtHeight <-
            strwidth(rtxt, units = "i", cex = rtxtCex) / pin[2]
        text(1000 * (1.05 + 0.5 * rtxtWidth), 0, labels = rtxt,
             adj = c(0, 0.25), srt = 90, cex = rtxtCex)
        ## 'len' is the number of positive or negative intervals of
        ## residuals (so overall, there are '2 * len')
        len <- length(shade) + 1
        ## 'bh' is the height of each box in the legend (including the
        ## separating whitespace
        bh <- 0.95 * (0.95 - rtxtHeight) / (2 * len)
        x.l <- 1000 * 1.05
        x.r <- 1000 * (1.05 + 0.7 * rtxtWidth)
        y.t <- 1000 * rev(seq(from = 0.95, by = - bh, length = 2 * len))
        y.b <- y.t - 1000 * 0.8 * bh
        ltype <- c(rep.int(2, len), rep.int(1, len))
        for(i in 1 : (2 * len)) {
            polygon(c(x.l, x.r, x.r, x.l),
                    c(y.b[i], y.b[i], y.t[i], y.t[i]),
                    col = color[i],
                    lty = ltype[i])
        }
        brks <- round(breaks, 2)
        y.m <- y.b + 1000 * 0.4 * bh
        text(1000 * (1.05 + rtxtWidth), y.m,
             c(paste("<", brks[2], sep = ""),
               paste(brks[2 : (2 * len - 1)],
                     brks[3 : (2 * len)],
                     sep = ":"),
               paste(">", brks[2 * len], sep = "")),
             srt = 90, cex = cex.axis)
    }

    if (!is.null(main) || !is.null(xlab) || !is.null(ylab) || !is.null(sub))
        title(main, sub = sub, xlab = xlab, ylab = ylab)
    adj.x <- adj.y <- 0.5
    x1 <- 50; y1 <- 5; x2 <- 950; y2 <- 950
    maxlen.xlabel <- maxlen.ylabel <- 35
    ## Calculations required for 'las' related string rotation
    ## and adjustment
    if(srt.x == 90){
        maxlen.xlabel <-
            max(strwidth(label[[dimd + 1 - match('v', rev(dir))]],
                cex = cex.axis))
        adj.x <- 1
        y2 <- y2 - maxlen.xlabel
    }
    if(srt.y == 0){
        maxlen.ylabel <-
            max(strwidth(label[[match('h', dir)]],
                cex = cex.axis))
        adj.y <- 0
        x1 <- x1 + maxlen.ylabel
    }

    mosaic.cell(Ind, x1 = x1, y1 = y1, x2 = x2, y2 = y2,
                srt.x = srt.x, srt.y = srt.y, adj.x = adj.x,
                adj.y = adj.y, off = off / 100, dir = dir,
                color = color, lablevx = 2, lablevy = 2,
                maxdim = apply(as.matrix(Ind[,1:dimd]), 2, max),
                currlev = 1, label = label)
}

mosaicplot.formula <-
function(formula, data = NULL, ...,
         main = deparse(substitute(data)), subset)
{
    main # force evaluation here
    m <- match.call(expand.dots = FALSE)
    edata <- eval(m$data, parent.frame())
    if(inherits(edata, "ftable")
       || inherits(edata, "table")
       || length(dim(edata)) > 2) {
        data <- as.table(data)
        varnames <- attr(terms(formula), "term.labels")
        if(all(varnames != "."))
            data <- margin.table(data,
                                 match(varnames, names(dimnames(data))))
        mosaicplot(data, main = main, ...)
    }
    else {
        if(is.matrix(edata))
            m$data <- as.data.frame(data)
        m$... <- NULL
        m[[1]] <- as.name("model.frame")
        mf <- eval(m, parent.frame())
        mosaicplot(table(mf), main = main, ...)
    }
}
mtext <-
function (text, side = 3, line = 0, outer = FALSE, at = NA,
	  adj = NA, cex = NA, col = NA, font = NA, vfont = NULL, ...)
{
    if (!is.null(vfont))
	vfont <- c(typeface = pmatch(vfont[1], Hershey$typeface) - 1,
		   fontindex= pmatch(vfont[2], Hershey$fontindex))
    .Internal(mtext(text, side, line, outer, at, adj, cex, col, font, vfont,
		    ...))
}
##> do_mtext in ../../../main/plot.c
na.pass <- function(object, ...) object
na.action <- function(object, ...) UseMethod("na.action")
na.action.default <- function(object, ...) attr(object, "na.action")

na.fail <- function(object, ...) UseMethod("na.fail")
na.fail.default <- function(object, ...)
{
    ok <- complete.cases(object)
    if(all(ok)) object else stop("missing values in object");
}

na.omit <- function(object, ...) UseMethod("na.omit")

na.omit.default <- function(object, ...)
{
    ## only handle vectors and matrices
    if (!is.atomic(object)) return(object)
    d <- dim(object)
    if (length(d) > 2) return(object)
    omit <- seq(along=object)[is.na(object)]
    if (length(omit) == 0) return(object)
    if (length(d)){
        omit <- unique(((omit-1) %% d[1]) + 1)
        nm <- rownames(object)
        object <- object[-omit, , drop=FALSE]
    } else {
        nm <- names(object)
        object <- object[-omit]
    }
    if (any(omit)) {
	names(omit) <- nm[omit]
	attr(omit, "class") <- "omit"
	attr(object, "na.action") <- omit
    }
    object
}

na.omit.data.frame <- function(object, ...)
{
    ## Assuming a data.frame like object
    n <- length(object)
    omit <- FALSE
    vars <- seq(length = n)
    for(j in vars) {
	x <- object[[j]]
	if(!is.atomic(x)) next
	## variables are assumed to be either some sort of matrix, numeric,...
	x <- is.na(x)
	d <- dim(x)
	if(is.null(d) || length(d) != 2)
	    omit <- omit | x
	else # matrix
	    for(ii in 1:d[2])
		omit <- omit | x[, ii]
    }
    xx <- object[!omit, , drop = FALSE]
    if (any(omit)) {
	temp <- seq(omit)[omit]
	names(temp) <- row.names(object)[omit]
	attr(temp, "class") <- "omit"
	attr(xx, "na.action") <- temp
    }
    xx
}

na.exclude <- function(object, ...) UseMethod("na.exclude")

na.exclude.default <- function(object, ...)
{
    ## only handle vectors and matrices
    if (!is.atomic(object)) return(object)
    d <- dim(object)
    if (length(d) > 2) return(object)
    omit <- seq(along=object)[is.na(object)]
    if (length(omit) == 0) return(object)
    if (length(d)){
        omit <- unique(((omit-1) %% d[1]) + 1)
        nm <- rownames(object)
        object <- object[-omit, , drop=FALSE]
    } else {
        nm <- names(object)
        object <- object[-omit]
    }
    if (any(omit)) {
	names(omit) <- nm[omit]
	attr(omit, "class") <- "omit"
	attr(object, "na.action") <- omit
    }
    object
}

na.exclude.data.frame <- function(object, ...)
{
    ## Assuming a data.frame like object
    n <- length(object)
    omit <- FALSE
    vars <- seq(length = n)
    for(j in vars) {
	x <- object[[j]]
	if(!is.atomic(x)) next
	## variables are assumed to be either some sort of matrix, numeric,...
	x <- is.na(x)
	d <- dim(x)
	if(is.null(d) || length(d) != 2)
	    omit <- omit | x
	else # matrix
	    for(ii in 1:d[2])
		omit <- omit | x[, ii]
    }
    xx <- object[!omit, , drop = FALSE]
    if (any(omit)) {
	temp <- seq(omit)[omit]
	names(temp) <- row.names(object)[omit]
	attr(temp, "class") <- "exclude"
	attr(xx, "na.action") <- temp
    }
    xx
}

naresid <- function(omit, x, ...) UseMethod("naresid")
naresid.default <- function(omit, x, ...) x

naresid.exclude <- function(omit, x, ...)
{
    if (length(omit) == 0 || !is.numeric(omit))
	stop("Invalid argument for 'omit'")
    if(length(x) == 0) return(x)

    if (is.matrix(x)) {
	n <- nrow(x)
	keep <- rep.int(NA, n+length(omit))
	keep[-omit] <- 1:n
	x <- x[keep, , drop=FALSE]
	temp <- rownames(x)
	if (length(temp)) {
	    temp[omit] <- names(omit)
	    rownames(x) <- temp
        }
    } else {
	n <- length(x)
	keep <- rep.int(NA, n+length(omit))
	keep[-omit] <- 1:n
	x <- x[keep]
	temp <- names(x)
	if (length(temp)) {
	    temp[omit] <- names(omit)
	    names(x) <- temp
        }
    }
    x
}

naprint <- function(x, ...) UseMethod("naprint")
naprint.default <- function(x, ...) return("")
naprint.exclude <- naprint.omit <- function(x, ...)
    paste(length(x), "observations deleted due to missing")

napredict <- function(omit, x, ...) UseMethod("napredict")
napredict.default <- function(omit, x, ...) x
napredict.exclude <- function(omit, x, ...) naresid.exclude(omit, x)
names <- function(x) UseMethod("names")
names.default <- function(x) .Internal(names(x))

"names<-" <- function(x, value) UseMethod("names<-")
"names<-.default" <- function(x, value) .Internal("names<-"(x, value))
getNamespace <- function(name) {
    ns <- .Internal(getRegisteredNamespace(as.name(name)))
    if (! is.null(ns)) ns
    else loadNamespace(name)
}
loadedNamespaces <- function()
    ls(env = .Internal(getNamespaceRegistry()), all = TRUE)
getNamespaceName <- function(ns) {
    ns <- asNamespace(ns)
    if (isBaseNamespace(ns)) "base"
    else getNamespaceInfo(ns, "spec")["name"]
}
getNamespaceVersion <- function(ns) {
    ns <- asNamespace(ns)
    if (isBaseNamespace(ns))
        c(version = paste(R.version$major, R.version$minor, sep="."))
    else getNamespaceInfo(ns, "spec")["version"]
}
getNamespaceExports <- function(ns) {
    ns <- asNamespace(ns)
    if (isBaseNamespace(ns)) ls(NULL, all = TRUE)
    else ls(getNamespaceInfo(ns, "exports"), all = TRUE)
}
getNamespaceImports <- function(ns) {
    ns <- asNamespace(ns)
    if (isBaseNamespace(ns)) NULL
    else getNamespaceInfo(ns, "imports")
}
getNamespaceUsers <- function(ns) {
    nsname <- getNamespaceName(asNamespace(ns))
    users <- character(0)
    for (n in loadedNamespaces()) {
        inames <- names(getNamespaceImports(n))
        if (match(nsname, inames, 0))
            users <- c(n, users)
    }
    users
}
getExportedValue <- function(ns, name) {
    getInternalExportName <- function(name, ns) {
        exports <- getNamespaceInfo(ns, "exports")
        if (! exists(name, env = exports, inherits = FALSE))
            stop(paste(name, "is not an exported object"))
        get(name, env = exports, inherits = FALSE)
    }
    ns <- asNamespace(ns)
    if (isBaseNamespace(ns)) get(name, env = ns)
    else get(getInternalExportName(name, ns), env = ns)
}
"::" <- function(pkg,name){
    pkg <- as.character(substitute(pkg))
    name <- as.character(substitute(name))
    getExportedValue(pkg, name)
}
":::" <- function(pkg,name){
    pkg <- as.character(substitute(pkg))
    name <- as.character(substitute(name))
    get(name, env = asNamespace(pkg))
}
attachNamespace <- function(ns, pos = 2) {
    runHook <- function(hookname, env, ...) {
        if (exists(hookname, envir = env, inherits = FALSE)) {
            fun <- get(hookname, envir = env, inherits = FALSE)
            if (! is.null(try({ fun(...); NULL})))
                stop(paste(hookname, "failed"))
        }
    }
    ns <- asNamespace(ns, base.OK = FALSE)
    nsname <- getNamespaceName(ns)
    nspath <- getNamespaceInfo(ns, "path")
    attname <- paste("package", nsname, sep=":")
    if (attname %in% search())
        stop("name space is already attached")
    env <- attach(NULL, pos = pos, name = attname)
    on.exit(detach(pos = pos))
    attr(env, "path") <- nspath
    exports <- getNamespaceExports(ns)
    importIntoEnv(env, exports, ns, exports)
    runHook(".onAttach", ns, dirname(nspath), nsname)
    lockEnvironment(env, TRUE)
    on.exit()
    invisible(env)
}
loadNamespace <- function (package, lib.loc = NULL,
                            keep.source = getOption("keep.source.pkgs"),
                            partial = FALSE, declarativeOnly = FALSE) {
    # eventually allow version as second component; ignore for now.
    package <- as.character(package)[[1]]

    # check for cycles
    dynGet <- function(name, notFound = stop(paste(name, "not found"))) {
        n <- sys.nframe()
        while (n > 1) {
            n <- n - 1
            env <- sys.frame(n)
            if (exists(name, env = env, inherits = FALSE))
                return(get(name, env = env, inherits = FALSE))
        }
        notFound
    }
    loading <- dynGet("__NameSpacesLoading__", NULL)
    if (match(package, loading, 0))
        stop("cyclic name space dependencies are not supported")
    "__NameSpacesLoading__" <- c(package, loading)

    ns <- .Internal(getRegisteredNamespace(as.name(package)))
    if (! is.null(ns))
        ns
    else {
        runHook <- function(hookname, env, ...) {
            if (exists(hookname, envir = env, inherits = FALSE)) {
                fun <- get(hookname, envir = env, inherits = FALSE)
                if (! is.null(try({ fun(...); NULL})))
                    stop(paste(hookname, "failed"))
            }
        }
        makeNamespace <- function(name, version = NULL, lib = NULL) {
            impenv <- new.env(parent = .BaseNamespaceEnv, hash = TRUE)
            env <- new.env(parent = impenv, hash = TRUE)
            name <- as.character(as.name(name))
            version <- as.character(version)
            info <- new.env(hash = TRUE, parent = NULL)
            assign(".__NAMESPACE__.", info, env = env)
            assign("spec", c(name=name,version=version), env = info)
            setNamespaceInfo(env, "exports", new.env(hash = TRUE, parent = NULL))
            setNamespaceInfo(env, "imports", list("base"=TRUE))
            setNamespaceInfo(env, "path", file.path(lib, name))
            setNamespaceInfo(env, "dynlibs", NULL)
            setNamespaceInfo(env, "S3methods", NULL)
            .Internal(registerNamespace(name, env))
            env
        }
        sealNamespace <- function(ns) {
            namespaceIsSealed <- function(ns)
               environmentIsLocked(ns)
            ns <- asNamespace(ns, base.OK = FALSE)
            if (namespaceIsSealed(ns)) stop("already sealed")
            lockEnvironment(ns, TRUE)
            lockEnvironment(parent.env(ns), TRUE)
        }
        addNamespaceDynLibs <- function(ns, newlibs) {
            dynlibs <- getNamespaceInfo(ns, "dynlibs")
            setNamespaceInfo(ns, "dynlibs", c(dynlibs, newlibs))
        }
        hadMethods <- .isMethodsDispatchOn()

        # find package and check it has a name space
        pkgpath <- .find.package(package, lib.loc, quiet = TRUE)
        if (length(pkgpath) == 0)
            stop(paste("There is no package called", sQuote(package)))
        package.lib <- dirname(pkgpath)
        if (! packageHasNamespace(package, package.lib))
            stop(paste("package", sQuote(package),
                       "does not have a name space"))

        # create namespace; arrange to unregister on error
        nsInfo <- parseNamespaceFile(package, package.lib, mustExist = FALSE)
        version = read.dcf(file.path(package.lib, package, "DESCRIPTION"),
                           fields="Version")
        ns <- makeNamespace(package, version = version, lib = package.lib)
        on.exit(.Internal(unregisterNamespace(package)))

        # process imports
        for (i in nsInfo$imports) {
            if (is.character(i))
                namespaceImport(ns, loadNamespace(i, c(lib.loc, .libPaths()),
                                                  keep.source))
            else
                namespaceImportFrom(ns,
                                    loadNamespace(i[[1]],
                                                  c(lib.loc, .libPaths()),
                                                  keep.source), i[[2]])
        }
        for(imp in nsInfo$importClasses) {
            namespaceImportClasses(ns, loadNamespace(imp[[1]],
                                                     c(lib.loc, .libPaths()),
                                                  keep.source), imp[[2]])
        }
        for(imp in nsInfo$importMethods) {
            namespaceImportMethods(ns, loadNamespace(imp[[1]],
                                                     c(lib.loc, .libPaths()),
                                                  keep.source), imp[[2]])
        }

        # dynamic variable to allow/disable .Import and friends
        "__NamespaceDeclarativeOnly__" <- declarativeOnly

        # store info for loading name space for loadingNamespaceInfo to read
        "__LoadingNamespaceInfo__" <- list(libname = package.lib,
                                           pkgname = package)

        env <- asNamespace(ns)
        # save the package name in the environment
        assign(".packageName", package, envir = env)

        # load the code
        codeFile <- file.path(package.lib, package, "R", package)
        if (file.exists(codeFile))
            sys.source(codeFile, env, keep.source = keep.source)
        else warning(paste("Package ", sQuote(package), "contains no R code"))

        # partial loading stops at this point
        if (partial) return(ns)

        # register any S3 methods
        for (spec in nsInfo$S3methods) {
            generic <- spec[1]
            class <- spec[2]
            if (length(spec) == 3) mname <- spec[3]
            else mname <- paste(generic, class, sep=".")
            registerS3method(spec[1], spec[2], mname, env = env)
        }

        # load any dynamic libraries
        for (lib in nsInfo$dynlibs)
            library.dynam(lib, package, package.lib)
        addNamespaceDynLibs(env, nsInfo$dynlibs)

        # run the load hook
        runHook(".onLoad", env, package.lib, package)

        # process exports, seal, and clear on.exit action
        exports <- nsInfo$exports

        for (p in nsInfo$exportPatterns)
            exports <- c(ls(env, pat = p, all = TRUE), exports)
        if(hadMethods) {
            ## process class definition objects
            expClasses <- nsInfo$exportClasses
            if(length(expClasses)>0) {
                missingClasses <- !sapply(expClasses, methods:::isClass, where = ns)
                if(any(missingClasses))
                    stop("Classes for export not defined: ",
                         paste(expClasses[missingClasses], collapse = ", "))
                expClasses <- paste(methods:::classMetaName(""), expClasses, sep="")
            }
            ## process methods metadata explicitly exported or
            ## implied by exporting the generic function.
            allMethods <- unique(c(methods:::getGenerics(ns),
                                   methods:::getGenerics(parent.env(ns))))
            expMethods <- nsInfo$exportMethods
            if(length(allMethods)>0) {
                expMethods  <- unique(c(expMethods,
                                       exports[!is.na(match(exports, allMethods))]))
                missingMethods <- !(expMethods %in% allMethods)
                if(any(missingMethods))
                    stop("Methods for export not found: ",
                         paste(expMethods[missingMethods], collapse = ", "))
                needMethods <- (exports %in% allMethods) & !(exports %in% expMethods)
                if(any(needMethods))
                    expMethods <- c(expMethods, exports[needMethods])
                for(i in seq(along=expMethods)) {
                    mi <- expMethods[[i]]
                    if(!(mi %in% exports) &&
                       exists(mi, envir = ns, mode = "function", inherits = FALSE))
                        exports <- c(exports, mi)
                    expMethods[[i]] <- methods:::mlistMetaName(mi, ns)
                }
            }
            else if(length(expMethods) > 0)
                stop("Methods specified for export, but none defined: ",
                     paste(expMethods, collapse=", "))
            exports <- unique(c(exports, expClasses, expMethods))
        }
        namespaceExport(ns, exports)
        sealNamespace(ns)
        on.exit()
        ns
    }
}
loadingNamespaceInfo <- function() {
    dynGet <- function(name, notFound = stop(paste(name, "not found"))) {
        n <- sys.nframe()
        while (n > 1) {
            n <- n - 1
            env <- sys.frame(n)
            if (exists(name, env = env, inherits = FALSE))
                return(get(name, env = env, inherits = FALSE))
        }
        notFound
    }
    dynGet("__LoadingNamespaceInfo__", stop("not loading a name space"))
}
saveNamespaceImage <- function (package, rdafile, lib.loc = NULL,
                                keep.source = getOption("keep.source.pkgs")) {
    if (! is.null(.Internal(getRegisteredNamespace(as.name(package)))))
        stop(paste("name space", sQuote(package), "is loaded"));
    ns <- loadNamespace(package, lib.loc, keep.source, TRUE, TRUE)
    vars <- ls(ns, all = TRUE)
    vars <- vars[vars != ".__NAMESPACE__."]
    save(list = vars, file = rdafile, envir = ns)
}
topenv <- function(envir = parent.frame(),
                   matchThisEnv = getOption("topLevelEnvironment")) {
    while (! is.null(envir)) {
        if (! is.null(attr(envir, "name")) ||
            identical(envir, matchThisEnv) ||
            identical(envir, .GlobalEnv) ||
            .Internal(isNamespaceEnv(envir)) ||
            exists(".packageName", envir = envir, inherits = FALSE))
            return(envir)
        else envir <- parent.env(envir)
    }
    return(.GlobalEnv)
}
unloadNamespace <- function(ns) {
    runHook <- function(hookname, env, ...) {
        if (exists(hookname, envir = env, inherits = FALSE)) {
            fun <- get(hookname, envir = env, inherits = FALSE)
            if (! is.null(try({ fun(...); NULL})))
                stop(paste(hookname, "failed"))
        }
    }
    ns <- asNamespace(ns, base.OK = FALSE)
    nsname <- getNamespaceName(ns)
    pos <- match(paste("package", nsname, sep=":"), search())
    if (! is.na(pos)) detach(pos = pos)
    users <- getNamespaceUsers(ns)
    if (length(users) != 0)
        stop(paste("name space still used by:", paste(users, collapse = ", ")))
    nspath <- getNamespaceInfo(ns, "path")
    try(runHook(".onUnload", ns, nspath))
    .Internal(unregisterNamespace(nsname))
}
.Import <- function(...) {
    dynGet <- function(name, notFound = stop(paste(name, "not found"))) {
        n <- sys.nframe()
        while (n > 1) {
            n <- n - 1
            env <- sys.frame(n)
            if (exists(name, env = env, inherits = FALSE))
                return(get(name, env = env, inherits = FALSE))
        }
        notFound
    }
    if (dynGet("__NamespaceDeclarativeOnly__", FALSE))
        stop("imperative name space directives are disabled")
    envir <- parent.frame()
    names <- as.character(substitute(list(...)))[-1]
    for (n in names)
        namespaceImportFrom(envir, n)
}
.ImportFrom <- function(name, ...) {
    dynGet <- function(name, notFound = stop(paste(name, "not found"))) {
        n <- sys.nframe()
        while (n > 1) {
            n <- n - 1
            env <- sys.frame(n)
            if (exists(name, env = env, inherits = FALSE))
                return(get(name, env = env, inherits = FALSE))
        }
        notFound
    }
    if (dynGet("__NamespaceDeclarativeOnly__", FALSE))
        stop("imperative name space directives are disabled")
    envir <- parent.frame()
    name <-  as.character(substitute(name))
    names <- as.character(substitute(list(...)))[-1]
    namespaceImportFrom(envir, name, names)
}
.Export <- function(...) {
    dynGet <- function(name, notFound = stop(paste(name, "not found"))) {
        n <- sys.nframe()
        while (n > 1) {
            n <- n - 1
            env <- sys.frame(n)
            if (exists(name, env = env, inherits = FALSE))
                return(get(name, env = env, inherits = FALSE))
        }
        notFound
    }
    if (dynGet("__NamespaceDeclarativeOnly__", FALSE))
        stop("imperative name space directives are disabled")
    ns <- topenv(parent.frame(), NULL)
    if (identical(ns, .BaseNamespaceEnv))
        warning("all objects in base name space are currently exported.")
    else if (! isNamespace(ns))
        stop("can only export from a name space")
    else {
        names <- as.character(substitute(list(...)))[-1]
        namespaceExport(ns, names)
    }
}
.S3method <- function(generic, class, method) {
    dynGet <- function(name, notFound = stop(paste(name, "not found"))) {
        n <- sys.nframe()
        while (n > 1) {
            n <- n - 1
            env <- sys.frame(n)
            if (exists(name, env = env, inherits = FALSE))
                return(get(name, env = env, inherits = FALSE))
        }
        notFound
    }
    if (dynGet("__NamespaceDeclarativeOnly__", FALSE))
        stop("imperative name space directives are disabled")
    generic <- as.character(substitute(generic))
    class <- as.character(substitute(class))
    if (missing(method)) method <- paste(generic, class, sep=".")
    registerS3method(generic, class, method, envir = parent.frame())
    invisible(NULL)
}
isNamespace <- function(ns) .Internal(isNamespaceEnv(ns))
isBaseNamespace <- function(ns) identical(ns, .BaseNamespaceEnv)
getNamespaceInfo <- function(ns, which) {
    ns <- asNamespace(ns, base.OK = FALSE)
    info <- get(".__NAMESPACE__.", env = ns, inherits = FALSE)
    get(which, env = info, inherits = FALSE)
}
setNamespaceInfo <- function(ns, which, val) {
    ns <- asNamespace(ns, base.OK = FALSE)
    info <- get(".__NAMESPACE__.", env = ns, inherits = FALSE)
    assign(which, val, env = info)
}
asNamespace <- function(ns, base.OK = TRUE) {
    if (is.character(ns) || is.name(ns))
        ns <- getNamespace(ns)
    if (! isNamespace(ns))
        stop("not a name space")
    else if (! base.OK && isBaseNamespace(ns))
        stop("operation not allowed on base name space")
    else ns
}
namespaceImport <- function(self, ...) {
    for (ns in list(...))
        namespaceImportFrom(self, asNamespace(ns))
}
namespaceImportFrom <- function(self, ns, vars) {
    addImports <- function(ns, from, what) {
        imp <- structure(list(what), names = getNamespaceName(from))
        imports <- getNamespaceImports(ns)
        setNamespaceInfo(ns, "imports", c(imports, imp))
    }
    namespaceIsSealed <- function(ns)
       environmentIsLocked(ns)
    makeImportExportNames <- function(spec) {
        old <- as.character(spec)
        new <- names(spec)
        if (is.null(new)) new <- old
        else new[new==""] <- old[new==""]
        names(old) <- new
        old
    }
    mergeImportMethods <- function(impenv, expenv, metaname) {
        expMethods <- get(metaname, envir = expenv)
        if(exists(metaname, envir = impenv, inherits = FALSE)) {
            impMethods <- get(metaname, envir = impenv)
            assign(metaname, methods:::mergeMethods(impMethods, expMethods), envir = impenv)
            TRUE
        }
        else
            FALSE
    }
    whichMethodMetaNames <- function(impvars) {
        if(!.isMethodsDispatchOn())
            return(numeric())
        mm <- methods:::mlistMetaName()
        seq(along = impvars)[substr(impvars, 1, nchar(mm)) == mm]
    }
    if (is.character(self))
        self <- getNamespace(self)
    ns <- asNamespace(ns)
    if (missing(vars)) impvars <- getNamespaceExports(ns)
    else impvars <- vars
    impvars <- makeImportExportNames(impvars)
    impnames <- names(impvars)
    if (any(duplicated(impnames))) {
        stop("duplicate import names ",
             paste(impnames[duplicated(impnames)], collapse=", "))
    }
    if (isNamespace(self) && isBaseNamespace(self)) {
        impenv <- self
        msg <- "replacing local value with import:"
        register <- FALSE
    }
    else if (isNamespace(self)) {
        if (namespaceIsSealed(self))
            stop("cannot import into a sealed namespace")
        impenv <- parent.env(self)
        msg <- "replacing previous import:"
        register <- TRUE
    }
    else if (is.environment(self)) {
        impenv <- self
        msg <- "replacing local value with import:"
        register <- FALSE
    }
    else stop("invalid import target")
    which <- whichMethodMetaNames(impvars)
    if(length(which)) {
        ## If methods are already in impenv, merge and don't import
        delete <- integer()
        for(i in which)
            if(mergeImportMethods(impenv, ns, impvars[[i]]))
                delete <- c(delete, i)
        if(length(delete)>0) {
            impvars <- impvars[-delete]
            impnames <- impnames[-delete]
        }
    }
    for (n in impnames)
        if (exists(n, env = impenv, inherits = FALSE))
            warning(paste(msg, n))
    importIntoEnv(impenv, impnames, ns, impvars)
    if (register) {
        if (missing(vars)) addImports(self, ns, TRUE)
        else addImports(self, ns, impvars)
    }
}
namespaceImportClasses <- function(self, ns, vars) {
    for(i in seq(along = vars))
        vars[[i]] <- methods:::classMetaName(vars[[i]])
    namespaceImportFrom(self, asNamespace(ns), vars)
}
namespaceImportMethods <- function(self, ns, vars) {
    allVars <- character()
    allMlists <- methods:::getGenerics(ns)
    if(any(is.na(match(vars, allMlists))))
        stop("Requested methods objects not found in environment/package \"",
                methods:::getPackageName(ns), "\": ",
                paste(vars[is.na(match(vars, allMlists))], collapse = ", "))
    for(i in seq(along = allMlists)) {
        ## import methods list objects if asked for
        ## or if the corresponding generic was imported
        g <- allMlists[[i]]
        if(exists(g, envir=self, inherits = FALSE) # already imported
           || g %in% vars) # requested explicitly
            allVars <- c(allVars, methods:::mlistMetaName(g, ns))
        if(g %in% vars && !exists(g, envir=self, inherits = FALSE) &&
           exists(g, envir=ns, inherits = FALSE) &&
           methods:::is(get(g, envir = ns), "genericFunction"))
            allVars <- c(allVars, g)
    }
    namespaceImportFrom(self, asNamespace(ns), allVars)
}
importIntoEnv <- function(impenv, impnames, expenv, expnames) {
    getInternalExportName <- function(name, ns) {
        exports <- getNamespaceInfo(ns, "exports")
        if (! exists(name, env = exports, inherits = FALSE))
            stop(paste(name, "is not an exported object"))
        get(name, env = exports, inherits = FALSE)
    }
    expnames <- unlist(lapply(expnames, getInternalExportName, expenv))
    if (is.null(impnames)) impnames <- character(0)
    if (is.null(expnames)) expnames <- character(0)
    .Internal(importIntoEnv(impenv, impnames, expenv, expnames))
}
namespaceExport <- function(ns, vars) {
    namespaceIsSealed <- function(ns)
       environmentIsLocked(ns)
    if (namespaceIsSealed(ns))
        stop("cannot add to exports of a sealed namespace")
    ns <- asNamespace(ns, base.OK = FALSE)
    if (length(vars) > 0) {
        addExports <- function(ns, new) {
            exports <- getNamespaceInfo(ns, "exports")
            expnames <- names(new)
            intnames <- new
            for (i in seq(along = new)) {
                if (exists(expnames[i], env = exports, inherits = FALSE))
                    warning("replacing previous export:", expnames[i])
                assign(expnames[i], intnames[i], env = exports)
            }
        }
        makeImportExportNames <- function(spec) {
            old <- as.character(spec)
            new <- names(spec)
            if (is.null(new)) new <- old
            else new[new==""] <- old[new==""]
            names(old) <- new
            old
        }
        new <- makeImportExportNames(vars)
        if (any(duplicated(new)))
            stop("duplicate export names ",
             paste(new[duplicated(new)], collapse=", "))
        undef <- new[! sapply(new, exists, env = ns)]
        if (length(undef) != 0) {
           undef <- do.call("paste", as.list(c(undef, sep=", ")))
            stop(paste("undefined exports:", undef))
        }
        .mergeExportMethods(new, ns)
        addExports(ns, new)
    }
}
.mergeExportMethods <- function(new, ns) {
    if(!.isMethodsDispatchOn())
        return(FALSE)
    mm = methods:::mlistMetaName()
    newMethods <- new[substr(new, 1, nchar(mm)) == mm]
    nsimports <- parent.env(ns)
    for(what in newMethods) {
        if(exists(what, envir = nsimports, inherits = FALSE)) {
            m1 <- get(what, envir = nsimports)
            m2 <- get(what, envir = ns)
            assign(what, envir = ns, methods:::mergeMethods(m1, m2))
        }
    }
}
packageHasNamespace <- function(package, package.lib) {
    namespaceFilePath <- function(package, package.lib)
        file.path(package.lib, package, "NAMESPACE")
    file.exists(namespaceFilePath(package, package.lib)) ||
    ! is.na(read.dcf(file.path(package.lib, package, "DESCRIPTION"),
                               fields="Namespace"))
}
parseNamespaceFile <- function(package, package.lib, mustExist = TRUE) {
    namespaceFilePath <- function(package, package.lib)
        file.path(package.lib, package, "NAMESPACE")
    nsFile <- namespaceFilePath(package, package.lib)
    if (file.exists(nsFile))
        directives <- parse(nsFile)
    else if (mustExist)
        stop(paste("package", sQuote(package), "has no NAMESPACE file"))
    else directives <- NULL
    exports <- character(0)
    exportPatterns <- character(0)
    exportClasses <- character(0)
    exportMethods <- character(0)
    imports <- list()
    importMethods <- list()
    importClasses <- list()
    dynlibs <- character(0)
    S3methods <- list()
    for (e in directives)
        switch(as.character(e[[1]]),
               export = {
                   exp <- e[-1]
                   exp <- structure(as.character(exp), names=names(exp))
                   exports <- c(exports, exp)
               },
               exportPattern = {
                   pat <- as.character(e[-1])
                   exportPatterns <- c(pat, exportPatterns)
               },
               exportClass = , exportClasses = {
                   exportClasses <- c(as.character(e[-1]), exportClasses)
               },
               exportMethods = {
                   exportMethods <- c(as.character(e[-1]), exportMethods)
               },
               import = imports <- c(imports,as.list(as.character(e[-1]))),
               importFrom = {
                   imp <- e[-1]
                   ivars <- imp[-1]
                   inames <- names(ivars)
                   imp <- list(as.character(imp[1]),
                               structure(as.character(ivars), names=inames))
                   imports <- c(imports, list(imp))
               },
               importClassFrom = , importClassesFrom = {
                   imp <- as.character(e[-1])
                   pkg <- imp[[1]]
                   impClasses <- imp[-1]
                   imp <- list(as.character(pkg), as.character(impClasses))
                   importClasses <- c(importClasses, list(imp))
               },
               importMethodsFrom = {
                   imp <- as.character(e[-1])
                   pkg <- imp[[1]]
                   impMethods <- imp[-1]
                   imp <- list(as.character(pkg), as.character(impMethods))
                   importMethods <- c(importMethods, list(imp))
               },
               useDynLib = {
                   dyl <- e[-1]
                   dynlibs <- c(dynlibs, as.character(dyl))
               },
               S3method = {
                   spec <- e[-1]
                   if (length(spec) != 2 && length(spec) != 3)
                       stop(paste("bad S3method directive:", deparse(e)))
                   S3methods <- c(S3methods, list(as.character(e[-1])))
               },
               stop(paste("unknown namespace directive:", deparse(e))))
    list(imports=imports, exports=exports, exportPatterns = exportPatterns,
         importClasses=importClasses, importMethods=importMethods,
         exportClasses=exportClasses, exportMethods=exportMethods,
         dynlibs=dynlibs, S3methods = S3methods)
}
registerS3method <- function(genname, class, method, envir = parent.frame()) {
    addNamespaceS3method <- function(ns, generic, class, method) {
        regs <- getNamespaceInfo(ns, "S3methods")
        regs <- c(regs, list(list(generic, class, method)))
        setNamespaceInfo(ns, "S3methods", regs)
    }
    groupGenerics <- c("Ops", "Math", "Summary")
    if(genname %in% groupGenerics) defenv <- .BaseNamespaceEnv
    else {
        genfun <- get(genname, envir = envir)
        if (typeof(genfun) == "closure")
            defenv <- environment(genfun)
        else defenv <- .BaseNamespaceEnv
    }
    if (! exists(".__S3MethodsTable__.", envir = defenv, inherits = FALSE))
        assign(".__S3MethodsTable__.", new.env(hash = TRUE, parent = NULL),
               envir = defenv)
    table <- get(".__S3MethodsTable__.", envir = defenv, inherits = FALSE)
    if (is.character(method)) {
        wrap <- function(method, home) {
            method <- method            # force evaluation
            home <- home                # force evaluation
            delay(get(method, env = home), env = environment())
        }
        if(!exists(method, env = envir)) {
            warning(paste("S3 method",
                          sQuote(method),
                          "was declared in NAMESPACE but not found"),
                    call. = FALSE)
        } else {
            assign(paste(genname, class, sep = "."), wrap(method, envir),
                   envir = table)
        }
    }
    else if (is.function(method))
        assign(paste(genname, class, sep = "."), method, envir = table)
    else stop("bad method")
    if (isNamespace(envir) && ! identical(envir, .BaseNamespaceEnv))
        addNamespaceS3method(envir, genname, class, method)
}

# export <- function(expr, where = topenv(parent.frame()),
#                    exclusions = c("last.dump", "last.warning", ".Last.value",
#                        ".Random.seed", ".packageName", ".noGenerics", ".required")) {
#     ns <- as.environment(where)
#     if(isNamespace(ns)) {
#         expEnv <- new.env(hash = TRUE, parent =ns)
#         ## copy .packageName (will also make this qualify as topenv()
#         ## for class & method assignment
#         assign(".packageName", get(".packageName", envir = ns), envir = expEnv)
#         eval(substitute(expr), expEnv)
#         ## objects assigned will be exported.
#         allObjects  <- objects(expEnv, all=TRUE)
#         newExports <- allObjects[!(allObjects %in% exclusions)]
#         ## Merge any methods lists with existing versions in ns == parent.env(expEnv)
#         .mergeExportMethods(newExports, expEnv)
#         ## copy the objects
#         for(what in allObjects)
#             assign(what, get(what, envir = expEnv), envir = ns)
#         ## and update the exports information
#         exports <- getNamespaceInfo(ns, "exports")
#         for(what in newExports)
#             assign(what, what, envir = exports)
#     }
#     else
#         eval(substitute(expr), ns)
# }
nlm <- function(f, p, hessian=FALSE, typsize=rep(1,length(p)),
		fscale=1, print.level=0, ndigit=12, gradtol=1e-6,
		stepmax=max(1000 * sqrt(sum((p/typsize)^2)), 1000),
		steptol=1e-6, iterlim=100, check.analyticals=TRUE, ...)
{

    print.level <- as.integer(print.level)
    if(print.level < 0 || print.level > 2)
	stop("`print.level' must be in {0,1,2}")
    ## msg is collection of bits, i.e., sum of 2^k (k = 0,..,4):
    msg <- (1 + c(8,0,16))[1+print.level]
    if(!check.analyticals) msg <- msg + (2 + 4)
    .Internal(nlm(function(x) f(x, ...), p, hessian, typsize, fscale,
                  msg, ndigit, gradtol, stepmax, steptol, iterlim))
}

optimize <- function(f, interval, lower=min(interval), upper=max(interval),
		     maximum=FALSE, tol=.Machine$double.eps^0.25, ...)
{
    if(maximum) {
	val <- .Internal(fmin(function(arg) -f(arg, ...), lower, upper, tol))
	list(maximum=val, objective= f(val, ...))
    } else {
	val <- .Internal(fmin(function(arg) f(arg, ...), lower, upper, tol))
	list(minimum=val, objective= f(val, ...))
    }
}

##nice to the English (or rather the Scots)
optimise <- optimize

uniroot <- function(f, interval, lower=min(interval), upper=max(interval),
		    tol=.Machine$double.eps^0.25, maxiter = 1000, ...)
{
    if(!is.numeric(lower) || !is.numeric(upper) || lower >= upper)
		   stop("lower < upper  is not fulfilled")
    if(f(lower, ...)*f(upper, ...) >= 0)
	stop("f() values at end points not of opposite sign")
    val <- .Internal(zeroin(function(arg) f(arg, ...), lower, upper, tol,
			    as.integer(maxiter)))
    if((iter <- as.integer(val[2])) < 0) {
	warning(paste("_NOT_ converged in ",maxiter,"iterations."))
        iter <- -iter
    }
    list(root=val[1], f.root=f(val[1], ...),
         iter=iter, estim.prec= val[3])
}

deriv <- function(expr, ...) UseMethod("deriv")

deriv.formula <- function(expr, namevec, function.arg=NULL, tag=".expr",
                          hessian = FALSE, ...)
{
    if((le <- length(expr)) > 1)
	.Internal(deriv.default(expr[[le]], namevec, function.arg, tag, hessian))
    else stop("invalid formula in deriv")
}

deriv.default <- function(expr, namevec, function.arg=NULL, tag=".expr",
                          hessian = FALSE, ...)
    .Internal(deriv.default(expr, namevec, function.arg, tag, hessian))

deriv3 <- function(expr, ...) UseMethod("deriv3")

deriv3.formula <- function(expr, namevec, function.arg=NULL, tag=".expr",
                          hessian = TRUE, ...)
{
    if((le <- length(expr)) > 1)
	.Internal(deriv.default(expr[[le]], namevec, function.arg, tag, hessian))
    else stop("invalid formula in deriv")
}

deriv3.default <- function(expr, namevec, function.arg=NULL, tag=".expr",
                          hessian = TRUE, ...)
    .Internal(deriv.default(expr, namevec, function.arg, tag, hessian))

.NotYetImplemented <- function ()
    stop(sQuote(as.character(sys.call(sys.parent())[[1]])),
         " is not implemented yet", call. = FALSE)

.NotYetUsed <- function(arg, error = TRUE) {
    msg <- paste("argument", sQuote(arg), "is not used (yet)")
    if(error) stop(msg) else warning(msg)
}
object.size <- function(x) .Internal(object.size(x))
## 'objects <- function(....) ...    --->>> ./attach.R

inherits <- function(x, what, which = FALSE)
	.Internal(inherits(x, what, which))

NextMethod <- function(generic=NULL, object=NULL, ...)
    .Internal(NextMethod(generic, object,...))

methods <- function (generic.function, class)
{
## FIXME: findGeneric() is almost identical inside getS3method() !
    findGeneric <- function(fname, envir) {
        if(!exists(fname, mode = "function", envir = envir)) return("")
        if(any(fname == tools:::.getInternalS3generics())) return(fname)
        f <- get(fname, mode = "function", envir = envir)
        isUMEbrace <- function(e) {
            for (ee in as.list(e[-1]))
                if (nchar(res <- isUME(ee))) return(res)
            ""
        }
        isUMEif <- function(e) {
            if (length(e) == 3) isUME(e[[3]])
            else {
                if (nchar(res <- isUME(e[[3]]))) res
                else if (nchar(res <- isUME(e[[4]]))) res
                else ""
            }
        }
        isUME <- function(e) {
            if (is.call(e) && (is.name(e[[1]]) || is.character(e[[1]]))) {
                switch(as.character(e[[1]]),
                       UseMethod = as.character(e[[2]]),
                       "{" = isUMEbrace(e),
                       "if" = isUMEif(e),
                       "")
            } else ""
        }
        isUME(body(f))
    }

## FIXME[MM]: An abstraction of this function should go to "tools" or similar:
    rbindSome <- function(df, nms, msg) {
        ## rbind.data.frame() -- dropping duplicated rows
        seriDf <- function(x)
            do.call("paste", c(cbind(rownames(x), x), sep = "\r"))
        n2 <- length(nms)
        dnew <- data.frame(visible = rep.int(FALSE, n2),
                           from    = rep.int(msg,   n2),
                           row.names = nms)
        n <- nrow(df)
        if(n == 0) return(dnew)
        ## else
        keep <- !duplicated(c(seriDf(df), seriDf(dnew)))
        rbind(df  [keep[1:n] , ],
              dnew[keep[(n+1):(n+n2)] , ])
    }

    S3MethodsStopList <- tools:::.makeS3MethodsStopList(NULL)
    S3groupGenerics <- c("Ops", "Math", "Summary")

    an <- lapply(seq(along=(sp <- search())), ls)
    names(an) <- sp
    an <- unlist(an)
    an <- an[!duplicated(an)] # removed masked objects, *keep* names
    names(an) <- sub("[0-9]*$", "", names(an))
    info <- data.frame(visible = rep.int(TRUE, length(an)),
                       from = names(an),
                       row.names = an)
    if (!missing(generic.function)) {
	if (!is.character(generic.function))
	    generic.function <- deparse(substitute(generic.function))
        truegf <- findGeneric(generic.function, parent.frame())
        if(nchar(truegf) && truegf != generic.function) {
            warning(paste("Generic", sQuote(generic.function),
                          "dispatches methods for generic",
                          sQuote(truegf)))
            generic.function <- truegf
        }
        genfun <- get(generic.function, mode = "function",
                      envir = parent.frame())
	name <- paste("^", generic.function, ".", sep = "")
        name <- gsub("([.[$+*])", "\\\\\\1",name)
        info <- info[grep(name, row.names(info)), ]
        info <- info[! row.names(info) %in% S3MethodsStopList, ]
        ## check that these are all functions
        ## might be none at this point
        if(nrow(info)) {
            keep <- sapply(row.names(info),
                           function(nm) exists(nm, mode="function"))
            info <- info[keep, ]
        }

        ## also look for registered methods from namespaces
        ## we assume that only functions get registered.
        if(generic.function %in% S3groupGenerics)
            defenv <- .BaseNamespaceEnv
        else {
            defenv <- if (typeof(genfun) == "closure") environment(genfun)
            else .BaseNamespaceEnv
        }
        S3reg <- ls(get(".__S3MethodsTable__.", envir = defenv),
                    pattern = name)
        if(length(S3reg))
            info <- rbindSome(info, S3reg, msg =
                              paste("registered S3method for", generic.function))
    }
    else if (!missing(class)) {
	if (!is.character(class))
	    class <- paste(deparse(substitute(class)))
	name <- paste(".", class, "$", sep = "")
        name <- gsub("([.[])", "\\\\\\1", name)
        info <- info[grep(name, row.names(info)), ]
        info <- info[! row.names(info) %in% S3MethodsStopList, ]

        if(nrow(info)) {
            ## check if we can find a generic matching the name
            possible.generics <- gsub(name, "", row.names(info))
            keep <- sapply(possible.generics, function(nm) {
                where <- find(nm, mode = "function")
                if(!length(where)) return(FALSE)
                any(sapply(where, function(w)
                           nchar(findGeneric(nm, envir=as.environment(w))) > 0))
            })
            info <- info[keep, ]
        }

        ## also look for registered methods in loaded namespaces.
        ## These should only be registered in environments containing
        ## the corresponding generic, so we don't check again.
        ## Note that the generic will not necessarily be visible,
        ## as the package may not be loaded -- we don't check.
        for(i in loadedNamespaces()) {
            S3reg <- ls(get(".__S3MethodsTable__.", envir = asNamespace(i)),
                        pattern = name)
            if(length(S3reg))
                info <- rbindSome(info, S3reg, msg = "registered S3method")
        }
    }
    else stop("must supply generic.function or class")

    info <- info[sort.list(row.names(info)), ]
    res <- row.names(info)
    class(res) <- "MethodsFunction"
    attr(res, "info") <- info
    res
}

print.MethodsFunction <- function(x, ...)
{
    visible <- attr(x, "info")[["visible"]]
    if(length(x)) {
        print(paste(x, ifelse(visible, "", "*"), sep=""), quote=FALSE, ...)
        if(any(!visible))
            cat("\n    Non-visible functions are asterisked\n")
    } else cat("no methods were found\n")
    invisible(x)
}

data.class <- function(x) {
    if (length(cl <- oldClass(x)))
	cl[1]
    else {
	l <- length(dim(x))
	if (l == 2)	"matrix"
	else if (l > 0)	"array"
	else mode(x)
    }
}


getS3method <-  function(f, class, optional = FALSE)
{
### FIXME: findGeneric() is almost identical inside methods()
###	MM thinks the one here is wrong
    findGeneric <- function(fname, envir) {
        if(!exists(fname, mode = "function", envir = envir)) return("")
        if(any(fname == tools:::.getInternalS3generics())) return(fname)
        f <- get(fname, mode = "function", envir = envir)
        if(.isMethodsDispatchOn() && is(f, "genericFunction")) {
            ## maybe an S3 pseudo-generic was turned into the default
            fdeflt <- finalDefaultMethod(getMethodsForDispatch(fname, f))
            if(is(fdeflt, "derivedDefaultMethod"))
                f <- fdeflt
            else
                warning("\"", fname, "\" is a formal generic function; S3 methods will not likely be found")
        }
        isUMEbrace <- function(e) {
            for (ee in as.list(e[-1]))
                if (nchar(res <- isUME(ee))) return(res)
            ""
        }
        isUMEif <- function(e) {
            if (length(e) == 3) isUME(e[[3]])
            else {
                if (nchar(res <- isUME(e[[3]]))) res
                else if (nchar(res <- isUME(e[[4]]))) res
                else ""
            }
        }
        isUME <- function(e) {
            if (is.call(e) && (is.name(e[[1]]) || is.character(e[[1]]))) {
                switch(as.character(e[[1]]),
                       UseMethod = as.character(e[[2]]),
                       "{" = isUMEbrace(e),
                       "if" = isUMEif(e),
                       "")
            } else ""
        }
        isUME(body(f))
    }

    groupGenerics <- c("Ops", "Math", "Summary")
    truegf <- findGeneric(f, parent.frame())
    if(nchar(truegf)) f <- truegf
    else {
        if(optional) return(NULL)
        else stop("no function '", f, "' could be found")
    }
    method <- paste(f, class, sep=".")
    if(exists(method, mode = "function", envir = parent.frame()))
        return(get(method, mode = "function", envir = parent.frame()))
    ## also look for registered method in namespaces
    if(f %in% groupGenerics)
        defenv <- .BaseNamespaceEnv
    else {
        genfun <- get(f, mode="function", envir = parent.frame())
        defenv <- if (typeof(genfun) == "closure") environment(genfun)
        else .BaseNamespaceEnv
        S3Table <- get(".__S3MethodsTable__.", envir = defenv)
        S3reg <- ls(S3Table)
        if(length(grep(gsub("([.[$])", "\\\\\\1", method), S3reg)))
            return(get(method, envir = S3Table))
    }
    if(optional) NULL
    else stop("S3 method ", method, " not found")
}

getFromNamespace <- function(x, ns, pos = -1, envir = as.environment(pos))
{
    if(missing(ns)) {
        nm <- attr(envir, "name")
        if(is.null(nm) || substring(nm, 1, 8) != "package:")
            stop("environment specified is not a package")
        ns <- asNamespace(substring(nm, 9))
    } else ns <- asNamespace(ns)
    get(x, envir = ns, inherits = FALSE)
}

fixInNamespace <- function (x, ns, pos = -1, envir = as.environment(pos), ...)
{
    subx <- substitute(x)
    if (is.name(subx))
        subx <- deparse(subx)
    if (!is.character(subx) || length(subx) != 1)
        stop("fixInNamespace requires a name")
    if(missing(ns)) {
        nm <- attr(envir, "name")
        if(is.null(nm) || substring(nm, 1, 8) != "package:")
            stop("environment specified is not a package")
        ns <- asNamespace(substring(nm, 9))
    } else ns <- asNamespace(ns)
    x <- edit(get(subx, envir = ns, inherits = FALSE), ...)
    if(bindingIsLocked(subx, ns)) {
        unlockBinding(subx, ns)
        assign(subx, x, env = ns)
        w <- options("warn")
        on.exit(options(w))
        options(warn = -1)
        lockBinding(subx, ns)
    } else
        assign(subx, x, env = ns)
    if(!isBaseNamespace(ns)) {
        ## now look for possible copy as a method
        S3 <- getNamespaceInfo(ns, "S3methods")
        if(!length(S3)) return(invisible(NULL))
        S3names <- sapply(S3, function(x) x[[3]])
        if(subx %in% S3names) {
            i <- match(subx, S3names)
            genfun <- get(S3[[i]][[1]], mode = "function",
                          envir = parent.frame())
            defenv <- if (typeof(genfun) == "closure") environment(genfun)
            else .BaseNamespaceEnv
            S3Table <- get(".__S3MethodsTable__.", envir = defenv)
            if(exists(subx, envir = S3Table, inherits = FALSE))
                assign(subx, x, S3Table)
        }
    }
    invisible(NULL)
}

getAnywhere <- function(x)
{
    if(!is.character(x)) x <- deparse(substitute(x))
    objs <- list(); where <- character(0); visible <- logical(0)
    ## first look on search path
    if(length(pos <- find(x, numeric=TRUE))) {
        objs <- lapply(pos, function(pos, x) get(x, pos=pos), x=x)
        where <- names(pos)
        visible <- rep(TRUE, length(pos))
    }
    ## next look for methods
    if(length(grep("\\.", x))) {
        np <- length(parts <- strsplit(x, "\\.")[[1]])
        for(i in 2:np) {
            gen <- paste(parts[1:(i-1)], collapse=".")
            cl <- paste(parts[i:np], collapse=".")
            if(!is.null(f <- getS3method(gen, cl, TRUE))) {
                ev <- topenv(environment(f), NULL)
                nmev <- if(isNamespace(ev)) getNamespaceName(ev) else NULL
                objs <- c(objs, f)
                msg <- paste("registered S3 method for", gen)
                if(!is.null(nmev))
                    msg <- paste(msg, "from namespace", nmev)
                where <- c(where, msg)
                visible <- c(visible, FALSE)
            }
        }
    }
    ## now look in namespaces, visible or not
    for(i in loadedNamespaces()) {
        ns <- asNamespace(i)
        if(exists(x, envir = ns, inherits = FALSE)) {
            f <- get(x, envir = ns, inherits = FALSE)
            objs <- c(objs, f)
            where <- c(where, paste("namespace", i, sep=":"))
            visible <- c(visible, FALSE)
        }
    }
    # now check for duplicates
    ln <- length(objs)
    dups <- rep(FALSE, ln)
    objs2 <- lapply(objs, function(x) {
        if(is.function(x)) environment(x) <- NULL
        x
    })
    if(ln > 1)
        for(i in 2:ln)
            for(j in 1:(i-1))
                if(identical(objs2[[i]], objs2[[j]])) {
                    dups[i] <- TRUE
                    break
                }
    res <- list(name=x, objs=objs, where=where, visible=visible, dups=dups)
    class(res) <- "getAnywhere"
    res
}

print.getAnywhere <- function(x, ...)
{
    n <- sum(!x$dups)
    if(n == 0) {
        cat("no object named", sQuote(x$name), "was found\n")
    } else if (n == 1) {
        cat("A single object matching", sQuote(x$name), "was found\n")
        cat("It was found in the following places\n")
        cat(paste("  ", x$where, sep=""), sep="\n")
        cat("with value\n\n")
        print(x$objs[[1]])
    } else {
        cat(n, "differing objects matching", sQuote(x$name),
            "were found\n")
        cat("in the following places\n")
        cat(paste("  ", x$where, sep=""), sep="\n")
        cat("Use [] to view one of them\n")
    }
    invisible(x)
}

"[.getAnywhere" <- function(x, i)
{
    if(!is.numeric(i)) stop("only numeric indices can be used")
    if(length(i) == 1) x$objs[[i]]
    else x$objs[i]
}
optim <- function(par, fn, gr = NULL,
                  method = c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN"),
                  lower = -Inf, upper = Inf,
                  control = list(), hessian = FALSE, ...)
{
    fn1 <- function(par) fn(par,...)
    gr1 <- if (!is.null(gr)) function(par) gr(par,...)
    method <- match.arg(method)
    if((length(lower) > 1 || length(upper) > 1 ||
       lower[1] != -Inf || upper[1] != Inf)
       && method != "L-BFGS-B") {
        warning("bounds can only be used with method L-BFGS-B")
        method <- "L-BFGS-B"
    }
    ## Defaults :
    con <- list(trace = 0, fnscale = 1, parscale = rep.int(1, length(par)),
                ndeps = rep.int(1e-3, length(par)),
                maxit = 100, abstol = -Inf, reltol=sqrt(.Machine$double.eps),
                alpha = 1.0, beta = 0.5, gamma = 2.0,
                REPORT = 10,
                type = 1,
                lmm = 5, factr = 1e7, pgtol = 0,
                tmax = 10, temp = 10.0)
    if (method == "Nelder-Mead") con$maxit <- 500
    if (method == "SANN") con$maxit <- 10000

    con[(namc <- names(control))] <- control
    if(con$trace < 0)
        warning("read the documentation for `trace' more carefully")
    if (method == "L-BFGS-B" &&
        any(!is.na(match(c("reltol","abstol"), namc))))
        warning("Method L-BFGS-B uses `factr' (& `pgtol') instead of `reltol' and `abstol'")
    npar <- length(par)
    if(npar == 1 && method == "Nelder-Mead")
        warning("one-diml optimization by Nelder-Mead is unreliable: use optimize")
    lower <- as.double(rep(lower, , npar))
    upper <- as.double(rep(upper, , npar))
    res <- .Internal(optim(par, fn1, gr1,
                           method, con, lower, upper))
    names(res) <- c("par", "value", "counts", "convergence", "message")
    nm <- names(par)
    if(!is.null(nm)) names(res$par) <- nm
    names(res$counts) <- c("function", "gradient")
    if (hessian) {
        hess <- .Internal(optimhess(res$par, fn1, gr1, con))
        hess <- 0.5*(hess + t(hess))
        if(!is.null(nm)) dimnames(hess) <- list(nm, nm)
        res$hessian <- hess
    }
    res
}
options <- function(...) .Internal(options(...))

getOption <- function(x) options(x)[[1]]

## transferred to system profile, where all the others are
## initial options settings (others are done in C code in InitOptions)
## options(defaultPackages = c("methods", "ctest"))

outer <- function (X, Y, FUN = "*", ...)
{
    no.nx <- is.null(nx <- dimnames(X <- as.array(X))); dX <- dim(X)
    no.ny <- is.null(ny <- dimnames(Y <- as.array(Y))); dY <- dim(Y)
    if (is.character(FUN) && FUN=="*") {
        robj <- as.vector(X) %*% t(as.vector(Y))
        dim(robj) <- c(dX, dY)
    } else {
        FUN <- match.fun(FUN)
        Y <- rep.int(Y, rep.int(length(X), length(Y)))
        X <- rep(X, length.out = length(Y))
        robj <- array(FUN(X, Y, ...), c(dX, dY))
    }
    ## no dimnames if both don't have ..
    if(no.nx) nx <- vector("list", length(dX)) else
    if(no.ny) ny <- vector("list", length(dY))
    if(!(no.nx && no.ny))
	dimnames(robj) <- c(nx, ny)
    robj
}

## Binary operator, hence don't simply do "%o%" <- outer.
"%o%" <- function(X, Y) outer(X, Y)
p.adjust.methods <-
    c("holm", "hochberg", "hommel", "bonferroni", "fdr", "none")

p.adjust <- function(p, method = p.adjust.methods, n = length(p)) {
    ## Methods 'Hommel' and 'FDR' and speed improvements contributed by
    ## Gordon Smyth <smyth@wehi.edu.au>.

    if (n == 1) return(p)
    method <- match.arg(method)
    switch(method,
           holm = {
               i <- 1:n
               o <- order(p)
               ro <- order(o)
               pmin(1, cummax( (n - i + 1) * p[o] ))[ro]
           },
           hochberg = {
               i <- n:1
               o <- order(p, decreasing = TRUE)
               ro <- order(o)
               pmin(1, cummin( (n - i + 1) * p[o] ))[ro]
           },
           hommel = {
               i <- 1:n
               s <- sort(p, index = TRUE)
               p <- s$x
               ro <- order(s$ix)
               q <- pa <- rep.int( min(n*p/(1:n)), n)
               for (j in (n-1):2) {
                   q1 <- min(j*p[(n-j+2):n]/(2:j))
                   q[1:(n-j+1)] <- pmin( j*p[1:(n-j+1)], q1)
                   q[(n-j+2):n] <- q[n-j+1]
                   pa <- pmax(pa,q)
               }
               pmax(pa,p)[ro]
           },
           fdr = {
               i <- n:1
               o <- order(p, decreasing = TRUE)
               ro <- order(o)
               pmin(1, cummin( n / i * p[o] ))[ro]
           },
           bonferroni = pmin(n * p, 1),
           none = p)
}
package.skeleton <-
function(name = "anRpackage", list, environment = .GlobalEnv,
         path = ".", force = FALSE)
{
    if(missing(list))
        list<-ls(env=environment)

    cat("Creating directories ...\n")
    ## Make the directories
    if(file.exists(file.path(path,name)) && !force)
        stop(paste("Directory", name, "exists."))

    ## <FIXME>
    ## If these already exist we get warnings ...
    dir.create(file.path(path, name))
    dir.create(file.path(path, name, "man"))
    dir.create(file.path(path, name, "src"))
    dir.create(file.path(path, name, "R"))
    dir.create(file.path(path, name, "data"))
    ## </FIXME>

    ## Structural files
    cat("Creating DESCRIPTION ...\n")
    description <- file(file.path(path, name, "DESCRIPTION"), "wt")
    cat("Package: the_name_of_the_package\n",
        "Title: What the package does\n",
        "Version: 1.0\n",
        "Author: Who wrote it\n",
        "Description: More about what it does\n",
        "Maintainer: Who to complain to <yourfault@somewhere.net>\n",
        "License: What license is it under?\n",
        file = description, sep = "")
    close(description)
    
    ## READMEs
    cat("Creating READMEs ...\n")

    ## src/README
    readme <- file(file.path(path, name, "src", "README"), "wt")
    cat("Put C/C++/Fortran code here.\n",
        "If you have compiled code, add a .First.lib() function\n",
        "in the 'R' subdirectory to load it.\n",
        file = readme, sep = "")
    close(readme)

    ## man/README
    readme <- file(file.path(path, name, "man", "README"), "wt")
    cat("Edit these help files.\n",
        "You may want to combine the help files for multiple functions.\n",
        file = readme, sep = "")
    close(readme)
    
    readme <- file(file.path(path, name, "README"), "wt")
    cat("1. Put any C/C++/Fortran code in 'src'\n",
        "2. If you have compiled code, add a .First.lib() function in 'R'\n",
        "   to load the shared library\n",
        "3. Edit the help file skeletons in 'man'\n",
        "4. Run R CMD build to create the index files\n",
        "5. Run R CMD check to check the package\n",
        "6. Run R CMD build to make the package file\n",
        "\n\nRead \"Writing R Extensions\" for more information.\n",
        file = readme, sep = "")
    close(readme)

    internalObjInds <- grep("^\\.", list)
    internalObjs <- list[internalObjInds]
    if(any(internalObjInds))
        list <- list[-internalObjInds]

    ## Dump the items in 'data' or 'R'
    cat("Saving functions and data ...\n")
    if(any(internalObjInds))
        dump(internalObjs,
             file = file.path(path, name, "R",
                              paste(name, "-internal.R", sep = "")))
    for(item in list){
        if(is.function(get(item)))
            dump(item,
                 file = file.path(path, name, "R",
                                  paste(item, "R", sep = ".")))
        else
            save(list = item,
                 file = file.path(path, name, "data",
                                  paste(item, "rda", sep = ".")))
    }

    ## Make help file skeletons in 'man'
    cat("Making help files ...\n")
    if(any(internalObjInds)) {
        Rdfile <- file(file.path(path, name, "man",
                                 paste(name, "-internal.Rd", sep = "")),
                       "wt")
        cat("\\name{", name, "-internal}\n",
            "\\title{Internal ", name, " objects}\n",
            file = Rdfile, sep = "")
        for(item in internalObjs) {
            cat("\\alias{", item, "}\n", file = Rdfile, sep = "")
        }
        cat("\\description{Internal ", name, " objects.}\n",
            "\\details{These are not to be called by the user.}\n",
            "\\keyword{internal}",
            file = Rdfile, sep = "")
        close(Rdfile)
    }
    ## Redirect output so that we do not see the partially inappropriate
    ## messages from prompt().
    outFile <- tempfile()
    outConn <- file(outFile, "w")
    sink(outConn, type = "output")
    yy <- try(sapply(list,
                     function(item) {
                         prompt(item,
                                filename = file.path(path, name, "man",
                                paste(item, "Rd", sep=".")))
                     }))
    sink(type = "output")
    close(outConn)
    unlink(outFile)
    if(inherits(yy, "try-error")) 
        stop(yy)
    
    cat("Done.\n")
    cat(paste("Further steps are described in",
              file.path(path, name, "README"),
              "\n"))
}
packageStatus <- function(lib.loc = NULL,
                           repositories = getOption("repositories"))
{
    if(is.null(lib.loc))
        lib.loc <- .libPaths()

    FIELDS <- c("Package", "Version","Priority", "Bundle", "Depends",
                "Built", "Status")
    FIELDS1 <- c(FIELDS, "LibPath")
    FIELDS2 <- c(FIELDS, "Repository")

    ## convert character matrices to dataframes
    char2df <- function(x)
    {
        y <- list()
        for(k in 1:ncol(x)) y[[k]] <- x[,k]
        attr(y, "names") <- colnames(x)
        attr(y, "row.names") <- 1:nrow(x)
        class(y) <- "data.frame"
        y
    }

    y <- NULL
    for(lib in lib.loc)
    {
        pkgs <- .packages(all.available=TRUE, lib.loc = lib)
        for(p in pkgs){
            desc <- package.description(p, lib=lib, fields=FIELDS)
            desc["Package"] <-
                ifelse(is.na(desc["Bundle"]),
                       desc["Package"],
                       paste(desc["Bundle"], desc["Package"], sep=":"))
            y <- rbind(y, c(desc, lib))
        }
    }

    y[,"Status"] <- "ok"
    y <- char2df(y)
    names(y) <- FIELDS1

    if(length(repositories) > 0){
        repositories <- unique(as.character(repositories))
        z <- matrix("", nrow=0, ncol=length(FIELDS2))
        colnames(z) <- FIELDS2
        for(rep in repositories){
            z1 <- try(read.dcf(paste(rep,"PACKAGES",sep="/"),
                               fields=FIELDS2))
            if(inherits(z1, "try-error")) next

            ## ignore packages which don't fit our version of R
            z1 <- z1[package.dependencies(z1, check=TRUE),,drop=FALSE]
            if(length(z1)==0) next

            z1[,"Repository"] <- rep
            z <- rbind(z[,FIELDS2], z1[,FIELDS2])
        }
    }

    ## only consider the newest version of each package
    ## in the first repository where it appears
    ztab <- table(z[,"Package"])
    for(pkg in names(ztab)[ztab>1]){
        zrow <- which(z[,"Package"]==pkg)
        znewest <- newestVersion(z[zrow,"Version"])
        ## and now exclude everything but the newest
        z <- z[-zrow[-znewest],]
    }

    z[,"Status"] <- "not installed"
    z[z[,"Package"] %in% y$Package, "Status"] <- "installed"
    z[!is.na(z[,"Bundle"]) & (z[,"Bundle"] %in% y$Bundle),
      "Status"] <- "installed"

    z <- char2df(z)
    z$Package <- ifelse(is.na(z$Bundle), z$Package, z$Bundle)
    attr(z, "row.names") <- z$Package

    for(k in 1:nrow(y)){
        pkg <- ifelse(is.na(y$Bundle[k]),
                      y[k,"Package"],
                      y[k,"Bundle"])

        if(pkg %in% z$Package){
            if(compareVersion(y[k,"Version"],
                              z[pkg,"Version"]) < 0){
                y[k,"Status"] <- "upgrade"
            }
        }
        else{
            if(!(y[k,"Priority"] %in% "base"))
                y[k,"Status"] <- "unavailable"
        }
    }

    y$LibPath <- factor(as.character(y$LibPath), levels=lib.loc)
    y$Status <- as.factor(y$Status)
    z$Repository <- factor(as.character(z$Repository), levels=repositories)
    z$Status <- as.factor(z$Status)

    retval <- list(inst=y, avail=z)
    class(retval) <- c("packageStatus")
    retval
}

summary.packageStatus <- function(object, ...)
{
    cat("\nInstalled packages:\n")
    cat(  "-------------------\n")
    for(k in levels(object$inst$LibPath)){
        ok <- (object$inst$LibPath==k)
        cat("\n*** Library ", k, "\n", sep="")
        if(any(ok)){
            print(tapply(object$inst$Package[ok],
                         object$inst$Status[ok],
                         function(x) sort(as.character(x))))
        }
    }
    cat("\n\nAvailable packages:\n")
    cat(    "-------------------\n")
    cat("(each package appears only once)\n")
    for(k in levels(object$avail$Repository)){
        cat("\n*** Repository ", k, "\n", sep="")
        ok <- object$avail$Repository==k
        if(any(ok))
            print(tapply(object$avail$Package[ok],
                         object$avail$Status[ok],
                         function(x) sort(as.character(x))))
    }
    invisible(object)
}

print.packageStatus <- function(x, ...)
{
    cat("Number of installed packages:\n")
    print(table(x$inst$LibPath, x$inst$Status))

    cat("\nNumber of available packages (each package counted only once):\n")
    print(table(x$avail$Repository, x$avail$Status))
    invisible(x)
}

compareVersion <- function(a, b){
    if(is.na(a))
        return(-1)
    if(is.na(b))
        return(1)
    a <- as.integer(strsplit(a, "[\\.-]")[[1]])
    b <- as.integer(strsplit(b, "[\\.-]")[[1]])
    for(k in 1:length(a)){
        if(k <= length(b)){
            if(a[k]>b[k])
                return(1)
            else if(a[k]<b[k])
                return(-1)
        }
        else{
            return(1)
        }
    }
    if(length(b)>length(a))
        return(-1)
    else
        return(0)
}

newestVersion <- function(x){

    for(k in 1:length(x)){
        y <- lapply(x[-1], compareVersion, b=x[1])
        if(all(y<=0))
            return(k)
        else
            x <- x[-1]
    }
}

update.packageStatus <-
    function(object, lib.loc=levels(object$inst$LibPath),
             repositories=levels(object$avail$Repository),
             ...)
{
    packageStatus(lib.loc=lib.loc, repositories=repositories)
}


upgrade <- function(object, ...)
    UseMethod("upgrade")

upgrade.packageStatus <- function(object, ask=TRUE, ...){

    update <- NULL
    old <- which(object$inst$Status=="upgrade")
    if(length(old)==0){
        cat("Nothing to do!\n")
        return(invisible())
    }

    askprint <- function(x)
        write.table(x, row.names=FALSE, col.names=FALSE, quote=FALSE,
                    sep=" at ")

    haveasked <- character(0)
    if(ask){
        for(k in old){
            pkg <- ifelse(is.na(object$inst[k,"Bundle"]),
                          object$inst[k,"Package"],
                          object$inst[k,"Bundle"])
            tmpstring <- paste(pkg, as.character(object$inst[k,"LibPath"]))
            if(tmpstring %in% haveasked) next
            haveasked <- c(haveasked, tmpstring)
            cat("\n")
            cat(pkg, ":\n")
            askprint(object$inst[k,c("Version","LibPath")])
            askprint(object$avail[pkg, c("Version", "Repository")])
            answer <- substr(readline("Update (y/N)?  "), 1, 1)
            if(answer == "y" | answer == "Y")
                update <-
                    rbind(update,
                          c(pkg, as.character(object$inst[k,c("LibPath")]),
                            as.character(object$avail[pkg,c("Repository")])))
        }
    }
    else
        update <- old

    if(length(update)>0){
        for(repo in unique(update[,3])){
            ok <- update[,3]==repo
            install.packages(update[ok,1], update[ok,2],
                             contriburl=repo)
        }
    }
}





CRAN.packages <- function(CRAN=getOption("CRAN"), method,
                          contriburl=contrib.url(CRAN))
{
    localcran <- length(grep("^file:", contriburl)) > 0
    if(localcran)
        tmpf <- paste(substring(contriburl,6), "PACKAGES", sep="/")
    else{
        tmpf <- tempfile()
        on.exit(unlink(tmpf))
        download.file(url=paste(contriburl, "PACKAGES", sep="/"),
                      destfile=tmpf, method=method, cacheOK=FALSE)
    }
    read.dcf(file=tmpf, fields=c("Package", "Version",
                       "Priority", "Bundle", "Depends"))
}

update.packages <- function(lib.loc=NULL, CRAN=getOption("CRAN"),
                            contriburl=contrib.url(CRAN),
                            method, instlib=NULL, ask=TRUE,
                            available=NULL, destdir=NULL,
			    installWithVers=FALSE)
{
    if(is.null(lib.loc))
        lib.loc <- .libPaths()

    if(is.null(available))
        available <- CRAN.packages(contriburl=contriburl, method=method)

    old <- old.packages(lib.loc=lib.loc,
                        contriburl=contriburl,
                        method=method,
                        available=available)

    update <- NULL
    if(ask & !is.null(old)){
        for(k in 1:nrow(old)){
            cat(old[k, "Package"], ":\n",
                "Version", old[k, "Installed"],
                "in", old[k, "LibPath"], "\n",
                "Version", old[k, "CRAN"], "on CRAN")
            cat("\n")
            answer <- substr(readline("Update (y/N)?  "), 1, 1)
            if(answer == "y" | answer == "Y")
                update <- rbind(update, old[k,])
        }
    }
    else
        update <- old


    if(!is.null(update)){
        if(is.null(instlib))
            instlib <-  update[,"LibPath"]

        install.packages(update[,"Package"], instlib,
                         contriburl=contriburl,
                         method=method,
                         available=available, destdir=destdir,
                         installWithVers=installWithVers)
    }
}

old.packages <- function(lib.loc=NULL, CRAN=getOption("CRAN"),
                         contriburl=contrib.url(CRAN),
                         method, available=NULL)
{
    if(is.null(lib.loc))
        lib.loc <- .libPaths()

    instp <- installed.packages(lib.loc=lib.loc)
    if(is.null(available))
        available <- CRAN.packages(contriburl=contriburl, method=method)

    ## for bundles it is sufficient to install the first package
    ## contained in the bundle, as this will install the complete bundle
    ## However, a bundle might be installed in more than one place.
    for(b in unique(instp[,"Bundle"])){
        if(!is.na(b))
            for (w in unique(instp[,"LibPath"])) {
            ok <- which(instp[,"Bundle"] == b & instp[,"LibPath"] == w)
            if(length(ok)>1) instp <- instp[-ok[-1],]
        }
    }

    ## for packages contained in bundles use bundle names from now on
    ok <- !is.na(instp[,"Bundle"])
    instp[ok,"Package"] <- instp[ok,"Bundle"]
    ok <- !is.na(available[,"Bundle"])
    available[ok,"Package"] <- available[ok,"Bundle"]

    update <- NULL

    newerVersion <- function(a, b){
        a <- as.integer(strsplit(a, "[\\.-]")[[1]])
        b <- as.integer(strsplit(b, "[\\.-]")[[1]])
        if(any(is.na(a)))
            return(FALSE)
        if(any(is.na(b)))
            return(TRUE)
        for(k in 1:length(a)){
            if(k <= length(b)){
                if(a[k]>b[k])
                    return(TRUE)
                else if(a[k]<b[k])
                    return(FALSE)
            }
            else{
                return(TRUE)
            }
        }
        return(FALSE)
    }

    for(k in 1:nrow(instp)){
        ok <- (!(instp[k, "Priority"] %in% "base")) &
                (available[,"Package"] == instp[k, "Package"])
        if(any(ok))
            ok[ok] <- sapply(available[ok, "Version"], newerVersion,
                             instp[k, "Version"])
        if(any(ok) && any(package.dependencies(available[ok, ], check=TRUE)))
        {
            update <- rbind(update,
                            c(instp[k, c("Package", "LibPath", "Version")],
                              available[ok, "Version"]))
        }
    }
    if(!is.null(update))
        colnames(update) <- c("Package", "LibPath",
                              "Installed", "CRAN")
    update
}

package.contents <- function(pkg, lib.loc=NULL)
{
    if(is.null(lib.loc))
        lib.loc <- .libPaths()

    file <- system.file("CONTENTS", package = pkg, lib.loc = lib.loc)
    if(file == "") {
        warning(paste("Cannot find CONTENTS file of package", pkg))
        return(NA)
    }

    read.dcf(file=file, fields=c("Entry", "Keywords", "Description"))
}


package.description <- function(pkg, lib.loc=NULL, fields=NULL)
{
    if(is.null(lib.loc))
        lib.loc <- .libPaths()

    file <- system.file("DESCRIPTION", package = pkg, lib.loc = lib.loc)
    if(file != "") {
        retval <- read.dcf(file=file, fields=fields)[1,]
    }

    if((file == "") || (length(retval) == 0)){
        warning(paste("DESCRIPTION file of package", pkg,
                      "missing or broken"))
        if(!is.null(fields)){
            retval <- rep(NA, length(fields))
            names(retval) <- fields
        }
        else
            retval <- NA
    }

    retval
}


installed.packages <- function(lib.loc = NULL, priority = NULL)
{
    if(is.null(lib.loc))
        lib.loc <- .libPaths()
    pkgFlds <- c("Version", "Priority", "Bundle", "Depends")
    if(!is.null(priority)) {
        if(!is.character(priority))
            stop("`priority' must be character or NULL")
        if(any(b <- priority == "high"))
            priority <- c(priority[!b], "recommended","base")
    }
    retval <- character()
    for(lib in lib.loc) {
        pkgs <- .packages(all.available=TRUE, lib.loc = lib)
        for(p in pkgs){
            desc <- package.description(p, lib=lib, fields= pkgFlds)
            if(!is.null(priority)) # skip if priority does not match
                if(is.na(pmatch(desc["Priority"], priority))) next
            retval <- rbind(retval, c(p, lib, desc))
        }
    }
    if (!is.null(retval))
        colnames(retval) <- c("Package", "LibPath", pkgFlds)
    retval
}

package.dependencies <- function(x, check = FALSE)
{
    if(!is.matrix(x))
        x <- matrix(x, nrow = 1, dimnames = list(NULL, names(x)))

    deps <- list()
    for(k in 1:nrow(x)){
        z <- x[k, "Depends"]
        if(!is.na(z) & z != ""){
            ## split dependencies, remove leading and trailing whitespace
            z <- unlist(strsplit(z, ","))
            z <- sub("^[[:space:]]*(.*)", "\\1", z)
            z <- sub("(.*)[[:space:]]*$", "\\1", z)

            ## split into package names and version
            pat <- "^([^\\([:space:]]+)[[:space:]]*\\(([^\\)]+)\\).*"
            deps[[k]] <-
                cbind(sub(pat, "\\1", z), sub(pat, "\\2", z), NA)

            noversion <- deps[[k]][,1] == deps[[k]][,2]
            deps[[k]][noversion,2] <- NA

            ## split version dependency into operator and version number
            pat <- "[[:space:]]*([[<>=]+)[[:space:]]+(.*)"
            deps[[k]][!noversion, 2:3] <-
                c(sub(pat, "\\1", deps[[k]][!noversion, 2]),
                  sub(pat, "\\2", deps[[k]][!noversion, 2]))
        }
        else
            deps[[k]] <- NA
    }

    if(check){
        z <- rep(TRUE, nrow(x))
        for(k in 1:nrow(x)){
            ## currently we only check the version of R itself
            if(!is.na(deps[[k]]) &&
               any(ok <- deps[[k]][,1] == "R")) {
                ## NOTE: currently operators must be `<=' or `>='.
                if(!is.na(deps[[k]][ok, 2])
                   && deps[[k]][ok, 2] %in% c("<=", ">=")) {
                    comptext <-
                        paste('"', R.version$major, ".",
                              R.version$minor, '" ',
                              deps[[k]][ok,2], ' "',
                              deps[[k]][ok,3], '"', sep = "")
                    compres <- try(eval(parse(text = comptext)))
                    if(!inherits(compres, "try-error"))
                        z[k] <- compres
                }
            }
        }
        names(z) <- x[,"Package"]
        return(z)
    }
    else{
        names(deps) <- x[,"Package"]
        return(deps)
    }
}

remove.packages <- function(pkgs, lib, version) {

    updateIndices <- function(lib) {
        ## This should eventually be made public, as it could also be
        ## used by install.packages() && friends.
        if(lib == .Library) {
            ## R version of
            ##   ${R_HOME}/bin/build-help --htmllists
            ##   cat ${R_HOME}/library/*/CONTENTS \
            ##     > ${R_HOME}/doc/html/search/index.txt
            if(exists("link.html.help", mode = "function"))
                link.html.help()
        }
    }

    if(missing(lib) || is.null(lib)) {
        lib <- .libPaths()[1]
        warning(paste("argument `lib' is missing: using", lib))
    }

    if (!missing(version))
        pkgs <- manglePackageName(pkgs, version)

    paths <- .find.package(pkgs, lib)
    unlink(paths, TRUE)
    for(lib in unique(dirname(paths)))
        updateIndices(lib)
}

page <- function(x, method = c("dput", "print"), ...)
{
    subx <- substitute(x)
    if( is.name(subx) )
	subx <- deparse(subx)
    if (!is.character(subx) || length(subx) != 1)
	stop("page requires a name")
    method <- match.arg(method)
    parent <- parent.frame()
    if(exists(subx, envir = parent, inherits=TRUE)) {
        file <- tempfile("Rpage.")
        if(method == "dput")
            dput(get(subx, envir = parent, inherits=TRUE), file)
        else {
            sink(file)
            print(get(subx, envir = parent, inherits=TRUE))
            sink()
        }
	file.show(file, title = subx, delete.file = TRUE, ...)
    } else
	stop(paste("no object named \"", subx, "\" to edit",sep=""))
}
as.pairlist <- function(x) .Internal(as.vector(x, "pairlist"))
pairlist <- function(...) as.pairlist(list(...))
## This is now .Primitive:
##is.pairlist <- function(x) typeof(x) == "pairlist"
pairs <- function(x, ...) UseMethod("pairs")

pairs.formula <-
function(formula, data = NULL, ..., subset)
{
    m <- match.call(expand.dots = FALSE)
    if(is.matrix(eval(m$data, parent.frame())))
        m$data <- as.data.frame(data)
    m$... <- NULL
    m[[1]] <- as.name("model.frame")
    mf <- eval(m, parent.frame())
    pairs(mf, ...)
}

#################################################
## some of the changes are from code
## Copyright 1999 Dr. Jens Oehlschlaegel-Akiyoshi
## Others are by BDR and MM
#################################################

pairs.default <-
function (x, labels, panel = points, ..., main = NULL, oma = NULL,
          font.main = par("font.main"), cex.main = par("cex.main"),
          lower.panel = panel, upper.panel = panel,
          diag.panel = NULL, text.panel = textPanel,
          label.pos = 0.5 + has.diag/3,
          cex.labels = NULL, font.labels = 1,
          row1attop = TRUE, gap=1)
{
    textPanel <-
        function(x = 0.5, y = 0.5, txt, cex, font)
        {
            text(x, y, txt, cex = cex, font = font)
        }
    if (!is.matrix(x)) x <- data.matrix(x)
    if (!is.numeric(x)) stop("non-numeric argument to pairs")
    panel <- match.fun(panel)
    if((has.lower <- !is.null(lower.panel)) && !missing(lower.panel))
        lower.panel <- match.fun(lower.panel)
    if((has.upper <- !is.null(upper.panel)) && !missing(upper.panel))
        upper.panel <- match.fun(upper.panel)
    if((has.diag  <- !is.null( diag.panel)) && !missing( diag.panel))
        diag.panel <- match.fun( diag.panel)

    if(row1attop) {
        tmp <- lower.panel; lower.panel <- upper.panel; upper.panel <- tmp
        tmp <- has.lower; has.lower <- has.upper; has.upper <- tmp
    }

    nc <- ncol(x)
    if (nc < 2) stop("only one column in the argument to pairs")
    has.labs <- TRUE
    if (missing(labels)) {
        labels <- colnames(x)
        if (is.null(labels)) labels <- paste("var", 1:nc)
    }
    else if(is.null(labels)) has.labs <- FALSE
    if (is.null(oma)) {
        oma <- c(4, 4, 4, 4)
        if (!is.null(main)) oma[3] <- 6
    }
    opar <- par(mfrow = c(nc, nc), mar = rep(gap/2, 4), oma = oma)
    on.exit(par(opar))

    for (i in if(row1attop) 1:nc else nc:1)
        for (j in 1:nc) {
            plot(x[, j], x[, i], xlab = "", ylab = "",
                 axes = FALSE, type = "n", ...)
            if(i == j || (i < j && has.lower) || (i > j && has.upper) ) {
                box()
                if(i == 1  && (!(j %% 2) || !has.upper || !has.lower ))
                    axis(1 + 2*row1attop, xpd = NA)
                if(i == nc && (  j %% 2  || !has.upper || !has.lower ))
                    axis(3 - 2*row1attop, xpd = NA)
                if(j == 1  && (!(i %% 2) || !has.upper || !has.lower ))
                    axis(2, xpd = NA)
                if(j == nc && (  i %% 2  || !has.upper || !has.lower ))
                    axis(4, xpd = NA)
                mfg <- par("mfg")
                if(i == j) {
                    if (has.diag) diag.panel(as.vector(x[, i]))
                    if (has.labs) {
                        par(usr = c(0, 1, 0, 1))
                        if(is.null(cex.labels)) {
                            l.wid <- strwidth(labels, "user")
                            cex.labels <- max(0.8, min(2, .9 / max(l.wid)))
                        }
                        text.panel(0.5, label.pos, labels[i],
                                   cex = cex.labels, font = font.labels)
                    }
                } else if(i < j)
                    lower.panel(as.vector(x[, j]), as.vector(x[, i]), ...)
                else
                    upper.panel(as.vector(x[, j]), as.vector(x[, i]), ...)
                if (any(par("mfg") != mfg))
                    stop("The panel function made a new plot")
            } else par(new = FALSE)

        }
    if (!is.null(main))
        mtext(main, 3, 3, TRUE, 0.5, cex = cex.main, font = font.main)
    invisible(NULL)
}
##-- These are the ones used in ../../../main/par.c  Query(..) :
##-- Documentation in		../../../include/Graphics.h
.Pars <- c(
	   "adj", "ann", "ask", "bg", "bty",
	   "cex", "cex.axis", "cex.lab", "cex.main", "cex.sub", "cin",
	   "col", "col.axis", "col.lab", "col.main", "col.sub",
           "cra", "crt", "csi","cxy",	"din", "err", "fg", "fig", "fin",
	   "font", "font.axis", "font.lab", "font.main", "font.sub",
           "gamma", "lab", "las", "lty", "lwd",
           "mai", "mar", "mex", "mfcol", "mfg", "mfrow", "mgp", "mkh",
	   "new", "oma", "omd", "omi", "pch", "pin", "plt", "ps", "pty",
	   "smo", "srt", "tck", "tcl", "tmag", "type", "usr",
	   "xaxp", "xaxs", "xaxt", "xlog", "xpd",
	   "yaxp", "yaxs", "yaxt", "ylog"
	   )
# Replaced with function to evaluate readonly pars because "gamma"
# is readonly on a per-device basis
# .Pars.readonly <- c("cin","cra","csi","cxy","din")

par <- function (..., no.readonly = FALSE)
{
    single <- FALSE
    args <- list(...)
    if (!length(args))
	args <- as.list(if (no.readonly)
                        .Pars[-match(.Internal(readonly.pars()), .Pars)]
        else .Pars)
    else {
	if (all(unlist(lapply(args, is.character))))
	    args <- as.list(unlist(args))
	if (length(args) == 1) {
	    if (is.list(args[[1]]) | is.null(args[[1]]))
		args <- args[[1]]
	    else
		if(is.null(names(args)))
		    single <- TRUE
	}
    }
    value <-
        if (single) .Internal(par(args))[[1]] else .Internal(par(args))
    if(!is.null(names(args))) invisible(value) else value
}

n2mfrow <- function(nr.plots)
{
  if      (nr.plots <=  3)  c(nr.plots,1) # 1, 2, 3
  else if (nr.plots <=  6)  c((nr.plots+1)%/%2,2)#-- n.. = 4,5,6
  else if (nr.plots <= 12)  c((nr.plots+2)%/%3,3)
  else c(nrow <- ceiling(sqrt(nr.plots)),
         ceiling( nr.plots / nrow))
}

parse <- function(file = "", n = NULL, text = NULL, prompt = "?")
{
    if(!is.null(text) && length(as.character(text)) == 0)
        return(expression())
    if(is.character(file))
        if(file == "") file <- stdin()
        else {
            file <- file(file, "r")
            on.exit(close(file))
        }
    .Internal(parse(file, n, text, prompt))
}
paste <- function (..., sep = " ", collapse = NULL)
{
    args <- list(...)
    if(length(args) == 0)
        if(length(collapse) == 0) character(0) else ""
    else {
	for(i in seq(along = args)) args[[i]] <- as.character(args[[i]])
	.Internal(paste(args, sep, collapse))
    }
}

##=== Could we extend  paste(.) to (optionally) accept a
##    2-vector for collapse ?	 With the following functionality

##- paste.extra <- function(r, collapse=c(", "," and ")) {
##-	    n <- length(r)
##-	    if(n <= 1) paste(r)
##-	    else
##-	      paste(paste(r[-n],collapse=collapse[1]),
##-		    r[n], sep=collapse[min(2,length(collapse))])
##- }
persp <- function(x, ...) UseMethod("persp")

persp.default <-
function (x = seq(0, 1, len = nrow(z)), y = seq(0, 1, len = ncol(z)),
    z, xlim = range(x), ylim = range(y), zlim = range(z, na.rm = TRUE),
    xlab = NULL, ylab = NULL, zlab = NULL, main = NULL, sub = NULL,
    theta = 0, phi = 15, r = sqrt(3), d = 1, scale = TRUE, expand = 1,
    col = "white", border = NULL, ltheta = -135, lphi = 0, shade = NA,
    box = TRUE, axes = TRUE, nticks = 5, ticktype = "simple", ...)
{
    if (is.null(xlab))
        xlab <- if (!missing(x)) deparse(substitute(x)) else "X"
    if (is.null(ylab))
        ylab <- if (!missing(y)) deparse(substitute(y)) else "Y"
    if (is.null(zlab))
        zlab <- if (!missing(z)) deparse(substitute(z)) else "Z"
    ## labcex is disregarded since we do NOT yet put  ANY labels...
    if (missing(z)) {
        if (!missing(x)) {
            if (is.list(x)) {
                z <- x$z
                y <- x$y
                x <- x$x
            }
            else {
                z <- x
                x <- seq(0, 1, len = nrow(z))
            }
        }
        else stop("no `z' matrix specified")
    }
    else if (is.list(x)) {
        y <- x$y
        x <- x$x
    }
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
        stop("increasing x and y values expected")
    ticktype <- pmatch(ticktype, c("simple", "detailed"))
    r <- .Internal(persp(x, y, z, xlim, ylim, zlim, theta, phi, r, d,
                         scale, expand, col, border, ltheta, lphi, shade,
                         box, axes, nticks, ticktype,
                         as.character(xlab), as.character(ylab),
                         as.character(zlab), ...))
    if(!is.null(main) || !is.null(sub))
        title(main = main, sub = sub, ...)
    invisible(r)
}
pictex <-
    function(file="Rplots.tex", width=5, height=4, debug = FALSE,
	     bg="white", fg="black")
{
    .Internal(PicTeX(file, bg, fg, width, height, as.logical(debug)))
    par(mar=c(5,4,2,4)+0.1)
}
pie <-
    function (x, labels = names(x), edges = 200, radius = 0.8,
              density = NULL, angle = 45, col = NULL, border = NULL, lty = NULL,
              main = NULL, ...)
{
    if (!is.numeric(x) || any(is.na(x) | x <= 0))
	stop("pie: `x' values must be positive.")
    if (is.null(labels))
	labels <- as.character(1:length(x))
    x <- c(0, cumsum(x)/sum(x))
    dx <- diff(x)
    plot.new()
    # NOTE: this needs to happen AFTER the plot.new so that
    # we enquire about the CURRENT plot region size, not the
    # PREVIOUS plot region size
    pin <- par("pin")
    xlim <- ylim <- c(-1, 1)
    if (pin[1] > pin[2]) xlim <- (pin[1]/pin[2]) * xlim
    else ylim <- (pin[2]/pin[1]) * ylim
    plot.window(xlim, ylim, "", asp = 1)
    nx <- length(dx)
    if (is.null(col))
        col <- if(is.null(density))
            c("white", "lightblue", "mistyrose", "lightcyan", "lavender", "cornsilk")
        else par("fg")
    col <- rep(col, length = nx)
    border <- rep(border, length = nx)
    lty <- rep(lty, length = nx)
    angle <- rep(angle, length = nx)
    density <- rep(density, length = nx)
    for (i in 1:nx) {
	n <- max(2, floor(edges * dx[i]))
	t2p <- 2*pi * seq(x[i], x[i + 1], length = n)
	xc <- c(cos(t2p), 0) * radius
	yc <- c(sin(t2p), 0) * radius
	polygon(xc, yc, density = density[i], angle = angle[i],
                border = border[i], col = col[i], lty = lty[i])
	t2p <- 2*pi * mean(x[i + 0:1])
	xc <- cos(t2p) * radius
	yc <- sin(t2p) * radius
        if(!is.na(lab <- labels[i]) && lab != "") {
            lines(c(1, 1.05)*xc, c(1, 1.05)*yc)
            text(1.1*xc, 1.1*yc, lab, xpd = TRUE, adj = ifelse(xc < 0, 1, 0),
                 ...)
        }
    }
    title(main = main, ...)
    invisible(NULL)
}
## NOTE that xyz.coords() in ./xyz.coords.R  should be kept in sync!
##
xy.coords <- function(x, y, xlab=NULL, ylab=NULL, log=NULL, recycle = FALSE)
{
    if(is.null(y)) {
	ylab <- xlab
	if(is.language(x)) {
	    if (inherits(x, "formula") && length(x) == 3) {
		ylab <- deparse(x[[2]])
		xlab <- deparse(x[[3]])
		y <- eval(x[[2]], environment(x), parent.frame())
		x <- eval(x[[3]], environment(x), parent.frame())
	    }
	    else stop("invalid first argument")
	}
	else if(is.ts(x)) {
	    y <- if(is.matrix(x)) x[,1] else x
	    x <- time(x)
	    xlab <- "Time"
	}
	else if(is.complex(x)) {
	    y <- Im(x)
	    x <- Re(x)
	    xlab <- paste("Re(", ylab, ")", sep="")
	    ylab <- paste("Im(", ylab, ")", sep="")
	}
	else if(is.matrix(x) || is.data.frame(x)) {
	    x <- data.matrix(x)
	    if(ncol(x) == 1) {
		xlab <- "Index"
		y <- x[,1]
		x <- 1:length(y)
	    }
	    else {
		colnames <- dimnames(x)[[2]]
		if(is.null(colnames)) {
		    xlab <- paste(ylab,"[,1]",sep="")
		    ylab <- paste(ylab,"[,2]",sep="")
		}
		else {
		    xlab <- colnames[1]
		    ylab <- colnames[2]
		}
		y <- x[,2]
		x <- x[,1]
	    }
	}
	else if(is.list(x)) {
	    xlab <- paste(ylab,"$x",sep="")
	    ylab <- paste(ylab,"$y",sep="")
	    y <- x[["y"]]
	    x <- x[["x"]]
	}
	else {
	    if(is.factor(x)) x <- as.numeric(x)
	    xlab <- "Index"
	    y <- x
	    x <- 1:length(x)
	}
    }
    ## to allow e.g. lines, points, identify to be used with plot.POSIXlt
    if(inherits(x, "POSIXt")) x <- as.POSIXct(x)

    if(length(x) != length(y)) {
	if(recycle) {
	    if((nx <- length(x)) < (ny <- length(y)))
		x <- rep(x, length= ny)
	    else
		y <- rep(y, length= nx)
	}
	else
	    stop("x and y lengths differ")
    }

    if(length(log) && log != "") {
	log <- strsplit(log, NULL)[[1]]
	if("x" %in% log && any(ii <- x <= 0 & !is.na(x))) {
	    n <- sum(ii)
	    warning(paste(n, " x value", if(n>1)"s",
			  " <= 0 omitted from logarithmic plot", sep=""))
	    x[ii] <- NA
	}
	if("y" %in% log && any(ii <- y <= 0 & !is.na(y))) {
	    n <- sum(ii)
	    warning(paste(n, " y value", if(n>1)"s",
			  " <= 0 omitted from logarithmic plot", sep=""))
	    y[ii] <- NA
	}
    }
    return(list(x=as.real(x), y=as.real(y), xlab=xlab, ylab=ylab))
}

plot <- function (x, y, ...)
{
    if (is.null(attr(x, "class")) && is.function(x)) {
	nms <- names(list(...))
	## need to pass `y' to plot.function() when positionally matched
	if(missing(y)) # set to defaults {could use formals(plot.default)}:
	    y <- { if (!"from" %in% nms) 0 else
		   if (!"to"   %in% nms) 1 else
		   if (!"xlim" %in% nms) NULL }
	if ("ylab" %in% nms)
	    plot.function(x,  y, ...)
	else
	    plot.function(x, y, ylab=paste(deparse(substitute(x)),"(x)"), ...)
    }
    else UseMethod("plot")
}

## xlim = NULL (instead of "missing", since it will be passed to plot.default:
plot.function <- function(x, from = 0, to = 1, xlim = NULL, ...) {
    if(!is.null(xlim)) {
	if(missing(from)) from <- xlim[1]
	if(missing(to))	  to   <- xlim[2]
    }
    curve(x, from, to, xlim = xlim, ...)
}

## NOTE: cex = 1 is correct, cex = par("cex") gives *square* of intended!
plot.default <- function(x, y=NULL, type="p", xlim=NULL, ylim=NULL,
			 log="", main=NULL, sub=NULL, xlab=NULL, ylab=NULL,
			 ann=par("ann"), axes=TRUE, frame.plot=axes,
			 panel.first=NULL, panel.last=NULL,
			 col=par("col"), bg=NA, pch=par("pch"),
			 cex = 1, lty=par("lty"), lab=par("lab"),
			 lwd=par("lwd"), asp=NA, ...)
{
    xlabel <- if (!missing(x)) deparse(substitute(x))
    ylabel <- if (!missing(y)) deparse(substitute(y))
    xy <- xy.coords(x, y, xlabel, ylabel, log)
    xlab <- if (is.null(xlab)) xy$xlab else xlab
    ylab <- if (is.null(ylab)) xy$ylab else ylab
    xlim <- if (is.null(xlim)) range(xy$x[is.finite(xy$x)]) else xlim
    ylim <- if (is.null(ylim)) range(xy$y[is.finite(xy$y)]) else ylim
    plot.new()
    plot.window(xlim, ylim, log, asp, ...)
    panel.first # eval() is wrong here {Ross I.}
    plot.xy(xy, type, col=col, pch=pch, cex=cex, bg=bg, lty=lty, lwd=lwd, ...)
    panel.last
    if (axes) {
	axis(1, ...)
	axis(2, ...)
    }
    if (frame.plot)
	box(...)
    if (ann)
	title(main=main, sub=sub, xlab=xlab, ylab=ylab, ...)
    invisible()
}

plot.factor <- function(x, y, legend.text=levels(y), ...)
{
    if(missing(y) || is.factor(y)) {## <==> will do barplot(.)
        dargs <- list(...)
        axisnames <- if (!is.null(dargs$axes)) dargs$axes
            else if (!is.null(dargs$xaxt)) dargs$xaxt != "n"
            else TRUE
    }
    if (missing(y)) {
	barplot(table(x), axisnames=axisnames, ...)
    } else if (is.factor(y)) {
	barplot(table(y, x), legend.text=legend.text, axisnames=axisnames, ...)
    } else if (is.numeric(y))
	boxplot(y ~ x, ...)
    else NextMethod("plot")
}

## FIXME (ideas/wishes):
## o for 1-D tables:
##   - alternatively, and/or as default, type = "bar" ??!??
##   - if "h", make the default lwd depend on number of classes instead of lwd=2
plot.table <-
    function(x, type = "h", ylim = c(0, max(x)), lwd = 2,
             xlab = NULL, ylab = NULL, frame.plot = is.num, ...)
{
    xnam <- deparse(substitute(x))
    rnk <- length(dim(x))
    if(rnk == 0)
	stop("invalid table `x'")
    if(rnk == 1) {
	dn <- dimnames(x)
	nx <- dn[[1]]
	if(is.null(xlab)) xlab <- names(dn)
	if(is.null(xlab)) xlab <- ""
	if(is.null(ylab)) ylab <- xnam
	ow <- options(warn = -1)
	is.num <- !any(is.na(xx <- as.numeric(nx))); options(ow)
	x0 <- if(is.num) xx else seq(x)
	plot(x0, unclass(x), type = type,
	     ylim = ylim, xlab = xlab, ylab = ylab, frame.plot = frame.plot,
	     lwd = lwd, ..., xaxt = "n")
	xaxt <-
	    if(length(as <- list(...))) {
		if(!is.null(as$axes) && !as$axes) "n" else as$xaxt
	    }## else NULL
	axis(1, at = x0, labels = nx, xaxt = xaxt)
    } else
	mosaicplot(x, xlab = xlab, ylab = ylab, ...)
}

plot.formula <-
function(formula, data = parent.frame(), ..., subset,
         ylab = varnames[response], ask = TRUE)
{
    m <- match.call(expand.dots = FALSE)
    if (is.matrix(eval(m$data, parent.frame())))
	m$data <- as.data.frame(data)
    dots <- m$...
    dots <- lapply(dots, eval, data, parent.frame())
    m$ylab <- m$... <- m$ask <- NULL
    subset.expr <- m$subset
    m$subset <- NULL
    m[[1]] <- as.name("model.frame")
    m <- as.call(c(as.list(m), list(na.action = NULL)))
    mf <- eval(m, parent.frame())
    if (!missing(subset)) {
	s <- eval(subset.expr, data, parent.frame())
	l <- nrow(mf)
	dosub <- function(x) if (length(x) == l) x[s] else x
	dots <- lapply(dots, dosub)
	mf <- mf[s,]
    }
    ## check for horizontal arg
    horizontal <- FALSE
    if("horizontal" %in% names(dots)) horizontal <- dots[["horizontal"]]
    response <- attr(attr(mf, "terms"), "response")
    if (response) {
	varnames <- names(mf)
	y <- mf[[response]]
	funname <- NULL
	if( is.object(y) ) {
	    found <- FALSE
	    for(j in class(y)) {
		funname <- paste("plot.",j,sep = "")
		if( exists(funname) ) {
		    found <- TRUE
		    break;
		}
	    }
	    if( !found )
		funname <- NULL
	}
	if( is.null(funname) )
	    funname <- "plot"
	if (length(varnames) > 2) {
	    opar <- par(ask = ask)
	    on.exit(par(opar))
	}
	xn <- varnames[-response]
        if(length(xn) > 0) {
            if( !is.null(xlab<- dots[["xlab"]]) )
                dots <- dots[-match("xlab", names(dots))]
            for (i in xn) {
                xl <- if(is.null(xlab)) i else xlab
                yl <- ylab
                if(horizontal && is.factor(mf[[i]])) {yl <- xl; xl <- ylab}
                   do.call(funname,
                           c(list(mf[[i]], y, ylab = yl, xlab = xl), dots))
               }
	} else do.call(funname, c(list(y, ylab = ylab), dots))
    }
    else plot.data.frame(mf)
}

lines.formula <-
function(formula,  data = parent.frame(), ..., subset)
{
    m <- match.call(expand.dots = FALSE)
    if (is.matrix(eval(m$data, parent.frame())))
	m$data <- as.data.frame(data)
    dots <- m$...
    dots <- lapply(dots, eval, data, parent.frame())
    m$... <- NULL
    m[[1]] <- as.name("model.frame")
    m <- as.call(c(as.list(m), list(na.action = NULL)))
    mf <- eval(m, parent.frame())
    if (!missing(subset)) {
	s <- eval(m$subset, data, parent.frame())
	l <- nrow(data)
	dosub <- function(x) if (length(x) == l) x[s] else x
	dots <- lapply(dots, dosub)
    }
    response <- attr(attr(mf, "terms"), "response")
    if (response) {
	varnames <- names(mf)
	y <- mf[[response]]
	if (length(varnames) > 2)
	    stop("cannot handle more than one x coordinate")
	xn <- varnames[-response]
	if (length(xn) == 0)
	    do.call("lines",
		    c(list(y), dots))
	else
	    do.call("lines",
		    c(list(mf[[xn]], y), dots))
    }
    else
	stop("must have a response variable")
}

points.formula <-
function(formula, data = parent.frame(), ..., subset)
{
    m <- match.call(expand.dots = FALSE)
    if (is.matrix(eval(m$data, parent.frame())))
	m$data <- as.data.frame(data)
    dots <- m$...
    dots <- lapply(dots, eval, data, parent.frame())
    m$... <- NULL
    m[[1]] <- as.name("model.frame")
    m <- as.call(c(as.list(m), list(na.action = NULL)))
    mf <- eval(m, parent.frame())
    if (!missing(subset)) {
	s <- eval(m$subset, data, parent.frame())
	l <- nrow(data)
	dosub <- function(x) if (length(x) == l) x[s] else x
	dots <- lapply(dots, dosub)
    }
    response <- attr(attr(mf, "terms"), "response")
    if (response) {
	varnames <- names(mf)
	y <- mf[[response]]
	if (length(varnames) > 2)
	    stop("cannot handle more than one x coordinate")
	xn <- varnames[-response]
	if (length(xn) == 0)
	    do.call("points",
		    c(list(y), dots))
	else
	    do.call("points",
		    c(list(mf[[xn]], y), dots))
    }
    else
	stop("must have a response variable")
}

plot.xy <- function(xy, type, pch = 1, lty = "solid", col = par("fg"),
		    bg = NA, cex = 1, ...) {
    .Internal(plot.xy(xy, type, pch, lty, col, bg, cex, ...))
}

plot.new <- function() .Internal(plot.new())

frame <- plot.new
plot.design <-
    function(x, y = NULL, fun = mean, data = NULL, ...,
             ylim = NULL, xlab = "Factors", ylab = NULL, main = NULL,
             ask = NULL, xaxt = par("xaxt"), axes = TRUE, xtick = FALSE)
{
    .plot.des <-
        function(x, y, fun, ylab, ylim = NULL, ...) {
	## Arguments: x : data.frame with only factor columns
	##	      y : one numeric vector

	if(!is.numeric(y))
	    stop("`y' must be a numeric vector")
	if(!is.data.frame(x)) # or allow factor (see 2 lines below)?? {FIXME}
	    stop("`x' must be a data frame")
	if(!all(sapply(x, is.factor)) & !is.factor(x)) # incl "ordered"
	    stop("all columns/components of `x' must be factors")
	k <- ncol(x)
        if(any(is.na(y))) {
            FUN <- fun; fun <- function(u) FUN(u [!is.na(u)])
        }
	tot <- fun(y)
	stats <- lapply(x, function(xc) tapply(y, xc, fun))

	if(any(is.na(unlist(stats))))
	    warning("some levels of the factors are empty", call. = FALSE)
        if(is.null(ylim))
            ylim <- range(c(sapply(stats,range,na.rm = TRUE),tot))
	plot(c(0,k+1), ylim, type = "n", axes = axes, xaxt = "n",
             xlab = xlab, ylab = ylab, main = main, adj = 0.5, ...)
	segments(0.5, tot, k+0.5, tot, ...)
	for(i in 1:k) {
            si <- stats[[i]]
	    segments(i, min(si, na.rm = TRUE),
		     i, max(si, na.rm = TRUE), ...)
	    for(j in 1:(length(si))) {
                sij <- si[j]
		segments(i-0.05, sij, i+0.05, sij, ...)
		text(i-0.1, sij, labels = names(sij), adj = 1, ...)
	    }
	}
        if(axes && xaxt != "n")
            axis(1, at = 1:k, names(stats), xaxt= xaxt, tick = xtick,
                 mgp = {p <- par("mgp"); c(p[1], if(xtick) p[2] else 0, 0)},
                 ...)
    } ## .plot.des()

    ## `fun' dealing
    fname <- deparse(substitute(fun))
    fun <- match.fun(fun)
    if (!(is.data.frame(x) | inherits(x,"formula")))
	stop("x must be a dataframe or a formula!")

    ## case `switch' :
    if(is.data.frame(x)) {
	if(is.null(y)) { ## nothing to do
	} else if(inherits(y,"formula")) {
	    x <- model.frame(y , data = x)
	}
	else if(is.numeric(y)) {
	    x <- cbind(y,x[,sapply(x, is.factor)])
	    tmpname <- match.call()
	    names(x) <- as.character(c(tmpname[[3]],names(x[,-1])))
	}
	else if(is.character(y)) {
	    ynames <- y
	    y <- data.frame(x[,y])
	    if(sum(sapply(y, is.numeric)) != ncol(y)) {
		stop("a variable in y is not numeric")
	    }
	    x <- x[,sapply(x, is.factor)]
	    xnames <- names(x)
	    x <- cbind(x,y)
	    names(x) <- c(xnames,ynames)
	}
    }
    else if (is.data.frame(data)) {
	x <- model.frame(x , data = data)
    }
    else {
	x <- model.frame(x)
    }

    i.fac <- sapply(x, is.factor)
    i.num <- sapply(x, is.numeric)
    nResp <- sum(i.num)
    if (nResp == 0)
	stop("there must be at least one numeric variable!")
    yname <- names(x)[i.num]
    if(is.null(ylab))
	ylab <- paste(fname, "of", yname)
    ydata <- as.matrix(x[,i.num])
    if (!any(i.fac)) {
	x <- data.frame(Intercept = rep(" ", nrow(x)))
	i.fac <- 1
    }
    xf <- x[, i.fac, drop = FALSE]
    if (is.null(ask))
	ask <- prod(par("mfcol")) < nResp && dev.interactive()
    if (ask) {
        op <- par(ask = ask); on.exit(par(op))
    }
    for(j in 1:nResp) {
	.plot.des(xf, ydata[,j], fun = fun, ylab = ylab[j], ylim = ylim, ...)
    }
}
plot.lm <-
function(x, which = 1:4,
         caption = c("Residuals vs Fitted", "Normal Q-Q plot",
         "Scale-Location plot", "Cook's distance plot"),
         panel = points,
         sub.caption = deparse(x$call), main = "",
         ask = prod(par("mfcol")) < length(which) && dev.interactive(),
         ...,
         id.n = 3, labels.id = names(residuals(x)), cex.id = 0.75)
{
    if (!inherits(x, "lm"))
	stop("Use only with 'lm' objects")
    if(!is.numeric(which) || any(which < 1) || any(which > 4))
        stop("`which' must be in 1:4")
    isGlm <- inherits(x, "glm")
    show <- rep(FALSE, 4)
    show[which] <- TRUE
    r <- residuals(x)
    n <- length(r)
    yh <- predict(x) # != fitted() for glm
    if (any(show[2:4])) {
        s <- if(inherits(x, "rlm")) x$s else sqrt(deviance(x)/df.residual(x))
        hii <- lm.influence(x, do.coef=FALSE)$hat
    }
    if (any(show[2:3])) {
        ylab23 <- if(isGlm) "Std. deviance resid." else "Standardized residuals"
        w <- weights(x)
        # r.w := weighted.residuals(x):
        r.w <- if(is.null(w)) r else (sqrt(w)*r)[w!=0]
        rs <- r.w/(s * sqrt(1 - hii))
    }
    if (any(show[c(1,3)]))
        l.fit <- if(isGlm) "Predicted values" else "Fitted values"
    if (is.null(id.n))
	id.n <- 0
    else {
	id.n <- as.integer(id.n)
	if(id.n < 0 || id.n > n)
	    stop("`id.n' must be in {1,..,",n,"}")
    }
    if(id.n > 0) { ## label the largest residuals
        if(is.null(labels.id))
            labels.id <- paste(1:n)
        iid <- 1:id.n
	show.r <- sort.list(abs(r), decreasing = TRUE)[iid]
        if(any(show[2:3]))
            show.rs <- sort.list(abs(rs), decreasing = TRUE)[iid]
        text.id <- function(x,y, ind, adj.x = FALSE)
            text(x - if(adj.x) strwidth(" ")*cex.id else 0, y, labels.id[ind],
                 cex = cex.id, xpd = TRUE, adj = if(adj.x) 1)
    }
    one.fig <- prod(par("mfcol")) == 1
    if (ask) {
	op <- par(ask = TRUE)
	on.exit(par(op))
    }
    ##---------- Do the individual plots : ----------
    if (show[1]) {
	ylim <- range(r, na.rm=TRUE)
	if(id.n > 0)
	    ylim <- ylim + c(-1,1)* 0.08 * diff(ylim)
	plot(yh, r, xlab = l.fit, ylab = "Residuals", main = main,
	     ylim = ylim, type = "n", ...)
	panel(yh, r, ...)
	if (one.fig)
	    title(sub = sub.caption, ...)
	mtext(caption[1], 3, 0.25)
	if(id.n > 0) {
	    y.id <- r[show.r]
	    y.id[y.id < 0] <- y.id[y.id < 0] - strheight(" ")/3
	    text.id(yh[show.r], y.id, show.r, adj.x = TRUE)
	}
	abline(h = 0, lty = 3, col = "gray")
    }
    if (show[2]) { ## Normal
	ylim <- range(rs, na.rm=TRUE)
	ylim[2] <- ylim[2] + diff(ylim) * 0.075
	qq <- qqnorm(rs, main = main, ylab = ylab23, ylim = ylim, ...)
	if (one.fig)
	    title(sub = sub.caption, ...)
	mtext(caption[2], 3, 0.25)
	if(id.n > 0)
	    text.id(qq$x[show.rs], qq$y[show.rs], show.rs, adj.x = TRUE)
    }
    if (show[3]) {
	sqrtabsr <- sqrt(abs(rs))
	ylim <- c(0, max(sqrtabsr, na.rm=TRUE))
	yl <- as.expression(substitute(sqrt(abs(YL)), list(YL=as.name(ylab23))))
        yhn0 <- if(is.null(w)) yh else yh[w!=0]
	plot(yhn0, sqrtabsr, xlab = l.fit, ylab = yl, main = main,
	     ylim = ylim, type = "n", ...)
	panel(yhn0, sqrtabsr, ...)
	if (one.fig)
	    title(sub = sub.caption, ...)
	mtext(caption[3], 3, 0.25)
	if(id.n > 0)
	    text.id(yhn0[show.rs], sqrtabsr[show.rs], show.rs, adj.x = TRUE)
    }
    if (show[4]) {
	cook <-
            if(isGlm) cooks.distance(x)
            else cooks.distance(x, sd=s, res = r)
	if(id.n > 0) {
	    show.r <- order(-cook)[iid]# index of largest `id.n' ones
	    ymx <- cook[show.r[1]] * 1.075
	} else ymx <- max(cook)
	plot(cook, type = "h", ylim = c(0, ymx), main = main,
	     xlab = "Obs. number", ylab = "Cook's distance", ...)
	if (one.fig)
	    title(sub = sub.caption, ...)
	mtext(caption[4], 3, 0.25)
	if(id.n > 0)
	    text.id(show.r, cook[show.r] + 0.4*cex.id * strheight(" "), show.r)
    }
    if (!one.fig && par("oma")[3] >= 1)
	mtext(sub.caption, outer = TRUE, cex = 1.25)
    invisible()
}
### pmax() & pmin() only differ by name and ONE character :

pmax <- function (..., na.rm = FALSE)
{
    elts <- list(...)
    mmm <- as.vector(elts[[1]])
    has.na <- FALSE
    for (each in elts[-1]) {
	work <- cbind(mmm, as.vector(each)) # recycling..
        nas <- is.na(work)
	if(has.na || (has.na <- any(nas))) {
            work[,1][nas[,1]] <- work[,2][nas[,1]]
            work[,2][nas[,2]] <- work[,1][nas[,2]]
        }
        change <- work[,1] < work[,2]
	work[,1][change] <- work[,2][change]
	if (has.na && !na.rm) work[,1][nas[,1] | nas[,2]] <- NA
	mmm <- work[,1]
    }
    mostattributes(mmm) <- attributes(elts[[1]])
    mmm
}

pmin <- function (..., na.rm = FALSE)
{
    elts <- list(...)
    mmm <- as.vector(elts[[1]])
    has.na <- FALSE
    for (each in elts[-1]) {
	work <- cbind(mmm, as.vector(each)) # recycling..
        nas <- is.na(work)
	if(has.na || (has.na <- any(nas))) {
            work[,1][nas[,1]] <- work[,2][nas[,1]]
            work[,2][nas[,2]] <- work[,1][nas[,2]]
        }
	change <- work[,1] > work[,2]
	work[,1][change] <- work[,2][change]
	if(has.na && !na.rm) work[,1][nas[,1] | nas[,2]] <- NA
	mmm <- work[,1]
    }
    mostattributes(mmm) <- attributes(elts[[1]])
    mmm
}
## --> see ./pmax.R
points <- function(x, ...) UseMethod("points")

### NOTE: cex = 1 is correct, cex = par("cex") gives *square* of intended!

points.default <-
    function(x, y=NULL, type="p", pch=par("pch"), col=par("col"), bg=NA,
             cex=1, ...)
{
    plot.xy(xy.coords(x,y), type=type, pch=pch, col=col, bg=bg, cex=cex,...)
}
### polyhatch -  a pure R implementation of polygon hatching
### Copyright (C) 2001 by Kevin Buhr <buhr@stat.wisc.edu>
### Provided to the R project for release under GPL.
### Original nice clean structure destroyed by Ross Ihaka

polygon <-
  function(x, y = NULL, density = NULL, angle = 45,
           border = NULL, col = NA, lty = NULL,
           xpd = NULL, ..debug.hatch = FALSE, ...)
{
    ##-- FIXME: what if `log' is active, for x or y?
    xy <- xy.coords(x, y)

    if (is.numeric(density) && all(is.na(density) | density < 0))
        density <- NULL
    if (!is.null(angle) && !is.null(density)) {

        ## hatch helper functions

        polygon.onehatch <-
            function(x, y, x0, y0, xd, yd, ..debug.hatch = FALSE, ...)
        {
            ## draw the intersection of one line with polygon
            ##
            ##  x,y - points of polygon (MUST have first and last points equal)
            ##  x0,y0 - origin of line
            ##  xd,yd - vector giving direction of line
            ##  ... - other parameters to pass to "segments"

            if (..debug.hatch) {
                points(x0, y0)
                arrows(x0, y0, x0 + xd, y0 + yd)
            }

            ## halfplane[i] is 0 or 1 as (x[i], y[i]) lies in left or right
            ##   half-plane of the line

            halfplane <- as.integer(xd * (y - y0) - yd * (x - x0) <= 0)

            ## cross[i] is -1,0, or 1 as segment (x[i], y[i]) -- (x[i+1], y[i+1])
            ##   crosses right-to-left, doesn't cross, or crosses left-to-right

            cross <- halfplane[-1] - halfplane[-length(halfplane)]
            does.cross <- cross != 0
            if (!any(does.cross)) return(invisible(FALSE)) # nothing to draw?

            ## calculate where crossings occur

            x1 <- x[-length(x)][does.cross]; y1 <- y[-length(y)][does.cross]
            x2 <- x[-1][does.cross]; y2 <- y[-1][does.cross]

            ## t[i] is "timepoint" on line at which segment (x1, y1)--(x2, y2)
            ##   crosses such that (x0,y0) + t*(xd,yd) is point of intersection

            t <- (((x1 - x0) * (y2 - y1) - (y1 - y0) * (x2 - x1))/
                  (xd * (y2 - y1) - yd * (x2 - x1)))

            ## sort timepoints along line

            o <- order(t)
            tsort <- t[o]

            ## we draw the part of line from t[i] to t[i+1] whenever it lies
            ##   "inside" the polygon --- we define this to mean we crossed
            ##   unequal numbers of left-to-right and right-to-left polygon
            ##   segments to get there

            drawline <- cumsum(cross[does.cross][o]) != 0

            ## draw those segments

            lx <- x0 + xd * tsort
            ly <- y0 + yd * tsort
            lx1 <- lx[-length(lx)][drawline]; ly1 <- ly[-length(ly)][drawline]
            lx2 <- lx[-1][drawline]; ly2 <- ly[-1][drawline]
            segments(lx1, ly1, lx2, ly2, ...)
        }

        polygon.fullhatch <-
            function(x, y, density, angle, ..debug.hatch = FALSE, ...)
        {
            ## draw the hatching for a given polygon
            ##
            ##  x,y - points of polygon (need not have first and last points
            ##        equal, but no NAs are allowed)
            ##  density,angle - of hatching
            ##  ... - other parameters to pass to "segments"

            x <- c(x, x[1])
            y <- c(y, y[1])
            angle <- angle %% 180

            if (par("xlog") || par("ylog")) {
                warning("cannot hatch with logarithmic scale active")
                return(invisible(FALSE))
            }
            usr <- par("usr"); pin <- par("pin")

            ## usr coords per inch

            upi <- c(usr[2] - usr[1], usr[4] - usr[3]) / pin

            ## handle "flipped" usr coords

            if (upi[1] < 0) angle <- 180 - angle
            if (upi[2] < 0) angle <- 180 - angle
            upi <- abs(upi)

            ## usr-coords direction vector for hatching

            xd <- cos(angle / 180 * pi) * upi[1]
            yd <- sin(angle / 180 * pi) * upi[2]

            ## to generate candidate hatching lines for polygon.onehatch,
            ##   we generate those lines necessary to cover the rectangle
            ##   (min(x),min(y)) to (max(x),max(y)) depending on the
            ##   hatching angle

            ## (Note:  We choose hatch line origins such that the hatching,
            ##   if extended outside polygon, would pass through usr-coordinate
            ##   origin.  This ensures that all hatching with same density,
            ##   angle in figure will be aligned.)

            if (angle < 45 || angle > 135) {

                ## first.x and last.x are x-coords of first and last points
                ##  of rectangle to hit, as y-coord moves from bottom up

                if (angle < 45) {
                    first.x <- max(x)
                    last.x <- min(x)
                }
                else {
                    first.x <- min(x)
                    last.x <- max(x)
                }

                ## y.shift is vertical shift between parallel hatching lines

                y.shift <- upi[2] / density / abs(cos(angle / 180 * pi))

                ## choose line origin (of first line) to align hatching
                ##   with usr origin

                x0 <- 0
                y0 <- floor((min(y) - first.x * yd / xd) / y.shift) * y.shift

                ## line origins above y.end won't hit figure

                y.end <- max(y) - last.x * yd / xd

                ## hatch against all candidate lines

                while (y0 < y.end) {
                    polygon.onehatch(x, y, x0, y0, xd, yd,
                                     ..debug.hatch=..debug.hatch,...)
                    y0 <- y0 + y.shift
                }
            }
            else {
                ## first.y, last.y are y-coords of first and last points
                ##   of rectangle to hit, as x-coord moves from left to right

                if (angle < 90) {
                    first.y <- max(y)
                    last.y <- min(y)
                }
                else {
                    first.y <- min(y)
                    last.y <- max(y)
                }

                ## x.shift is horizontal shift between parallel hatching lines

                x.shift <- upi[1] / density / abs(sin(angle / 180 * pi))

                ## choose line origin to align with usr origin

                x0 <- floor((min(x) - first.y * xd / yd) / x.shift) * x.shift
                y0 <- 0

                ## line origins to right of x.end won't hit figure

                x.end <- max(x) - last.y * xd / yd

                ## hatch!

                while (x0 < x.end) {
                    polygon.onehatch(x, y, x0, y0, xd, yd,
                                     ..debug.hatch=..debug.hatch,...)
                    x0 <- x0 + x.shift
                }
            }
        }

        ## end of hatch helper functions


        if (missing(col) || is.null(col)) col <- par("fg")
        if (is.null(border)) border <- col
        if (is.logical(border)) {
            if (!is.na(border) && border) border <- col
            else border <- NA
        }

        ## process multiple polygons separated by NAs

        start <- 1
        ends <- c((1:length(xy$x))[is.na(xy$x) | is.na(xy$y)], length(xy$x) + 1)

        num.polygons <- length(ends)
        col <- rep(col, length.out = num.polygons)
        border <- rep(border, length.out = num.polygons)
        lty <- rep(lty, length.out = num.polygons)
        density <- rep(density, length.out = num.polygons)
        angle <- rep(angle, length.out = num.polygons)

        i <- 1
        for (end in ends) {
            if (end > start) {
                den <- density[i]
                if(is.na(den) || den < 0)
                    .Internal(polygon(xy$x[start:(end - 1)],
                                      xy$y[start:(end - 1)],
                                      col[i], NA, lty[i], xpd, ...))
                else if (den > 0) {

                        ## note: if col[i]==NA, "segments" will fill with par("fg")

                        polygon.fullhatch(xy$x[start:(end - 1)],
                                          xy$y[start:(end - 1)],
                                          col = col[i], lty = lty[i],
                                          xpd = xpd,
                                          density = density[i],
                                          angle = angle[i],
                                          ..debug.hatch = ..debug.hatch, ...)
                    }

                ## compatible with .Internal(polygon)
                ## only cycle through col, lty, etc. on non-empty polygons
                i <- i + 1
            }
            start <- end + 1
        }
        .Internal(polygon(xy$x, xy$y, NA, border, lty, xpd, ...))
    }
    else {
        if (is.logical(border)) {
            if (!is.na(border) && border) border <- par("fg")
            else border <- NA
        }
        .Internal(polygon(xy$x, xy$y, col, border, lty, xpd, ...))
    }
}
.PostScript.Options <-
    list(paper	= "default",
	 horizontal = TRUE,
	 width	= 0,
	 height = 0,
	 family = "Helvetica",
	 encoding = "default",
	 pointsize  = 12,
	 bg	= "transparent",
	 fg	= "black",
	 onefile    = TRUE,
	 print.it   = FALSE,
	 append	    = FALSE,
	 pagecentre = TRUE,
	 command    = "default")

check.options <-
    function(new, name.opt, reset = FALSE, assign.opt = FALSE,
	     envir = .GlobalEnv, check.attributes = c("mode", "length"),
	     override.check = FALSE)
{
    lnew <- length(new)
    if(lnew != length(newnames <- names(new)))
	stop(paste("invalid arguments in \"",
		   deparse(sys.call(sys.parent())),
		   "\" (need NAMED args)", sep=""))
    if(!is.character(name.opt))
	stop("'name.opt' must be character, name of an existing list")
    if(reset) {
	if(exists(name.opt, envir=envir, inherits=FALSE)) {
	    if(length(find(name.opt)) > 1)
		rm(list=name.opt, envir=envir)
##-	    else
##-		stop(paste("Cannot reset '", name.opt,
##-			"'  since it exists only once in search()!\n", sep=""))

	} else stop(paste("Cannot reset non-existing '", name.opt, "'", sep=""))
    }
    old <- get(name.opt, envir=envir)
    if(!is.list(old))
	stop(paste("invalid options in `",name.opt,"'",sep=""))
    oldnames <- names(old)
    if(lnew > 0) {
	matches <- pmatch(newnames, oldnames)
	if(any(is.na(matches)))
	    stop(paste("invalid argument name(s) `",
		       paste(newnames[is.na(matches)], collapse=", "),
		       "' in \"", deparse(sys.call(sys.parent())),"\"",sep=""))
##-- This does not happen: ambiguities are plain "NA" here:
##-	else if(any(matches==0))
##-	    stop(paste("ambiguous argument name(s) `",
##-			   paste(newnames[matches == 0], collapse=", "),
##-			   "' in \"", deparse(sys.call(sys.parent())),"\"",sep=""))
	else { #- match(es) found:  substitute if appropriate
	    i.match <- oldnames[matches]
	    prev <- old[i.match]
	    doubt <- rep(FALSE, length(prev))
	    for(fn in check.attributes)
		if(any(ii <- sapply(prev, fn) != sapply(new, fn))) {
		    doubt <- doubt | ii
		    do.keep <- ii & !override.check
		    warning(paste(paste(paste("`",fn,"(",names(prev[ii]),")'",
					      sep=""),
					collapse=" and "),
				  " differ", if(sum(ii)==1) "s",
				  " between new and previous!",
				  if(any(do.keep))
				  paste("\n\t ==> NOT changing ",
					paste(paste("`",names(prev[do.keep]),
						    "'", sep=""),
					      collapse=" & "),
					collapse = ""),
				  sep=""))
		}
	    names(new) <- NULL
	    if(any(doubt)) {
		ii <- !doubt | override.check
		old[i.match[ii]] <- new[ii]
	    } else old[i.match] <- new

	}
	if(assign.opt) assign(name.opt, old, envir=envir)
    }
    old
}

ps.options <- function(..., reset=FALSE, override.check= FALSE)
{
    l... <- length(new <- list(...))
    old <- check.options(new = new, name.opt = ".PostScript.Options",
			 reset = as.logical(reset), assign.opt = l... > 0,
			 override.check= override.check)
    if(reset || l... > 0) invisible(old)
    else old
}

##--> source in ../../../main/devices.c	 and ../../../main/devPS.c :

postscript <- function (file = ifelse(onefile,"Rplots.ps", "Rplot%03d.ps"),
                        onefile = TRUE, family,
                        title = "R Graphics Output", ...)
{
    new <- list(onefile=onefile, ...)# eval
    old <- check.options(new = new, name.opt = ".PostScript.Options",
			 reset = FALSE, assign.opt = FALSE)

    if(is.null(old$command) || old$command == "default")
        old$command <- if(!is.null(cmd <- getOption("printcmd"))) cmd else ""
    ## handle family separately as length can be 1, 4, or 5
    if(!missing(family)) {
        if(length(family) == 4) family <- c(family, "sy______.afm")
        old$family <- family
    }
    if(is.null(old$encoding) || old$encoding  == "default")
        old$encoding <- switch(.Platform$OS.type,
                               "windows" = "WinAnsi.enc",
                               "ISOLatin1.enc")
    .Internal(PS(file, old$paper, old$family, old$encoding, old$bg, old$fg,
		 old$width, old$height, old$horizontal, old$pointsize,
                 old$onefile, old$pagecentre, old$print.it, old$command,
                 title))
}

xfig <- function (file = ifelse(onefile,"Rplots.fig", "Rplot%03d.fig"),
                  onefile = FALSE, ...)
{
    new <- list(onefile=onefile, ...)# eval
    old <- check.options(new = new, name.opt = ".PostScript.Options",
			 reset = FALSE, assign.opt = FALSE)

    .Internal(XFig(file, old$paper, old$family, old$bg, old$fg,
		 old$width, old$height, old$horizontal, old$pointsize,
                 old$onefile, old$pagecentre))
}

pdf <- function (file = ifelse(onefile, "Rplots.pdf", "Rplot%03d.pdf"),
                 width = 6, height = 6, onefile = TRUE,
                 title = "R Graphics Output", ...)
{
    new <- list(onefile=onefile, ...)# eval
    old <- check.options(new = new, name.opt = ".PostScript.Options",
			 reset = FALSE, assign.opt = FALSE)
    if(is.null(old$encoding) || old$encoding  == "default")
        old$encoding <- switch(.Platform$OS.type,
                               "windows" = "WinAnsi.enc",
                               "ISOLatin1.enc")
    .Internal(PDF(file, old$family, old$encoding, old$bg, old$fg,
                  width, height, old$pointsize, old$onefile, title))
}

.ps.prolog <- c(
"/gs  { gsave } def",
"/gr  { grestore } def",
"/ep  { showpage gr gr } def",
"/m   { moveto } def",
"/l  { rlineto } def",
"/np  { newpath } def",
"/cp  { closepath } def",
"/f   { fill } def",
"/o   { stroke } def",
"/c   { newpath 0 360 arc } def",
"/r   { 4 2 roll moveto 1 copy 3 -1 roll exch 0 exch rlineto 0 rlineto -1 mul 0 exch rlineto closepath } def",
"/p1  { stroke } def",
"/p2  { gsave bg setrgbcolor fill grestore newpath } def",
"/p3  { gsave bg setrgbcolor fill grestore stroke } def",
"/t   { 6 -2 roll moveto gsave rotate",
"       ps mul neg 0 2 1 roll rmoveto",
"       1 index stringwidth pop",
"       mul neg 0 rmoveto show grestore } def",
"/cl  { grestore gsave newpath 3 index 3 index moveto 1 index",
"       4 -1 roll lineto  exch 1 index lineto lineto",
"       closepath clip newpath } def",
"/rgb { setrgbcolor } def",
"/s   { scalefont setfont } def",
"/R   { /Font1 findfont } def",
"/B   { /Font2 findfont } def",
"/I   { /Font3 findfont } def",
"/BI  { /Font4 findfont } def",
"/S   { /Font5 findfont } def",
"1 setlinecap 1 setlinejoin")
ppoints <- function (n, a = ifelse(n <= 10, 3/8, 1/2))
{
    if(length(n) > 1) n <- length(n)
    if(n > 0)
	(1:n - a)/(n + 1-2*a)
    else numeric(0)
}
predict <- function(object,...) UseMethod("predict")

## This is not used anywhere anymore, is it ?
## It would only work with objects very much like  "lm", would it?
if(FALSE)
predict.default <- function (object, ...) {
    namelist <- list(...)
    names(namelist) <- substitute(list(...))[-1]
    m <- length(namelist)
    X <- as.matrix(namelist[[1]])
    if (m > 1)
	for (i in (2:m)) X <- cbind(X, namelist[[i]])
    if (object$intercept)
	X <- cbind(rep(1, NROW(X)), X)
    k <- NCOL(X)
    n <- NROW(X)
    if (length(object$coef) != k)
	stop("Wrong number of predictors")
    predictor <- X %*% object$coef
    ip <- numeric(n)
    names(ip) <- paste("P", 1:n, sep = "")
    for (i in 1:n)
	ip[i] <- sum(X[i, ] * (object$covmat %*% X[i, ]))
    stderr1 <- sqrt(ip)
    stderr2 <- sqrt(object$rms^2 + ip)
    tt <- qt(0.975, object$df)
    predictor + tt * cbind(Predicted=0,
                           "Conf lower"=-stderr1, "Conf upper"=stderr1,
                           "Pred lower"=-stderr2, "Pred upper"=stderr2)
}
predict.glm <-
  function(object, newdata = NULL, type = c("link", "response", "terms"),
           se.fit = FALSE, dispersion = NULL, terms=NULL,
           na.action = na.pass, ...)
{
    ## 1998/06/23 KH:  predict.lm() now merged with the version in lm.R

    type <- match.arg(type)
    na.act <- object$na.action
    object$na.action <- NULL # kill this for predict.lm calls
    if (!se.fit) {
	## No standard errors
	if(missing(newdata)) {
	    pred <- switch(type,
			   link = object$linear.predictors,
			   response = object$fitted,
                           terms = predict.lm(object,  se.fit=se.fit,
                               scale = 1, type="terms", terms=terms)
                           )
            if(!is.null(na.act)) pred <- napredict(na.act, pred)
	} else {
	    pred <- predict.lm(object, newdata, se.fit, scale = 1,
                               type = ifelse(type=="link", "response", type),
                               terms = terms, na.action = na.action)
	    switch(type,
		   response = {pred <- family(object)$linkinv(pred)},
		   link =, terms= )
          }
    } else {
	## summary.survreg has no ... argument.
	if(inherits(object, "survreg")) dispersion <- 1.
	if(is.null(dispersion) || dispersion == 0)
	    dispersion <- summary(object, dispersion=dispersion)$dispersion
	residual.scale <- as.vector(sqrt(dispersion))
	pred <- predict.lm(object, newdata, se.fit, scale = residual.scale,
                           type = ifelse(type=="link", "response", type),
                           terms = terms, na.action = na.action)
	fit <- pred$fit
	se.fit <- pred$se.fit
	switch(type,
	       response = {
		   se.fit <- se.fit * abs(family(object)$mu.eta(fit))
		   fit <- family(object)$linkinv(fit)
	       },
	       link =, terms=)
        if( missing(newdata) && !is.null(na.act) ) {
            fit <- napredict(na.act, fit)
            se.fit <- napredict(na.act, se.fit)
        }
	pred <- list(fit=fit, se.fit=se.fit, residual.scale=residual.scale)
    }
    pred
}
pretty <- function(x, n=5, min.n= n %/% 3, shrink.sml = 0.75,
                   high.u.bias = 1.5, u5.bias = .5 + 1.5*high.u.bias,
                   eps.correct = 0)
{
    if(!is.numeric(x))
	stop("x must be numeric")
    if(length(x)==0)
	return(x)
    if(is.na(n <- as.integer(n[1])) || n < 0)# n=0 !!
	stop("invalid n value")
    if(!is.numeric(shrink.sml) || shrink.sml <= 0)
	stop("argument `shrink.sml' must be numeric > 0")
    if((min.n <- as.integer(min.n)) < 0 || min.n > n)
	stop("argument `min.n' must be non-negative integer <= n")
    if(!is.numeric(high.u.bias) || high.u.bias < 0)
	stop("argument `high.u.bias' must be non-negative numeric")
    if(!is.numeric(u5.bias) || u5.bias < 0)
	stop("argument `u5.bias' must be non-negative numeric")
    if((eps.correct <- as.integer(eps.correct)) < 0 || eps.correct > 2)
	stop("argument `eps.correct' must be 0, 1, or 2")
    z <- .C("R_pretty", l=as.double(min(x)), u=as.double(max(x)),
            n = n,
            min.n,
	    shrink = as.double(shrink.sml),
            high.u.fact = as.double(c(high.u.bias, u5.bias)),
            eps.correct,
            DUP = FALSE, PACKAGE = "base")
    s <- seq(z$l, z$u, length = z$n+1)
    if(!eps.correct && z$n) { # maybe zap smalls from seq() rounding errors
        ## better than zapsmall(s, digits = 14) :
        delta <- diff(range(z$l, z$u)) / z$n
        if(any(small <- abs(s) < 1e-14 * delta))
            s[small] <- 0
    }
    s
}
print <- function(x, ...) UseMethod("print")

##- Need '...' such that it can be called as  NextMethod("print", ...):
print.default <- function(x, digits = NULL, quote = TRUE, na.print = NULL,
                          print.gap = NULL, right = FALSE, ...)
{
    noOpt <- missing(digits) && missing(quote) && missing(na.print) &&
      missing(print.gap) && missing(right) && length(list(...)) == 0
    .Internal(print.default(x, digits, quote, na.print, print.gap, right,
                            noOpt))
}

print.matrix <- print.default  ## back-compatibility

prmatrix <-
    function (x, rowlab = dn[[1]], collab = dn[[2]],
              quote = TRUE, right = FALSE,
              na.print = NULL, ...)
{
    x <- as.matrix(x)
    dn <- dimnames(x)
    .Internal(prmatrix(x, rowlab, collab, quote, right, na.print))
}

noquote <- function(obj) {
    ## constructor for a useful "minor" class
    if(!inherits(obj,"noquote")) class(obj) <- c(attr(obj, "class"),"noquote")
    obj
}

as.matrix.noquote <- function(x) noquote(NextMethod("as.matrix", x))

"[.noquote" <- function (x, ...) {
    attr <- attributes(x)
    r <- unclass(x)[...] ## shouldn't this be NextMethod?
    attributes(r) <- c(attributes(r),
		       attr[is.na(match(names(attr),
                                        c("dim","dimnames","names")))])
    r
}

print.noquote <- function(x, ...) {
    if(!is.null(cl <- attr(x, "class"))) {
	cl <- cl[cl != "noquote"]
        attr(x, "class") <-
          (if(length(cl)>0) cl else NULL)
      }
    print(x, quote = FALSE, ...)
}

## for alias:
print.listof <- function(x, ...)
{
    nn <- names(x)
    ll <- length(x)
    if(length(nn) != ll) nn <- paste("Component", seq(ll))
    for(i in seq(length=ll)) {
	cat(nn[i], ":\n"); print(x[[i]], ...); cat("\n")
    }
    invisible(x)
}

## used for version:
print.simple.list <- function(x, ...)
    print(noquote(cbind("_"=unlist(x))), ...)

printCoefmat <-
    function(x, digits = max(3, getOption("digits") - 2),
	     signif.stars = getOption("show.signif.stars"),
	     dig.tst = max(1, min(5, digits - 1)),
	     cs.ind = 1:k, tst.ind = k+1, zap.ind = integer(0),
	     P.values = NULL,
	     has.Pvalue = nc >= 4 && substr(colnames(x)[nc],1,3) == "Pr(",
             eps.Pvalue = .Machine$double.eps,
	     na.print = "NA", ...)
{
    ## For printing ``coefficient matrices'' as they are in summary.xxx(.) where
    ## xxx in {lm, glm, aov, ..}. (Note: summary.aov(.) gives a class "anova").

    ## By Default
    ## Assume: x is a matrix-like numeric object.
    ## ------  with *last* column = P-values  --iff-- P.values (== TRUE)
    ##	  columns {cs.ind}= numbers, such as coefficients & std.err  [def.: 1:k]
    ##	  columns {tst.ind}= test-statistics (as "z", "t", or "F")  [def.: k+1]

    if(is.null(d <- dim(x)) || length(d) != 2)
	stop("1st arg. 'x' must be coefficient matrix/d.f./...")
    nc <- d[2]
    if(is.null(P.values)) {
        scp <- getOption("show.coef.Pvalues")
        if(!is.logical(scp) || is.na(scp)) {
            warning("option `show.coef.Pvalues' is invalid: assuming TRUE")
            scp <- TRUE
        }
	P.values <- has.Pvalue && scp
    }
    else if(P.values && !has.Pvalue)
	stop("'P.values is TRUE, but has.Pvalue not!")

    if(has.Pvalue && !P.values) {# P values are there, but not wanted
	d <- dim(xm <- data.matrix(x[,-nc , drop = FALSE]))
	nc <- nc - 1
	has.Pvalue <- FALSE
    } else xm <- data.matrix(x)

    k <- nc - has.Pvalue - (if(missing(tst.ind)) 1 else length(tst.ind))
    if(!missing(cs.ind) && length(cs.ind) > k) stop("wrong k / cs.ind")

    Cf <- array("", dim=d, dimnames = dimnames(xm))

    ok <- !(ina <- is.na(xm))
    if(length(cs.ind)>0) {
	acs <- abs(coef.se <- xm[, cs.ind, drop=FALSE])# = abs(coef. , stderr)
        if(any(is.finite(acs))) {
            ## #{digits} BEFORE decimal point -- for min/max. value:
            digmin <- 1+floor(log10(range(acs[acs != 0], na.rm= TRUE)))
            Cf[,cs.ind] <- format(round(coef.se, max(1,digits-digmin)),
                                  digits=digits)
        }
    }
    if(length(tst.ind)>0)
	Cf[, tst.ind]<- format(round(xm[, tst.ind], dig=dig.tst), digits=digits)
    if(length(zap.ind)>0)
	Cf[, zap.ind]<- format(zapsmall(xm[,zap.ind], dig=digits),digits=digits)
    if(any(r.ind <- !((1:nc) %in% c(cs.ind,tst.ind,zap.ind, if(has.Pvalue)nc))))
	Cf[, r.ind] <- format(xm[, r.ind], digits=digits)
    okP <- if(has.Pvalue) ok[, -nc] else ok
    x0 <- xm[okP]==0 != (as.numeric(Cf[okP])==0)
    if(length(not.both.0 <- which(x0 & !is.na(x0)))) {
	## not.both.0==TRUE:  xm !=0, but Cf[] is: --> fix these:
	Cf[okP][not.both.0] <- format(xm[okP][not.both.0], digits= max(1,digits-1))
    }
    if(any(ina)) Cf[ina] <- na.print
    if(P.values) {
        if(!is.logical(signif.stars) || is.na(signif.stars)) {
            warning("option `show.signif.stars' is invalid: assuming TRUE")
            signif.stars <- TRUE
        }
	pv <- xm[, nc]
	if(any(okP <- ok[,nc])) {
	    Cf[okP, nc] <- format.pval(pv[okP],
                                       digits = dig.tst, eps = eps.Pvalue)
	    signif.stars <- signif.stars && any(pv[okP] < .1)
	    if(signif.stars) {
		Signif <- symnum(pv, corr = FALSE, na = FALSE,
				 cutpoints = c(0,  .001,.01,.05, .1, 1),
				 symbols   =  c("***","**","*","."," "))
		Cf <- cbind(Cf, format.char(Signif)) #format.ch: right=TRUE
	    }
	} else signif.stars <- FALSE
    } else signif.stars <- FALSE
    print.matrix(Cf, quote = FALSE, right = TRUE, na.print=na.print, ...)
    if(signif.stars) cat("---\nSignif. codes: ",attr(Signif,"legend"),"\n")
    invisible(x)
}

print.anova <- function(x, digits = max(getOption("digits") - 2, 3),
                        signif.stars= getOption("show.signif.stars"), ...)
{
    if (!is.null(heading <- attr(x, "heading")))
	cat(heading, sep = "\n")
    nc <- dim(x)[2]
    if(is.null(cn <- colnames(x))) stop("anova object must have colnames(.)!")
    ncn <- nchar(cn)
    has.P <- substr(cn[nc],1,3) == "Pr(" # P-value as last column
    zap.i <- 1:(if(has.P) nc-1 else nc)
    i <- which(substr(cn,2,7) == " value")
    i <- c(i, which(!is.na(match(cn, c("F", "Cp", "Chisq")))))
    if(length(i))
	zap.i <- zap.i[!(zap.i %in% i)]
    tst.i <- i
    if(length(i <- which(substr(cn,ncn-1,ncn) == "Df")))
	zap.i <- zap.i[!(zap.i %in% i)]

    printCoefmat(x, digits = digits, signif.stars = signif.stars,
                 has.Pvalue = has.P, P.values = has.P,
                 cs.ind = NULL, zap.ind = zap.i, tst.ind= tst.i,
                 na.print = "", # not yet in print.matrix:  print.gap = 2,
                 ...)
    invisible(x)
}

## print.data.frame here was a duplicate of that in dataframe.R
profile <- function(fitted, ...) UseMethod("profile")
proj <- function(object, ...) UseMethod("proj")

proj.default <- function(object, onedf = TRUE, ...)
{
    if(!is.qr(object$qr))
	stop("Argument does not include a qr component")
    if(is.null(object$effects))
	stop("Argument does not include an effects component")
    RB <- c(object$effects[seq(object$rank)],
	    rep.int(0, nrow(object$qr$qr) - object$rank))
    prj <- as.matrix(qr.Q(object$qr, Dvec = RB))
    DN <- dimnames(object$qr$qr)
    dimnames(prj) <- list(DN[[1]], DN[[2]][seq(ncol(prj))])
    prj
}

proj.lm <- function(object, onedf = FALSE, unweighted.scale = FALSE, ...)
{
    if(inherits(object, "mlm"))
	stop("proj is not implemented for mlm fits")
    rank <- object$rank
    if(rank > 0) {
	prj <- proj.default(object, onedf = TRUE)[, 1:rank, drop = FALSE]
	if(onedf) {
	    df <- rep.int(1, rank)
	    result <- prj
	} else {
	    asgn <- object$assign[object$qr$pivot[1:object$rank]]
	    uasgn <- unique(asgn)
	    nmeffect <- c("(Intercept)",
			  attr(object$terms, "term.labels"))[1 + uasgn]
	    nterms <- length(uasgn)
	    df <- vector("numeric", nterms)
	    result <- matrix(0, length(object$residuals), nterms)
	    dimnames(result) <- list(rownames(object$fitted.values), nmeffect)
	    for(i in seq(along=uasgn)) {
		select <- (asgn == uasgn[i])
		df[i] <- sum(select)
		result[, i] <- prj[, select, drop = FALSE] %*% rep.int(1, df[i])
	    }
	}
    } else {
	result <- NULL
	df <- NULL
    }
    if(!is.null(wt <- object$weights) && unweighted.scale)
	result <- result/sqrt(wt)
    use.wt <- !is.null(wt) && !unweighted.scale
    if(object$df.residual > 0) {
	if(!is.matrix(result)) {
	    if(use.wt) result <- object$residuals * sqrt(wt)
	    else result <- object$residuals
	    result <- matrix(result, length(result), 1, dimnames
			     = list(names(result), "Residuals"))
	} else {
	    dn <- dimnames(result)
	    d <- dim(result)
	    result <- c(result, if(use.wt) object$residuals * sqrt(wt)
			else object$residuals)
	    dim(result) <- d + c(0, 1)
	    dn[[1]] <- names(object$residuals)
	    names(result) <- NULL
	    dn[[2]] <- c(dn[[2]], "Residuals")
	    dimnames(result) <- dn
	}
	df <- c(df, object$df.residual)
    }
    names(df) <- colnames(result)
    attr(result, "df") <- df
    attr(result, "formula") <- object$call$formula
    attr(result, "onedf") <- onedf
    if(!is.null(wt)) attr(result, "unweighted.scale") <- unweighted.scale
    result
}

proj.aov <- function(object, onedf = FALSE, unweighted.scale = FALSE, ...)
{
    if(inherits(object, "maov"))
	stop("proj is not implemented for multiple responses")
    factors.aov <- function(pnames, tfactor)
    {
	if(!is.na(int <- match("(Intercept)", pnames)))
	    pnames <- pnames[ - int]
	tnames <- lapply(colnames(tfactor), function(x, mat)
			 rownames(mat)[mat[, x] > 0], tfactor)
	names(tnames) <- colnames(tfactor)
	if(!is.na(match("Residuals", pnames))) {
	    enames <- c(rownames(tfactor)
			[as.logical(tfactor %*% rep.int(1, ncol(tfactor)))],
			"Within")
	    tnames <- append(tnames, list(Residuals = enames))
	}
	result <- tnames[match(pnames, names(tnames))]
	if(!is.na(int)) result <- c("(Intercept)" = "(Intercept)", result)
	## should reorder result, but probably OK
	result
    }
    projections <- NextMethod("proj")
    t.factor <- attr(terms(object), "factor")
    attr(projections, "factors") <-
	factors.aov(colnames(projections), t.factor)
    attr(projections, "call") <- object$call
    attr(projections, "t.factor") <- t.factor
    class(projections) <- "aovproj"
    projections
}


proj.aovlist <- function(object, onedf = FALSE, unweighted.scale = FALSE, ...)
{
    attr.xdim <- function(x)
    {
	## all attributes except names, dim and dimnames
	atrf <- attributes(x)
	atrf[is.na(match(names(atrf), c("names", "dim", "dimnames")))]
    }
    "attr.assign<-" <- function(x, value)
    {
	## assign to x all attributes in attr.x
	##    attributes(x)[names(value)] <- value not allowed in R
	for(nm in names(value)) attr(x, nm) <- value[nm]
	x
    }
    factors.aovlist <- function(pnames, tfactor,
				strata = FALSE, efactor = FALSE)
    {
	if(!is.na(int <- match("(Intercept)", pnames))) pnames <- pnames[-int]
	tnames <- apply(tfactor, 2, function(x, nms)
			nms[as.logical(x)], rownames(tfactor))
	if(!missing(efactor)) {
	    enames <- NULL
	    if(!is.na(err <- match(strata, colnames(efactor))))
		enames <- (rownames(efactor))[as.logical(efactor[, err])]
	    else if(strata == "Within")
		enames <- c(rownames(efactor)
			    [as.logical(efactor %*% rep.int(1, ncol(efactor)))],
			    "Within")
	    if(!is.null(enames))
		tnames <- append(tnames, list(Residuals = enames))
	}
	result <- tnames[match(pnames, names(tnames))]
	if(!is.na(int))
	    result <- c("(Intercept)" = "(Intercept)", result)
	##should reorder result, but probably OK
	result
    }
    if(unweighted.scale && is.null(attr(object, "weights")))
	unweighted.scale <- FALSE
    err.qr <- attr(object, "error.qr")
    Terms <- terms(object, "Error")
    t.factor <- attr(Terms, "factor")
    i <- attr(Terms, "specials")$Error
    t <- attr(Terms, "variables")[[1 + i]]
    error <- Terms
    error[[3]] <- t[[2]]
    e.factor <- attr(terms(formula(error)), "factor")
    n <- nrow(err.qr$qr)
    n.object <- length(object)
    result <- vector("list", n.object)
    names(result) <- names(object)
    D1 <- rownames(err.qr$qr)
    if(unweighted.scale) wt <- attr(object, "weights")
    for(i in names(object)) {
	prj <- proj.lm(object[[i]], onedf = onedf)
	if(unweighted.scale) prj <- prj/sqrt(wt)
	result.i <- matrix(0, n, ncol(prj), dimnames = list(D1, colnames(prj)))
	select <- rownames(object[[i]]$qr$qr)
	if(is.null(select)) select <- rownames(object[[i]]$residuals)
	result.i[select,  ] <- prj
	result[[i]] <- as.matrix(qr.qy(err.qr, result.i))
	attr.assign(result[[i]]) <- attr.xdim(prj)
	D2i <- colnames(prj)
	dimnames(result[[i]]) <- list(D1, D2i)
	attr(result[[i]], "factors") <-
	    factors.aovlist(D2i, t.factor, strata = i, efactor = e.factor)
    }
    attr(result, "call") <- attr(object, "call")
    attr(result, "e.factor") <- e.factor
    attr(result, "t.factor") <- t.factor
    class(result) <- c("aovprojlist", "listof")
    result
}

terms.aovlist <- function(x, ...)
{
    x <- attr(x, "terms")
    terms(x, ...)
}

prompt <-
function(object, filename = NULL, name = NULL, ...)
    UseMethod("prompt")

prompt.default <-
function(object, filename = NULL, name = NULL,
         force.function = FALSE, ...)
{
    paste0 <- function(...) paste(..., sep = "")
    
    is.missing.arg <- function(arg)
        typeof(arg) == "symbol" && deparse(arg) == ""

    if(missing(name))
        name <-
            if(is.character(object))
                object
            else {
                name <- substitute(object)
                if(is.language(name) && !is.name(name))
                    name <- eval(name)
                as.character(name)
            }
    if(is.null(filename))
        filename <- paste0(name, ".Rd")

    ## Better than get(); works when called in fun :
    x <- get(name, envir = parent.frame())

    ## <FIXME>
    ## If not a function or forced to document a function (?), always
    ## assume data set.
    if(!(is.function(x) || force.function))
        return(promptData(x, filename = filename, name = name))
    ## </FIXME>

    s <- seq(length = n <- length(argls <- formals(x)))
    if(n > 0) {
        arg.names <- arg.n <- names(argls)
        arg.n[arg.n == "..."] <- "\\dots"
    }
    ## Construct the 'call' for \usage.
    call <- paste0(name, "(")
    for(i in s) {                       # i-th argument
        call <- paste0(call, arg.names[i],
                       if(!is.missing.arg(argls[[i]]))
                       paste0(" = ",
                              deparse(argls[[i]], width.cutoff= 500)))
        if(i != n) call <- paste0(call, ", ")
    }

    ## Construct the definition for \examples.
    x.def <- attr(x, "source")
    if(is.null(x.def))
        x.def <- deparse(x)
    if(any(br <- substr(x.def, 1, 1) == "}"))
        x.def[br] <- paste(" ", x.def[br])

    Rdtxt <-
        list(name = paste0("\\name{", name, "}"),
             aliases = c(paste0("\\alias{", name, "}"),
             paste("%- Also NEED an '\\alias' for EACH other topic",
                   "documented here.")),
             title = "\\title{ ~~function to do ... ~~ }",
             description = c("\\description{",
             paste("  ~~ A concise (1-5 lines) description of what",
                   "the function does. ~~"),
             "}"),
             usage = c("\\usage{", paste0(call, ")"), "}",
             paste("%- maybe also 'usage' for other objects",
                   "documented here.")),
             arguments = NULL,
             details = c("\\details{",
             paste("  ~~ If necessary, more details than the",
                   "__description__  above ~~"),
             "}"),
             value = c("\\value{",
             "  ~Describe the value returned",
             "  If it is a LIST, use",
             "  \\item{comp1 }{Description of 'comp1'}",
             "  \\item{comp2 }{Description of 'comp2'}",
             "  ...",
             "}"),
             references = paste("\\references{ ~put references to the",
             "literature/web site here ~ }"),
             author = "\\author{ ~~who you are~~ }",
             note = c("\\note{ ~~further notes~~ }",
             "",
             paste(" ~Make other sections like Warning with",
                   "\\section{Warning }{....} ~"),
             ""),
             seealso = paste("\\seealso{ ~~objects to See Also as",
             "\\code{\\link{~~fun~~}}, ~~~ }"),
             examples = c("\\examples{",
             "##---- Should be DIRECTLY executable !! ----",
             "##-- ==>  Define data, use random,",
             "##--	or do  help(data=index)  for the standard data sets.",
             "",
             "## The function is currently defined as",
             x.def,
             "}"),
             keywords = c(paste("\\keyword{ ~kwd1 }% at least one,",
             "from doc/KEYWORDS"),
             "\\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line"))

    Rdtxt$arguments <- if(length(s))
        c("\\arguments{",
          paste0("  \\item{", arg.n, "}{",
                 " ~~Describe \\code{", arg.n, "} here~~ }"),
          "}")
    else
        NULL

    if(is.na(filename)) return(Rdtxt)

    cat(unlist(Rdtxt), file = filename, sep = "\n")
    cat(strwrap(c(paste("Created file named",
                        sQuote(filename),
                        "in the current directory."),
                  paste("Edit the file and move it to the appropriate",
                        "directory."))),
        sep = "\n")

    invisible(filename)
}

prompt.data.frame <-
function(object, filename = NULL, name = NULL, ...)
{
    paste0 <- function(...) paste(..., sep = "")

    if(missing(name))
        name <-
            if(is.character(object))
                object
            else {
                name <- substitute(object)
                if(is.language(name) && !is.name(name))
                    name <- eval(name)
                as.character(name)
            }
    if(is.null(filename))
        filename <- paste0(name, ".Rd")

    x <- get(name, envir = parent.frame())

    ## <FIXME>
    ## Always assume data set ???
    promptData(x, filename = filename, name = name)
    ## </FIXME>
}

promptData <-
function(object, filename = NULL, name = NULL)
{
    paste0 <- function(...) paste(..., sep = "")

    if(missing(name))
        name <-
            if(is.character(object))
                object
            else {
                name <- substitute(object)
                if(is.language(name) && !is.name(name))
                    name <- eval(name)
                as.character(name)
            }
    if(is.null(filename))
        filename <- paste0(name, ".Rd")
    
    ## Better than get(); works when called in fun :
    x <- get(name, envir = parent.frame())

    ## Construct the format.
    if(is.data.frame(x)) {
        fmt <- c("\\format{",
                 paste("  A data frame with",
                       nrow(x),
                       "observations on the following",
                       ifelse(ncol(x) == 1,
                              "variable.",
                              paste(ncol(x), "variables."))),
                 "  \\describe{")
        for(i in names(x)) {
            xi <- x[[i]]
            fmt <-
                c(fmt,
                  paste0("    \\item{", i, "}{",
                         if(inherits(xi, "ordered")) {
                             paste("an", data.class(xi),
                                   "factor with levels",
                                   paste0("\\code{", levels(xi), "}",
                                          collapse = " < "),
                                   collapse = " ")
                         } else if(inherits(xi, "factor")) {
                             paste("a factor with levels",
                                   paste0("\\code{", levels(xi), "}",
                                          collapse = " "),
                                   collapse = " ")
                         } else if(is.vector(xi)) {
                             paste("a", data.class(xi), "vector")
                         } else if(is.matrix(xi)) {
                             paste("a matrix with", ncol(xi), "columns")
                         } else {
                             paste("a", data.class(xi))
                         },
                         "}"))
        }
        fmt <- c(fmt, "  }", "}")
    }
    else {
        tf <- tempfile(); on.exit(unlink(tf))
        sink(tf) ; str(object) ; sink()
        fmt <- c("\\format{",
                 "  The format is:",
                 scan(tf, "", quiet = !getOption("verbose"), sep = "\n"),
                 "}")
    }

    Rdtxt <-
        list(name = paste0("\\name{", name, "}"),
             aliases = paste0("\\alias{", name, "}"),
             docType = "\\docType{data}",
             title = "\\title{ ~~ data name/kind ... ~~}",
             description = c("\\description{",
             "  ~~ A concise (1-5 lines) description of the dataset. ~~",
             "}"),
             usage = paste0("\\usage{data(", name, ")}"),
             format = fmt,
             details = c("\\details{",
             paste("  ~~ If necessary, more details than the",
                   "__description__ above ~~"),
             "}"),
             source = c("\\source{",
             paste("  ~~ reference to a publication or URL",
                   "from which the data were obtained ~~"),
             "}"),
             references = c("\\references{",
             "  ~~ possibly secondary sources and usages ~~",
             "}"),
             examples = c("\\examples{",
             paste0("data(", name, ")"),
             paste0("## maybe str(", name, ") ; plot(", name, ") ..."),
             "}"),
             keywords = "\\keyword{datasets}")

    if(is.na(filename)) return(Rdtxt)

    cat(unlist(Rdtxt), file = filename, sep = "\n")
    cat(strwrap(c(paste("Created file named",
                        sQuote(filename),
                        "in the current directory."),
                  paste("Edit the file and move it to the appropriate",
                        "directory."))),
        sep = "\n")
    
    invisible(filename)
}
qqnorm <- function(y, ...) UseMethod("qqnorm")

qqnorm.default <-
    function(y, ylim, main="Normal Q-Q Plot",
	     xlab="Theoretical Quantiles", ylab="Sample Quantiles",
	     plot.it=TRUE, datax = FALSE, ...)
{
    if(has.na <- any(ina <- is.na(y))) { ## keep NA's in proper places
        yN <- y
        y <- y[!ina]
    }
    if(0 == (n <- length(y)))
        stop("y is empty or has only NAs")
    if (plot.it && missing(ylim))
        ylim <- range(y)
    x <- qnorm(ppoints(n))[order(order(y))]
    if(has.na) {
        y <- x; x <- yN; x[!ina] <- y
        y <- yN
    }
    if(plot.it)
        if (datax)
            plot(y, x, main= main, xlab= ylab, ylab=xlab, xlim = ylim, ...)
        else
            plot(x, y, main= main, xlab= xlab, ylab= ylab, ylim= ylim, ...)
    invisible(if(datax) list(x = y, y = x) else list(x = x, y = y))
}

## Splus also has qqnorm.aov(), qqnorm.aovlist(), qqnorm.maov() ...

qqline <- function(y, datax = FALSE, ...)
{
    y <- quantile(y[!is.na(y)],c(0.25, 0.75))
    x <- qnorm(c(0.25, 0.75))
    if (datax) {
        slope <- diff(x)/diff(y)
        int <- x[1] - slope*y[1]
    } else {
        slope <- diff(y)/diff(x)
        int <- y[1]-slope*x[1]
    }
    abline(int, slope, ...)
}
qqplot <- function(x, y, plot.it = TRUE, xlab = deparse(substitute(x)),
		   ylab = deparse(substitute(y)), ...)
{
    sx<-sort(x)
    sy<-sort(y)
    lenx<-length(sx)
    leny<-length(sy)
    if( leny < lenx )
	sx<-approx(1:lenx, sx, n=leny)$y
    if( leny > lenx )
	sy<-approx(1:leny, sy, n=lenx)$y
    if(plot.it)
	plot(sx, sy, xlab = xlab, ylab = ylab, ...)
    invisible(list(x = sx, y = sy))
}
#is.qr <- function(x) !is.null(x$qr) && !is.null(x$rank) && !is.null(x$qraux)

is.qr <- function(x) inherits(x, "qr")

qr <- function(x, tol = 1e-07, LAPACK = FALSE)
{
    x <- as.matrix(x)
    if(is.complex(x))
        return(structure(.Call("La_zgeqp3", x, PACKAGE = "base"), class="qr"))
    if(LAPACK) {
        res <- .Call("La_dgeqp3", x, PACKAGE = "base")
        attr(res, "useLAPACK") <- TRUE
        class(res) <- "qr"
        return(res)
    }

    p <- ncol(x) # guaranteed to be integer
    n <- nrow(x)
    if(!is.double(x))
	storage.mode(x) <- "double"
    res <- .Fortran("dqrdc2",
	     qr=x,
	     n,
	     n,
	     p,
	     as.double(tol),
	     rank=integer(1),
	     qraux = double(p),
	     pivot = as.integer(1:p),
	     double(2*p),
	     PACKAGE="base")[c(1,6,7,8)]# c("qr", "rank", "qraux", "pivot")
    class(res) <- "qr"
    res
}

qr.coef <- function(qr, y)
{
    if( !is.qr(qr) )
	stop("first argument must be a QR decomposition")
    n <- nrow(qr$qr)
    p <- ncol(qr$qr)
    k <- as.integer(qr$rank)
    im <- is.matrix(y)
    if (!im) y <- as.matrix(y)
    ny <- ncol(y)
    if (p==0) return( if (im) matrix(0,p,ny) else numeric(0) )
    if(is.complex(qr$qr)) {
	if(!is.complex(y)) y[] <- as.complex(y)
	coef <- matrix(as.complex(NA), nr=p, nc=ny)
	coef[qr$pivot,] <- .Call("qr_coef_cmplx", qr, y, PACKAGE = "base")
	return(if(im) coef else c(coef))
    }
    ## else {not complex} :
    a <- attr(qr, "useLAPACK")
    if(!is.null(a) && is.logical(a) && a) {
	coef <- matrix(as.double(NA), nr=p, nc=ny)
	coef[qr$pivot,] <- .Call("qr_coef_real", qr, y, PACKAGE = "base")
	return(if(im) coef else c(coef))
    }
    if (k==0) return( if (im) matrix(NA,p,ny) else rep(NA,p))

    storage.mode(y) <- "double"
    if( nrow(y) != n )
	stop("qr and y must have the same number of rows")
    z <- .Fortran("dqrcf",
		  as.double(qr$qr),
		  n, k,
		  as.double(qr$qraux),
		  y,
		  ny,
		  coef=matrix(0,nr=k,nc=ny),
		  info=integer(1),
		  NAOK = TRUE, PACKAGE="base")[c("coef","info")]
    if(z$info != 0) stop("exact singularity in qr.coef")
    if(k < p) {
	coef <- matrix(as.double(NA), nr=p, nc=ny)
	coef[qr$pivot[1:k],] <- z$coef
    }
    else coef <- z$coef

    if(!is.null(nam <- colnames(qr$qr)))
	rownames(coef) <- nam
    if(im && !is.null(nam <- colnames(y)))
       colnames(coef) <- nam

    if(im) coef else drop(coef)
}

qr.qy <- function(qr, y)
{
    if(!is.qr(qr)) stop("argument is not a QR decomposition")
    if(is.complex(qr$qr)) {
        y <- as.matrix(y)
        if(!is.complex(y)) y[] <- as.complex(y)
        return(.Call("qr_qy_cmplx", qr, y, 0, PACKAGE = "base"))
    }
    a <- attr(qr, "useLAPACK")
    if(!is.null(a) && is.logical(a) && a)
        return(.Call("qr_qy_real", qr, as.matrix(y), 0, PACKAGE = "base"))
    n <- nrow(qr$qr)
#    p <- ncol(qr$qr)
    k <- as.integer(qr$rank)
    ny <- NCOL(y)
    storage.mode(y) <- "double"
    if(NROW(y) != n)
	stop("qr and y must have the same number of rows")
    .Fortran("dqrqy",
	     as.double(qr$qr),
	     n, k,
	     as.double(qr$qraux),
	     y,
	     ny,
	     qy = y,# incl. {dim}names
	     PACKAGE="base")$qy
}

qr.qty <- function(qr, y)
{
    if(!is.qr(qr)) stop("argument is not a QR decomposition")
    if(is.complex(qr$qr)){
        y <- as.matrix(y)
        if(!is.complex(y)) y[] <- as.complex(y)
        return(.Call("qr_qy_cmplx", qr, y, 1, PACKAGE = "base"))
    }
    a <- attr(qr, "useLAPACK")
    if(!is.null(a) && is.logical(a) && a)
        return(.Call("qr_qy_real", qr, as.matrix(y), 1, PACKAGE = "base"))

    n <- nrow(qr$qr)
#    p <- ncol(qr$qr)
    k <- as.integer(qr$rank)
    ny <- NCOL(y)
    if(NROW(y) != n)
	stop("qr and y must have the same number of rows")
    storage.mode(y) <- "double"
    .Fortran("dqrqty",
	     as.double(qr$qr),
	     n, k,
	     as.double(qr$qraux),
	     y,
	     ny,
	     qty = y,# incl. {dim}names
             PACKAGE = "base")$qty
}

qr.resid <- function(qr, y)
{
    if(!is.qr(qr)) stop("argument is not a QR decomposition")
    if(is.complex(qr$qr)) stop("implemented for complex qr")
    a <- attr(qr, "useLAPACK")
    if(!is.null(a) && is.logical(a) && a)
        stop("not supported for LAPACK QR")
    k <- as.integer(qr$rank)
    if (k==0) return(y)
    n <- nrow(qr$qr)
#    p <- ncol(qr$qr)
    ny <- NCOL(y)
    if( NROW(y) != n )
	stop("qr and y must have the same number of rows")
    storage.mode(y) <- "double"
    .Fortran("dqrrsd",
	     as.double(qr$qr),	     n, k,
	     as.double(qr$qraux),
             y,
	     ny,
	     rsd = y,# incl. {dim}names
	     PACKAGE="base")$rsd
}

qr.fitted <- function(qr, y, k=qr$rank)
{
    if(!is.qr(qr)) stop("argument is not a QR decomposition")
    if(is.complex(qr$qr)) stop("implemented for complex qr")
    a <- attr(qr, "useLAPACK")
    if(!is.null(a) && is.logical(a) && a)
        stop("not supported for LAPACK QR")
    n <- nrow(qr$qr)
    k <- as.integer(k)
    if(k > qr$rank) stop("k is too large")
    ny <- NCOL(y)
    if( NROW(y) != n )
	stop("qr and y must have the same number of rows")
    storage.mode(y) <- "double"
    .Fortran("dqrxb",
	     as.double(qr$qr),
	     n, k,
	     as.double(qr$qraux),
	     y,
	     ny,
	     xb = (yy <- y),# incl. {dim}names
             DUP=FALSE, PACKAGE="base")$xb
}

## qr.solve is defined in  ./solve.R

##---- The next three are from Doug Bates ('st849'):
qr.Q <- function (qr, complete = FALSE,
		  Dvec = rep(if (cmplx) 1 + 0i else 1,
		  if (complete) dqr[1] else min(dqr)))
{
    if(!is.qr(qr)) stop("argument is not a QR decomposition")
    dqr <- dim(qr$qr)
    cmplx <- mode(qr$qr) == "complex"
    D <-
	if (complete) diag(Dvec, dqr[1])
	else {
	    ncols <- min(dqr)
	    diag(Dvec[1:ncols], nrow = dqr[1], ncol = ncols)
	}
    qr.qy(qr, D)
}

qr.R <- function (qr, complete = FALSE)
{
    if(!is.qr(qr)) stop("argument is not a QR decomposition")
    R <- qr$qr
    if (!complete)
	R <- R[seq(min(dim(R))), , drop = FALSE]
    R[row(R) > col(R)] <- 0
    R
}

qr.X <- function (qr, complete = FALSE,
		  ncol = if (complete) nrow(R) else min(dim(R)))
{
    if(!is.qr(qr)) stop("argument is not a QR decomposition")
    pivoted <- !identical(qr$pivot, seq(along=qr$pivot))
    R <- qr.R(qr, complete = TRUE)
    if(pivoted && ncol < length(qr$pivot))
        stop("need larger value of ncol as pivoting occurred")
    cmplx <- mode(R) == "complex"
    p <- dim(R)[2]
    if (ncol < p)
	R <- R[, 1:ncol, drop = FALSE]
    else if (ncol > p) {
	tmp <- diag(if (!cmplx) 1 else 1 + 0i, nrow(R), ncol)
	tmp[, 1:p] <- R
	R <- tmp
    }
    res <- qr.qy(qr, R)
    if(pivoted) res[, qr$pivot] <- res[, seq(along=qr$pivot)]
    res
}
quantile <- function(x, ...) UseMethod("quantile")

quantile.default <-
    function(x, probs = seq(0, 1, 0.25), na.rm = FALSE, names = TRUE, ...)
{
    if (na.rm)
	x <- x[!is.na(x)]
    else if (any(is.na(x)))
	stop("Missing values and NaN's not allowed if `na.rm' is FALSE")
    if (any((p.ok <- !is.na(probs)) & (probs < 0 | probs > 1)))
	stop("probs outside [0,1]")
    n <- length(x)
    if(na.p <- any(!p.ok)) { # set aside NA & NaN
        o.pr <- probs
        probs <- probs[p.ok]
    }
    np <- length(probs)
    if(n > 0 && np > 0) {
	index <- 1 + (n - 1) * probs
	lo <- floor(index)
	hi <- ceiling(index)
	x <- sort(x, partial = unique(c(lo, hi)))
	i <- index > lo
	qs <- x[lo]
        i <- seq(along=i)[i & !is.na(i)]
        .minus <- function(x,y) ifelse(x == y, 0, x - y)# ok for Inf - Inf
        qs[i] <- qs[i] + .minus(x[hi[i]], x[lo[i]]) * (index[i] - lo[i])
    }
    else {
	qs <- rep(as.numeric(NA), np)
    }
    if(names && np > 0) {
	dig <- max(2, getOption("digits"))
	names(qs) <- paste(## formatC is slow for long probs
			   if(np < 100)
			   formatC(100*probs, format="fg", wid = 1, digits=dig)
			   else format(100 * probs, trim=TRUE, digits=dig),
			   "%", sep = "")
    }
    if(na.p) { # do this more elegantly (?!)
        o.pr[p.ok] <- qs
        names(o.pr) <- rep("", length(o.pr)) # suppress <NA> names
        names(o.pr)[p.ok] <- names(qs)
        o.pr
    } else qs
}

IQR <- function (x, na.rm = FALSE)
    diff(quantile(as.numeric(x), c(0.25, 0.75), na.rm = na.rm, names = FALSE))
"?" <- function(e1, e2)
{
    e1Expr <- substitute(e1)
    if(missing(e2)) {
        if(is.call(e1Expr))
            return(.helpForCall(e1Expr, parent.frame()))
        if(is.name(e1Expr))
            e1 <- as.character(e1Expr)
        eval(substitute(help(TOPIC), list(TOPIC = e1)))
    }
  else {
      ## interpret e1 as a type, but to allow customization, do NOT force
      ## arbitrary expressions to be single character strings (so that methods
      ## can be defined for topicName).
        if(is.name(e1Expr))
            e1 <- as.character(e1Expr)
      e2Expr <- substitute(e2)
    if(is.name(e2Expr))
      e2 <- as.character(e2Expr)
        else if(is.call(e2Expr) && identical(e1, "method"))
            return(.helpForCall(e2Expr, parent.frame(), FALSE))
    topic <- topicName(e1, e2)
    doHelp <- .tryHelp(topic)
    if(inherits(doHelp, "try-error")) {
        stop(paste("no documentation of type \"", e1,
                   "\" and topic \"", e2,
                   "\" (or error in processing help)", sep=""))
    }
  }
}

topicName <- function(type, topic) {
    if((length(type) == 0) || (length(topic) == 0))
        character(0)
    else
        paste(paste(topic, collapse = ","), type, sep = "-")
}

.helpForCall <- function(expr, envir, doEval = TRUE) {
    f <- expr[[1]] # the function specifier
    if(is.name(f))
        f <- as.character(f)
    if(!.isMethodsDispatchOn() || !isGeneric(f)){
        if(!is.character(f) || length(f) != 1)
            stop("The object of class \"", class(f), "\" in the function call \"",
                 deparse(expr), "\"could not be used as a documentation topic")
        h <- .tryHelp(f)
        if(inherits(h, "try-error"))
            stop("No methods for \"", f, "\" and no documentation for it as a function")
    }
    else {
        ## allow generic function objects or names
        if(is(f, "genericFunction")) {
            fdef <- f
            f <- fdef@generic
        }
        else
            fdef <- getGeneric(f)
        call <- match.call(fdef, expr)
        ## make the signature
        sigNames <- fdef@signature
        sigClasses <- rep("missing", length(sigNames))
        names(sigClasses) <- sigNames
        for(arg in sigNames) {
            argExpr <- elNamed(call, arg)
            if(!is.null(argExpr)) {
                simple <- (is.character(argExpr) || is.name(argExpr))
                ## TODO:  ideally, if doEval is TRUE, we would like to create
                ## the same context used by applyClosure in eval.c, but then
                ## skip the actual evaluation of the body.  If we could create
                ## this environment then passing it to selectMethod is closer to
                ## the semantics of the "real" function call than the code below.
                ## But, seems to need a change to eval.c and a flag to the evaluator.
                if(doEval || !simple) {
                    argVal <- try(eval(argExpr, envir))
                    if(is(argVal, "try-error"))
                        stop("Error in trying to evaluate the expression for argument \"",
                             arg, "\" (", deparse(argExpr), ")")
                    elNamed(sigClasses, arg) <- class(argVal)
                }
                else
                    elNamed(sigClasses, arg) <- as.character(argExpr)
            }
        }
        method <- selectMethod(f, sigClasses, optional=TRUE, fdef = fdef)
        if(is(method, "MethodDefinition"))
            sigClasses <- method@defined
        else
            warning("No method defined for function \"", f,
                    "\" and signature ",
                    paste(sigNames, " = \"", sigClasses, "\"", sep = "", collapse = ", "))
        topic <- topicName("method", c(f,sigClasses))
        h <- .tryHelp(topic)
        if(is(h, "try-error"))
            stop("No documentation for function \"", f,
                 "\" and signature ",
                 paste(sigNames, " = \"", sigClasses, "\"", sep = "", collapse = ", "))
    }
}

.tryHelp <- function(topic) {
    opts <- options(error= function()TRUE, show.error.messages = FALSE)
    on.exit(options(opts))
    try(do.call("help", list(topic)))
}

quit <- function(save = "default", status=0, runLast=TRUE)
    .Internal(quit(save, status, runLast))
q <- quit
range <- function(..., na.rm = FALSE)
    .Internal(range(..., na.rm = na.rm))

range.default <- function(..., na.rm = FALSE, finite = FALSE) {
    x <- c(..., recursive = TRUE)
    if(finite) x <- x[is.finite(x)]
    else if(na.rm) x <- x[!is.na(x)]
    c(min(x), max(x)) # even if x is empty from 1.5.0
}
rank <- function(x, na.last = TRUE, ties.method=c("average", "first", "random"))
{
    nas <- is.na(x)
    ties.method <- match.arg(ties.method)
    y <- switch(ties.method,
                "average" = .Internal(rank(   x[!nas])),
                "first" = sort.list(sort.list(x[!nas])),
                "random" = sort.list(order(   x[!nas], runif(sum(!nas)))))
    if(!is.na(na.last) && any(nas)) {
	## the internal code has ranks in [1, length(y)]
	storage.mode(x) <- "double"
	NAkeep <- (na.last == "keep")
	if(NAkeep || na.last) {
	    x[!nas] <- y
	    if(!NAkeep) x[nas] <- (length(y) + 1:1):length(x)
	} else {
	    len <- sum(nas)
	    x[!nas] <- y + len
	    x[nas] <- 1 : len
	}
	y <- x
    } else names(y) <- names(x)[!nas]
    y
}
read.fwf <-
function(file, widths, header = FALSE, sep = "\t", as.is = FALSE,
         skip = 0, row.names, col.names, n = -1, ...)
{
    doone <- function(x) {
        x <- substring(x, first, last)
        x[nchar(x)==0] <- as.character(NA)
        x
    }
    FILE <- tempfile("Rfwf.")
    on.exit(unlink(FILE))
    raw <- readLines(file, n=n)
    st <- c(1, 1+cumsum(widths))
    first <- st[-length(st)]
    last <- cumsum(widths)
    cat(file = FILE, sapply(raw, doone),
        sep = c(rep(sep, length = length(widths)-1), "\n"))
    read.table(file = FILE, header = header, sep = sep, as.is = as.is,
	       skip = skip, row.names = row.names, col.names =
               col.names, quote="", ...)
}
url.show <-
    function (url,  title = url, file = tempfile(),
              delete.file = TRUE, method, ...)
{
    if (download.file(url, dest = file, method = method) != 0)
        stop("transfer failure")
    file.show(file, delete.file = delete.file, title = title, ...)
}
count.fields <- function(file, sep = "", quote = "\"'", skip = 0,
                         blank.lines.skip = TRUE, comment.char = "#")
{
    if(is.character(file)) {
        file <- file(file)
        on.exit(close(file))
    }
    if(!inherits(file, "connection"))
        stop("argument `file' must be a character string or connection")
    .Internal(count.fields(file, sep, quote, skip, blank.lines.skip,
                           comment.char))
}


type.convert <- function(x, na.strings = "NA", as.is = FALSE, dec = ".")
    .Internal(type.convert(x, na.strings, as.is, dec))


read.table <-
    function (file, header = FALSE, sep = "", quote = "\"'", dec = ".",
              row.names, col.names, as.is = FALSE,
	      na.strings = "NA", colClasses = NA,
              nrows = -1, skip = 0,
              check.names = TRUE, fill = !blank.lines.skip,
              strip.white = FALSE, blank.lines.skip = TRUE,
              comment.char = "#")
{
    if(is.character(file)) {
        file <- file(file, "r")
        on.exit(close(file))
    }
    if(!inherits(file, "connection"))
        stop("argument `file' must be a character string or connection")
    if(!isOpen(file)) {
        open(file, "r")
        on.exit(close(file))
    }

    if(skip > 0) readLines(file, skip)
    ## read a few lines to determine header, no of cols.
#    nlines <- 0
#    lines <- NULL
#     while(nlines < 5) {
#         ## read up to five non-blank and non-comment lines.
#         line <- readLines(file, 1, ok = TRUE)
#         if(length(line) == 0) break
#         if(blank.lines.skip && length(grep("^[ \\t]*$", line))) next
#         if(length(comment.char) && nchar(comment.char)) {
#             pattern <- paste("^[ \\t]*", substring(comment.char,1,1),
#                              sep ="")
#             if(length(grep(pattern, line))) next
#         }
#         lines <- c(lines, line)
#     }

    nlines <- if (nrows < 0) 5 else min(5, (header + nrows))

    lines <- .Internal(readTableHead(file, nlines, comment.char,
                                     blank.lines.skip))
    nlines <- length(lines)
    if(!nlines) {
        if(missing(col.names))
            stop("no lines available in input")
        else {
            tmp <- vector("list", length(col.names))
            names(tmp) <- col.names
            class(tmp) <- "data.frame"
            return(tmp)
        }
    }
    if(all(nchar(lines) == 0)) stop("empty beginning of file")
    pushBack(c(lines, lines), file)
    first <- scan(file, what = "", sep = sep, quote = quote,
                  nlines = 1, quiet = TRUE, skip = 0,
                  strip.white = TRUE,
                  blank.lines.skip = blank.lines.skip,
                  comment.char = comment.char)
    col1 <- if(missing(col.names)) length(first) else length(col.names)
    col <- numeric(nlines - 1)
    if (nlines > 1)
        for (i in seq(along=col))
            col[i] <- length(scan(file, what = "", sep = sep,
                                  quote = quote,
                                  nlines = 1, quiet = TRUE, skip = 0,
                                  strip.white = strip.white,
                                  blank.lines.skip = blank.lines.skip,
                                  comment.char = comment.char))
    cols <- max(col1, col)

    ##	basic column counting and header determination;
    ##	rlabp (logical) := it looks like we have column names

    rlabp <- (cols - col1) == 1
    if(rlabp && missing(header))
	header <- TRUE
    if(!header) rlabp <- FALSE

    if (header) {
        readLines(file, 1) # skip over header
        if(missing(col.names)) col.names <- first
        else if(length(first) != length(col.names))
            warning("header and `col.names' are of different lengths")

    } else if (missing(col.names))
	col.names <- paste("V", 1:cols, sep = "")
    if(length(col.names) + rlabp < cols)
        stop("more columns than column names")
    if(fill && length(col.names) > cols)
        cols <- length(col.names)
    if(!fill && cols > 0 && length(col.names) > cols)
        stop("more column names than columns")
    if(cols == 0) stop("first five rows are empty: giving up")


    if(check.names) col.names <- make.names(col.names, unique = TRUE)
    if (rlabp) col.names <- c("row.names", col.names)

    if(length(colClasses) < cols) colClasses <- rep(colClasses, len=cols)

    ##	set up for the scan of the file.
    ##	we read unknown values as character strings and convert later.

    what <- rep(list(""), cols)
    names(what) <- col.names

    colClasses[colClasses %in% c("real", "double")] <- "numeric"
    known <- colClasses %in%
                c("logical", "integer", "numeric", "complex", "character")
    what[known] <- sapply(colClasses[known], do.call, list(0))

    data <- scan(file = file, what = what, sep = sep, quote = quote,
                 dec = dec, nmax = nrows, skip = 0,
		 na.strings = na.strings, quiet = TRUE, fill = fill,
                 strip.white = strip.white,
                 blank.lines.skip = blank.lines.skip, multi.line = FALSE,
                 comment.char = comment.char)

    nlines <- length(data[[1]])

    ##	now we have the data;
    ##	convert to numeric or factor variables
    ##	(depending on the specified value of "as.is").
    ##	we do this here so that columns match up

    if(cols != length(data)) { # this should never happen
	warning(paste("cols =", cols," != length(data) =", length(data)))
	cols <- length(data)
    }

    if(is.logical(as.is)) {
	as.is <- rep(as.is, length=cols)
    } else if(is.numeric(as.is)) {
	if(any(as.is < 1 | as.is > cols))
	    stop("invalid numeric as.is expression")
	i <- rep(FALSE, cols)
	i[as.is] <- TRUE
	as.is <- i
    } else if(is.character(as.is)) {
        i <- match(as.is, col.names, 0)
        if(any(i <= 0))
            warning("not all columns named in as.is exist")
        i <- i[i > 0]
        as.is <- rep(FALSE, cols)
        as.is[i] <- TRUE
    } else if (length(as.is) != cols)
	stop(paste("as.is has the wrong length",
		   length(as.is),"!= cols =", cols))
    for (i in 1:cols) {
#        if(known[i] || as.is[i]) next
        if(known[i]) next
        data[[i]] <-
            if (!is.na(colClasses[i])) as(data[[i]], colClasses[i])
            else type.convert(data[[i]], as.is = as.is[i], dec = dec,
                              na.strings = character(0))
        ## as na.strings have already be converted to <NA>
    }

    ##	now determine row names

    if (missing(row.names)) {
	if (rlabp) {
	    row.names <- data[[1]]
	    data <- data[-1]
	}
	else row.names <- as.character(seq(len=nlines))
    } else if (is.null(row.names)) {
	row.names <- as.character(seq(len=nlines))
    } else if (is.character(row.names)) {
	if (length(row.names) == 1) {
	    rowvar <- (1:cols)[match(col.names, row.names, 0) == 1]
	    row.names <- data[[rowvar]]
	    data <- data[-rowvar]
	}
    } else if (is.numeric(row.names) && length(row.names) == 1) {
	rlabp <- row.names
	row.names <- data[[rlabp]]
	data <- data[-rlabp]
    } else stop("invalid row.names specification")

    ##	this is extremely underhanded
    ##	we should use the constructor function ...
    ##	don't try this at home kids

    class(data) <- "data.frame"
    row.names(data) <- row.names
    data
}

read.csv <-
    function (file, header = TRUE, sep = ",", quote="\"", dec=".",
              fill = TRUE, ...)
    read.table(file = file, header = header, sep = sep,
               quote = quote, dec = dec, fill = fill, ...)

read.csv2 <-
    function (file, header = TRUE, sep = ";", quote="\"", dec=",",
              fill = TRUE, ...)
    read.table(file = file, header = header, sep = sep,
               quote = quote, dec = dec, fill = fill, ...)

read.delim <-
    function (file, header = TRUE, sep = "\t", quote="\"", dec=".",
              fill = TRUE, ...)
    read.table(file = file, header = header, sep = sep,
               quote = quote, dec = dec, fill = fill, ...)

read.delim2 <-
    function (file, header = TRUE, sep = "\t", quote="\"", dec=",",
              fill = TRUE, ...)
    read.table(file = file, header = header, sep = sep,
               quote = quote, dec = dec, fill = fill, ...)

recordPlot <- function()
{
    if(dev.cur() == 1)
        stop("no current device to record from")
    res <- .Internal(getSnapshot())
    class(res) <- "recordedplot"
    res
}

replayPlot <- function(x)
{
    if(dev.cur() == 1)
        stop("no current device to replay to")
    if(class(x) != "recordedplot")
        stop("argument is not of class \"recordedplot\"")
    plot.new()
    nm <- names(x)
    if(length(nm) == 2 && nm == c("displaylist", "gpar")) {
        ## pre-1.4.0 save
        .Internal(setGPar(x[[2]]))
        .Internal(playDL(x[[1]]))
    } else .Internal(playSnapshot(x))
}

print.recordedplot <- function(x, ...)
{
    replayPlot(x)
    invisible(x)
}

rect <-
  function (xleft, ybottom, xright, ytop, density = NULL, angle = 45,
            col = NULL, border = NULL,
            lty = NULL, lwd = par("lwd"), xpd = NULL, ...)
{
    if (is.numeric(density) && all(is.na(density) | density < 0))
        density <- NULL
    if (!is.null(density) && !is.null(angle)) {
        if (is.logical(border)) {
            if (border) border <- col
            else border <- NA
        }
        n <- range(length(xleft), length(xright),
                   length(ybottom), length(ytop))
        if (n[1] == 0)
            stop("invalid rectangle specification")
        n <- n[2]
        x <- rbind(rep.int(NA, n), xleft, xright, xright, xleft)[-1]
        y <- rbind(rep.int(NA, n), ybottom, ybottom, ytop, ytop)[-1]
        polygon(x, y, col=col, border=border, lty=lty, lwd=lwd, xpd=xpd,
                density=density, angle=angle, ...)
    }
    else
        .Internal(rect(as.double(xleft), as.double(ybottom),
                       as.double(xright), as.double(ytop),
                       col = col, border = border,
                       lty = lty, lwd = lwd, xpd = xpd, ...))
}
relevel <- function(x, ref, ...) UseMethod("relevel")

relevel.default <- function(x, ref, ...)
    stop("relevel only for factors")

relevel.ordered <- function(x, ref, ...)
    stop("relevel only for factors")

relevel.factor <- function(x, ref, ...)
{
    lev <- levels(x)
    if(is.character(ref))
        ref <- match(ref, lev)
    if(is.na(ref))
        stop("ref must be an existing level")
    nlev <- length(lev)
    if(ref < 1 || ref > nlev)
        stop(paste("ref =", ref, "must be in 1 :", nlev))
    factor(x, levels = lev[c(ref, seq(along=lev)[-ref])])
}
rep <- function(x, times, ...) UseMethod("rep")

rep.default <- function(x, times, length.out, each, ...)
{
    if (length(x) == 0) return(x)
    if (!missing(each)) {
        x <- .Internal(rep(x, .Internal(rep(each, length(x)))))
        if(missing(length.out) && missing(times)) return(x)
        if(missing(times)) times <- 1
    }
    if (missing(times))
	times <- ceiling(length.out/length(x))
    r <- .Internal(rep(x, times))
    if(!is.null(nm <- names(x))) names(r) <- .Internal(rep(nm, times))
    if (!missing(length.out))
	return(r[if(length.out > 0) 1:length.out else integer(0)])
    return(r)
}

rep.int <- function(x, times) .Internal(rep(x, times))
replace <-
    function (x, list, values)
{
    x[list] <- values
    x
}
replicate <- function(n, expr, simplify = TRUE) 
        sapply(integer(n), 
           eval.parent(substitute(function(x)expr)), simplify = simplify)
reshape <-
    function(data, varying= NULL, v.names= NULL, timevar = "time", idvar = "id",
             ids = 1:NROW(data), times = seq(length = length(varying[[1]])),
             drop = NULL, direction, new.row.names = NULL,
             split = list(regexp= "\\.", include= FALSE))
{
    guess <- function(nms,re = split$regexp,drop = !split$include) {
        if (is.numeric(nms))
            nms <- names(data)[nms]
        if (drop)
            nn <- do.call("rbind",strsplit(nms,re))
        else
            nn <- cbind(substr(nms,1,regexpr(re,nms)),
                        substr(nms,regexpr(re,nms)+1,nchar(nms)))
        v.names <- tapply(nms,nn[,1],c)
        varying <- unique(nn[,1])
        times <- sort(unique(nn[,2]))
        attr(v.names,"v.names") <- varying
        tt <- as.numeric(times)
        if (is.factor(tt)) tt <- times
        attr(v.names,"times") <- tt
        v.names
    }

    reshapeLong <-
        function(data,varying,v.names = NULL,timevar,idvar,
                 ids = 1:NROW(data), times,drop = NULL,new.row.names = NULL) {

        if (is.matrix(varying))
            varying <- tapply(varying,row(varying),list)
        ll <- unlist(lapply(varying,length))
        if (any(ll != ll[1])) stop("'varying' arguments must be the same length")
        if (ll[1] != length(times)) stop("'times' is wrong length")

        if (!is.null(drop)) {
            if (is.character(drop))
                drop <- names(data) %in% drop
            data <- data[,if (is.logical(drop)) !drop else -drop, drop = FALSE]
        }
        d <- data
        all.varying <- unlist(varying)
        d <- d[,!(names(data) %in% all.varying),drop = FALSE]
        d[,timevar] <- times[1]

        if (is.null(v.names))
            v.names <- unlist(lapply(varying,function(x) x[1]))

        for(i in 1:length(v.names))
            d[, v.names[i]] <- data[, varying[[i]][1] ]

        if (!(idvar %in% names(data)))
            d[,idvar] <- ids

        rval <- d

        if (length(times) == 1) return(rval)
        if (is.null(new.row.names))
            row.names(rval) <- paste(d[,idvar],times[1],sep = ".")
        else
            row.names(rval) <- new.row.names[1:NROW(rval)]

        for(i in 2:length(times)) {
            d[,timevar] <- times[i]
            for(j in 1:length(v.names))
                d[ ,v.names[j]] <- data[ ,varying[[j]][i]]

            if (is.null(new.row.names))
                row.names(d) <- paste(d[,idvar],times[i],sep = ".")
            else
                row.names(d) <- new.row.names[NROW(rval)+1:NROW(d)]
            rval <- rbind(rval,d)  ##inefficient. So sue me.
        }

        attr(rval,"reshapeLong") <- list(varying = varying,v.names = v.names,
                                         idvar = idvar,timevar = timevar)
        return(rval)
    } ## re..Long()

    reshapeWide <- function(data,timevar,idvar,varying = NULL,v.names = NULL,
                            drop = NULL,new.row.names = NULL) {

        if (!is.null(drop)) {
            if (is.character(drop))
                drop <- names(data) %in% drop
            data <- data[,if (is.logical(drop)) !drop else -drop, drop = FALSE]
        }

        ## times <- sort(unique(data[,timevar]))
        ## varying and times must have the same order
        times <- unique(data[,timevar])
        if (any(is.na(times)))
            warning("There are records with missing times, which will be dropped.")

        if (is.null(v.names))
            v.names <- names(data)[!(names(data) %in% c(timevar,idvar))]

        if (is.null(varying))
            varying <- outer(v.names,times,paste,sep = ".")
        if (is.list(varying))
            varying <- do.call("rbind",varying)

        CHECK <- TRUE
        if (CHECK) {
            keep <- !(names(data) %in% c(timevar,v.names,idvar))
            if(any(keep)) {
                rval <- data[keep]
                tmp <- data[,idvar]
                really.constant <-
                    unlist(lapply(rval,
                                  function(a) all(tapply(a, tmp,
                                                         function(b) length(unique(b)) == 1))))
                if (!all(really.constant))
                    warning("Some constant variables (",
                            paste(names(rval)[!really.constant],collapse = ","),
                            ") are really varying")
            }
        }


        rval <- data[!duplicated(data[,idvar]),
                     !(names(data) %in% c(timevar,v.names)), drop = FALSE]

        for(i in seq(length = length(times))) {
            thistime <- data[data[,timevar] %in% times[i],]
            rval[,varying[,i]] <- thistime[match(rval[,idvar],thistime[,idvar]),
                                           v.names]
        }

        if (!is.null(new.row.names))
            row.names(rval) <- new.row.names

        attr(rval,"reshapeWide") <- list(varying = varying,v.names = v.names,
                                       timevar = timevar,idvar = idvar,times = times)
        rval
    } ## re..Wide()

    ## Begin reshape()
    direction <- match.arg(direction, c("wide", "long"))
    if (!is.null(varying) && is.atomic(varying) && direction == "long")
        varying <- guess(varying)

    switch(direction,
           "wide" =
       {
           if (missing(timevar) && missing(idvar)) {
               back <- attr(data,"reshapeLong")
               if (is.null(back)) stop("No time or id specified")
               reshapeWide(data, idvar = back$idvar, timevar = back$timevar,
                           varying = back$varying, v.names = back$v.names,
                           new.row.names = new.row.names)
           } else {
               reshapeWide(data, idvar = idvar, timevar = timevar,
                           varying = varying, v.names = v.names, drop = drop,
                           new.row.names = new.row.names)
       }

       },
           "long" =
       {
           if (missing(timevar) && missing(idvar) && missing(v.names) && missing(varying)) {
               back <- attr(data,"reshapeWide")
               if (is.null(back)) stop("No time or id specified")
               reshapeLong(data, idvar = back$idvar, timevar = back$timevar,
                           varying = back$varying, v.names = back$v.names,
                           times = back$times)
           } else if (missing(v.names) && !is.null(attr(varying,"v.names"))) {
               reshapeLong(data, idvar = idvar, timevar = timevar, varying = varying,
                           v.names = attr(varying,"v.names"), drop = drop,
                           times = attr(varying,"times"), ids = ids,
                           new.row.names = new.row.names)
           } else {
               reshapeLong(data, idvar = idvar, timevar = timevar,
                           varying = varying, v.names = v.names, drop = drop,
                           times = times, ids = ids, new.row.names = new.row.names)
           }
       })
}
rev <- function(x) UseMethod("rev")

rev.default <- function(x) if (length(x) > 0) x[length(x):1] else x
rle <- function(x) {
    if (!is.vector(x))
        stop("x must be a vector")
    n <- length(x)
    if (n == 0)
        return(list(lengths = integer(0), values = x))
    y <- x[-1] != x[-n]
    i <- c(which(y | is.na(y)), n)
    structure(list(lengths = diff(c(0:0, i)), values = x[i]),
              class = "rle")
}

print.rle <- function(x, digits = getOption("digits"), ...)
{
    if(is.null(digits)) digits <- getOption("digits")
    cat("Run Length Encoding\n  lengths:")
    str(x$lengths)
    cat("  values :")
    str(x$values, digits = digits)
    invisible(x)
}

inverse.rle <- function(x, ...)
{
    if(is.null(le <- x$lengths) ||
       is.null(v  <- x$values) || length(le) != length(v))
        stop("invalid `rle' structure")
    rep(v, le)
}

rm <-
    function (..., list = character(0), pos = -1, envir = as.environment(pos),
              inherits = FALSE)
{
    names <- sapply(match.call(expand.dots=FALSE)$..., as.character)
    if (length(names)==0) names<-character(0)
    list <- .Primitive("c")(list, names)
    .Internal(remove(list, envir, inherits))
}

remove <- rm
rowsum<-function(x,group,reorder=TRUE,...)
    UseMethod("rowsum")

rowsum.default <-function(x,group,reorder=TRUE,...){
    if (!is.numeric(x)) 
        stop("x must be numeric")
    if (length(group) != NROW(x)) 
        stop("Incorrect length for 'group'")
    if (any(is.na(group))) 
        warning("Missing values for 'group'")
    ugroup<-unique(group)
    if (reorder) ugroup<-sort(ugroup,na.last=TRUE)
    
    rval<-.Call("Rrowsum_matrix",x,NCOL(x),group,ugroup,PACKAGE="base")
    
    dimnames(rval)<-list(as.character(ugroup),dimnames(x)[[2]])
    rval
}

rowsum.data.frame<-function(x,group,reorder=TRUE,...){
    if (!is.data.frame(x)) stop("not a data frame") ## make MM happy
    if (length(group) != NROW(x)) 
        stop("Incorrect length for 'group'")
    if (any(is.na(group))) 
        warning("Missing values for 'group'")
    ugroup<-unique(group)
    if (reorder) ugroup<-sort(ugroup,na.last=TRUE)
    
    rval<-.Call("Rrowsum_df",x,NCOL(x),group,ugroup,PACKAGE="base")
    
    as.data.frame(rval,row.names=as.character(ugroup))
}
rug <- function(x, ticksize = 0.03, side = 1, lwd = 0.5, col,
		quiet = getOption("warn") < 0, ...)
{
    x <- as.vector(x)
    ok <- is.finite(x)
    x <- x[ok]
    oldtick <- par(tck = ticksize)
    on.exit(par(oldtick))
    if( !missing(col) ) {
	oldcol <- par(fg = col)
	on.exit(par(oldcol), add=TRUE)
    }
    if(!quiet) {
	u <- par("usr")
	u <- if (side %% 2 == 1) {
	    if(par("xlog")) 10^u[1:2] else u[1:2]
	} else {
	    if(par("ylog")) 10^u[3:4] else u[3:4]
	}
	if(any(x < u[1] | x > u[2]))
	    warning("some values will be clipped")
    }
    axis(side, at = x, lab = FALSE, lwd = lwd, ...)
}
sample <- function(x, size, replace=FALSE, prob=NULL)
{
    if(length(x) == 1 && x >= 1) {
	if(missing(size)) size <- x
	.Internal(sample(x, size, replace, prob))
    }
    else {
	if(missing(size)) size <- length(x)
	x[.Internal(sample(length(x), size, replace, prob))]
    }
}
sapply <- function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE)
{
    FUN <- match.fun(FUN)
    answer <- lapply(as.list(X), FUN, ...)
    if(USE.NAMES && is.character(X) && is.null(names(answer)))
                names(answer) <- X
    if(simplify && length(answer) &&
       length(common.len <- unique(unlist(lapply(answer, length)))) == 1) {
	if(common.len == 1)
	    unlist(answer, recursive = FALSE)
	else if(common.len > 1)
	    array(unlist(answer, recursive = FALSE),
		  dim= c(common.len, length(X)),
		  dimnames= if(!(is.null(n1 <- names(answer[[1]])) &
			         is.null(n2 <- names(answer)))) list(n1,n2))
	else answer
    } else answer
}

scale <- function(x, center = TRUE, scale = TRUE) UseMethod("scale")

scale.default <- function(x, center = TRUE, scale = TRUE)
{
    x <- as.matrix(x)
    nc <- ncol(x)
    if (is.logical(center)) {
	if (center) {
            center <- colMeans(x, na.rm=TRUE)
	    x <- sweep(x, 2, center)
        }
    }
    else if (is.numeric(center) && (length(center) == nc))
	x <- sweep(x, 2, center)
    else
	stop("Length of center must equal the number of columns of x")
    if (is.logical(scale)) {
	if (scale) {
	    f <- function(v) {
		v <- v[!is.na(v)]
		sqrt(sum(v^2) / max(1, length(v) - 1))
	    }
            scale <- apply(x, 2, f)
	    x <- sweep(x, 2, scale, "/")
	}
    }
    else if (is.numeric(scale) && length(scale) == nc)
	x <- sweep(x, 2, scale, "/")
    else
	stop("Length of scale must equal the number of columns of x")
    if(is.numeric(center)) attr(x, "scaled:center") <- center
    if(is.numeric(scale)) attr(x, "scaled:scale") <- scale
    x
}
scan <-
    function(file = "", what = double(0), nmax = -1, n = -1, sep = "",
	     quote = if (sep=="\n") "" else "'\"",
             dec = ".", skip = 0, nlines = 0,
	     na.strings = "NA", flush = FALSE, fill = FALSE,
             strip.white = FALSE, quiet = FALSE, blank.lines.skip = TRUE,
             multi.line = TRUE, comment.char = "")
{
    na.strings <- as.character(na.strings)# allow it to be NULL
    if(!missing(n)) {
        if(missing(nmax))
            nmax <- n / pmax(length(what), 1)
        else
            stop("Either specify `nmax' or `n', but not both.")
    }
    if(is.character(file))
        if(file == "") file <- stdin()
        else {
            file <- file(file, "r")
            on.exit(close(file))
        }
    if(!inherits(file, "connection"))
        stop("argument `file' must be a character string or connection")
    .Internal(scan(file, what, nmax, sep, dec, quote, skip, nlines,
                   na.strings, flush, fill, strip.white, quiet,
                   blank.lines.skip, multi.line, comment.char))
}
split.screen <-
    function(figs,
	     screen = if(exists(".split.screens", envir=.GlobalEnv))
		      .split.cur.screen else 0,
	     erase = TRUE)
{
    first.split <- !exists(".split.screens", envir=.GlobalEnv)
    if (missing(figs))
	if (first.split)
	    return(FALSE)
	else
	    return(.split.valid.screens)
    if ((first.split && screen != 0) ||
	(!first.split && !(screen %in% .split.valid.screens)))
	stop("Invalid screen number\n")
    ## if figs isn't a matrix, make it one
    if (!is.matrix(figs)) {
	if (!is.vector(figs))
	    stop("figs must be a vector or a matrix with 4 columns\n")
	nr <- figs[1]
	nc <- figs[2]
	x <- seq(0, 1, len=nc+1)
	y <- seq(1, 0, len=nr+1)
	figs <- matrix(c(rep.int(x[-(nc+1)], nr), rep.int(x[-1], nr),
			 rep.int(y[-1], rep.int(nc, nr)),
			 rep.int(y[-(nr+1)], rep.int(nc, nr))),
		       nc = 4)
    }
    num.screens <- nrow(figs)
    if (num.screens < 1)
	stop("figs must specify at least one screen\n")
    new.screens <- valid.screens <- cur.screen <- 0
    if (first.split) {
        if (erase) plot.new()
	split.par.list <- c("adj", "bty", "cex", "col", "crt", "err",
			    "font", "lab", "las", "lty",
			    "lwd", "mar", "mex", "mfg", "mgp",
			    "pch", "pty", "smo", "srt", "tck", "usr",
			    "xaxp", "xaxs", "xaxt", "xpd", "yaxp",
			    "yaxs", "yaxt", "fig")
	assign(".split.par.list", split.par.list, envir=.GlobalEnv)
	## save the current graphics state
	split.saved.pars <- par(split.par.list)
	split.saved.pars$fig <- NULL
	## NOTE: remove all margins when split screens
	split.saved.pars$omi <- par(omi=rep.int(0,4))$omi
	assign(".split.saved.pars", split.saved.pars, envir=.GlobalEnv)
	## set up the screen information
	split.screens <- vector(mode="list", length=num.screens)
	new.screens <- 1:num.screens
	for (i in new.screens) {
	    split.screens[[i]] <- par(split.par.list)
	    split.screens[[i]]$fig <- figs[i,]
	}
	valid.screens <- new.screens
	cur.screen <- 1
    }
    else {
	max.screen <- max(.split.valid.screens)
	new.max.screen <- max.screen + num.screens
	split.screens <- .split.screens
	## convert figs to portions of the specified screen
	total <- c(0,1,0,1)
	if (screen > 0)
	    total <- split.screens[[screen]]$fig
	for (i in 1:num.screens)
	    figs[i,] <- total[c(1,1,3,3)] +
		figs[i,]*rep.int(c(total[2]-total[1],
                                   total[4]-total[3]),
                                 c(2,2))
	new.screens <- (max.screen+1):new.max.screen
	for (i in new.screens) {
	    split.screens[[i]] <- par(.split.par.list)
	    split.screens[[i]]$fig <- figs[i-max.screen,]
	}
	valid.screens <- c(.split.valid.screens, new.screens)
	cur.screen <- max.screen+1
    }
    assign(".split.screens", split.screens, envir=.GlobalEnv)
    assign(".split.cur.screen", cur.screen, envir=.GlobalEnv)
    assign(".split.valid.screens", valid.screens, envir=.GlobalEnv)
    if (erase)
	erase.screen(0)
    par(.split.screens[[cur.screen]])
    return(new.screens)
}

screen <- function(n = .split.cur.screen, new = TRUE)
{
    if (!exists(".split.screens", envir=.GlobalEnv))
	return(FALSE)
    if (missing(n) && missing(new))
	return(.split.cur.screen)
    if (!(n %in% .split.valid.screens))
	stop("Invalid screen number\n")
    .split.screens[[.split.cur.screen]] <- par(.split.par.list)
    assign(".split.screens", .split.screens, envir=.GlobalEnv)
    assign(".split.cur.screen", n, envir=.GlobalEnv)
    par(.split.screens[[n]])
    if (new)
	erase.screen(n)
    invisible(n)
}

erase.screen <- function(n = .split.cur.screen)
{
    if (!exists(".split.screens", envir=.GlobalEnv))
	return(FALSE)
    if (!(n %in% .split.valid.screens) && n != 0)
	stop("Invalid screen number\n")
    old <- par(usr=c(0,1,0,1), mar=c(0,0,0,0),
	       fig = if (n > 0)
	       .split.screens[[n]]$fig
	       else
	       c(0,1,0,1),
	       xaxs="i", yaxs="i")
    on.exit(par(old))
    par(new=TRUE)
    plot.new()
    polygon(c(0,1,1,0), c(0,0,1,1), border=NA, col=0)
    par(new=TRUE)
    invisible()
}

close.screen <- function(n, all.screens=FALSE)
{
    if (!exists(".split.screens", envir=.GlobalEnv))
	return(FALSE)
    if (missing(n) && missing(all.screens))
	return(.split.valid.screens)
    if (all.screens || all(.split.valid.screens %in% n)) {
	par(.split.saved.pars)
	par(mfrow=c(1,1), new=FALSE)
	remove(".split.screens", ".split.cur.screen",
	       ".split.saved.pars", ".split.valid.screens",
	       ".split.par.list",
	       envir=.GlobalEnv)
	invisible()
    }
    else {
	assign(".split.valid.screens",
	       .split.valid.screens[-sort(match(n, .split.valid.screens))],
	       envir=.GlobalEnv)
	temp <- .split.cur.screen
	if (temp %in% n)
	    temp <- min(.split.valid.screens[.split.valid.screens>temp])
	if (temp > max(.split.valid.screens))
	    temp <- min(.split.valid.screens)
	screen(temp, new=FALSE)
	return(.split.valid.screens)
    }
}




sd <- function(x, na.rm=FALSE) {
    if (is.matrix(x))
	apply(x, 2, sd, na.rm=na.rm)
    else if (is.vector(x))
	sqrt(var(x, na.rm=na.rm))
    else if (is.data.frame(x))
	sapply(x, sd, na.rm=na.rm)
    else 
	sqrt(var(as.vector(x), na.rm=na.rm))
}
segments <-
    function(x0, y0, x1, y1, col=par("fg"), lty=par("lty"), lwd=par("lwd"), ...)
    .Internal(segments(x0, y0, x1, y1, col=col, lty=lty, lwd=lwd, ...))
seq <- function(...) UseMethod("seq")

seq.default <-
    function(from = 1, to = 1, by = ((to - from)/(length.out - 1)),
             length.out = NULL, along.with = NULL, ...)
{
    if((One <- nargs() == 1) && !missing(from)) {
	lf <- length(from)
	return(if(mode(from) == "numeric" && lf == 1) 1:from else
	       if(lf) 1:lf else integer(0))
    }
    if(!missing(along.with)) {
	length.out <- length(along.with)
	if(One) return(if(length.out) 1:length.out else integer(0))
    }
    else if(!missing(length.out))
	length.out <- ceiling(length.out)
    if(is.null(length.out))
	if(missing(by))
	    from:to
	else { # dealing with 'by'
	    del <- to - from
	    if(del == 0 && to == 0) return(to)
	    n <- del/by
	    if(!(length(n) && is.finite(n))) {
		if(length(by) && by == 0 && length(del) && del == 0)
		    return(from)
		stop("invalid (to - from)/by in seq(.)")
	    }
	    if(n < 0)
		stop("Wrong sign in 'by' argument")
	    if(n > .Machine$integer.max)
		stop("'by' argument is much too small")

	    dd <- abs(del)/max(abs(to), abs(from))
	    if (dd < 100*.Machine$double.eps) return(from)
	    n <- as.integer(n + 1e-7)
	    from + (0:n) * by
	}
    else if(!is.finite(length.out) || length.out < 0)
	stop("Length must be non-negative number")
    else if(length.out == 0)
	integer(0)
    else if(missing(by)) {
	if(from == to || length.out < 2)
	    by <- 1
	if(missing(to))
	    to <- from + length.out - 1
	if(missing(from))
	    from <- to - length.out + 1
	if(length.out > 2)
	    if(from == to)
		rep.int(from, length.out)
	    else as.vector(c(from, from + (1:(length.out - 2)) * by, to))
	else as.vector(c(from, to))[1:length.out]
    }
    else if(missing(to))
	from + (0:(length.out - 1)) * by
    else if(missing(from))
	to - ((length.out - 1):0) * by
    else stop("Too many arguments")
}

sequence <- function(nvec)
{
    s <- integer(0)
    for(i in nvec)
	s <- c(s, 1:i)
    return(s)
}
.saveRDS <-
function(object, file = "", ascii = FALSE, version = NULL,
         compress = FALSE, refhook = NULL) 
{
    if(is.character(file)) {
        if(file == "") stop("'file' must be non-empty string")
        mode <- if(ascii) "w" else "wb"
        if(compress && capabilities("libz")) con <- gzfile(file, mode)
        else con <- file(file, mode)
        on.exit(close(con))
    }
    else if (inherits(file, "connection")) {
        con <- file
        if(missing(ascii)) 
            if(summary(con)$text == "text") 
                ascii <- TRUE
            else ascii <- FALSE
    }        
    else stop("bad 'file' argument")
    invisible(.Internal(serializeToConn(object, con, ascii, version,
                                        refhook)))
}

.readRDS <-
function(file, refhook = NULL) 
{
    if(is.character(file)) {
        if(capabilities("libz")) 
            con <- gzfile(file, "rb")
        else
            con <- file(file, "rb")
        on.exit(close(con))
    }
    else if (inherits(file, "connection")) 
        con <- file
    else stop("bad 'file' argument")
    .Internal(unserializeFromConn(con, refhook))
}

serialize <- function(object, connection, ascii = FALSE, refhook = NULL) {
    if (! is.null(connection)) {
        if (!inherits(connection, "connection")) 
            stop("`connection' must be a connection")
        if (missing(ascii))
            if (summary(connection)$text == "text")
                ascii <- TRUE
            else
                ascii <- FALSE
    }
    if (! ascii && inherits(connection, "sockconn"))
        .Call("R_serializeb", object, connection, refhook, PACKAGE="base")
    else
        .Call("R_serialize", object, connection, ascii, refhook,
              PACKAGE="base")
}

unserialize <- function(connection, refhook = NULL) {
    if (! is.character(connection) && !inherits(connection, "connection")) 
        stop("`connection' must be a connection")
    .Call("R_unserialize", connection, refhook, PACKAGE="base")
}
union <- function(x, y) unique(c(x, y))

intersect <- function(x, y) unique(y[match(x, y, 0)])

setdiff <- function(x, y)
    unique(if(length(x) || length(y)) x[match(x, y, 0) == 0] else x)

## Faster versions, see R-devel, Jan.4-6, 2000;  optimize later...
setequal <- function(x, y) all(c(match(x, y, 0) > 0, match(y, x, 0) > 0))

##  same as %in% ( ./match.R ) but different arg names:
is.element <- function(el, set) match(el, set, 0) > 0
sink <- function(file=NULL, append = FALSE, type = c("output", "message"))
{
    type <- match.arg(type)
    if(type == "message") {
        if(is.null(file)) file <- stderr()
        else if(!inherits(file, "connection") || !isOpen(file))
           stop("`file' must be NULL or an already open connection")
        .Internal(sink(file, FALSE, TRUE))
    } else {
        closeOnExit <- FALSE
        if(is.null(file)) file <- -1
        else if(is.character(file)) {
            file <- file(file, ifelse(append, "a", "w"))
            closeOnExit <- TRUE
        } else if(!inherits(file, "connection"))
            stop("`file' must be NULL, a connection or a character string")
        .Internal(sink(file, closeOnExit, FALSE))
    }
}

sink.number <- function(type = c("output", "message"))
{
    type <- match.arg(type)
    .Internal(sink.number(type != "message"))
}
print.socket <- function(x, ...)
{
    if(length(as.integer(x$socket)) != 1)
	stop("invalid `socket' argument")
    cat("Socket connection #", x$socket, "to", x$host,
	"on port", x$port, "\n")
    invisible(x)
}

make.socket <- function(host = "localhost", port, fail = TRUE, server = FALSE)
{
    if(length(port <- as.integer(port)) != 1)
	stop("`port' must be integer of length 1")
    if(length(host <- as.character(host)) != 1)
	stop("`host' must be character of length 1")
    if (!server){
	tmp2 <- .C("Rsockconnect",
                   port = port,
                   host = host,
                   PACKAGE = "base")
    }
    else{
	if (host != "localhost")
	    stop("Can only receive calls on local machine")
	tmp <- .C("Rsockopen", port = port, PACKAGE="base")
	buffer <- paste(rep("#",256), collapse = "")
	tmp2 <- .C("Rsocklisten", port = tmp$port,
                   buffer = buffer, len = as.integer(256), PACKAGE="base")
	host <- substr(tmp2$buffer, 1, tmp2$len)
	.C("Rsockclose", tmp$port, PACKAGE="base")
    }
    if (tmp2$port <= 0) {
	w <- "Socket not established"
	if (fail) stop(w) else warning(w)
    }
    rval <- list(socket = tmp2$port, host = host, port = port)
    class(rval) <- "socket"
    rval
}

close.socket <- function(socket, ...)
{
    if(length(port <- as.integer(socket$socket)) != 1)
	stop("invalid `socket' argument")
    as.logical(.C("Rsockclose", port, PACKAGE="base")[[1]])
}

read.socket <- function(socket, maxlen=256, loop=FALSE)
{
    if(length(port <- as.integer(socket$socket)) != 1)
	stop("invalid `socket' argument")
    maxlen <- as.integer(maxlen)
    buffer <- paste(rep("#",maxlen), collapse="")
    repeat {
	tmp <- .C("Rsockread", port,
		  buffer = buffer, len = maxlen, PACKAGE="base")
	rval <- substr(tmp$buffer, 1, tmp$len)
	if (nchar(rval) > 0 || !loop) break
    }
    rval
}

write.socket <- function(socket, string)
{
    if(length(port <- as.integer(socket$socket)) != 1)
	stop("invalid `socket' argument")
    strlen <- length(strsplit(string,NULL)[[1]])
    invisible(.C("Rsockwrite", port, string,
		 as.integer(0), strlen, strlen, PACKAGE="base")[[5]])
}


solve.qr <- function(a, b, ...)
{
    if( !is.qr(a) )
	stop("this is the qr method for the solve generic")
    nc <- ncol(a$qr)
    if( a$rank != nc )
	stop("singular matrix `a' in solve")
    if( missing(b) ) {
	if( nc != nrow(a$qr) )
	    stop("only square matrices can be inverted")
	b <- diag(1, nc)
    }
    return(qr.coef(a, b))
}

solve.default <- function(a, b, tol = 1e-7, LINPACK = FALSE, ...)
{
    if(is.complex(a) || (!missing(b) && is.complex(b))) {
        a <- as.matrix(a)
        if(missing(b)) {
            b <- diag(1+0i, nrow(a))
            colnames(b) <- rownames(a)
        } else if(!is.complex(b)) b[] <- as.complex(b)
        if(!is.complex(a)) a[] <- as.complex(a)
        return (if (is.matrix(b)) {
            rownames(b) <- colnames(a)
	    .Call("La_zgesv", a, b, PACKAGE = "base")
	} else
	    drop(.Call("La_zgesv", a, as.matrix(b), PACKAGE = "base")))
    }
    if(is.qr(a)) {
        warning("solve.default called with a qr object: use qr.solve")
        return(solve.qr(a, b, tol))
    }
    if(!LINPACK) {
        a <- as.matrix(a)
        if(missing(b)) {
            b <- diag(1.0, nrow(a))
            colnames(b) <- rownames(a)
        } else storage.mode(b) <- "double"
        storage.mode(a) <- "double"
        return (if (is.matrix(b)) {
            rownames(b) <- colnames(a)
	    .Call("La_dgesv", a, b, PACKAGE = "base")
	} else
	    drop(.Call("La_dgesv", a, as.matrix(b), PACKAGE = "base")))
    }
    a <- qr(a, tol = tol)
    nc <- ncol(a$qr)
    if( a$rank != nc )
	stop("singular matrix `a' in solve")
    if( missing(b) ) {
	if( nc != nrow(a$qr) )
	    stop("only square matrices can be inverted")
        ## preserve dimnames
	b <- diag(1, nc)
        colnames(b) <- rownames(a$qr)
    }
    qr.coef(a, b)
}

solve <- function(a, b, ...) UseMethod("solve")

qr.solve <- function(a, b, tol = 1e-7)
{
    if( !is.qr(a) )
	a <- qr(a, tol = tol)
    nc <- ncol(a$qr)
    if( a$rank != nc )
	stop("singular matrix `a' in solve")
    if( missing(b) ) {
	if( nc != nrow(a$qr) )
	    stop("only square matrices can be inverted")
	b <- diag(1, nc)
    }
    return(qr.coef(a, b))
}

sort <- function(x, partial = NULL, na.last = NA, decreasing = FALSE,
                 method = c("shell", "quick"), index.return = FALSE)
{
    if(isfact <- is.factor(x)) {
        if(index.return) stop("index.return only for non-factors")
	lev <- levels(x)
	nlev <- nlevels(x)
 	isord <- is.ordered(x)
        x <- c(x)
    } else
    if(!is.atomic(x))
        stop("`x' must be atomic")
    if(has.na <- any(ina <- is.na(x))) {
        nas <- x[ina]
        x <-  x[!ina]
    }
    if(index.return && !is.na(na.last))
        stop("index.return only for na.last = NA")
    if(!is.null(partial)) {
        if(!all(is.finite(partial))) stop("non-finite `partial'")
	y <- .Internal(psort(x, partial))
    }
    else {
        nms <- names(x)
        method <- if(is.numeric(x)) match.arg(method) else "shell"
        switch(method,
               "quick" = {
                   if(!is.null(nms)) {
                       if(decreasing) x <- -x
                       y <- .Internal(qsort(x, TRUE))
                       if(decreasing) y$x <- -y$x
                       names(y$x) <- nms[y$ix]
                       if (!index.return) y <- y$x
                   } else {
                       if(decreasing) x <- -x
                       y <- .Internal(qsort(x, index.return))
                       if(decreasing)
                           if(index.return) y$x <- -y$x else y <- -y
                   }
               },
               "shell" = {
                   if(index.return || !is.null(nms)) {
                       o <- sort.list(x, decreasing = decreasing)
                       y <- if (index.return) list(x = x[o], ix = o) else x[o]
                       ## names(y) <- nms[o] # pointless!
                   }
                   else
                       y <- .Internal(sort(x, decreasing))
               })
    }
    if(!is.na(na.last) && has.na)
	y <- if(!na.last) c(nas, y) else c(y, nas)
    if(isfact)
        y <- (if (isord) ordered else factor)(y, levels=seq(len=nlev),
                                              labels=lev)
    y
}

order <- function(..., na.last = TRUE, decreasing = FALSE)
{
    if(!is.na(na.last))
        .Internal(order(na.last, decreasing, ...))
    else{ ## remove nas
        z <- list(...)
        if(any(diff(sapply(z, length)) != 0))
            stop("Argument lengths differ")
        ans <- sapply(z, is.na)
        ok <- if(is.matrix(ans)) !apply(ans, 1, any) else !any(ans)
        if(all(!ok)) return(integer(0))
        z[[1]][!ok] <- NA
        ans <- do.call("order", c(z, decreasing=decreasing))
        keep <- seq(along=ok)[ok]
        ans[ans %in% keep]
    }
}

sort.list <- function(x, partial = NULL, na.last = TRUE, decreasing = FALSE,
                      method = c("shell", "quick", "radix"))
{
    method <- match.arg(method)
    if(!is.atomic(x))
        stop("`x' must be atomic")
    if(!is.null(partial))
        .NotYetUsed("partial != NULL")
    if(method == "quick") {
        if(is.factor(x)) x <- as.integer(x) # sort the internal codes
        if(is.numeric(x))
            return(sort(x, na.last = na.last, decreasing = decreasing,
                        method = "quick", index.return = TRUE)$ix)
        else stop("method=\"quick\" is only for numeric x")
    }
    if(method == "radix") {
        if(!is.integer(x)) stop("method=\"radix\" is only for integer x")
        if(is.na(na.last))
            return(.Internal(radixsort(x[!is.na(x)], TRUE, decreasing)))
        else
            return(.Internal(radixsort(x, na.last, decreasing)))
    }
    ## method == "shell"
    if(is.na(na.last)) .Internal(order(TRUE, decreasing, x[!is.na(x)]))
    else .Internal(order(na.last, decreasing, x))
}
source <-
function(file, local = FALSE, echo = verbose, print.eval = echo,
         verbose = getOption("verbose"),
         prompt.echo = getOption("prompt"),
         max.deparse.length = 150, chdir = FALSE)
{
    eval.with.vis <-
	function (expr, envir = parent.frame(),
		  enclos = if (is.list(envir) || is.pairlist(envir))
		  parent.frame())
	.Internal(eval.with.vis(expr, envir, enclos))

    envir <- if (local)
	parent.frame()
    else .GlobalEnv
    if (!missing(echo)) {
	if (!is.logical(echo))
	    stop("echo must be logical")
	if (!echo && verbose) {
	    warning(paste("verbose is TRUE, echo not; ... coercing",
                          sQuote("echo <- TRUE")))
	    echo <- TRUE
	}
    }
    if (verbose) {
	cat(sQuote("envir"), "chosen:")
	print(envir)
    }
    Ne <- length(exprs <- parse(n = -1, file = file))
    if (verbose)
	cat("--> parsed", Ne, "expressions; now eval(.)ing them:\n")
    if (Ne == 0)
	return(invisible())
    if (chdir && (path <- dirname(file)) != ".") {
	owd <- getwd()
	on.exit(setwd(owd))
	setwd(path)
    }
    #-- ass1 :	the  '<-' symbol/name
#    ass1 <- expression(y <- x)[[1]][[1]]
    if (echo) {
	## Reg.exps for string delimiter/ NO-string-del /
        ## odd-number-of-str.del needed, when truncating below
	sd <- "\""
	nos <- "[^\"]*"
	oddsd <- paste("^", nos, sd, "(", nos, sd, nos, sd, ")*",
		       nos, "$", sep = "")
    }
    for (i in 1:Ne) {
	if (verbose)
	    cat("\n>>>> eval(expression_nr.", i, ")\n\t	 =================\n")
	ei <- exprs[i]
	if (echo) {
	    # drop "expression("
	    dep <- substr(paste(deparse(ei), collapse = "\n"),
			  12, 1e+06)
	    # -1: drop ")"
	    nd <- nchar(dep) - 1
	    do.trunc <- nd > max.deparse.length
	    dep <- substr(dep, 1, if (do.trunc)
			  max.deparse.length
			  else nd)
	    cat("\n", prompt.echo, dep, if (do.trunc)
		paste(if (length(grep(sd, dep)) && length(grep(oddsd,
							       dep)))
		      " ...\" ..."
		      else " ....", "[TRUNCATED] "), "\n", sep = "")
	}
	yy <- eval.with.vis(ei, envir)
	i.symbol <- mode(ei[[1]]) == "name"
	if (!i.symbol) {
	    ## ei[[1]] : the function "<-" or other
	    curr.fun <- ei[[1]][[1]]
	    if (verbose) {
		cat("curr.fun:")
		str(curr.fun)
	    }
	}
	if (verbose >= 2) {
	    cat(".... mode(ei[[1]])=", mode(ei[[1]]), "; paste(curr.fun)=")
	    str(paste(curr.fun))
	}
	if (print.eval && yy$visible)
	    print(yy$value)
	if (verbose)
	    cat(" .. after ", sQuote(deparse(ei)), "\n", sep = "")
    }
    invisible(yy)
}

sys.source <-
function(file, envir = NULL, chdir = FALSE,
         keep.source = getOption("keep.source.pkgs"))
{
    if(!(is.character(file) && file.exists(file)))
	stop(paste(sQuote(file), "is not an existing file"))
    oop <- options(keep.source = as.logical(keep.source),
                   topLevelEnvironment = as.environment(envir))
    on.exit(options(oop))
    exprs <- parse(n = -1, file = file)
    if (length(exprs) == 0)
	return(invisible())
    if (chdir && (path <- dirname(file)) != ".") {
	owd <- getwd()
	on.exit(setwd(owd), add = TRUE)
	setwd(path)
    }
    for (i in exprs) eval(i, envir)
    invisible()
}

demo <-
function(topic, device = getOption("device"),
         package = .packages(), lib.loc = NULL,
         character.only = FALSE, verbose = getOption("verbose"))
{
    paths <- .find.package(package, lib.loc, verbose = verbose)

    ## Find the directories with a 'demo' subdirectory.
    paths <- paths[tools::fileTest("-d", file.path(paths, "demo"))]
    ## Earlier versions remembered given packages with no 'demo'
    ## subdirectory, and warned about them.

    if(missing(topic)) {
        ## List all possible demos.

        ## Build the demo db.
        db <- matrix(character(0), nr = 0, nc = 4)
        noindex <- character(0)
        for(path in paths) {
            entries <- NULL
            ## Check for new-style 'Meta/demo.rds', then for '00Index'.
            if(tools::fileTest("-f",
                               INDEX <-
                               file.path(path, "Meta", "demo.rds"))) {
                entries <- .readRDS(INDEX)
            }
            else if(tools::fileTest("-f",
                                    INDEX <-
                                    file.path(path, "demo", "00Index")))
                entries <- read.00Index(INDEX)
            else {
                ## No index: check whether subdir 'demo' contains demos.
                demoDir <- file.path(path, "demo")
                entries <- tools::listFilesWithType(demoDir, "demo")
                if(length(entries) > 0) {
                    entries <-
                        unique(tools::filePathSansExt(basename(entries)))
                    entries <- cbind(entries, "")
                }
                else
                    noindex <- c(noindex, basename(path))
            }
            if(NROW(entries) > 0) {
                db <- rbind(db,
                            cbind(basename(path), dirname(path),
                                  entries))
            }
        }
        colnames(db) <- c("Package", "LibPath", "Item", "Title")

        if(length(noindex) > 0) {
            if(!missing(package) && (length(package) > 0)) {
                ## Warn about given packages which do not have a demo
                ## index.
                packagesWithNoIndex <- package[package %in% noindex]
                if(length(packagesWithNoIndex) > 0)
                    warning(paste("packages with demos",
                                  "but no index:",
                                  paste(sQuote(packagesWithNoIndex),
                                        collapse = ",")))
            }
        }

        footer <- if(missing(package))
            paste("Use ",
                  sQuote(paste("demo(package =",
                               ".packages(all.available = TRUE))")),
                  "\n",
                  "to list the demos in all *available* packages.",
                  sep = "")
        else
            NULL
        y <- list(title = "Demos", header = NULL, results = db,
                  footer = footer)
        class(y) <- "packageIQR"
        return(y)
    }

    if(!character.only)
        topic <- as.character(substitute(topic))
    available <- character(0)
    paths <- file.path(paths, "demo")
    for(p in paths) {
        files <- basename(tools::listFilesWithType(p, "demo"))
        ## Files with base names sans extension matching topic
        files <- files[topic == tools::filePathSansExt(files)]
        if(length(files) > 0)
            available <- c(available, file.path(p, files))
    }
    if(length(available) == 0)
        stop(paste("No demo found for topic", sQuote(topic)))
    if(length(available) > 1) {
        available <- available[1]
        warning(paste("Demo for topic ",
                      sQuote(topic),
                      " found more than once,\n",
                      "using the one found in ",
                      sQuote(dirname(available[1])),
                      sep = ""))
    }
    cat("\n\n",
        "\tdemo(", topic, ")\n",
        "\t---- ", rep("~", nchar(topic)), "\n",
        sep="")
    if(interactive()) {
        cat("\nType  <Return>	 to start : ")
        readline()
    }
    source(available, echo = TRUE, max.deparse.length = 250)
}

example <-
function(topic, package = .packages(), lib.loc = NULL, local = FALSE,
         echo = TRUE, verbose = getOption("verbose"),
         prompt.echo = paste(abbreviate(topic, 6), "> ", sep = ""))
{
    topic <- substitute(topic)
    if(!is.character(topic))
	topic <- deparse(topic)[1]
    INDICES <- .find.package(package, lib.loc, verbose = verbose)
    file <- index.search(topic, INDICES, "AnIndex", "R-ex")
    if(file == "") {
	warning(paste("No help file found for", sQuote(topic)))
	return(invisible())
    }
    packagePath <- dirname(dirname(file))
    if(length(file) > 1) {
        packagePath <- packagePath[1]
	warning(paste("More than one help file found: using package",
                      sQuote(basename(packagePath))))
        file <- file[1]
    }
    pkg <- basename(packagePath)
    lib <- dirname(packagePath)
    ## experimental code
    zfile <- zip.file.extract(file, "Rex.zip")
    if(zfile != file) on.exit(unlink(zfile))
    ## end of experimental code
    if(!file.exists(zfile)) {
	warning(paste(sQuote(topic),
                      "has a help file but no examples file"))
	return(invisible())
    }
    if(pkg != "base")
	library(pkg, lib = lib, character.only = TRUE)
    source(zfile, local, echo = echo, prompt.echo = prompt.echo,
           verbose = verbose, max.deparse.length = 250)
}
spline <-
    function(x, y=NULL, n=3*length(x), method="fmm", xmin=min(x), xmax=max(x))
{
    x <- xy.coords(x, y)
    y <- x$y
    x <- x$x
    ## ensured by  xy.coords(.) :
    ##	if (!is.numeric(x) || !is.numeric(y))
    ##		stop("spline: x and y must be numeric")
    nx <- length(x)
    ## ensured by  xy.coords(.) :
    ##	if (nx != length(y))
    ##		stop("x and y must have equal lengths")
    method <- match(method, c("periodic", "natural", "fmm"))
    if(is.na(method))
	stop("spline: invalid interpolation method")
    dx <- diff(x)
    if(any(dx < 0)) {
	o <- order(x)
	x <- x[o]
	y <- y[o]
    }
    if(method == 1 && y[1] != y[nx]) {
	warning("spline: first and last y values differ - using y[1] for both")
	y[nx] <- y[1]
    }
    z <- .C("spline_coef",
	    method=as.integer(method),
	    n=nx,
	    x=x,
	    y=y,
	    b=double(nx),
	    c=double(nx),
	    d=double(nx),
	    e=double(if(method == 1) nx else 0),
            PACKAGE="base")
    u <- seq(xmin, xmax, length.out=n)
    ##-	 cat("spline(.): result of  .C(\"spline_coef\",...):\n")
    ##-	 str(z, vec.len=10)
    ##-	 cat("spline(.): now calling .C(\"spline_eval\", ...)\n")

    .C("spline_eval",
       z$method,
       nu=length(u),
       x =u,
       y =double(n),
       z$n,
       z$x,
       z$y,
       z$b,
       z$c,
       z$d,
       PACKAGE="base")[c("x","y")]
}


splinefun <- function(x, y=NULL, method="fmm")
{
    x <- xy.coords(x, y)
    y <- x$y
    x <- x$x
    n <- length(x)# = length(y), ensured by xy.coords(.)
    method <- match(method, c("periodic", "natural", "fmm"))
    if(is.na(method))
	stop("splinefun: invalid interpolation method")
    if(any(diff(x) < 0)) {
	z <- order(x)
	x <- x[z]
	y <- y[z]
    }
    if(method == 1 && y[1] != y[n]) {
	warning("first and last y values differ in spline - using y[1] for both")
	y[n] <- y[1]
    }
    z <- .C("spline_coef",
	    method=as.integer(method),
	    n=n,
	    x=x,
	    y=y,
	    b=double(n),
	    c=double(n),
	    d=double(n),
	    e=double(if(method == 1) n else 0),
            PACKAGE="base")
    rm(x,y,n,method)
    function(x) {
	.C("spline_eval",
	   z$method,
	   length(x),
	   x=as.double(x),
	   y=double(length(x)),
	   z$n,
	   z$x,
	   z$y,
	   z$b,
	   z$c,
	   z$d,
           PACKAGE="base")$y
    }
}
split <- function(x, f) UseMethod("split")

split.default <- function(x, f)
{
    if (is.list(f)) f <- interaction(f)
    f <- factor(f)                  # drop extraneous levels
    if (is.null(attr(x, "class")) && is.null(names(x)))
        return(.Internal(split(x, f)))
    ## else
    lf <- levels(f)
    y <- vector("list", length(lf))
    names(y) <- lf
    for(k in lf) y[[k]] <- x[f == k]
    y
}

split.data.frame <- function(x, f)
    lapply(split(seq(length=nrow(x)), f), function(ind) x[ind, , drop = FALSE ])

"split<-" <- function(x, f, value) UseMethod("split<-")

"split<-.default" <- function(x, f, value)
{
    x[unlist(split(seq(along=x), f))] <- unlist(value)
    x
}

"split<-.data.frame" <- function(x, f, value)
{
    x[unlist(split(seq(length=nrow(x)), f)),] <- do.call("rbind", value)
    x
}

unsplit <- function(value, f)
{
    len <- length(if (is.list(f)) f[[1]] else f)
    x <- vector(mode = typeof(value[[1]]), length = len)
    split(x, f) <- value
    x
}
### This code started life as spatial star plots by David A. Andrews.
### See http://www.udallas.edu:8080/~andrews/software/software.html
### T. Dye <tdye@lava.net>, July 1999;  many improvements by MM

stars <-
function(x, full = TRUE, scale = TRUE, radius = TRUE,
	 labels = dimnames(x)[[1]], locations = NULL,
         nrow = NULL, ncol = NULL, len = 1,
         key.loc = NULL, key.labels = dimnames(x)[[2]], key.xpd = TRUE,
         xlim = NULL, ylim = NULL, flip.labels = NULL,
         draw.segments = FALSE, col.segments = 1:n.seg,
         col.stars = NA,
         axes = FALSE, frame.plot = axes,
         main = NULL, sub = NULL, xlab = "", ylab = "",
         cex = 0.8, lwd = 0.25, lty = par("lty"), xpd = FALSE,
         mar = pmin(par("mar"),
                    1.1+ c(2*axes+ (xlab != ""), 2*axes+ (ylab != ""), 1,0)),
         add=FALSE, plot=TRUE, ...)
{
    if (is.data.frame(x))
	x <- data.matrix(x)
    else if (!is.matrix(x))
	stop("x must be a matrix or a data frame")
    if (!is.numeric(x))
	stop("data in x must be numeric")

    n.loc <- nrow(x)
    n.seg <- ncol(x)

    if (is.null(locations)) { ## Default (x,y) locations matrix
	if(is.null(nrow))
            nrow <- ceiling(if(!is.numeric(ncol)) sqrt(n.loc) else n.loc/ncol)
	if(is.null(ncol))
            ncol <- ceiling(n.loc/nrow)
        if(nrow * ncol < n.loc)
            stop("nrow * ncol <  number of observations")
        ff <- if(!is.null(labels)) 2.3 else 2.1
        locations <- expand.grid(ff * 1:ncol, ff * nrow:1)[1:n.loc, ]
        if(!is.null(labels) && (missing(flip.labels) ||
                                !is.logical(flip.labels)))
            flip.labels <- ncol * mean(nchar(labels)) > 30
    }
    else {
        if (is.numeric(locations) && length(locations) == 2) {
            ## all stars around the same origin
            locations <- cbind(rep.int(locations[1],n.loc),
                               rep.int(locations[2],n.loc))
            if(!missing(labels) && n.loc > 1)
                warning("labels don't make sense for a single location")
            else labels <- NULL
        }
        else {
            if (is.data.frame(locations))
                locations <- data.matrix(locations)
            if (!is.matrix(locations) || ncol(locations) != 2)
                stop("locations must be a 2-column matrix.")
            if (n.loc != nrow(locations))
                stop("number of rows of locations and x must be equal.")
        }
        if(missing(flip.labels) || !is.logical(flip.labels))
            flip.labels <- FALSE # have no grid
    }
    xloc <- locations[,1]
    yloc <- locations[,2]
    ## Angles start at zero and pace around the circle counter
    ## clock-wise in equal increments.
    angles <-
	if(full)
	    seq(0, 2*pi, length=n.seg+1)[-(n.seg+1)]
	else if (draw.segments)
	    seq(0, pi, length=n.seg+1)[-(n.seg+1)]
	else
	    seq(0, pi, length=n.seg)

    if (length(angles) != n.seg)
	stop("length(angles) must be the same as ncol(x)")

    ## Missing values are treated as 0
    if (scale) {
        x <- apply(x, 2, function(x)
                   (x - min(x, na.rm = TRUE))/diff(range(x, na.rm = TRUE)))
#	x <- sweep(x,2,apply(x,2,max), FUN="/")
    }
    ## Missing values are treated as 0
    x[is.na(x)] <- 0
    mx <- max(x <- x * len)

    if(is.null(xlim)) xlim <- range(xloc) + c(-mx, mx)
    if(is.null(ylim)) ylim <- range(yloc) + c(-mx, mx)

    deg <- pi / 180

    ## The asp argument keeps everything (the symbols!) square
    op <- par(mar = mar, xpd = xpd) ; on.exit(par(op))
    if(!add)
        plot(0, type="n", ..., xlim=xlim, ylim=ylim,
             main = main, sub = sub, xlab = xlab, ylab=ylab,
             asp = 1, axes = axes)

    if(!plot)
        return()

    s.x <- xloc + x * rep.int(cos(angles), rep.int(n.loc,n.seg))
    s.y <- yloc + x * rep.int(sin(angles), rep.int(n.loc,n.seg))

    if ( draw.segments ) {
        aangl <- c(angles, if(full)2*pi else pi)
	for (i in 1:n.loc) { ## for each location, draw a segment diagram
	    px <- py <- numeric()
	    for (j in 1:n.seg) {
		k <- seq(from = aangl[j], to = aangl[j+1], by = 1*deg)
		px <- c(px, xloc[i], s.x[i,j], x[i,j]*cos(k) + xloc[i], NA)
		py <- c(py, yloc[i], s.y[i,j], x[i,j]*sin(k) + yloc[i], NA)
	    }
	    polygon(px, py, col = col.segments, lwd=lwd, lty=lty)
	}
    } # Segment diagrams

    else { # Draw stars instead
	for (i in 1:n.loc) {
	    polygon(s.x[i,], s.y[i,], lwd=lwd, lty=lty, col = col.stars[i])
	    if (radius)
		segments(rep.int(xloc[i],n.seg),
			 rep.int(yloc[i],n.seg),
			 s.x[i,], s.y[i,], lwd=lwd, lty=lty)
	}
    }

    if(!is.null(labels)) {
        ## vertical text offset from center
        y.off <- mx * (if(full) 1 else 0.1)
        if(flip.labels)
            y.off <- y.off + cex*par("cxy")[2] *
                ((1:n.loc)%%2 - if(full) .4 else 0)
        ##DBG cat("mx=",format(mx),"y.off:"); str(y.off)
        text(xloc, yloc - y.off, labels, cex=cex, adj=c(0.5, 1))
    }

    if ( !is.null(key.loc) ) { ## Draw unit key

        ## usually allow drawing outside plot region:
        par(xpd = key.xpd) # had `xpd' already above
        key.x <- len * cos(angles) + key.loc[1]
        key.y <- len * sin(angles) + key.loc[2]
	if (draw.segments) {
	    px <- py <- numeric()
	    for (j in 1:n.seg) {
		k <- seq(from = aangl[j], to = aangl[j+1], by = 1*deg)
		px <- c(px, key.loc[1], key.x[j], len * cos(k) + key.loc[1], NA)
		py <- c(py, key.loc[2], key.y[j], len * sin(k) + key.loc[2], NA)
	    }
	    polygon(px, py, col = col.segments, lwd=lwd, lty=lty)
	}
	else { # draw unit star
	    polygon(key.x, key.y, lwd=lwd, lty=lty)
	    if (radius)
		segments(rep.int(key.loc[1],n.seg), rep.int(key.loc[2],n.seg),
			 key.x, key.y, lwd=lwd, lty=lty)
	}

        ## Radial Labeling -- should this be a standalone function ?
	lab.angl <- angles +
            if(draw.segments) (angles[2] - angles[1]) / 2 else 0
	label.x <- 1.1 * len * cos(lab.angl) + key.loc[1]
	label.y <- 1.1 * len * sin(lab.angl) + key.loc[2]
        ## Maybe do the following without loop {need not use adj but ..)!
	for (k in 1:n.seg) {
	    text.adj <-
                c(## horizontal
                  if      (lab.angl[k] < 90*deg || lab.angl[k] > 270*deg) 0
                  else if (lab.angl[k] > 90*deg && lab.angl[k] < 270*deg) 1
                  else 0.5,
                  ## vertical
                  if (lab.angl[k] <= 90*deg) (1 - lab.angl[k] / (90*deg)) /2
                  else if (lab.angl[k] <= 270*deg)
                  (lab.angl[k] - 90*deg) / (180*deg)
                  else ## lab.angl[k] > 270*deg
                  1 - (lab.angl[k] - 270*deg) / (180*deg)
                  )
	    text(label.x[k], label.y[k],
                 labels= key.labels[k], cex = cex, adj = text.adj)
	}
    } # Unit key is drawn and labelled

    if (frame.plot) box(...)

    invisible(locations)
}
stem <- function(x, scale = 1, width = 80, atom = 0.00000001) {
    if (!is.numeric(x) )
	stop("stem: x must be numeric")
    x <- x[!is.na(x)]
    if (length(x)==0) stop("no non-missing values")
    if (scale <= 0) stop("scale must be positive")# unlike S
    .C("stemleaf", as.double(x), length(x),
       as.double(scale), as.integer(width), as.double(atom), PACKAGE="base")
    invisible(NULL)
}
stop <- function(..., call. = TRUE)
{
    args <- list(...)
    if (length(args) == 1 && inherits(args[[1]], "condition")) {
        cond <- args[[1]]
        message <- conditionMessage(cond)
        call = conditionCall(cond)
        .Internal(.signalCondition(cond, message, call))
        .Internal(.dfltStop(message, call))
    }
    else {
        if (length(args) > 0)
            message <- paste(..., sep = "")
        else message <- ""
        .Internal(stop(as.logical(call.), message))
    }
}

stopifnot <- function(...)
{
    n <- length(ll <- list(...))
    if(n == 0)
        return(invisible())
    mc <- match.call()
    for(i in 1:n)
        if(!(is.logical(r <- eval(ll[[i]])) && all(r)))
            stop(paste(deparse(mc[[i+1]]), "is not TRUE"), call. = FALSE)
}

warning <- function(..., call. = TRUE)
{
    args <- list(...)
    if (length(args) == 1 && inherits(args[[1]], "condition")) {
        cond <- args[[1]]
        message <- conditionMessage(cond)
        call = conditionCall(cond)
        withRestarts({
                .Internal(.signalCondition(cond, message, call))
                .Internal(.dfltStop(message, call))
            }, muffleWarning = function() NULL) #**** allow simpler form??
        invisible(message)
    }
    else {
        if (length(args) > 0)
            message <- paste(..., sep = "")
        else message <- ""
        .Internal(warning(as.logical(call.), message))
    }
}
####------ str : show STRucture of an R object
str <- function(object, ...) UseMethod("str")

str.data.frame <- function(object, ...)
{
    ## Method to 'str' for  'data.frame' objects
    if(! is.data.frame(object)) {
	warning("str.data.frame(.) called with non-data.frame. Coercing one.")
	object <- data.frame(object)
    }

    ## Show further classes // Assume that they do NOT have an own Method --
    ## not quite perfect ! (.Class = 'remaining classes', starting with current)
    cl <- oldClass(object); cl <- cl[cl != "data.frame"]  #- not THIS class
    if(0 < length(cl)) cat("Classes", cl, " and ")

    cat("`data.frame':	", nrow(object), " obs. of  ",
	(p <- length(object)), " variable", if(p != 1)"s", if(p > 0)":",
	"\n",sep="")

    ## calling next method, usually  str.default:
    if(length(l <- list(...)) && any("give.length" == names(l)))
	invisible(NextMethod("str", ...))
    else invisible(NextMethod("str", give.length=FALSE,...))
}

str.default <-
    function(object, max.level = 0, vec.len = 4, digits.d = 3,
	     nchar.max = 128, give.attr = TRUE, give.length = TRUE,
	     wid = getOption("width"), nest.lev = 0,
	     indent.str = paste(rep(" ", max(0, nest.lev + 1)), collapse = ".."),
	     ...)
{
    ## Purpose: Display STRucture of any R - object (in a compact form).
    ## --- see HELP file --
    ## ------------------------------------------------------------------------
    ## Author: Martin Maechler <maechler@stat.math.ethz.ch>	1990--1997
    ## ------ Please send Bug-reports, -fixes and improvements !
    ## ------------------------------------------------------------------------

    oo <- options(digits = digits.d); on.exit(options(oo))
    le <- length(object)
    P0 <- function(...) paste(..., sep="")
    pasteCh <- function(x)
	sapply(x, function(a) if(is.na(a)) "NA" else P0('"',a,'"'),
	       USE.NAMES = FALSE)
    ## le.str: not used for arrays:
    le.str <-
	if(is.na(le)) " __no length(.)__ "
	else if(give.length) {
	    if(le > 0) P0("[1:", paste(le), "]") else "(0)"
	} else ""
    v.len <- vec.len # modify v.len, not vec.len!
    ## NON interesting attributes:
    std.attr <- "names"

    has.class <- !is.null(cl <- attr(object, "class"))
    mod <- ""; char.like <- FALSE
    if(give.attr) a <- attributes(object)#-- save for later...

    if(is.function(object)) {
	cat(if(is.null(ao <- args(object))) deparse(object)
	else { dp <- deparse(ao); paste(dp[-length(dp)], collapse="\n") },"\n")
    } else if (is.null(object))
	cat(" NULL\n")
    else if(is.list(object)) {
	i.pl <- is.pairlist(object)
	is.d.f <- is.data.frame(object)
	if(is.d.f) std.attr <- c(std.attr, "class", if(is.d.f) "row.names")
	if(le == 0) {
	    if(!is.d.f) cat(" ", if(i.pl)"pair", "list()\n",sep="")
	} else {
	    if(has.class && any(sapply(paste("str", cl, sep="."),
					#use sys.function(.) ..
					function(ob)exists(ob, mode= "function",
							   inherits= TRUE)))) {
		## str.default is a 'NextMethod' : omit the 'List of ..'
		std.attr <- c(std.attr, "class", if(is.d.f) "row.names")
	    } else {
		cat(if(i.pl) "Dotted pair list" else "List",
		    " of ", le, "\n", sep="")
	    }
	    if (max.level==0 || nest.lev < max.level) {
		nam.ob <-
		    if(is.null(nam.ob <- names(object))) rep("", le)
		    else { max.ncnam <- max(nchar(nam.ob))
			   format.char(nam.ob, width = max.ncnam, flag = '-')
		       }
		for(i in 1:le) {
		    cat(indent.str,"$ ", nam.ob[i], ":", sep="")
		    str(object[[i]], nest.lev = nest.lev + 1,
			indent.str= paste(indent.str,".."), nchar.max=nchar.max,
			max.level=max.level, vec.len=vec.len, digits.d=digits.d,
			give.attr= give.attr, give.length= give.length, wid=wid)
		}
	    }
	}
    } else { #- not function, not list
	if(is.vector(object)
	   || (is.array(object) && is.atomic(object))
	   || is.vector(object, mode='language')
	   || is.vector(object, mode='symbol')## R bug(<=0.50-a4) should be part
	   ) { ##-- Splus: FALSE for 'named vectors'
	    if(is.atomic(object)) {
		##-- atomic:   numeric	complex	 character  logical
		mod <- substr(mode(object), 1, 4)
		if     (mod == "nume")
		    mod <- if(is.integer(object)) "int"
		    else if(has.class) cl[1] else "num"
		else if(mod == "char") { mod <- "chr"; char.like <- TRUE }
		else if(mod == "comp") mod <- "cplx" #- else: keep 'logi'
		if(is.array(object)) {
		    di <- dim(object)
		    di <- P0(ifelse(di>1, "1:",""), di,
			     ifelse(di>0, "" ," "))
		    le.str <- paste(c("[", P0(di[-length(di)], ", "),
				      di[length(di)], "]"), collapse = "")
		    std.attr <- "dim" #- "names"
		} else if(!is.null(names(object))) {
		    mod <- paste("Named", mod)
		    std.attr <- std.attr[std.attr != "names"]
		}
		str1 <-
		    if(le == 1 && !is.array(object)) paste(NULL, mod)
		    else P0(" ", mod, if(le>0)" ", le.str)
	    } else { ##-- not atomic, but vector: #
		mod <- typeof(object)#-- typeof(.) is more precise than mode!
		str1 <- switch(mod,
			       call = " call",
			       language = " language",
			       symbol = " symbol",
			       expression = " ",# "expression(..)" by deparse(.)
			       name = " name",
			       ##not in R:argument = "",# .Argument(.) by deparse(.)
			       ## in R (once):	comment.expression

			       ## default :
			       paste("		#>#>", mod, NULL)
			       )
	    }
#  These are S-PLUS classes not found in R.
# 	} else if (inherits(object,"rts") || inherits(object,"cts")
# 		   || inherits(object,"its")) {
# 	    tsp.a <- tspar(object)
# 	    t.cl <- cl[b.ts <- substring(cl,2,3) == "ts"] # "rts" "cts" or "its"
# 	    ts.kind <- switch(t.cl,
# 			      rts="Regular", cts="Calendar", its="Irregular")
# 	    ## from  print.summary.ts(.) :
# 	    pars <- unlist(sapply(summary(object)$ pars, format,
# 				  nsmall=0, digits=digits.d, justify = "none"))
# 	    if(length(pars)>=4) pars <- pars[-3]
# 	    pars <- paste(abbreviate(names(pars),min=2), pars,
# 			  sep= "=", collapse=", ")
# 	    str1 <- P0(ts.kind, " Time-Series ", le.str, " ", pars, ":")
# 	    v.len <- switch(t.cl,rts=.8, cts=.6, its=.9) * v.len
# 	    class(object) <- if(any(!b.ts)) cl[!b.ts]
# 	    std.attr <- c(std.attr, "tspar")
	} else if(is.ts(object)) {
	    tsp.a <- tsp(object)
	    str1 <- P0(" Time-Series ", le.str, " from ", format(tsp.a[1]),
		       " to ", format(tsp.a[2]), ":")
	    std.attr <- c("tsp","class") #- "names"
	} else if (is.factor(object)) {
	    nl <- length(lev.att <- levels(object))
	    if(!is.character(lev.att)) {# should not happen..
		warning("`object' doesn't have legal levels()!")
		nl <- 0
	    }
	    ord <- is.ordered(object)
	    object <- unclass(object)
	    if(nl) {
		lenl <- cumsum(3 + nchar(lev.att))# level space
		ml <- if(nl <= 1 || lenl[nl] <= 13)
		    nl else which(lenl > 13)[1]
		if((d <- lenl[ml] - if(ml>1)18 else 14) >= 3)# truncate last
		    lev.att[ml] <-
			P0(substring(lev.att[ml],1, nchar(lev.att[ml])-d), "..")
	    }
	    else # nl == 0
		ml <- length(lev.att <- "")

	    lsep <- if(ord) "<" else ","
	    str1 <- P0(if(ord)" Ord.f" else " F",
		       "actor w/ ", nl, " level",if(nl != 1) "s",
		       if(nl) " ",
		       if(nl) P0(pasteCh(lev.att[1:ml]), collapse = lsep),
		       if(ml < nl) P0(lsep,".."), ":")

	    std.attr <- c("levels","class")
	} else if(has.class) {
	    cat("Class", if(length(cl) > 1) "es",
		" '", paste(cl, collapse = "', '"), "' ", sep="")
	    ## If there's a str.<method>, it should have been called before!
	    str(unclass(object),
		max.level = max.level, vec.len = vec.len, digits.d = digits.d,
		indent.str = paste(indent.str,".."), nest.lev = nest.lev + 1,
		nchar.max = nchar.max, give.attr = give.attr, wid=wid)
	    return(invisible())
	} else if(is.atomic(object)) {
	    if((1 == length(a <- attributes(object))) && (names(a) == "names"))
		str1 <- paste(" Named vector", le.str)
	    else {
		##-- atomic / not-vector  "unclassified object" ---
		str1 <- paste(" atomic", le.str)
	    }
	} else {
	    ##-- NOT-atomic / not-vector  "unclassified object" ---
	    ##str1 <- paste(" ??? of length", le, ":")
	    str1 <- paste("length", le)
	}
	##-- end  if else..if else...  {still non-list case}

	##-- This needs some improvement: Not list nor atomic --
	if ((is.language(object) || !is.atomic(object)) && !has.class) {
	    ##-- has.class superfluous --
	    mod <- mode(object)
	    give.mode <- FALSE
	    if (any(mod == c("call", "language", "(", "symbol",
                    "externalptr", "weakref")) || is.environment(object)) {
		##give.mode <- !is.vector(object)#--then it has not yet been done
		object <- deparse(object)
                if(mod == "(") give.mode <- TRUE
		le <- length(object) #== 1, always / depending on char.length ?
		format.fun <- function(x)x
		v.len <- round(.5 * v.len)
	    } else if (mod == "expression") {
		format.fun <- function(x) deparse(as.expression(x))
		v.len <- round(.75 * v.len)
	    } else if (mod == "name"){
		object <- paste(object)#-- show `as' char
	    } else if (mod == "argument"){
		format.fun <- deparse
	    } else {
		give.mode <- TRUE
	    }
	    if(give.mode) str1 <- P0(str1, ', mode "', mod,'":')

	} else if(is.logical(object)) {
	    v.len <- 3 * v.len
	    format.fun <- format
	} else if(is.numeric(object)) {
	    iv.len <- round(2.5 * v.len)
	    if(iSurv <- inherits(object, "Surv"))
		std.attr <- c(std.attr, "class")
	    int.surv <- iSurv || is.integer(object)
	    if(!int.surv) {
		ob <- if(le > iv.len) object[seq(len=iv.len)] else object
		ao <- abs(ob <- ob[!is.na(ob)])
	    }
	    if(int.surv || (all(ao > 1e-10 | ao==0) && all(ao < 1e10| ao==0) &&
			    all(ob == signif(ob, digits.d)))) {
		v.len <- iv.len
		format.fun <- function(x)x
	    } else {
		v.len <- round(1.25 * v.len)
		format.fun <- format
	    }
	} else if(is.complex(object)) {
	    v.len <- round(.75 * v.len)
	    format.fun <- format
	}

	## Not sure, this is ever triggered:
	if(is.na(le)) { warning("'str.default': 'le' is NA !!"); le <- 0}

	if(char.like) {
	    v.len <-
		if(missing(vec.len))
		    max(1,sum(cumsum(3 + if(le>0) nchar(object) else 0) <
			      wid - (4 + 5*nest.lev + nchar(str1))))
	    ## `5*ne..' above is fudge factor
		else round(v.len)
	    ile <- min(le, v.len)
	    if(ile >= 1) { # have LONG char ?!
		nc <- nchar(object[1:ile])
		if(any((ii <- nc > nchar.max)))
		    object[ii] <- P0(substr(object[ii], 1, nchar.max),
				     "| __truncated__")
	    }
	    formObj <- function(x) P0(pasteCh(x), collapse=" ")
	}
	else {
	    if(!exists("format.fun", inherits=TRUE)) #-- define one --
		format.fun <-
		    if(mod == 'num' || mod == 'cplx') format else as.character
	    ## v.len <- max(1,round(v.len))
	    ile <- min(v.len, le)
	    formObj <- function(x) paste(format.fun(x), collapse = " ")
	}

	cat(str1, " ", formObj(if(ile >= 1) object[1:ile] else
			       if(v.len > 0) object),
	    if(le > v.len) " ...", "\n", sep="")

    } ## else (not function nor list)----------------------------------------

    if(give.attr) { ## possible: || has.class && any(cl == 'terms')
	nam <- names(a)
	for (i in seq(len=length(a)))
	    if (all(nam[i] != std.attr)) {# only `non-standard' attributes:
		cat(indent.str, P0('- attr(*, "',nam[i],'")='),sep="")
		str(a[[i]],
		    indent.str= paste(indent.str,".."), nest.lev= nest.lev+1,
		    max.level = max.level, digits.d = digits.d,
		    nchar.max = nchar.max,
		    vec.len = if(nam[i] == "source") 1 else vec.len,
		    give.attr= give.attr, give.length= give.length, wid= wid)
	    }
    }
    invisible()	 ## invisible(object)#-- is SLOOOOW on large objects
}# end of `str.default()'

## An extended `ls()' using str() :
ls.str <- function(pos = 1, pattern, ..., envir = as.environment(pos),
		   mode = "any", max.level = 1, give.attr = FALSE)
{
    n <- length(nms <- ls(..., envir = envir, pattern = pattern))
    r <- character(n)
    for(i in seq(length = n))
	if(exists(nam <- nms[i], envir = envir, mode = mode)) {
	    cat(nam, ": ")
	    r[i] <- nam
	    str(get(nam, envir = envir, mode = mode),
		max.level = max.level, give.attr = give.attr)
	}
    invisible(r)
}

lsf.str <- function(pos = 1, ..., envir = as.environment(pos))
    ls.str(pos = pos, envir = envir, mode = "function", ...)
## Dotplots a la Box, Hunter and Hunter

stripchart <-
function(x, method="overplot", jitter=0.1, offset=1/3, vertical=FALSE,
	 group.names, add = FALSE, at = NULL,
	 xlim=NULL, ylim=NULL, main="", ylab="", xlab="",
	 log="", pch=0, col=par("fg"), cex=par("cex"))
{
    method <- pmatch(method, c("overplot", "jitter", "stack"))[1]
    if(is.na(method) || method==0)
	stop("invalid plotting method")
    groups <-
	if(is.language(x)) {
	    if (inherits(x, "formula") && length(x) == 3) {
		groups <- eval(x[[3]], parent.frame())
		x <- eval(x[[2]], parent.frame())
		split(x, groups)
	    }
	}
	else if(is.list(x)) x
	else if(is.numeric(x)) list(x)
    if(0 == (n <- length(groups)))
	stop("invalid first argument")
    if(!missing(group.names))
	attr(groups, "names") <- group.names
    else if(is.null(attr(groups, "names")))
	attr(groups, "names") <- 1:n
    if(is.null(at))
	at <- 1:n
    else if(length(at) != n)
	stop("`at' must have length = no{groups}, i.e. ",n)
    if(!add) {
	dlim <- c(NA, NA)
	for(i in groups)
	    dlim <- range(dlim, i[is.finite(i)], na.rm = TRUE)
	glim <- c(1,n)# in any case, not range(at)
	if(method == 2) { # jitter
	    glim <- glim + jitter * if(n == 1) c(-5, 5) else c(-2, 2)
	} else if(method == 3) { # stack
	    glim <- glim + if(n == 1) c(-1,1) else c(0, 0.5)
	}
	if(is.null(xlim))
	    xlim <- if(vertical) glim else dlim
	if(is.null(ylim))
	    ylim <- if(vertical) dlim else glim
	plot(xlim, ylim, type="n", ann=FALSE, axes=FALSE, log=log)
	box()
	if(vertical) {
	    if(n > 1) axis(1, at=at, lab=names(groups))
	    axis(2)
	}
	else {
	    axis(1)
	    if(n > 1) axis(2, at=at, lab=names(groups))
	}
    }
    csize <- cex*
	if(vertical) xinch(par("cin")[1]) else yinch(par("cin")[2])
    f <- function(x) seq(length=length(x))
    for(i in 1:n) {
	x <- groups[[i]]
	y <- rep.int(at[i], length(x))
	if(method == 2) ## jitter
	    y <- y + runif(length(y), -jitter, jitter)
	else if(method == 3) { ## stack
	    xg <- split(x, factor(x))
	    xo <- lapply(xg, f)
	    x <- unlist(xg, use.names=FALSE)
	    y <- rep.int(at[i], length(x)) +
		(unlist(xo, use.names=FALSE) - 1) * offset * csize
	}
	if(vertical) points(y, x, col=col[(i - 1)%%length(col) + 1],
			    pch=pch[(i - 1)%%length(pch) + 1], cex=cex)
	else points(x, y, col=col[(i - 1)%%length(col) + 1],
		    pch=pch[(i - 1)%%length(pch) + 1], cex=cex)
    }
    title(main=main, xlab=xlab, ylab=ylab)
}
"structure" <-
    function (.Data, ...)
{
    specials <- c(".Dim", ".Dimnames", ".Names", ".Tsp", ".Label")
    replace <- c("dim", "dimnames", "names", "tsp", "levels")
    attrib <- list(...)
    if(length(attrib) > 0) {
	m <- match(names(attrib), specials)
	ok <- (!is.na(m) & m > 0)
	names(attrib)[ok] <- replace[m[ok]]
	if(any(names(attrib) == "tsp"))
	    attrib$class <- unique(c("ts", attrib$class))
	if(is.numeric(.Data) && any(names(attrib) == "levels"))
	    .Data <- factor(.Data,levels=seq(along=attrib$levels))
	attributes(.Data) <- c(attributes(.Data), attrib)
    }
    return(.Data)
}
strwidth <- function(s, units="user", cex=NULL) {
    .Internal(strwidth(s, pmatch(units, c("user", "figure", "inches")), cex))
}

strheight <- function(s, units="user", cex=NULL) {
    .Internal(strheight(s, pmatch(units, c("user", "figure", "inches")), cex))
}

strwrap <-
function(x, width = 0.9 * getOption("width"), indent = 0, exdent = 0,
         prefix = "", simplify = TRUE) {

    ## Useful variables.
    indentString <- paste(rep.int(" ", indent), collapse = "")
    exdentString <- paste(rep.int(" ", exdent), collapse = "")
    y <- list()                         # return value
    z <- lapply(strsplit(x, "\n[ \t\n]*\n"), strsplit, "[ \t\n]")
    ## Now z[[i]][[j]] is a character vector of all "words" in
    ## paragraph j of x[i].

    for(i in seq(along = z)) {
        yi <- character(0)
        for(j in seq(along = z[[i]])) {
            ## Format paragraph j in x[i].
            words <- z[[i]][[j]]
            nc <- nchar(words)

            ## Remove extra white space unless after a period which
            ## hopefully ends a sentence.
            if(any(nc == 0)) {
                zLenInd <- which(nc == 0)
                zLenInd <- zLenInd[!(zLenInd %in%
                                     (grep("\\.$", words) + 1))]
                if(length(zLenInd) > 0) {
                    words <- words[-zLenInd]
                    nc <- nc[-zLenInd]
                }
            }

            if(length(words) == 0) {
                yi <- c(yi, "", prefix)
                next
            }

            currentIndex <- 0
            lowerBlockIndex <- 1
            upperBlockIndex <- integer(0)
            lens <- cumsum(nc + 1)

            first <- TRUE
            maxLength <- width - nchar(prefix) - indent

            ## Recursively build a sequence of lower and upper indices
            ## such that the words in line k are the ones in the k-th
            ## index block.
            while(length(lens) > 0) {
                k <- max(sum(lens < maxLength), 1)
                if(first) {
                    first <- FALSE
                    maxLength <- maxLength + indent - exdent
                }
                currentIndex <- currentIndex + k
                if(nc[currentIndex] == 0)
                    ## Are we sitting on a space?
                    upperBlockIndex <- c(upperBlockIndex,
                                         currentIndex - 1)
                else
                    upperBlockIndex <- c(upperBlockIndex,
                                         currentIndex)
                if(length(lens) > k) {
                    ## Are we looking at a space?
                    if(nc[currentIndex + 1] == 0) {
                        currentIndex <- currentIndex + 1
                        k <- k + 1
                    }
                    lowerBlockIndex <- c(lowerBlockIndex,
                                         currentIndex + 1)
                }
                if(length(lens) > k)
                    lens <- lens[-(1:k)] - lens[k]
                else
                    lens <- NULL
            }

            nBlocks <- length(upperBlockIndex)
            s <- paste(prefix,
                       c(indentString, rep.int(exdentString, nBlocks - 1)),
                       sep = "")
            for(k in (1 : nBlocks))
                s[k] <- paste(s[k], paste(words[lowerBlockIndex[k] :
                                                upperBlockIndex[k]],
                                          collapse = " "),
                              sep = "")
            yi <- c(yi, s, prefix)
        }
        y <- c(y, list(yi[-length(yi)]))
    }

    if(simplify) y <- unlist(y)
    y
}

formatDL <-
function(x, y, style = c("table", "list"),
         width = 0.9 * getOption("width"), indent = NULL)
{
    if(is.list(x)) {
        if((length(x) == 2) && (diff(sapply(x, length)) == 0)) {
            y <- x[[2]]; x <- x[[1]]
        }
        else
            stop("incorrect value for x")
    }
    else if(is.matrix(x)) {
        if(NCOL(x) == 2) {
            y <- x[, 2]; x <- x[, 1]
        }
        else
            stop("incorrect value for x")
    }
    else if(length(x) != length(y))
        stop("x and y must have the same length")
    x <- as.character(x)
    if(length(x) == 0) return(x)
    y <- as.character(y)

    style <- match.arg(style)

    if(is.null(indent))
        indent <- switch(style, table = width / 3, list = width / 9)
    if(indent > 0.5 * width)
        stop("incorrect values of indent and width")

    indentString <- paste(rep.int(" ", indent), collapse = "")

    if(style == "table") {
        i <- (nchar(x) > indent - 3)
        if(any(i))
            x[i] <- paste(x[i], "\n", indentString, sep = "")
        i <- !i
        if(any(i))
            x[i] <- formatC(x[i], width = indent, flag = "-")
        y <- lapply(strwrap(y, width = width - indent,
                            simplify = FALSE),
                    paste,
                    collapse = paste("\n", indentString, sep = ""))
        r <- paste(x, unlist(y), sep = "")
    }
    else if(style == "list") {
        y <- strwrap(paste(x, ": ", y, sep = ""), exdent = indent,
                     width = width, simplify = FALSE)
        r <- unlist(lapply(y, paste, collapse = "\n"))
    }
    r
}
summaryRprof <- function(filename = "Rprof.out", chunksize = 5000)
{
    rprof <- file(filename)
    open(rprof, "r")
    on.exit(close(rprof))
    head  <-  scan(rprof,  nlines = 1, what = list("", interval=0), sep = "=",
                   quiet = TRUE)

    total <- new.env(hash = TRUE)
    self <- new.env(hash = TRUE)
    inc <- function(f, e){
        if (exists(f, envir = e, inherits = FALSE))
            assign(f, get(f, envir = e)+1, envir = e)
        else
            assign(f, 1, envir = e)
    }
    count <- 0
    repeat({
        chunk <- readLines(rprof, n = chunksize)
        nread <- length(chunk)
        if (nread == 0)
            break
        count <- count+nread
        thelines <- strsplit(chunk, " ")
        lapply(thelines, function (a.line){
            lapply(unique(a.line), inc, e = total)
            inc(a.line[[1]], e = self)
        })
        if (nread < chunksize)
            break
    })
    if(count == 0) stop("no events were recorded")
    totalt <- sapply(ls(envir = total), function(f) get(f, envir = total))
    selft <- sapply(ls(envir = self), function(f) get(f, envir = self))

    digits <- ifelse(head$interval < 1e4, 3, 2)
    totalpct <- round(totalt*100/count, 1)
    selfpct <- round(selft*100/sum(selft), 1)
    totalt <- round(totalt*head$interval/1e6, digits)
    selft <- round(selft*head$interval/1e6, digits)

    combine <- merge(data.frame(self.time = selft, self.pct = selfpct),
                     data.frame(total.time = totalt, total.pct = totalpct),
                     by = 0, all = TRUE)
    row.names(combine) <- combine[, "Row.names"]
    combine <- combine[, -1]
    combine$self.time[is.na(combine$self.time)] <- 0
    combine$self.pct[is.na(combine$self.pct)] <- 0
    list(by.self = combine[order(-combine$self.time), ],
         by.total = combine[order(-combine$total.time), c(3,4,1,2)],
         sampling.time = count * head$interval/1e6)
}

sum <- function(..., na.rm = FALSE)
    .Internal(sum(..., na.rm = na.rm))

min <- function(..., na.rm = FALSE)
    .Internal(min(..., na.rm = na.rm))

max <- function(..., na.rm = FALSE)
    .Internal(max(..., na.rm = na.rm))

prod <- function(..., na.rm = FALSE)
    .Internal(prod(..., na.rm = na.rm))

all <- function(..., na.rm = FALSE)
    .Internal(all(..., na.rm = na.rm))

any <- function(..., na.rm = FALSE)
    .Internal(any(..., na.rm = na.rm))
summary <- function (object, ...) UseMethod("summary")

summary.default <-
    function(object, ..., digits = max(3, getOption("digits") - 3))
{
    if(is.factor(object))
	return(summary.factor(object, ...))
    else if(is.matrix(object))
	return(summary.matrix(object, digits = digits, ...))

    value <- if(is.logical(object))# scalar or array!
	c(Mode = "logical",
          {tb <- table(object, exclude=NULL)# incl. NA s
           if(!is.null(n <- dimnames(tb)[[1]]) && any(iN <- is.na(n)))
               dimnames(tb)[[1]][iN] <- "NA's"
           tb
           })
    else if(is.numeric(object)) {
	nas <- is.na(object)
	object <- object[!nas]
	qq <- quantile(object)
	qq <- signif(c(qq[1:3], mean(object), qq[4:5]), digits)
	names(qq) <- c("Min.", "1st Qu.", "Median", "Mean", "3rd Qu.", "Max.")
	if(any(nas))
	    c(qq, "NA's" = sum(nas))
	else qq
    } else if(is.recursive(object) && !is.language(object) &&
	      (n <- length(object))) {
	sumry <- array("", c(n, 3), list(names(object),
					 c("Length", "Class", "Mode")))
	ll <- numeric(n)
	for(i in 1:n) {
	    ii <- object[[i]]
	    ll[i] <- length(ii)
	    cls <- oldClass(ii)
	    sumry[i, 2] <- if(length(cls)>0) cls[1] else "-none-"
	    sumry[i, 3] <- mode(ii)
	}
	sumry[, 1] <- format(as.integer(ll))
	sumry
    }
    else c(Length= length(object), Class= class(object), Mode= mode(object))
    class(value) <- "table"
    value
}

summary.factor <- function(object, maxsum = 100, ...)
{
    nas <- is.na(object)
    ll <- levels(object)
    if(any(nas)) maxsum <- maxsum - 1
    tbl <- table(object)
    tt <- c(tbl) # names dropped ...
    names(tt) <- dimnames(tbl)[[1]]
    if(length(ll) > maxsum) {
	drop <- maxsum:length(ll)
	o <- sort.list(tt, decreasing = TRUE)
	tt <- c(tt[o[ - drop]], "(Other)" = sum(tt[o[drop]]))
    }
    if(any(nas)) c(tt, "NA's" = sum(nas)) else tt
}

summary.matrix <- function(object, ...)
    summary.data.frame(data.frame(object), ...)

summary.data.frame <-
    function(object, maxsum = 7, digits = max(3, getOption("digits") - 3), ...)
{
    # compute results to full precision.
    z <- lapply(as.list(object), summary, maxsum = maxsum, digits = 12, ...)
    nv <- length(object)
    nm <- names(object)
    lw <- numeric(nv)
    nr <- max(unlist(lapply(z, NROW)))
    for(i in 1:nv) {
        sms <- z[[i]]
        if(is.matrix(sms)) {
            ## need to produce a single column, so collapse matrix
            ## across rows
            cn <- paste(nm[i], gsub("^ +", "", colnames(sms)), sep=".")
            tmp <- format(sms)
            if(nrow(sms) < nr)
                tmp <- rbind(tmp, matrix("", nr - nrow(sms), ncol(sms)))
            sms <- apply(tmp, 1, function(x) paste(x, collapse="  "))
            ## produce a suitable colname: undoing padding
            wid <- sapply(tmp[1,], nchar)
            blanks <- paste(character(max(wid)), collapse = " ")
            pad0 <- floor((wid-nchar(cn))/2); pad1 <- wid - nchar(cn) - pad0
            cn <- paste(substring(blanks, 1, pad0), cn,
                        substring(blanks, 1, pad1), sep = "")
            nm[i] <- paste(cn, collapse="  ")
            z[[i]] <- sms
        } else {
            lbs <- format(names(sms))
            sms <- paste(lbs, ":", format(sms, digits = digits), "  ",
                         sep = "")
            lw[i] <- nchar(lbs[1])
            length(sms) <- nr
            z[[i]] <- sms
        }
    }
    z <- unlist(z, use.names=TRUE)
    dim(z) <- c(nr, nv)
    blanks <- paste(character(max(lw) + 2), collapse = " ")
    pad <- floor(lw-nchar(nm)/2)
    nm <- paste(substring(blanks, 1, pad), nm, sep = "")
    dimnames(z) <- list(rep.int("", nr), nm)
    attr(z, "class") <- c("table") #, "matrix")
    z
}
sunflowerplot <-
    function(x, y = NULL, number, log = "", digits = 6,
             xlab = NULL, ylab = NULL, xlim = NULL, ylim = NULL,
             add = FALSE, rotate = FALSE,
             pch = 16, cex = 0.8, cex.fact =  1.5,
             size = 1/8, seg.col = 2, seg.lwd = 1.5, ...)
{
    ## Argument "checking" as plot.default:
    xlabel <- if (!missing(x)) deparse(substitute(x))
    ylabel <- if (!missing(y)) deparse(substitute(y))
    xy <- xy.coords(x, y, xlabel, ylabel, log)
    if(!add) {
        xlab <- if (is.null(xlab)) xy$xlab else xlab
        ylab <- if (is.null(ylab)) xy$ylab else ylab
        xlim <- if (is.null(xlim)) range(xy$x[is.finite(xy$x)]) else xlim
        ylim <- if (is.null(ylim)) range(xy$y[is.finite(xy$y)]) else ylim
    }
    n <- length(xy$x)
    if(missing(number)) { # Compute number := multiplicities
        ## must get rid of rounding fuzz
        x <- signif(xy$x,digits=digits)
        y <- signif(xy$y,digits=digits)
        orderxy <- order(x, y)
        x <- x[orderxy]
        y <- y[orderxy]
        first <- c(TRUE, (x[-1] != x[-n]) | (y[-1] != y[-n]))
        x <- x[first]
        y <- y[first]
        number <- diff(c((1:n)[first], n + 1))
    } else {
        if(length(number) != n)
            stop("number must have same length as x & y !")
        np <- number > 0
        x <- xy$x[np]
        y <- xy$y[np]
        number <- number[np]
    }
    n <- length(x)
    if(!add)
        plot(x, y, xlab = xlab, ylab = ylab,
             xlim=xlim, ylim=ylim, log=log, type = "n", ...)

    n.is1 <- number == 1
    if(any(n.is1))
        points(x[ n.is1], y[ n.is1], pch = pch, cex = cex)
    if(any(!n.is1)) {
        points(x[!n.is1], y[!n.is1], pch = pch, cex = cex / cex.fact)
        i.multi <- (1:n)[number > 1]
        ppin <- par("pin")
        pusr <- par("usr")
        xr <- size * abs(pusr[2] - pusr[1])/ppin[1]
        yr <- size * abs(pusr[4] - pusr[3])/ppin[2]

        i.rep <- rep.int(i.multi, number[number > 1])
        z <- numeric()
        for(i in i.multi)
            z <- c(z, 1:number[i] + if(rotate) runif(1) else 0)
        deg <- (2 * pi * z)/number[i.rep]
        segments(x[i.rep], y[i.rep],
                 x[i.rep] + xr * sin(deg),
                 y[i.rep] + yr * cos(deg),
                 col=seg.col, lwd = seg.lwd)
    }
    invisible(list(x=x, y=y, number=number))
}
svd <- function(x, nu=min(n,p), nv=min(n,p), LINPACK = FALSE)
{
    x <- as.matrix(x)
    dx <- dim(x)
    n <- dx[1]
    p <- dx[2]
    if(!n || !p) stop("0 extent dimensions")
    if (is.complex(x)) {
        res <- La.svd(x, nu, nv)
        return(list(d = res$d, u = if(nu) res$u, v = if(nv) Conj(t(res$vt))))
    }
    if (!LINPACK) {
        method <- "dgesdd"
        if(!capabilities("IEEE754")) method <- "dgesvd"
        res <- La.svd(x, nu, nv, method)
        return(list(d = res$d, u = if(nu) res$u, v = if(nv) t(res$vt)))
    }
    if(!is.numeric(x))
	stop("argument to svd must be numeric")

    if(nu == 0) {
	job <- 0
	u <- double(0)
    }
    else if(nu == n) {
	job <- 10
	u <- matrix(0, n, n)
    }
    else if(nu == p) {
	job <- 20
	u <- matrix(0, n, p)
    }
    else
	stop("nu must be 0, nrow(x) or ncol(x)")

    job <- job +
	if(nv == 0) 0 else if(nv == p || nv == n) 1 else
    stop("nv must be 0 or ncol(x)")

    v <- if(job == 0) double(0) else matrix(0, p, p)

    mn <- min(n,p)
    mm <- min(n+1,p)
    z <- .Fortran("dsvdc",
		  as.double(x),
		  n,
		  n,
		  p,
		  d=double(mm),
		  double(p),
		  u=u,
		  n,
		  v=v,
		  p,
		  double(n),
		  as.integer(job),
		  info=integer(1),
		  DUP=FALSE, PACKAGE="base")[c("d","u","v","info")]
    if(z$info)
	stop(paste("error ",z$info," in dsvdc"))
    z$d <- z$d[1:mn]
    if(nv && nv < p) z$v <- z$v[, 1:nv, drop = FALSE]
    z[c("d", if(nu) "u", if(nv) "v")]
}
sweep <- function(x, MARGIN, STATS, FUN = "-", ...)
{
    FUN <- match.fun(FUN)
    dims <- dim(x)
    perm <- c(MARGIN, (1:length(dims))[ - MARGIN])
    FUN(x, aperm(array(STATS, dims[perm]), order(perm)), ...)
}
switch <- function(EXPR,...)
    .Internal(switch(EXPR,...))
symbols <-
function (x, y = NULL, circles, squares, rectangles, stars,
	  thermometers, boxplots, inches = TRUE, add = FALSE,
	  fg = 1, bg = NA, xlab = NULL, ylab = NULL, main = NULL,
	  xlim=NULL, ylim=NULL, ...)
{
    count <- 0
    if (!missing(circles)) {
	count <- count + 1
	data <- circles
	type <- 1
    }
    if (!missing(squares)) {
	count <- count + 1
	data <- squares
	type <- 2
    }
    if (!missing(rectangles)) {
	count <- count + 1
	data <- rectangles
	type <- 3
    }
    if (!missing(stars)) {
	count <- count + 1
	data <- stars
	type <- 4
    }
    if (!missing(thermometers)) {
	count <- count + 1
	data <- thermometers
	type <- 5
    }
    if (!missing(boxplots)) {
	count <- count + 1
	data <- boxplots
	type <- 6
    }
    if (count != 1)
	stop("exactly one symbol type must be specified")
    xy <- xy.coords(x, y, xlab = deparse(substitute(x)),
                    ylab = deparse(substitute(y)))
    x <- xy$x; y <- xy$y
    if (!add) {
	if(is.null(xlab)) xlab <- xy$xlab
	if(is.null(ylab)) ylab <- xy$ylab
	if(is.null(xlim)) {
	    ## Expand the range by 20% : wild guess !
	    ## FIXME: better guess: use size of largest symbol...
	    ##	      really would need	 (x, y, type, data, inches) ->
	    ##	      rather an internal symbols.limits()
	    xlim <- range(x, na.rm = TRUE)
	    xlim <- xlim + c(-1, 1) * .10 * diff(xlim)
	}
	if(is.null(ylim)) {
	    ylim <- range(y, na.rm = TRUE)
	    ylim <- ylim + c(-1, 1) * .10 * diff(ylim)
	}
	plot(NA, NA, type="n", xlim=xlim, ylim=ylim,
	     xlab=xlab, ylab=ylab, main=main, ...)
    }
    .Internal(symbols(x, y, type, data, inches, bg, fg, ...))
}
symnum <- function(x, cutpoints = c(  .3,  .6,	 .8,  .9, .95),
		   symbols =	 c(" ", ".", ",", "+", "*", "B"),
		   legend = length(symbols) >= 3,
		   na = "?", eps = 1e-5,
		   corr = missing(cutpoints),
		   show.max = if(corr) "1", show.min = NULL,
		   abbr.colnames = has.colnames,
		   lower.triangular = corr & is.matrix(x),
		   diag.lower.tri = corr & !is.null(show.max))
{
    ## Martin Maechler, 21 Jan 1994; Dedicated to Benjamin Schaad, born that day

    ##--------------- Argument checking -----------------------------
    if(length(x) == 0)
	return(noquote("()"))
    has.na <- any(nax <- is.na(x))
    num.x <- is.numeric(x)## !is.logical(x)
    if(num.x) {
	force(corr) # missingness..
	cutpoints <- sort(cutpoints)
	if(corr) cutpoints <- c(0, cutpoints, 1)
	if(any(duplicated(cutpoints)) ||
	   (corr && (any(cutpoints > 1) || any(cutpoints < 0)) ))
	    stop(paste("'cutpoints' must be unique",
		       if(corr)"in 0 < cuts < 1", ", but are =",
		       paste(format(cutpoints), collapse="|")))
	nc <- length(cutpoints)
	minc <- cutpoints[1]
	maxc <- cutpoints[nc]
	range.msg <- paste("'x' must be between",
			   if(corr) "-1" else format(minc),
			   " and", if(corr) "1" else format(maxc)," !")
	if(corr) x <- abs(x)
	else
	    if(any(x < minc - eps, na.rm=TRUE)) stop(range.msg)
	if (   any(x > maxc + eps, na.rm=TRUE)) stop(range.msg)

	ns <- length(symbols)
	symbols <- as.character(symbols)
	if(any(duplicated(symbols)))
	    stop(paste("'symbols' must be unique, but are =",
		       paste(symbols, collapse="|")))
	if(nc != ns+1)
	    stop(paste("number of cutpoints must be  ONE",
		       if(corr)"LESS" else "MORE", "than number of symbols"))

	iS <- cut(x, breaks=cutpoints, include.lowest=TRUE, labels= FALSE)
	if(any(ii <- is.na(iS))) {
	    ##-- can get 0, if x[i]== minc  --- only case ?
	    iS[which(ii)[abs(x[ii] - minc) < eps]] <- 1#-> symbol[1]
	}
    }
    else if(!is.logical(x))
	stop("`x' must be numeric or logical")
    else  { ## logical x : no need for cut(points)
	if(missing(symbols))		# different default
	    symbols <- c(".","|")
	else if(length(symbols) != 2)
	    stop("must have 2 `symbols' for logical `x' argument")
	iS <- x + 1 # F = 1,  T = 2
    }
    if(has.na) {
	ans <- character(length(iS))
	if((has.na <- is.character(na)))
	    ans[nax] <- na
	ans[!nax] <- symbols[iS[!nax]]
    } else ans <- symbols[iS]
    if(num.x) {
	if(!is.null(show.max)) ans[x >= maxc - eps] <-
	    if(is.character(show.max)) show.max else format(maxc, dig=1)
	if(!is.null(show.min)) ans[x <= minc + eps] <-
	    if(is.character(show.min)) show.min else format(minc, dig=1)
    }
    if(lower.triangular && is.matrix(x))
	ans[!lower.tri(x, diag = diag.lower.tri)] <- ""
    attributes(ans) <- attributes(x)
    if(is.array(ans)&& (rank <- length(dim(x))) >= 2) { # `fix' column names
	has.colnames <- !is.null(dimnames(ans))
	if(!has.colnames) {
	    dimnames(ans) <- vector("list",rank)
	} else {
	    has.colnames <- length(dimnames(ans)[[2]]) > 0
	}
	if((is.logical(abbr.colnames) || is.numeric(abbr.colnames))
	   && abbr.colnames) {
	    dimnames(ans)[[2]] <-
		abbreviate(dimnames(ans)[[2]], minlength= abbr.colnames)
	    ## dropped further abbrev. depending on getOption("width")
	}
	else if(is.null(abbr.colnames) || is.null(dimnames(ans)[[2]]))
	    dimnames(ans)[[2]] <- rep("", dim(ans)[2])
	else if(!is.logical(abbr.colnames)) stop("invalid `abbr.colnames'")
    }
    if(legend) {
	legend <- c(rbind(sapply(cutpoints,format),
			  c(paste("`",symbols,"'",sep=""),"")),
		    if(has.na) paste("	    ## NA: `",na,"'",sep=""))
	attr(ans,"legend") <- paste(legend[-2*(ns+1)], collapse=" ")
    }
    noquote(ans)
}
sys.call <-function(which = 0)
    .Internal(sys.call(which))

sys.calls <-function()
    .Internal(sys.calls())

sys.frame <-function(which = 0)
    .Internal(sys.frame(which))

sys.function <-function(n = 0)
    .Internal(sys.function(n))

sys.frames <-function()
    .Internal(sys.frames())

sys.nframe <- function()
    .Internal(sys.nframe())

sys.parent <- function(n = 1)
    .Internal(sys.parent(n))

sys.parents <- function()
    .Internal(sys.parents())

sys.status <- function()
    list(sys.calls=sys.calls(), sys.parents=sys.parents(), sys.frames=sys.frames())

sys.on.exit <- function()
    .Internal(sys.on.exit())
table <- function (..., exclude = c(NA, NaN),
		   dnn = list.names(...), deparse.level = 1)
{
    list.names <- function(...) {
	l <- as.list(substitute(list(...)))[-1]
	nm <- names(l)
	fixup <- if (is.null(nm)) seq(along = l) else nm == ""
	dep <- sapply(l[fixup], function(x)
	    switch (deparse.level + 1,
		    "", ## 0
		    if (is.symbol(x)) as.character(x) else "", ## 1
		    deparse(x)[1]) ## 2
		      )
	if (is.null(nm))
	    dep
	else {
	    nm[fixup] <- dep
	    nm
	}
    }

    args <- list(...)
    if (length(args) == 0)
	stop("nothing to tabulate")
    if (length(args) == 1 && is.list(args[[1]])) {
	args <- args[[1]]
	if (length(dnn) != length(args))
	    dnn <- if (!is.null(argn <- names(args)))
		 argn
	    else
		 paste(dnn[1], 1:length(args), sep = '.')
    }
    bin <- 0
    lens <- NULL
    dims <- integer(0)
    pd <- 1
    dn <- NULL
    for (a in args) {
	if (is.null(lens)) lens <- length(a)
	else if (length(a) != lens)
	    stop("all arguments must have the same length")
        cat <-
            if (is.factor(a)) {
                if (!missing(exclude)) {
                    ll <- levels(a)
                    factor(a, levels = ll[!(ll %in% exclude)],
                           exclude = if(is.null(exclude)) NULL else NA)
                } else a
            } else factor(a, exclude = exclude)

	nl <- length(ll <- levels(cat))
	dims <- c(dims, nl)
	dn <- c(dn, list(ll))
	## requiring   all(unique(as.integer(cat)) == 1:nlevels(cat))  :
	bin <- bin + pd * (as.integer(cat) - 1)
	pd <- pd * nl
    }
    names(dn) <- dnn
    bin <- bin[!is.na(bin)]
    if (length(bin)) bin <- bin + 1 # otherwise, that makes bin NA
    y <- array(tabulate(bin, pd), dims, dimnames = dn)
    class(y) <- "table"
    y
}

## From  1999-12-19 till 2003-03-27:
## print.table <-
## function(x, digits = getOption("digits"), quote = FALSE, na.print = "", ...)
## {
##     print.default(unclass(x), digits = digits, quote = quote,
## 		  na.print = na.print, ...)
##     ## this does *not* return x !
## }

## Better (NA in dimnames *should* be printed):
print.table <-
function (x, digits = getOption("digits"), quote = FALSE, na.print = "",
	  zero.print = "0",
	  justify = "none", ...)
{
    xx <- format(unclass(x), digits = digits, justify = justify)
    ## na.print handled here
    if(any(ina <- is.na(x)))
	xx[ina] <- na.print
    if(is.integer(x) && zero.print != "0" && any(i0 <- !ina & x == 0))
	## MM thinks this should be an option for many more print methods...
	xx[i0] <- sub("0", zero.print, xx[i0])
    print(xx, quote = quote, ...)
    invisible(x)
}

summary.table <- function(object, ...)
{
    if(!inherits(object, "table"))
	stop("object must inherit from class table")
    n.cases <- sum(object)
    n.vars <- length(dim(object))
    y <- list(n.vars = n.vars,
	      n.cases = n.cases)
    if(n.vars > 1) {
	m <- vector("list", length = n.vars)
	relFreqs <- object / n.cases
	for(k in 1:n.vars)
	    m[[k]] <- apply(relFreqs, k, sum)
	expected <- apply(do.call("expand.grid", m), 1, prod) * n.cases
	statistic <- sum((c(object) - expected)^2 / expected)
	parameter <-
	    prod(sapply(m, length)) - 1 - sum(sapply(m, length) - 1)
	y <- c(y, list(statistic = statistic,
		       parameter = parameter,
		       approx.ok = all(expected >= 5),
		       p.value = pchisq(statistic, parameter, lower.tail=FALSE),
		       call = attr(object, "call")))
    }
    class(y) <- "summary.table"
    y
}

print.summary.table <-
function(x, digits = max(1, getOption("digits") - 3), ...)
{
    if(!inherits(x, "summary.table"))
	stop(paste("x must inherit from class", sQuote("summary.table")))
    if(!is.null(x$call)) {
	cat("Call: "); print(x$call)
    }
    cat("Number of cases in table:", x$n.cases, "\n")
    cat("Number of factors:", x$n.vars, "\n")
    if(x$n.vars > 1) {
	cat("Test for independence of all factors:\n")
	ch <- x$statistic
	cat("\tChisq = ",	format(round(ch, max(0, digits - log10(ch)))),
	    ", df = ",		x$parameter,
	    ", p-value = ",	format.pval(x$p.value, digits, eps = 0),
	    "\n", sep = "")
	if(!x$approx.ok)
	    cat("\tChi-squared approximation may be incorrect\n")
    }
    invisible(x)
}

as.data.frame.table <- function(x, row.names = NULL, optional = FALSE, ...)
{
    x <- as.table(x)
    data.frame(do.call("expand.grid", dimnames(x)), Freq = c(x),
	       row.names = row.names)
}

is.table <- function(x) inherits(x, "table")
as.table <- function(x, ...) UseMethod("as.table")
as.table.default <- function(x, ...)
{
    if(is.table(x))
	return(x)
    else if(is.array(x) || is.numeric(x)) {
	x <- as.array(x)
	if(any(dim(x) == 0))
	    stop("cannot coerce into a table")
	## Try providing dimnames where missing.
	dnx <- dimnames(x)
	if(is.null(dnx))
	    dnx <- vector("list", length(dim(x)))
	for(i in which(sapply(dnx, is.null)))
	    dnx[[i]] <- LETTERS[seq(length = dim(x)[i])]
	dimnames(x) <- dnx
	class(x) <- c("table", oldClass(x))
	return(x)
    }
    else
	stop("cannot coerce into a table")
}

prop.table <- function(x, margin = NULL)
{
    if(length(margin))
	sweep(x, margin, margin.table(x, margin), "/")
    else
	x / sum(x)
}

margin.table <- function(x, margin = NULL)
{
    if(!is.array(x)) stop("x is not an array")
    if (length(margin)) {
	z <- apply(x, margin, sum)
	dim(z) <- dim(x)[margin]
	dimnames(z) <- dimnames(x)[margin]
    }
    else return(sum(x))
    class(z) <- oldClass(x) # avoid adding "matrix"
    z
}

r2dtable <- function(n, r, c) {
    if(length(n) == 0 || (n < 0) || is.na(n))
	stop("invalid argument 'n'")
    if((length(r) <= 1) || any(r < 0) || any(is.na(r)))
	stop("invalid argument 'r'")
    if((length(c) <= 1) || any(c < 0) || any(is.na(c)))
	stop("invalid argument 'c'")
    if(sum(r) != sum(c))
	stop("arguments 'r' and 'c' must have the same sums")
    .Call("R_r2dtable",
	  as.integer(n),
	  as.integer(r),
	  as.integer(c),
	  PACKAGE = "base")
}
tabulate <- function(bin, nbins = max(1,bin))
{
    if(!is.numeric(bin) && !is.factor(bin))
	stop("tabulate: bin must be numeric or a factor")
    .C("R_tabulate",
       as.integer(bin),
       as.integer(length(bin)),
       as.integer(nbins),
       ans = integer(nbins),
       PACKAGE="base")$ans
}
tapply <- function (X, INDEX, FUN=NULL, ..., simplify=TRUE)
{
    FUN <- if (!is.null(FUN)) match.fun(FUN)
    if (!is.list(INDEX)) INDEX <- list(INDEX)
    nI <- length(INDEX)
    namelist <- vector("list", nI)
    names(namelist) <- names(INDEX)
    extent <- integer(nI)
    nx <- length(X)
    one <- as.integer(1)
    group <- rep(one, nx)#- to contain the splitting vector
    ngroup <- one
    for (i in seq(INDEX)) {
	index <- as.factor(INDEX[[i]])
	if (length(index) != nx)
	    stop("arguments must have same length")
	namelist[[i]] <- levels(index)#- all of them, yes !
	extent[i] <- nlevels(index)
	group <- group + ngroup * (as.integer(index) - one)
	ngroup <- ngroup * nlevels(index)
    }
    if (is.null(FUN)) return(group)
    ans <- lapply(split(X, group), FUN, ...)
    index <- as.numeric(names(ans))
    if (simplify && all(unlist(lapply(ans, length)) == 1)) {
	ansmat <- array(dim=extent, dimnames=namelist)
	ans <- unlist(ans, recursive = FALSE)
    }
    else  {
	ansmat <- array(vector("list", prod(extent)),
			dim=extent, dimnames=namelist)
    }
    ## old : ansmat[as.numeric(names(ans))] <- ans
    names(ans) <- NULL
    ansmat[index] <- ans
    ansmat
}





addTaskCallback <- function(f, data = NULL, name = character(0))
{
    if(!is.function(f))
        stop("handler must be a function")
    val <- .Call("R_addTaskCallback", f, data, !missing(data),
                 as.character(name), PACKAGE="base")

    val + 1
}

removeTaskCallback <- function(id)
{
    if(!is.character(id))
        id <- as.integer(id)

    .Call("R_removeTaskCallback", id, PACKAGE="base")
}

getTaskCallbackNames <-
function()
{
    .Call("R_getTaskCallbackNames", PACKAGE="base")
}


taskCallbackManager <-
  #
  #
  #
function(handlers = list(), registered = FALSE, verbose = FALSE)
{
    suspended <- FALSE
    .verbose <- verbose

    add <-
    #
    # this is used to register a callback.
    # It has the same call sequence and semantics
    # as addTaskCallback but provides an optional
    # name by which to identify the element.
    # This can be used to remove the value in the future.
    # The default name is the next available position in the
    # list.
    # The result is stored in the `handlers' list using the
    # name.
    #
    # The element in the list contains the function
    # in the `f' slot,  and optionally a data field
    # to store the `data' argument.
    #
    # This could arrange to register itself using
    # addTaskCallback() if the size of the handlers list
    # becomes 1.
        function(f, data = NULL, name = NULL, register = TRUE)
        {

      # generate default name if none supplied
            if(is.null(name))
                name <- as.character(length(handlers) + 1)

      # Add to handlers, replacing any element with that name
      # if needed.
            handlers[[name]] <<- list(f = f)

      # If data was specified, add this to the new element
      # so that it will be included in the call for this function
            if(!missing(data))
                handlers[[name]][["data"]] <<- data

      # We could arrange to register the evaluate function
      # so that the handlers list would be active. However,
      # we would have to unregister it in the remove()
      # function when there were no handlers.
            if(!registered && register) {
                register()
            }

            name
        }

    remove <- function(which)
    {
        if(is.character(which)) {
            tmp <- (1:length(handlers))[!is.na(match(which, names(handlers)))]
            if(length(tmp))
                stop(paste("No such element", which))
            which <- tmp
        } else
        which <- as.integer(which)

        handlers <<- handlers[-which]

        return(TRUE)
    }


    evaluate <-
    #
    # This is the actual callback that is registered with the C-level
    # mechanism. It is invoked by R when a top-level task is completed.
    # It then calls each of the functions in the handlers list
    # passing these functions the arguments it received and any
    # user-level data for those functions registered in the call to
    # add() via the `data' argument.
    #
    # At the end of the evaluation, any function that returned FALSE
    # is discarded.
        function(expr, value, ok, visible)
        {
            if(suspended)
                return(TRUE)
            discard <- character(0)
            for(i in names(handlers)) {
                h <- handlers[[i]]
                if(length(h) > 1) {
                    val <- h[["f"]](expr, value, ok, visible, i[["data"]])
                } else {
                    val <- h[["f"]](expr, value, ok, visible)
                }
                if(!val) {
                    discard <- c(discard, i)
                }
            }
            if(length(discard) > 0) {
                if(.verbose)
                    cat("Removing", paste(discard, collapse=", "), "\n")
                idx <- is.na(match(names(handlers), discard))
                if(length(idx))
                    handlers <<- handlers[idx]
                else
                    handlers <<- list()
            }
            return(TRUE)
        }

    suspend <-
        function(status = TRUE) {
            suspended <<- status
        }

    register <-
        function(name = "R-taskCallbackManager", verbose = .verbose)
        {
            if(verbose)
                cat("Registering evaluate as low-level callback\n")
            id <- addTaskCallback(evaluate, name = name)
            registered <<- TRUE
            id
        }

    list(add = add,
         evaluate = evaluate,
         remove = remove,
         register = register,
         suspend = suspend,
         callbacks = function()
         handlers
         )
}

tempfile <- function(pattern = "file", tmpdir = tempdir()) .Internal(tempfile(pattern, tmpdir))

tempdir <- function() .Internal(tempdir())
termplot <- function(model, data=NULL,envir=environment(formula(model)),
                     partial.resid=FALSE,
		     rug=FALSE, terms=NULL, se=FALSE, xlabs=NULL, ylabs=NULL,
                     main = NULL, col.term = 2, lwd.term = 1.5,
                     col.se = "orange", lty.se = 2, lwd.se = 1,
                     col.res= "gray", cex = 1, pch = par("pch"),
                     ask = interactive() && nb.fig < n.tms &&
                           .Device != "postscript",
                     use.factor.levels=TRUE,
                     ...)
{
    terms <- ## need if(), since predict.coxph() has non-NULL default terms :
	if (is.null(terms))
	    predict(model, type="terms", se=se)
	else
	    predict(model, type="terms", se=se, terms=terms)
    n.tms <- ncol(tms <- as.matrix(if(se) terms$fit else terms))
    mf <- model.frame(model)
    if (is.null(data))
        data<-eval(model$call$data,envir)
    if (is.null(data))
        data<-mf
    if (NROW(tms)<NROW(data))
        data <- data[ dimnames( tms)[[1]], ]
    nmt <- colnames(tms)
    cn <- parse(text=nmt)
    ## Defaults:
    if (is.null(ylabs))
	ylabs <- paste("Partial for",nmt)
    if (is.null(main))
        main <- ""
    else if(is.logical(main))
        main <- if(main) deparse(model$call, 500) else ""
    else if(!is.character(main))
        stop("`main' must be TRUE, FALSE, NULL or character (vector).")
    main <- rep(main, length = n.tms) # recycling
    pf <- envir
    carrier <- function(term) { # used for non-factor ones
	if (length(term) > 1)
	    carrier(term[[2]])
	else
	    eval(term, data, enclos = pf)
    }
    carrier.name<-function(term){
      	if (length(term) > 1)
	    carrier.name(term[[2]])
	else
	    as.character(term)
    }
    if (is.null(xlabs))
        xlabs<-unlist(lapply(cn,carrier.name))

    if (partial.resid)
	pres <- residuals(model, "partial")
    is.fac <- sapply(nmt, function(i) is.factor(mf[,i]))

    se.lines <- function(x, iy, i, ff = 2) {
        tt <- ff * terms$se.fit[iy,i]
        lines(x, tms[iy,i] + tt, lty=lty.se, lwd=lwd.se, col=col.se)
        lines(x, tms[iy,i] - tt, lty=lty.se, lwd=lwd.se, col=col.se)
    }

    nb.fig <- prod(par("mfcol"))
    if (ask) {
        op <- par(ask = TRUE)
        on.exit(par(op))
    }
    ##---------- Do the individual plots : ----------

    for (i in 1:n.tms) {
	ylims <- range(tms[,i], na.rm=TRUE)
	if (se)
	    ylims <- range(ylims,
			   tms[,i] + 1.05*2*terms$se.fit[,i],
			   tms[,i] - 1.05*2*terms$se.fit[,i], na.rm=TRUE)
	if (partial.resid)
	    ylims <- range(ylims, pres[,i], na.rm=TRUE)
	if (rug)
	    ylims[1] <- ylims[1]-0.07*diff(ylims)

	if (is.fac[i]) {
	    ff <- mf[,nmt[i]]
	    ll <- levels(ff)
	    xlims <- range(seq(along=ll)) + c(-.5, .5)
            xx <- as.numeric(ff) ##need if rug or partial
	    if(rug) {
		xlims[1] <- xlims[1]-0.07*diff(xlims)
		xlims[2] <- xlims[2]+0.03*diff(xlims)
	    }
	    plot(1,0, type = "n", xlab = xlabs[i], ylab = ylabs[i],
                 xlim = xlims, ylim = ylims, main = main[i],xaxt="n", ...)
            if (use.factor.levels)
                axis(1,at=seq(along=ll),labels=ll,...)
            else
                axis(1)
	    for(j in seq(along=ll)) {
		ww <- which(ff==ll[j])[c(1,1)]
		jf <- j + c(-.4, .4)
		lines(jf,tms[ww,i], col=col.term, lwd=lwd.term, ...)
		if(se) se.lines(jf, iy=ww, i=i)
	    }
	}
	else { ## continuous carrier
	    xx <- carrier(cn[[i]])
	    xlims <- range(xx,na.rm=TRUE)
	    if(rug)
		xlims[1] <- xlims[1]-0.07*diff(xlims)
	    oo <- order(xx)
	    plot(xx[oo], tms[oo,i], type = "l", xlab = xlabs[i], ylab = ylabs[i],
		 xlim = xlims, ylim = ylims, main = main[i],
                 col=col.term, lwd=lwd.term, ...)
            if(se) se.lines(xx[oo], iy=oo, i=i)
	}
	if (partial.resid)
	    points(xx, pres[,i], cex = cex, pch = pch, col = col.res)
	if (rug) {
            n <- length(xx)
            ## Fixme: Isn't this a kludge for segments() ?
	    lines(rep.int(jitter(xx), rep.int(3,n)),
                  rep.int(ylims[1] + c(0,0.05,NA)*diff(ylims), n))
	    if (partial.resid)
		lines(rep.int(xlims[1] + c(0,0.05,NA)*diff(xlims), n),
                      rep.int(pres[,i], rep.int(3,n)))
	}
    }
    invisible(n.tms)
}
text <- function(x, ...) UseMethod("text")

text.default <-
function(x, y = NULL, labels = seq(along = x),
         adj = NULL, pos = NULL, offset = 0.5,
         vfont = NULL, cex = 1, col = NULL, font = NULL, xpd = NULL, ...) {
    if (!missing(y) && (is.character(y) || is.expression(y))) {
	labels <- y; y <- NULL
    }
    if (!is.null(vfont))
        vfont <- c(typeface = pmatch(vfont[1], Hershey$typeface) - 1,
                   fontindex= pmatch(vfont[2], Hershey$fontindex))
    .Internal(text(xy.coords(x,y, recycle = TRUE),
		   labels, adj, pos, offset, vfont,
		   cex, col, font, xpd, ...))
}

Hershey <-
    list(typeface =
         c("serif", "sans serif", "script",
           "gothic english", "gothic german", "gothic italian",
           "serif symbol", "sans serif symbol"),
         fontindex =
         c("plain", "italic", "bold", "bold italic",
           "cyrillic", "oblique cyrillic", "EUC"),
## List of valid combinations : ../man/Hershey.Rd
## *checking* of allowed combinations is done in
## (via max{#}) in    FixupVFont() ../../../main/plot.c
## The basic "table" really is in  ../../../modules/vfonts/g_fontdb.c

         allowed = rbind(cbind(1, 1:8), cbind(2, 1:5), cbind(3,1:4),
                         cbind(4:6, 1), cbind(7, 1:5), cbind(8,1:3))
         )
system.time <- function(expr) {
    if(!exists("proc.time")) return(rep(NA, 5))
    loc.frame <- parent.frame()
    on.exit(cat("Timing stopped at:", proc.time() - time, "\n"))
    expr <- substitute(expr)
    time <- proc.time()
    eval(expr, envir = loc.frame)
    new.time <- proc.time()
    on.exit()
    if(length(new.time) == 3)	new.time <- c(new.time, 0, 0)
    if(length(time) == 3)	time	 <- c(	  time, 0, 0)
    new.time - time
}
unix.time <- system.time

date <- function().Internal(date())
title <- function(main=NULL, sub=NULL, xlab=NULL, ylab=NULL,
                  line=NA, outer=FALSE, ...)
.Internal(title(main, sub, xlab, ylab, line, outer, ...))
#functions to convert their first argument to strings
toString <- function(x, ...)
    UseMethod("toString")

toString.default <- function(x, width, ...) {
  string <- paste(x, collapse=", ")
  if( missing(width) )
    return( string )
  if( width <= 0 )
    stop("width must be positive")
  if(nchar(string) > width) {
    if(width < 6)
      width <- 6  ## Leave something!
    string <- paste(substring(string, 1, width-4), "....", sep="")
  }
  string
}

traceback <- function()
{
    if (exists(".Traceback", env = .GlobalEnv))
	.Traceback <- get(".Traceback", env = .GlobalEnv)
    else .Traceback <- NULL
    if(is.null(.Traceback) || length(.Traceback) == 0)
        cat("No traceback available\n")
    else {
        n <- length(.Traceback)
        for(i in 1:n) {
            label <- paste(n-i+1, ": ", sep="")
            if((m <- length(.Traceback[[i]])) > 1)
                label <- c(label, rep(substr("          ", 1, nchar(label)),
                                      m - 1))
            cat(paste(label, .Traceback[[i]], sep=""), sep="\n")
        }
    }
    invisible()
}
## Commented by KH on 1999/01/30.
## trunc() should really be in the `Math' group.

##trunc <- function(x, ...) UseMethod("trunc")
##trunc.default <- function(x) {
##    a <- attributes(x)
##    x <- ifelse(x < 0, ceiling(x), floor(x))
##    attributes(x) <- a
##    x
##}
start	  <- function(x, ...) UseMethod("start")
end	  <- function(x, ...) UseMethod("end")
frequency <- function(x, ...) UseMethod("frequency")
time	  <- function(x, ...) UseMethod("time")
window	  <- function(x, ...) UseMethod("window")
cycle     <- function(x, ...) UseMethod("cycle")
deltat    <- function(x, ...) UseMethod("deltat")

options(ts.eps = 1e-5)   # default as S

ts <- function(data = NA, start = 1, end = numeric(0), frequency = 1,
	       deltat = 1, ts.eps  =  getOption("ts.eps"),
               class = if(nseries > 1) c("mts", "ts") else "ts",
               names = if(!is.null(dimnames(data))) colnames(data)
               else paste("Series", seq(nseries))
               )
{
    if(is.data.frame(data)) data <- data.matrix(data)
#   if(!is.numeric(data)) stop("`data'  must be a numeric vector or matrix")
    if(is.matrix(data)) {
	nseries <- ncol(data)
	ndata <- nrow(data)
        dimnames(data) <- list(NULL, names)
    } else {
	nseries <- 1
	ndata <- length(data)
    }
    if(ndata == 0) stop("ts object must have one or more observations")

    if(missing(frequency)) frequency <- 1/deltat
    else if(missing(deltat)) deltat <- 1/frequency

    if(frequency > 1 && abs(frequency - round(frequency)) < ts.eps)
	frequency <- round(frequency)

    if(length(start) > 1) {
## strange: this never checked for < 1!  commented for 1.7.0
##	if(start[2] > frequency) stop("invalid start")
	start <- start[1] + (start[2] - 1)/frequency
    }
    if(length(end) > 1) {
##	if(end[2] > frequency) stop("invalid end")
	end <- end[1] + (end[2] - 1)/frequency
    }
    if(missing(end))
	end <- start + (ndata - 1)/frequency
    else if(missing(start))
	start <- end - (ndata - 1)/frequency

    if(start > end) stop("start cannot be after end")
    nobs <- floor((end - start) * frequency + 1.01)

    if(nobs != ndata)
	data <-
	    if(NCOL(data) == 1) {
		if(ndata < nobs) rep(data, length = nobs)
		else if(ndata > nobs) data[1:nobs]
	    } else {
		if(ndata < nobs) data[rep(1:ndata, length = nobs), ]
		else if(ndata > nobs) data[1:nobs, ]
	    }
    ## FIXME: The following "attr<-"() calls C tspgets() which uses a
    ##  	fixed equivalent of ts.eps := 1e-5
    attr(data, "tsp") <- c(start, end, frequency) #-- order is fixed
    if(!is.null(class) && class != "none") attr(data, "class") <- class
    data
}

tsp <- function(x) attr(x, "tsp")

"tsp<-" <- function(x, value)
{
    cl <- oldClass(x)
    attr(x, "tsp") <- value # does error-checking internally
    if (inherits(x, "ts") && is.null(value))
        class(x) <- if(!identical(cl,"ts")) cl["ts" != cl]
    else if (inherits(x, "mts") && is.null(value))
        class(x) <- if(!identical(cl,"mts")) cl["mts" != cl]
    x
}

hasTsp <- function(x)
{
    if(is.null(attr(x, "tsp")))
        attr(x, "tsp") <- c(1, NROW(x), 1)
    x
}

is.ts <- function (x) inherits(x, "ts") && length(x)

as.ts <- function (x)
{
    if (is.ts(x)) x
    else if(!is.null(xtsp <- tsp(x))) ts(x, xtsp[1], xtsp[2], xtsp[3])
    else ts(x)
}

.cbind.ts <- function(sers, nmsers, dframe = FALSE, union = TRUE)
{
    nulls <- sapply(sers, is.null)
    sers <- sers[!nulls]
    nser <- length(sers)
    if(nser == 0) return(NULL)
    if(nser == 1)
        if(dframe) return(as.data.frame(sers[[1]])) else return(sers[[1]])
    tsser <-  sapply(sers, function(x) length(tsp(x)) > 0)
    if(!any(tsser))
        stop("no time series supplied")
    sers <- lapply(sers, as.ts)
    nsers <- sapply(sers, NCOL)
    tsps <- sapply(sers[tsser], tsp)
    freq <- mean(tsps[3,])
    if(max(abs(tsps[3,] - freq)) > getOption("ts.eps")) {
        stop("Not all series have the same frequency")
    }
    if(union) {
        st <- min(tsps[1,])
        en <- max(tsps[2,])
    } else {
        st <- max(tsps[1,])
        en <- min(tsps[2,])
        if(st > en) {
            warning("Non-intersecting series")
            return(NULL)
        }
    }
    p <- c(st, en, freq)
    n <- round(freq * (en - st) + 1)
    if(any(!tsser)) {
        ln <- lapply(sers[!tsser], NROW)
        if(any(ln != 1 && ln != n))
            stop("non-time series not of the correct length")
        for(i in (1:nser)[!tsser]) {
            sers[[i]] <- ts(sers[[i]], start=st, end=en, frequency=freq)
        }
        tsps <- sapply(sers, tsp)
    }
    if(dframe) {
        x <- vector("list", nser)
        names(x) <- nmsers
    } else {
        ns <- sum(nsers)
        x <- matrix(, n, ns)
        cs <- c(0, cumsum(nsers))
        nm <- character(ns)
        for(i in 1:nser)
            if(nsers[i] > 1) {
                cn <- colnames(sers[[i]])
                if(is.null(cn)) cn <- 1:nsers[i]
                nm[(1+cs[i]):cs[i+1]] <- paste(nmsers[i], cn, sep=".")
            } else nm[cs[i+1]] <- nmsers[i]
        dimnames(x) <- list(NULL, nm)
    }
    for(i in 1:nser) {
        if(union) {
            xx <-
                if(nsers[i] > 1)
                    rbind(matrix(NA, round(freq * (tsps[1,i] - st)), nsers[i]),
                          sers[[i]],
                          matrix(NA, round(freq * (en - tsps[2,i])), nsers[i]))
                else
                    c(rep.int(NA, round(freq * (tsps[1,i] - st))), sers[[i]],
                      rep.int(NA, round(freq * (en - tsps[2,i]))))
        } else {
            xx <- window(sers[[i]], st, en)
        }
        if(dframe) x[[i]] <- structure(xx, tsp=p, class="ts")
        else x[, (1+cs[i]):cs[i+1]] <- xx
    }
    if(dframe) as.data.frame(x)
    else ts(x, start=st, freq=freq)
}

Ops.ts <- function(e1, e2)
{
    if(missing(e2)) {
        ## univariate operator
        NextMethod(.Generic)
    } else if(any(nchar(.Method) == 0)) {
        ## one operand is not a ts
        NextMethod(.Generic)
    } else {
        nc1 <- NCOL(e1)
        nc2 <- NCOL(e2)
        ## use ts.intersect to align e1 and e2
        e12 <- .cbind.ts(list(e1, e2),
                         c(deparse(substitute(e1))[1],
                           deparse(substitute(e2))[1]),
                         union = FALSE)
        e1 <- if(is.matrix(e1)) e12[, 1:nc1, drop = FALSE] else e12[, 1]
        e2 <- if(is.matrix(e2)) e12[, nc1 + (1:nc2), drop = FALSE]
        else e12[, nc1 + 1]
        NextMethod(.Generic)
    }
}

cbind.ts <- function(..., deparse.level = 1) {
    if(deparse.level != 1) .NotYetUsed("deparse.level != 1")
    makeNames <- function(...) {
        l <- as.list(substitute(list(...)))[-1]
        nm <- names(l)
        fixup <- if(is.null(nm)) seq(along = l) else nm == ""
        ## <NOTE>
        dep <- sapply(l[fixup], function(x) deparse(x)[1])
        ## We could add support for `deparse.level' here by creating dep
        ## as in list.names() inside table().  But there is a catch: we
        ## need deparse.level = 2 to get the `usual' deparsing when the
        ## method is invoked by the generic ...
        ## </NOTE>
        if(is.null(nm)) return(dep)
        if(any(fixup)) nm[fixup] <- dep
        nm
    }
    .cbind.ts(list(...), makeNames(...), dframe = FALSE, union = TRUE)
}

diff.ts <- function (x, lag = 1, differences = 1, ...)
{
    if (lag < 1 | differences < 1)
        stop("Bad value for lag or differences")
    if (lag * differences >= NROW(x)) return(x[0])
    ## <FIXME>
    ## lag() and its default method are defined in package ts, so we
    ## need to provide our own implementation.
    tsLag <- function(x, k = 1) {
        p <- tsp(x)
        tsp(x) <- p - (k/p[3]) * c(1, 1, 0)
        x
    }
    r <- x
    for (i in 1:differences) {
        r <- r - tsLag(r, -lag)
    }
    xtsp <- attr(x, "tsp")
    if(is.matrix(x)) colnames(r) <- colnames(x)
    ts(r, end = xtsp[2], freq = xtsp[3])
}

na.omit.ts <- function(object, ...)
{
    tm <- time(object)
    xfreq <- frequency(object)
    ## drop initial and final NAs
    if(is.matrix(object))
        good <- which(apply(!is.na(object), 1, all))
    else  good <- which(!is.na(object))
    if(!length(good)) stop("all times contain an NA")
    omit <- integer(0)
    n <- NROW(object)
    st <- min(good)
    if(st > 1) omit <- c(omit, 1:(st-1))
    en <- max(good)
    if(en < n) omit <- c(omit, (en+1):n)
    cl <- attr(object, "class")
    if(length(omit)) {
        object <- if(is.matrix(object)) object[st:en,] else object[st:en]
        attr(omit, "class") <- "omit"
        attr(object, "na.action") <- omit
        tsp(object) <- c(tm[st], tm[en], xfreq)
        if(!is.null(cl)) class(object) <- cl
    }
    if(any(is.na(object))) stop("time series contains internal NAs")
    object
}

is.mts <- function (x) inherits(x, "mts")

start.default <- function(x, ...)
{
    ts.eps <- getOption("ts.eps")
    tsp <- attr(hasTsp(x), "tsp")
    is <- tsp[1]*tsp[3]
    if(abs(tsp[3] - round(tsp[3])) < ts.eps &&
       abs(is - round(is)) < ts.eps) {
	is <- floor(tsp[1]+ts.eps)
	fs <- floor(tsp[3]*(tsp[1] - is)+0.001)
	c(is,fs+1)
    }
    else tsp[1]
}

end.default <- function(x, ...)
{
    ts.eps <- getOption("ts.eps")
    tsp <- attr(hasTsp(x), "tsp")
    is <- tsp[2]*tsp[3]
    if(abs(tsp[3] - round(tsp[3])) < ts.eps &&
       abs(is - round(is)) < ts.eps) {
	is <- floor(tsp[2]+ts.eps)
	fs <- floor(tsp[3]*(tsp[2] - is)+0.001)
	c(is, fs+1)
    }
    else tsp[2]
}

frequency.default <- function(x, ...)
    if(!is.null(xtsp <- attr(x, "tsp"))) xtsp[3] else 1

deltat.default <- function(x, ...)
    if(!is.null(xtsp <- attr(x, "tsp"))) 1/xtsp[3] else 1

time.default <- function (x, offset = 0, ...)
{
    n <- if(is.matrix(x)) nrow(x) else length(x)
    xtsp <- attr(hasTsp(x), "tsp")
    y <- seq(xtsp[1], xtsp[2], length = n) + offset/xtsp[3]
    tsp(y) <- xtsp
    y
}

time.ts <- function (x, ...) as.ts(time.default(x, ...))

cycle.default <- function(x, ...)
{
    p <- tsp(hasTsp(x))
    m <- round((p[1] %% 1) * p[3])
    x <- (1:NROW(x) + m - 1) %% p[3] + 1
    tsp(x) <- p
    x
}

cycle.ts <- function (x, ...) as.ts(cycle.default(x, ...))

print.ts <- function(x, calendar, ...)
{
    x.orig <- x
    x <- as.ts(x)
    fr.x <- frequency(x)
    if(missing(calendar))
	calendar <- any(fr.x == c(4,12))
    if(!calendar)
        header <- function(x) {
            if((fr.x <- frequency(x))!= 1)
                cat("Time Series:\nStart =", deparse(start(x)),
                    "\nEnd =", deparse(end(x)),
                    "\nFrequency =", deparse(fr.x), "\n")
            else
                cat("Time Series:\nStart =", format(tsp(x)[1]),
                    "\nEnd =", format(tsp(x)[2]),
                    "\nFrequency =", deparse(fr.x), "\n")
        }
    if(NCOL(x) == 1) { # could be 1-col matrix
        if(calendar) {
            if(fr.x > 1) {
                dn2 <-
                    if(fr.x == 12) month.abb
                    else if(fr.x == 4) {
                        c("Qtr1", "Qtr2", "Qtr3", "Qtr4")
                    } else paste("p", 1:fr.x, sep = "")
                if(NROW(x) <= fr.x && start(x)[1] == end(x)[1]) {
                    ## not more than one period
                    dn1 <- start(x)[1]
                    dn2 <- dn2[1 + (start(x)[2] - 2 + seq(along=x))%%fr.x]
                    x <- matrix(format(x, ...), nrow = 1 , byrow = TRUE,
                                dimnames = list(dn1, dn2))
                } else { # more than one period
                    start.pad <- start(x)[2] - 1
                    end.pad <- fr.x - end(x)[2]
                    dn1 <- start(x)[1]:end(x)[1]
                    x <- matrix(c(rep.int("", start.pad), format(x, ...),
                                  rep.int("", end.pad)), nc =  fr.x, byrow = TRUE,
                                dimnames = list(dn1, dn2))
                }
            } else { ## fr.x == 1
                tx <- time(x)
                attributes(x) <- NULL
                names(x) <- tx
            }
        } else { ##-- no `calendar' --
            header(x)
            attr(x, "class") <- attr(x, "tsp") <- attr(x, "na.action") <- NULL
        }
    } else { # multi-column matrix
	if(calendar && fr.x > 1) {
	    tm <- time(x)
	    t2 <- 1 + round(fr.x*((tm+0.001) %%1))
	    p1 <- format(floor(tm))# yr
	    rownames(x) <-
		if(fr.x == 12)
		    paste(month.abb[t2], p1, sep=" ")
		else
		    paste(p1, if(fr.x == 4) c("Q1", "Q2", "Q3", "Q4")[t2]
			      else format(t2),
			  sep=" ")
        } else {
            if(!calendar) header(x)
            rownames(x) <- format(time(x))
        }
        attr(x, "class") <- attr(x, "tsp") <- attr(x, "na.action") <- NULL
    }
    NextMethod("print", x, quote = FALSE, right = TRUE, ...)
    invisible(x.orig)
}

plot.ts <- function(x, y = NULL, plot.type = c("multiple", "single"),
                    xy.labels, xy.lines, panel = lines, nc, ...)
{
    plotts <-
        function (x, y = NULL, plot.type = c("multiple", "single"),
                  xy.labels, xy.lines, panel = lines, oma = c(6, 0, 5, 0), nc,
                  xlabel, ylabel,
                  type = "l", xlim = NULL, ylim = NULL,
                  xlab = "Time", ylab, log = "",
                  col = par("col"), bg = NA,
                  pch = par("pch"), cex = par("cex"),
                  lty = par("lty"), lwd = par("lwd"),
                  axes = TRUE, frame.plot = axes, ann = par("ann"),
                  main = NULL, ...)
    {
        plot.type <- match.arg(plot.type)
        nser <- NCOL(x)

        if(plot.type == "multiple" && nser > 1) {
            addmain <- function(main, cex.main=par("cex.main"),
                                font.main=par("font.main"),
                                col.main=par("col.main"), ...)
                mtext(main, 3, 3, cex=cex.main, font=font.main, col=col.main, ...)

            panel <- match.fun(panel)
            nser <- NCOL(x)
            if(nser > 10) stop("Can't plot more than 10 series")
            if(is.null(main)) main <- xlabel
            nm <- colnames(x)
            if(is.null(nm)) nm <- paste("Series", 1:nser)
            if(missing(nc)) nc <- if(nser >  4) 2 else 1
            oldpar <- par("mar", "oma", "mfcol")
            on.exit(par(oldpar))
            par(mar = c(0, 5.1, 0, 2.1), oma = oma)
            nr <- ceiling(nser / nc)
            par(mfcol = c(nr, nc))
            for(i in 1:nser) {
                plot.default(x[, i], axes = FALSE, xlab="", ylab="",
                     log = log, col = col, bg = bg, pch = pch, ann = ann,
                     type = "n", ...)
                panel(x[, i], col = col, bg = bg, pch = pch, type=type, ...)
                box()
                axis(2, xpd=NA)
                mtext(nm[i], 2, 3)
                if(i%%nr==0 || i==nser) axis(1, xpd=NA)
            }
            if(ann) {
                mtext(xlab, 1, 3, ...)
                if(!is.null(main)) {
                    par(mfcol=c(1,1))
                    addmain(main, ...)
                }
            }
            return(invisible())
        }
        ## end of multiple plot section

        x <- as.ts(x)
        if(!is.null(y)) {
            ## want ("scatter") plot of y ~ x
            y <- hasTsp(y)
            if(NCOL(x) > 1 || NCOL(y) > 1)
                stop("scatter plots only for univariate time series")
            if(is.ts(x) && is.ts(y)){
                xy <- ts.intersect(x, y)
                xy <- xy.coords(xy[,1], xy[,2], xlabel, ylabel, log)
            } else
            xy <- xy.coords(x, y, xlabel, ylabel, log)
            xlab <- if (missing(xlab)) xy$xlab else xlab
            ylab <- if (missing(ylab)) xy$ylab else ylab
            xlim <- if (is.null(xlim)) range(xy$x[is.finite(xy$x)]) else xlim
            ylim <- if (is.null(ylim)) range(xy$y[is.finite(xy$y)]) else ylim
            n <- length(xy $ x)           #-> default for xy.l(ines|abels)
            if(missing(xy.labels)) xy.labels <- (n <= 150)
            if(!is.logical(xy.labels)) {
                if(!is.character(xy.labels))
                    stop("`xy.labels' must be logical or character")
                do.lab <- TRUE
            } else do.lab <- xy.labels

            ptype <-
                if(do.lab) "n" else if(missing(type)) "p" else type
            plot.default(xy, type = ptype,
                         xlab = xlab, ylab = ylab,
                         xlim = xlim, ylim = ylim, log = log, col = col, bg = bg,
                         pch = pch, axes = axes, frame.plot = frame.plot,
                         ann = ann, main = main, ...)
            if(missing(xy.lines)) xy.lines <- do.lab
            if(do.lab)
                text(xy, labels =
                     if(is.character(xy.labels)) xy.labels
                     else if(all(tsp(x) == tsp(y))) formatC(time(x), wid = 1)
                     else seq(along = x),
                     col = col, cex = cex)
            if(xy.lines)
                lines(xy, col = col, lty = lty, lwd = lwd,
                      type = if(do.lab) "c" else "l")
            return(invisible())
        }
        ## Else : no y, only x

        if(missing(ylab)) {
            ylab <- colnames(x)
            if(length(ylab) != 1)
                ylab <- xlabel
        }
        ## using xy.coords() mainly for the log treatment
        if(is.matrix(x)) {
            k <- ncol(x)
            tx <- time(x)
            xy <- xy.coords(x = matrix(rep.int(tx, k), ncol = k),
                            y = x, log=log)
            xy$x <- tx
        }
        else xy <- xy.coords(x, NULL, log=log)
        if(is.null(xlim)) xlim <- range(xy$x)
        if(is.null(ylim)) ylim <- range(xy$y[is.finite(xy$y)])
        plot.new()
        plot.window(xlim, ylim, log, ...)
        if(is.matrix(x)) {
            for(i in seq(length=k))
                lines.default(xy$x, x[,i],
                              col = col[(i-1) %% length(col) + 1],
                              lty = lty[(i-1) %% length(lty) + 1],
                              lwd = lwd[(i-1) %% length(lwd) + 1],
                              bg  =	 bg[(i-1) %% length(bg)	 + 1],
                              pch = pch[(i-1) %% length(pch) + 1],
                              type = type)
        }
        else {
            lines.default(xy$x, x, col = col[1], bg = bg, lty = lty[1],
                          lwd = lwd[1], pch = pch[1], type = type)
        }
        if (ann)
            title(main = main, xlab = xlab, ylab = ylab, ...)
        if (axes) {
            axis(1, ...)
            axis(2, ...)
        }
        if (frame.plot) box(...)
    }
    xlabel <- if (!missing(x)) deparse(substitute(x)) else NULL
    ylabel <- if (!missing(y)) deparse(substitute(y))else NULL
    plotts(x = x, y = y, plot.type = plot.type,
           xy.labels = xy.labels, xy.lines = xy.lines,
           panel = panel, nc = nc, xlabel = xlabel, ylabel = ylabel, ...)
}

lines.ts <- function(x, ...)
    lines.default(time(as.ts(x)), x, ...)


window.default <- function(x, start = NULL, end = NULL,
                           frequency = NULL, deltat = NULL,
                           extend = FALSE, ...)
{
    x <- hasTsp(x)
    xtsp <- tsp(x)
    xfreq <- xtsp[3]
    xtime <- time(x)
    ts.eps <- getOption("ts.eps")

    if(!is.null(frequency) && !is.null(deltat) &&
       abs(frequency*deltat - 1) > ts.eps)
        stop("frequency and deltat are both supplied and are inconsistent")
    if (is.null(frequency) && is.null(deltat)) yfreq <- xfreq
    else if (is.null(deltat)) yfreq <- frequency
    else if (is.null(frequency)) yfreq <- 1/deltat
    if (yfreq > 0 && xfreq%%yfreq < ts.eps) {
        thin <- round(xfreq/yfreq)
        yfreq <- xfreq/thin
    } else {
        thin <- 1
        yfreq <- xfreq
        warning("Frequency not changed")
    }
    start <- if(is.null(start))
	xtsp[1]
    else switch(length(start),
		start,
		start[1] + (start[2] - 1)/xfreq,
		stop("Bad value for start"))
    if(start < xtsp[1] && !extend) {
	start <- xtsp[1]
	warning("start value not changed")
    }

    end <- if(is.null(end))
	xtsp[2]
    else switch(length(end),
		end,
		end[1] + (end[2] - 1)/xfreq,
		stop("Bad value for end"))
    if(end > xtsp[2] && !extend) {
	end <- xtsp[2]
	warning("end value not changed")
    }

    if(start > end)
	stop("start cannot be after end")

    if(!extend) {
        if(all(abs(start - xtime) > abs(start) * ts.eps))
            start <- xtime[(xtime > start) & ((start + 1/xfreq) > xtime)]

        if(all(abs(end - xtime) > abs(end) * ts.eps))
            end <- xtime[(xtime < end) & ((end - 1/xfreq) < xtime)]

        i <- seq(trunc((start - xtsp[1]) * xfreq + 1.5),
                 trunc((end - xtsp[1]) * xfreq + 1.5), by = thin)
        y <- if(is.matrix(x)) x[i, , drop = FALSE] else x[i]
        ystart <- xtime[i[1]]
        yend <- xtime[i[length(i)]]
        attr(y, "tsp") <- c(ystart, yend, yfreq)
    } else {
        ## first adjust start and end to the time base
        stoff <- ceiling((start - xtsp[1]) * xfreq - ts.eps)
        ystart <- xtsp[1] + stoff/xfreq
        enoff <- floor((end - xtsp[2]) * xfreq + ts.eps)
        yend <- xtsp[2] + enoff/xfreq
        nold <- round(xfreq*(xtsp[2] - xtsp[1])) + 1
        i <- c(rep.int(nold+1, max(0, -stoff)),
                   (1+max(0, stoff)):(nold + min(0, enoff)),
                   rep.int(nold+1, max(0, enoff)))
        y <- if(is.matrix(x)) rbind(x, NA)[i, , drop = FALSE] else c(x, NA)[i]
        attr(y, "tsp") <- c(ystart, yend, xfreq)
        if(yfreq != xfreq) y <- Recall(y, frequency = yfreq)
    }
    y
}

window.ts <- function (x, ...) as.ts(window.default(x, ...))

"[.ts" <- function (x, i, j, drop = TRUE) {
    y <- NextMethod("[")
    if (missing(i))
	ts(y, start = start(x), freq = frequency(x))
#     else {
#         if(is.matrix(i)) return(y)
# 	n <- if (is.matrix(x)) nrow(x) else length(x)
# 	li <- length(ind <- (1:n)[i])
#         if(li == 0) return(numeric(0))
#         if(li == 1) {
#             tsp(y) <- c(start(x), start(x), frequency(x))
#             class(y) <- class(x)
#             return(y)
#         }
# 	if (length(unique(ind[-1] - ind[-li])) != 1) {
# 	    warning("Not returning a time series object")
# 	} else {
# 	    xtsp <- tsp(x)
# 	    xtimes <- seq(from = xtsp[1], to = xtsp[2], by = 1 / xtsp[3])
# 	    ytsp <- xtimes[range(ind)]
# 	    tsp(y) <- c(ytsp, (li - 1) / (ytsp[2] - ytsp[1]))
#             class(y) <- class(x)
# 	}
# 	y
#     }
    else y
}

t.ts <- function(x) {
    cl <- oldClass(x)
    other <- !(cl %in% c("ts","mts"))
    class(x) <- if(any(other)) cl[other]
    attr(x, "tsp") <- NULL
    t(x)
}
cm <- function(x) 2.54*x

xinch <- function(x=1, warn.log=TRUE) {
    if(warn.log && par("xlog")) warning("x log scale:  xinch() is non-sense")
    x * diff(par("usr")[1:2])/par("pin")[1]
}
yinch <- function(y=1, warn.log=TRUE) {
    if(warn.log && par("ylog")) warning("y log scale:  yinch() is non-sense")
    y * diff(par("usr")[3:4])/par("pin")[2]
}

xyinch <- function(xy=1, warn.log=TRUE) {
    if(warn.log && (par("xlog") || par("ylog")))
	warning("log scale:  xyinch() is non-sense")
    u <- par("usr"); xy * c(u[2]-u[1], u[4]-u[3]) / par("pin")
}
unlist <- function(x, recursive=TRUE, use.names=TRUE)
    .Internal(unlist(x, recursive, use.names))
unname <- function (obj, force= FALSE) {
    if (length(names(obj)))
        names(obj) <- NULL
    if (length(dimnames(obj)) && (force || !is.data.frame(obj)))
        dimnames(obj) <- NULL
    obj
}
update.default <-
    function (object, formula., ..., evaluate = TRUE)
{
    call <- object$call
    if (is.null(call))
	stop("need an object with call component")
    extras <- match.call(expand.dots = FALSE)$...
    if (!missing(formula.))
	call$formula <- update.formula(formula(object), formula.)
    if(length(extras) > 0) {
	existing <- !is.na(match(names(extras), names(call)))
	## do these individually to allow NULL to remove entries.
	for (a in names(extras)[existing]) call[[a]] <- extras[[a]]
	if(any(!existing)) {
	    call <- c(as.list(call), extras[!existing])
	    call <- as.call(call)
	}
    }
    if(evaluate) eval(call, parent.frame())
    else call
}

update.formula <- function (old, new, ...) {
    env <- environment(as.formula(old))
    tmp <- .Internal(update.formula(as.formula(old), as.formula(new)))
    out <- formula(terms.formula(tmp, simplify = TRUE))
    environment(out) <- env
    return(out)
}
upper.tri <- function(x, diag = FALSE)
{
    x <- as.matrix(x)
    if(diag) row(x) <= col(x)
    else row(x) < col(x)
}
mat.or.vec <- function(nr,nc)
    if(nc==1) numeric(nr) else matrix(0,nr,nc)

## Use  'version' since that exists in all S dialects :
is.R <-
    function() exists("version") && !is.null(vl <- version$language) && vl == "R"

vcov <- function(object, ...) UseMethod("vcov")

vcov.glm <- function(object, ...)
{
    so <- summary.glm(object, corr=FALSE, ...)
    so$dispersion * so$cov.unscaled
}

vcov.lm <- function(object, ...)
{
    so <- summary.lm(object, corr=FALSE)
    so$sigma^2 * so$cov.unscaled
}

vcov.coxph <- vcov.survreg <- function (object, ...) object$var

vcov.gls <- function (object, ...) object$varBeta

vcov.lme <- function (object, ...) object$varFix
vector <- function(mode = "logical", length = 0).Internal(vector(mode,length))
logical <- function(length = 0) vector("logical", length)
character <- function(length = 0) vector("character", length)
integer <- function(length = 0) vector("integer", length)
double <- function(length = 0) vector("double", length)
real <- double
numeric <- double
complex <- function(length.out = 0,
		    real = numeric(), imaginary = numeric(),
		    modulus = 1, argument = 0) {
    if(missing(modulus) && missing(argument)) {
	## assume 'real' and 'imaginary'
	.Internal(complex(length.out, real, imaginary))
    } else {
	n <- max(length.out, length(argument), length(modulus))
	rep(modulus,length.out=n) *
	    exp(1i * rep(argument, length.out=n))
    }
}

single <- function(length = 0)
    structure(vector("double", length), Csingle=TRUE)
vignette <-
function(topic, package = NULL, lib.loc = NULL)
{
    if(is.null(package))
        package <- .packages(all.available = TRUE, lib.loc)
    paths <- .find.package(package, lib.loc)

    ## Find the directories with a 'doc' subdirectory *possibly*
    ## containing vignettes.

    paths <- paths[tools::fileTest("-d", file.path(paths, "doc"))]

    vignettes <-
        lapply(paths, 
               function(dir) {
                   tools::listFilesWithType(file.path(dir, "doc"),
                                            "vignette")
               })

    if(!missing(topic)) {
        topic <- topic[1]               # Just making sure ...
        vignettes <- as.character(unlist(vignettes))
        idx <-
            which(tools::filePathSansExt(basename(vignettes)) == topic)
        if(length(idx)) {
            f <- sub("\\.[[:alpha:]]+$", ".pdf", vignettes[idx])
            f <- f[tools::fileTest("-f", f)]
            if(length(f) > 1) {
                ## <FIXME>
                ## Should really offer a menu to select from.
                f <- f[1]
                warning(paste("vignette ", sQuote(topic),
                              " found more than once,\n",
                              "using the one found in ",
                              sQuote(dirname(f)),
                              sep = ""),
                        call. = FALSE)
                ## </FIXME>
            }
            if(length(f)) {
                ## <FIXME>
                ## Should really abstract this into a BioC style
                ## openPDF() along the lines of browseURL() ...
                if(.Platform$OS == "windows")
                    shell.exec(f)
                else
                    system(paste(Sys.getenv("R_PDFVIEWER"), f, "&"))
                ## </FIXME>
            }
            else
                warning(paste("vignette", sQuote(topic), "has no PDF"),
                        call. = FALSE)
        }
        else
            warning(paste("vignette", sQuote(topic), "*not* found"),
                    call. = FALSE)
    }

    if(missing(topic)) {
        ## List all possible vignettes.

        vDB <- matrix(character(0), nr = 0, nc = 4)
        colnames(vDB) <- c("Dir", "File", "Title", "PDF")

        for(db in vignettes[sapply(vignettes, length) > 0]) {
            dir <- dirname(dirname(db[1]))
            entries <- NULL
            ## Check for new-style 'Meta/vignette.rds' ...
            if(file.exists(INDEX <-
                           file.path(dir, "Meta", "vignette.rds"))) {
                entries <- .readRDS(INDEX)
            }
            else {
                ## ... if not found, let tools:::.buildVignetteIndex()
                ## do the job, including worrying about old-style
                ## 'doc/00Index.dcf' files.
                ## <FIXME>
                ## Currently not exported, should it be?
                entries <-
                    tools:::.buildVignetteIndex(file.path(dir, "doc"))
                ## </FIXME>
            }
            if(NROW(entries) > 0)
                vDB <-
                    rbind(vDB,
                          cbind(Dir = I(dir),
                                entries[c("File", "Title", "PDF")]))
        }

        ## Now compute info on available PDFs ...
        title <- if(NROW(vDB) > 0) {
            paste(vDB[, "Title"],
                  paste(rep.int("(source", NROW(vDB)),
                        ifelse(vDB[, "PDF"] != "", ", pdf", ""),
                        ")",
                        sep = ""))
        }
        else
            character()
        ## ... and rewrite into the form used by packageIQR.
        db <- cbind(Package = basename(vDB[, "Dir"]),
                    LibPath = dirname(vDB[, "Dir"]),
                    Item = tools::filePathSansExt(basename(vDB[, "File"])),
                    Title = title)

        y <- list(type = "vignette", title = "Vignettes", header = NULL,
                  results = db, footer = NULL)
        class(y) <- "packageIQR"
        return(y)
    }
}
warnings <- function(...)
{
    if(!exists("last.warning") || !(n <- length(last.warning)))
	return()
    names <- names(last.warning)
    cat("Warning message", if(n > 1)"s", ":\n", sep="")
    for(i in 1:n) {
	out <- if(n == 1) names[i] else paste(i,": ", names[i], sep="")
	if(length(last.warning[[i]])) {
	    temp <- deparse(last.warning[[i]])
	    out <- paste(out, "in:", temp[1], if(length(temp) > 1) " ...")
	}
	cat(out, ..., fill = TRUE)
    }
}
which <- function(x, arr.ind = FALSE)
{
    if(!is.logical(x))
	stop("argument to \"which\" is not logical")
    wh <- seq(along=x)[ll <- x & !is.na(x)]
    if ((m <- length(wh)) > 0) {
	dl <- dim(x)
	if (is.null(dl) || !arr.ind) {
	    names(wh) <- names(x)[ll]
	}
	else { ##-- return a matrix  length(wh) x rank
	    rank <- length(dl)
	    wh1 <- wh - 1
	    wh <- 1 + wh1 %% dl[1]
	    wh <- matrix(wh, nrow = m, ncol = rank,
			 dimnames =
			 list(dimnames(x)[[1]][wh],
			      if(rank == 2) c("row", "col")# for matrices
			      else paste("dim", 1:rank, sep="")))
	    if(rank >= 2) {
		denom <- 1
		for (i in 2:rank) {
		    denom <- denom * dl[i-1]
		    nextd1 <- wh1 %/% denom# (next dim of elements) - 1
		    wh[,i] <- 1 + nextd1 %% dl[i]
		}
	    }
	    storage.mode(wh) <- "integer"
	}
    }
    wh
}

which.min <- function(x) .Internal(which.min(x))
which.max <- function(x) .Internal(which.max(x))

write <- function(x, file="data",ncolumns=if(is.character(x)) 1 else 5, append=FALSE)
    cat(x, file=file, sep=c(rep.int(" ",ncolumns-1), "\n"), append=append)
write.table <-
function (x, file = "", append = FALSE, quote = TRUE, sep = " ",
    eol = "\n", na = "NA", dec = ".", row.names = TRUE,
    col.names = TRUE, qmethod = c("escape", "double"))
{
    qmethod <- match.arg(qmethod)

    if(!is.data.frame(x))
	x <- data.frame(x)
    else if(is.logical(quote) && quote)
	quote <- which(unlist(lapply(x, function(x)
                                     is.character(x) || is.factor(x))))
    if(dec != ".") {
        ## only need to consider numeric non-integer columns
    	num <- which(unlist(lapply(x, is.double)))
	if(length(num))
           x[num] <- lapply(x[num],
                            function(z) gsub("\\.", ",", as.character(z)))
    }
    i <- is.na(x)
    x <- as.matrix(x)
    if(any(i))
        x[i] <- na
    p <- ncol(x)
    d <- dimnames(x)

    if(is.logical(quote))
	quote <- if(quote) 1 : p else NULL
    else if(is.numeric(quote)) {
	if(any(quote < 1 | quote > p))
	    stop(paste("invalid numbers in", sQuote("quote")))
    }
    else
	stop(paste("invalid", sQuote("quote"), "specification"))

    rn <- FALSE
    if(is.logical(row.names)) {
	if(row.names) {
	    x <- cbind(d[[1]], x)
            rn <- TRUE
        }
    }
    else {
	row.names <- as.character(row.names)
	if(length(row.names) == nrow(x))
	    x <- cbind(row.names, x)
	else
	    stop(paste("invalid", sQuote("row.names"),
                       "specification"))
    }
    if(!is.null(quote) && (p < ncol(x)))
	quote <- c(0, quote) + 1

    if(is.logical(col.names))
        col.names <- if(is.na(col.names) && rn) c("", d[[2]])
        else if(col.names) d[[2]] else NULL
    else {
	col.names <- as.character(col.names)
	if(length(col.names) != p)
	    stop(paste("invalid", sQuote("col.names"), "specification"))
    }

    if(file == "")
        file <- stdout()
    else if(is.character(file)) {
        file <- file(file, ifelse(append, "a", "w"))
        on.exit(close(file))
    }
    if(!inherits(file, "connection"))
        stop(paste("argument", sQuote("file"),
                   "must be a character string or connection"))

    if(!is.null(col.names)) {
	if(append)
	    warning("appending column names to file")
	if(!is.null(quote))
	    col.names <- paste("\"", col.names, "\"", sep = "")
        writeLines(paste(col.names, collapse = sep), file, sep = eol)
    }

    qstring <-                          # quoted embedded quote string
        switch(qmethod,
               "escape" = '\\\\"',
               "double" = '""')
    for(i in quote)
	x[, i] <- paste('"', gsub('"', qstring, as.character(x[, i])),
                        '"', sep = "")

    writeLines(paste(c(t(x)), c(rep.int(sep, ncol(x) - 1), eol),
                     sep = "", collapse = ""),
               file, sep = "")
}
xor <- function(x, y) { (x | y) & !(x & y) }
xtabs <- function(formula = ~., data = parent.frame(), subset,
		  na.action, exclude = c(NA, NaN), drop.unused.levels = FALSE)
{
    if(!missing(formula) && !inherits(formula, "formula"))
	stop("formula is incorrect")
    if(any(attr(terms(formula), "order") > 1))
	stop("interactions are not allowed")
    m <- match.call(expand.dots = FALSE)
    if(is.matrix(eval(m$data, parent.frame())))
	m$data <- as.data.frame(data)
    m$... <- m$exclude <- m$drop.unused.levels <- NULL
    m[[1]] <- as.name("model.frame")
    mf <- eval(m, parent.frame())
    if(length(formula) == 2) {
	by <- mf
	y <- NULL
    }
    else {
	i <- attr(attr(mf, "terms"), "response")
	by <- mf[-i]
	y <- mf[[i]]
    }
    by <- lapply(by, function(u) {
	if(!is.factor(u)) u <- factor(u, exclude = exclude)
	u[ , drop = drop.unused.levels]
    })
    x <-
	if(is.null(y))
	    do.call("table", by)
	else if(NCOL(y) == 1)
	    tapply(y, by, sum)
	else {
	    z <- lapply(as.data.frame(y), tapply, by, sum)
	    array(unlist(z),
		  dim = c(dim(z[[1]]), length(z)),
		  dimnames = c(dimnames(z[[1]]), list(names(z))))
	}
    x[is.na(x)] <- 0
    class(x) <- c("xtabs", "table")
    attr(x, "call") <- match.call()
    x
}

print.xtabs <- function(x, ...)
{
    ox <- x
    attr(x, "call") <- NULL
    print.table(x, ...)
    invisible(ox)
}
## the obvious analog of  xy.coords() -- in ./plot.R

xyz.coords <- function(x, y, z, xlab=NULL, ylab=NULL, zlab=NULL,
		       log = NULL, recycle = FALSE)
{
    ## Only x
    if(is.null(y)) {
	if (is.language(x)) {
	    if (inherits(x, "formula") && length(x) == 3
		&& length(rhs <- x[[3]]) == 3) {
		zlab <- deparse(x[[2]])
		ylab <- deparse(rhs[[3]])
		xlab <- deparse(rhs[[2]])
		pf <- parent.frame()
		z <- eval(x[[2]],   environment(x), pf)
		y <- eval(rhs[[3]], environment(x), pf)
		x <- eval(rhs[[2]], environment(x), pf)
	    }
	    else stop("invalid first argument [bad language]")
	}
	else if(is.matrix(x) || is.data.frame(x)) {
	    x <- data.matrix(x)
	    if(ncol(x) < 2) stop("at least 2 columns needed")
	    if(ncol(x) == 2) {
		xlab <- "Index"
		y <- x[,1]
		z <- x[,2]
		x <- seq(along=y)
	    }
	    else { ## >= 3 columns
		colnames <- dimnames(x)[[2]]
		if(is.null(colnames)) {
		    zlab <- paste(xlab,"[,3]",sep="")
		    ylab <- paste(xlab,"[,2]",sep="")
		    xlab <- paste(xlab,"[,1]",sep="")
		}
		else {
		    xlab <- colnames[1]
		    ylab <- colnames[2]
		    zlab <- colnames[3]
		}
		y <- x[,2]
		z <- x[,3]
		x <- x[,1]
	    }
	}
	else if(is.list(x)) {
	    zlab <- paste(xlab,"$z",sep="")
	    ylab <- paste(xlab,"$y",sep="")
	    xlab <- paste(xlab,"$x",sep="")
	    y <- x[["y"]]
	    z <- x[["z"]]
	    x <- x[["x"]]
	}
    }

    ## Only x, y
    if(!is.null(y) && is.null(z)) {
	if(is.complex(x)) {
	    z <- y
	    y <- Im(x)
	    x <- Re(x)
	    zlab <- ylab
	    ylab <- paste("Im(", xlab, ")", sep="")
	    xlab <- paste("Re(", xlab, ")", sep="")
	}
	else if(is.complex(y)) {
	    z <- x
	    x <- Re(y)
	    y <- Im(y)
	    zlab <- xlab
	    xlab <- paste("Re(", ylab, ")", sep="")
	    ylab <- paste("Im(", ylab, ")", sep="")
	}
	else {
	    if(is.factor(x)) x <- as.numeric(x)
	    if(is.factor(y)) y <- as.numeric(y)
	    xlab <- "Index"
	    z <- y
	    y <- x
	    x <- seq(along=x)
	}
    }

    ## Lengths and recycle
    if(((xl <- length(x)) != length(y)) || (xl != length(z))) {
	if(recycle) {
	    ml <- max(xl, (yl <- length(y)), (zl <- length(z)))
	    if(xl < ml) x <- rep(x, length=ml)
	    if(yl < ml) y <- rep(y, length=ml)
	    if(zl < ml) z <- rep(z, length=ml)
	}
	else stop("x, y and z lengths differ")
    }

    ## log
    if(length(log) && log != "") {
	log <- strsplit(log, NULL)[[1]]
	o.msg <- " <= 0 omitted from logarithmic plot"
	if("x" %in% log && any(ii <- x <= 0 & !is.na(x))) {
	    n <- sum(ii)
	    warning(paste(n, " x value", if(n>1)"s", o.msg, sep=""))
	    x[ii] <- NA
	}
	if("y" %in% log && any(ii <- y <= 0 & !is.na(y))) {
	    n <- sum(ii)
	    warning(paste(n, " y value", if(n>1)"s", o.msg, sep=""))
	    y[ii] <- NA
	}
	if("z" %in% log && any(ii <- z <= 0 & !is.na(z))) {
	    n <- sum(ii)
	    warning(paste(n, " z value", if(n>1)"s", o.msg, sep=""))
	    z[ii] <- NA
	}
    }
    list(x=as.real(x), y=as.real(y), z=as.real(z),
	 xlab=xlab, ylab=ylab, zlab=zlab)
}
zapsmall <- function(x, digits = getOption("digits"))
{
    if (length(digits) == 0)
        stop("invalid digits")
    if (all(ina <- is.na(x)))
        return(x)
    mx <- max(abs(x[!ina]))
    round(x, digits = if(mx > 0) max(0, digits - log10(mx)) else digits)
}
## needs to run after paste()
{
    .leap.seconds <-
        c("1972-6-30", "1972-12-31", "1973-12-31", "1974-12-31",
          "1975-12-31", "1976-12-31", "1977-12-31", "1978-12-31",
          "1979-12-31", "1981-6-30", "1983-6-30", "1985-6-30",
          "1986-6-30", "1987-12-31", "1989-12-31", "1990-12-31",
          "1992-6-30", "1993-6-30", "1994-6-30","1995-12-31",
          "1997-6-30", "1998-12-31")
    .leap.seconds <- strptime(paste(.leap.seconds , "23:59:60"),
                              "%Y-%m-%d %H:%M:%S")
    .leap.seconds <- as.POSIXct(.leap.seconds, "GMT")
}
## Need to ensure this comes late enough ...
## Perhaps even merge it into the common profile?

.dynLibs <- local({
    ## <NOTE>
    ## Versions of R prior to 1.4.0 had .Dyn.libs in .AutoloadEnv
    ## (and did not always ensure getting it from there).
    ## Until 1.6.0, we consistently used the base environment.
    ## Now we have a dynamic variable instead.
    ## </NOTE>
    .Dyn.libs <- character(0)
    function(new) {
        if(!missing(new))
            .Dyn.libs <<- new
        else
            .Dyn.libs
    }
})

.libPaths <- local({
    .lib.loc <- character(0)            # Profiles need to set this.
    function(new) {
        if(!missing(new))
            .lib.loc <<- unique(c(new, .Library))
        else
            .lib.loc
    }
})
Rprof <- function(filename = "Rprof.out", append = FALSE, interval = 0.02)
{
    if(is.null(filename)) filename <- ""
    invisible(.Internal(Rprof(filename, append, interval)))
}

dev2bitmap <- function(file, type="png256", height=6, width=6, res=72,
                       pointsize, ...)
{
    if(missing(file)) stop("`file' is missing with no default")
    if(!is.character(file) || nchar(file) == 0)
        stop("`file' is must be a non-empty character string")
    gsexe <- Sys.getenv("R_GSCMD")
    if(is.null(gsexe) || nchar(gsexe) == 0) {
        gsexe <- "gs"
        rc <- system(paste(gsexe, "-help > /dev/null"))
        if(rc != 0) stop("Sorry, gs cannot be found")
    }
    gshelp <- system(paste(gsexe, "-help"), intern=TRUE)
    st <- grep("^Available", gshelp)
    en <- grep("^Search", gshelp)
    gsdevs <- gshelp[(st+1):(en-1)]
    devs <- c(strsplit(gsdevs, " "), recursive=TRUE)
    if(match(type, devs, 0) == 0)
        stop(paste(paste("Device ", type, "is not available"),
                   "Available devices are",
                   paste(gsdevs, collapse="\n"), sep="\n"))
    if(missing(pointsize)) pointsize <- 1.5*min(width, height)
    tmp <- tempfile("Rbit")
    on.exit(unlink(tmp))
    din <- par("din"); w <- din[1]; h <- din[2]
    if(missing(width) && !missing(height)) width <- w/h * height
    if(missing(height) && !missing(width)) height <- h/w * width

    current.device <- dev.cur()
    dev.off(dev.copy(device = postscript, file=tmp, width=width,
                     height=height,
                     pointsize=pointsize, paper="special",
                     horizontal=FALSE, ...))
    dev.set(current.device)
    cmd <- paste(gsexe, " -dNOPAUSE -dBATCH -q -sDEVICE=", type,
                 " -r", res,
                 " -g", ceiling(res*width), "x", ceiling(res*height),
                 " -sOutputFile=", file, " ", tmp, sep="")
    system(cmd)
    invisible()
}

bitmap <- function(file, type="png256", height=6, width=6, res=72,
                   pointsize, ...)
{
    if(missing(file)) stop("`file' is missing with no default")
    if(!is.character(file) || nchar(file) == 0)
        stop("`file' is must be a non-empty character string")
    gsexe <- Sys.getenv("R_GSCMD")
    if(is.null(gsexe) || nchar(gsexe) == 0) {
        gsexe <- "gs"
        rc <- system(paste(gsexe, "-help > /dev/null"))
        if(rc != 0) stop("Sorry, gs cannot be found")
    }
    gshelp <- system(paste(gsexe, "-help"), intern=TRUE)
    st <- grep("^Available", gshelp)
    en <- grep("^Search", gshelp)
    gsdevs <- gshelp[(st+1):(en-1)]
    devs <- c(strsplit(gsdevs, " "), recursive=TRUE)
    if(match(type, devs, 0) == 0)
        stop(paste(paste("Device ", type, "is not available"),
                   "Available devices are",
                   paste(gsdevs, collapse="\n"), sep="\n"))
    if(missing(pointsize)) pointsize <- 1.5*min(width, height)
    cmd <- paste("|", gsexe, " -dNOPAUSE -dBATCH -q -sDEVICE=", type,
                 " -r", res,
                 " -g", ceiling(res*width), "x", ceiling(res*height),
                 " -sOutputFile=", file, " -", sep="")
    postscript(file=cmd, width=width, height=height,
               pointsize=pointsize, paper="special", horizontal=FALSE, ...)
    invisible()
}

png <- function(filename = "Rplot%03d.png",
                width=480, height=480, pointsize=12,
                gamma = 1, colortype = getOption("X11colortype"),
                maxcubesize = 256, bg = "white")
    .Internal(X11(paste("png::", filename, sep=""),
                  width, height, pointsize, gamma,
                  colortype, maxcubesize, bg))

jpeg <- function(filename = "Rplot%03d.jpeg",
                 width=480, height=480, pointsize=12,
                 quality = 75,
                 gamma = 1, colortype = getOption("X11colortype"),
                 maxcubesize = 256, bg = "white")
    .Internal(X11(paste("jpeg::", quality, ":", filename, sep=""),
                  width, height, pointsize, gamma,
                  colortype, maxcubesize, bg))
download.file <- function(url, destfile, method,
                          quiet = FALSE, mode = "w", cacheOK = TRUE)
{
    method <- if (missing(method))
        ifelse(!is.null(getOption("download.file.method")),
               getOption("download.file.method"),
               "auto")
    else
        match.arg(method, c("auto", "internal", "wget", "lynx"))

    if(method == "auto") {
        if(capabilities("http/ftp"))
            method <- "internal"
        else if(length(grep("^file:", url)))
            method <- "internal"
        else if(system("wget --help > /dev/null")==0)
            method <- "wget"
        else if(system("lynx -help > /dev/null")==0)
            method <- "lynx"
        else
            stop("No download method found")
    }
    if(method == "internal")
        status <- .Internal(download(url, destfile, quiet, mode, cacheOK))
    else if(method == "wget") {
        extra <- if(quiet) " --quiet" else ""
        if(!cacheOK) extra <- paste(extra, "--cache=off")
        status <- system(paste("wget", extra, " '", url,
                               "' -O", path.expand(destfile), sep=""))
    } else if(method == "lynx")
        status <- system(paste("lynx -dump '", url, "' >",
                               path.expand(destfile), sep=""))

    if(status > 0)
        warning("Download had nonzero exit status")

    invisible(status)
}

nsl <- function(hostname)
    .Internal(nsl(hostname))
### NOTE: This is for Unix only (cf. ../{mac,windows}/help.R)

help <- function(topic, offline = FALSE, package = .packages(),
                 lib.loc = NULL, verbose = getOption("verbose"),
                 try.all.packages = getOption("help.try.all.packages"),
                 htmlhelp = getOption("htmlhelp"),
                 pager = getOption("pager"))
{
    htmlhelp <- is.logical(htmlhelp) && htmlhelp
    if (!missing(package))
        if (is.name(y <- substitute(package)))
            package <- as.character(y)
    if (!missing(topic)) {
        ischar<-try(is.character(topic), silent=TRUE)
        if (inherits(ischar, "try-error")) ischar<-FALSE
        if (!ischar) topic <- deparse(substitute(topic))
        # for cmd/help ..
        if (!is.na(match(topic, c("+", "-", "*", "/", "^", "%%"))))
            topic <- "Arithmetic"
        else if (!is.na(match(topic, c("<", ">", "<=", ">=", "==", "!="))))
            topic <- "Comparison"
        else if (!is.na(match(topic, c("[", "[[", "$"))))
            topic <- "Extract"
        else if (!is.na(match(topic, c("&", "&&", "|", "||", "!"))))
            topic <- "Logic"
        else if (!is.na(match(topic, c("%*%"))))
            topic <- "matmult"
        type <- if(offline) "latex" else if (htmlhelp) "html" else "help"
        INDICES <- .find.package(package, lib.loc, verbose = verbose)
        file <- index.search(topic, INDICES, "AnIndex", type)
        if (length(file) && file != "") {
            if (verbose)
                cat("\t\t\t\t\t\tHelp file name ",
                    sQuote(paste(basename(file), ".Rd", sep = "")),
                    "\n", sep = "")
            if (!offline) {
                if (htmlhelp) {
                    if(file.exists(file)) {
                        ofile <- file
                        base.pos <- match("package:base", search())
                        ## We need to use the version in per-session dir
                        ## if we can.
                        lnkfile <-
                            file.path(tempdir(), ".R",
                                      "library", package, "html",
                                      paste(topic, "html", sep="."))
                        if (any(ex <- file.exists(lnkfile))) {
                            lnkfile <- lnkfile[ex]
                            file <- lnkfile[1] # could be more than one
                        }
                        if (file == ofile) {
                            warning("Using non-linked HTML file: style sheet and hyperlinks may be incorrect")
                        }
                        file <- paste("file://", file, sep = "")
                        if(is.null(browser <- getOption("browser")))
                            stop("options(\"browser\") not set")
                        browseURL(file)
                        cat("help() for",topic, " is shown in browser",browser,
                            "...\nUse\t help(",topic,", htmlhelp=FALSE)\nor\t",
                            "options(htmlhelp = FALSE)\nto revert.\n")
                        return(invisible())
                    } else {
                        if(verbose)
                            cat("no HTML help for", sQuote(topic),
                                "is available\n", sep = "")
                        file <- index.search(topic, INDICES, "AnIndex", "help")
                    }
                }
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                ## end of experimental code
                if(file.exists(zfile))
                    file.show(zfile,
                              title = paste("R Help on", sQuote(topic)),
                              delete.file = (zfile != file),
                              pager = pager)
                else
                    stop(paste("The help file for", sQuote(topic),
                               "is missing"))
                return(invisible())
            }
            else {
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                if(zfile != file) on.exit(unlink(zfile))
                ## end of experimental code
                if(file.exists(zfile)) {
                    FILE <- tempfile()
                    on.exit(unlink(FILE))
                    cat("\\documentclass[",
                        getOption("papersize"),
                        "paper]{article}",
                        "\n",
                        "\\usepackage[",
                        Sys.getenv("R_RD4DVI"),
                        "]{Rd}",
                        "\n",
                        "\\InputIfFileExists{Rhelp.cfg}{}{}\n",
                        "\\begin{document}\n",
                        file = FILE, sep = "")
                    file.append(FILE, zfile)
                    cat("\\end{document}\n",
                        file = FILE, append = TRUE)
                    ## <NOTE>
                    ## We now have help-print.sh in share/sh but we do
                    ## not use the .Script mechanism because we play
                    ## with the TEXINPUTS environment variable and not
                    ## all systems can be assumed to support Sys.putenv().
                    system(paste(paste("TEXINPUTS=",
                                       file.path(R.home(), "share",
                                                 "texmf"),
                                       ":",
                                       "$TEXINPUTS",
                                       sep = ""),
                                 "/bin/sh",
                                 file.path(R.home(), "share", "sh",
                                           "help-print.sh"),
                                 FILE,
                                 topic,
                                 getOption("latexcmd"),
                                 getOption("dvipscmd")))
                    ## </NOTE>
                    return(invisible())
                }
                else
                    stop(paste("No offline documentation for", topic,
                               "is available"))
            }
        }
        else {
            if(is.null(try.all.packages) || !is.logical(try.all.packages))
                try.all.packages <- FALSE
            if(try.all.packages && missing(package) && missing(lib.loc)) {
                ## try all the remaining packages
                lib.loc <- .libPaths()
                packages <- .packages(all.available = TRUE,
                                      lib.loc = lib.loc)
                packages <- packages[is.na(match(packages, .packages()))]
                pkgs <- libs <- character(0)
                for (lib in lib.loc)
                    for (pkg in packages) {
                        INDEX <- system.file(package = pkg, lib.loc = lib)
                        file <- index.search(topic, INDEX, "AnIndex", "help")
                        if(length(file) && file != "") {
                            pkgs <- c(pkgs, pkg)
                            libs <- c(libs, lib)
                        }
                    }
                if(length(pkgs) == 1) {
                    writeLines(c(paste("  topic", sQuote(topic),
                                       "is not in any loaded package"),
                                 paste("  but can be found in package",
                                       sQuote(pkgs), "in library",
                                       sQuote(libs))))
                } else if(length(pkgs) > 1) {
                    writeLines(c(paste("  topic", sQuote(topic),
                                       "is not in any loaded package"),
                                 paste("  but can be found in the",
                                       "following packages:")))
                    A <- cbind(package = pkgs, library = libs)
                    rownames(A) <- 1 : nrow(A)
                    print(A, quote = FALSE)
                } else {
                    stop(paste("No documentation for ", sQuote(topic),
                               " in specified packages and libraries:\n",
                               "  you could try ",
                               sQuote(paste("help.search(\"", topic,
                                            "\")", sep = "")),
                               sep = ""))
                         
                }
            } else {
                    stop(paste("No documentation for ", sQuote(topic),
                               " in specified packages and libraries:\n",
                               "  you could try ",
                               sQuote(paste("help.search(\"", topic,
                                            "\")", sep = "")),
                               sep = ""))
            }
        }
    }
    else if (!missing(package))
        library(help = package, lib.loc = lib.loc, character.only = TRUE)
    else if (!missing(lib.loc))
        library(lib.loc = lib.loc)
    else help("help", package = "base", lib.loc = .Library)
}
help.start <- function (gui = "irrelevant", browser = getOption("browser"),
			remote = NULL)
{
    if(is.null(browser))
	stop("Invalid browser name, check options(\"browser\").")
    if(browser != getOption("browser")) {
        msg <- paste("Changing the default browser",
                     "(as specified by the `browser' option)",
                     "to the given browser so that it gets used",
                     "for all future help requests.")
        writeLines(strwrap(msg, exdent = 4))
        options(browser = browser)
    }
#     sessiondir <- file.path(tempdir(), ".R")
#     dir.create(sessiondir)
#     dir.create(file.path(sessiondir, "doc"))
#     dir.create(file.path(sessiondir, "doc", "html"))
    cat("Making links in per-session dir ...\n")
    .Script("sh", "help-links.sh",
            paste(tempdir(), paste(.libPaths(), collapse = " ")))
    make.packages.html()
    tmpdir <- paste("file://", tempdir(), "/.R", sep = "")
    url <- paste(if (is.null(remote)) tmpdir else remote,
		 "/doc/html/index.html", sep = "")
    writeLines(strwrap(paste("If", browser, "is already running,",
                             "it is *not* restarted, and you must",
                             "switch to its window."),
                       exdent = 4))
    writeLines("Otherwise, be patient ...")
    browseURL(url)
    options(htmlhelp = TRUE)
}

browseURL <- function(url, browser = getOption("browser"))
{
    if(!is.character(url) || !(length(url) == 1) || (nchar(url) == 0))
        stop("url must be a non-empty character string")
    if(!is.character(browser)
       || !(length(browser) == 1)
       || (nchar(browser) == 0))
        stop("browser must be a non-empty character string")
    
    if (.Platform$GUI=="AQUA" ||
        length(grep("^(localhost|):", Sys.getenv("DISPLAY"))) > 0)
      isLocal <- TRUE
    else
      isLocal <- FALSE

    remoteCmd <- if(isLocal)
        switch(basename(browser),
               "gnome-moz-remote" =, "open" = url,
               "galeon" = paste("-x", url),
               "kfmclient" = paste("openURL", url),
               "netscape" =, "mozilla" =, "opera" =, {
                   paste("-remote \"openURL(",
                         ## Quote ',' and ')' ...
                         gsub("([,)])", "%\\1", url), ")\"",
                         sep = "")
               })
    else url
    system(paste(browser, remoteCmd, "2>&1 >/dev/null ||",
                 browser, url, "&"))
}

make.packages.html <- function(lib.loc=.libPaths())
{
    f.tg <- file.path(tempdir(), ".R/doc/html/packages.html")
    if(!file.create(f.tg)) {
        warning("cannot create HTML package index")
        return(FALSE)
    }
    searchindex <- file.path(tempdir(), ".R/doc/html/search/index.txt")
    if(!file.create(searchindex)) {
        warning("cannot create HTML search index")
        return(FALSE)
    }
    file.append(f.tg, file.path(R.home(), "doc/html/packages-head.html"))
    out <- file(f.tg, open="a")
    search <- file(searchindex, open="w")
    known <- character(0)
    for (lib in lib.loc) {
        cat("<p><h3>Packages in ", lib, '</h3>\n<p><table width="100%">\n',
            sep = "", file=out)
        pg <- sort(.packages(all.available = TRUE, lib.loc = lib))
        for (i in pg) {
            ## links are set up to break ties of package names
            before <- sum(i %in% known)
            link <- if(before == 0) i else paste(i, before, sep=".")
            from <- file.path(lib, i)
            to <- file.path(tempdir(), ".R", "library", link)
            file.symlink(from, to)
            title <- package.description(i, lib.loc = lib, field="Title")
            if (is.na(title)) title <- "-- Title is missing --"
            cat('<tr align="left" valign="top">\n',
                '<td width="25%"><a href="../../library/', link,
                '/html/00Index.html">', i, "</a></td><td>", title,
                "</td></tr>\n", file=out, sep="")
            contentsfile <- file.path(from, "CONTENTS")
            if(!file.exists(contentsfile)) next
            contents <- readLines(contentsfile)
            contents <- gsub(paste("/library/", i, sep = ""),
                             paste("/library/", link, sep = ""),
                             contents)
            writeLines(contents, search)
        }
        cat("</table>\n\n", file=out)
        known <- c(known, pg)
    }
    cat("</body></html>\n", file=out)
    close(out)
    close(search)
    invisible(TRUE)
}
quartz <- function (display = "", width = 5, height = 5, pointsize = 12, 
                    family="Helvetica", antialias = TRUE, autorefresh = TRUE){
  if (.Platform$GUI=="AQUA")
    .Internal(Quartz(display, width, height, pointsize,family, antialias,autorefresh))
  else
    stop("quartz() currently works only under RAqua")
}
system <- function(command, intern = FALSE, ignore.stderr = FALSE)
    .Internal(system(if(ignore.stderr) paste(command, "2>/dev/null") else
		     command, intern))

unix <- function(call, intern = FALSE) {
    .Deprecated("system")
    system(call, intern)
}

##--- The following should/could really be done in C [platform !] :
unlink <- function(x, recursive = FALSE) {
    if(!is.character(x)) stop("argument must be character")
    if(recursive)
        system(paste("rm -rf ", paste(x, collapse = " ")))
    else
        system(paste("rm -f ", paste(x, collapse = " ")))
}

dir.create <- function(path)
{
    if(!is.character(path) || (length(path) > 1) || !nchar(path))
	stop("invalid `path' argument")
    invisible(system(paste("mkdir", path)) == 0)
}
install.packages <- function(pkgs, lib, CRAN=getOption("CRAN"),
                             contriburl=contrib.url(CRAN),
                             method, available=NULL, destdir=NULL,
			     installWithVers=FALSE)
{
    if(missing(lib) || is.null(lib)) {
        lib <- .libPaths()[1]
        if(length(.libPaths()) > 1)
            warning(paste("argument `lib' is missing: using", lib))
    }
    localcran <- length(grep("^file:", contriburl)) > 0
    if(!localcran) {
        if (is.null(destdir)){
            tmpd <- tempfile("Rinstdir")
            dir.create(tmpd)
        } else tmpd <- destdir
    }

    foundpkgs <- download.packages(pkgs, destdir=tmpd,
                                   available=available,
                                   contriburl=contriburl, method=method)

    if(!is.null(foundpkgs))
    {
        update <- cbind(pkgs, lib)
        colnames(update) <- c("Package", "LibPath")
        for(lib in unique(update[,"LibPath"]))
        {
            oklib <- lib==update[,"LibPath"]
            for(p in update[oklib, "Package"])
            {
                okp <- p == foundpkgs[, 1]
                if(length(okp) > 0){
                    cmd <- paste(file.path(R.home(),"bin","R"),
				 "CMD INSTALL")
		    if (installWithVers)
			cmd <- paste(cmd,"--with-package-versions")

		    cmd <- paste(cmd,"-l",lib,foundpkgs[okp, 2])
                    status <- system(cmd)
                    if(status>0){
                        warning(paste("Installation of package",
                                      foundpkgs[okp, 1],
                                      "had non-zero exit status"))
                    }
                }
            }
        }
        cat("\n")
        if(!localcran && is.null(destdir)){
            answer <- substr(readline("Delete downloaded files (y/N)? "), 1, 1)
            if(answer == "y" | answer == "Y")
                unlink(tmpd, TRUE)
            else
                cat("The packages are in", tmpd)
            cat("\n")
        }
    }
    else
        unlink(tmpd, TRUE)
    invisible()
}


download.packages <- function(pkgs, destdir, available=NULL,
                              CRAN=getOption("CRAN"),
                              contriburl=contrib.url(CRAN),
                              method)
{
    localcran <- length(grep("^file:", contriburl)) > 0
    if(is.null(available))
        available <- CRAN.packages(contriburl=contriburl, method=method)

    retval <- NULL
    for(p in unique(pkgs))
    {
        ok <- (available[,"Package"] == p) | (available[,"Bundle"] == p)
        ok <- ok & !is.na(ok)
        if(!any(ok))
            warning(paste("No package \"", p, "\" on CRAN.", sep=""))
        else{
            fn <- paste(p, "_", available[ok, "Version"], ".tar.gz", sep="")
            if(localcran){
                fn <- paste(substring(contriburl, 6), fn, sep="/")
                retval <- rbind(retval, c(p, fn))
            }
            else{
                url <- paste(contriburl, fn, sep="/")
                destfile <- file.path(destdir, fn)

                if(download.file(url, destfile, method) == 0)
                    retval <- rbind(retval, c(p, destfile))
                else
                    warning(paste("Download of package", p, "failed"))
            }
        }
    }

    retval
}

contrib.url <- function(CRAN, type=c("source","mac.binary")){
  type<-match.arg(type)
  switch(type, 
         source=paste(CRAN,"/src/contrib",sep=""),
         mac.binary=paste(CRAN,"/bin/macosx/",version$major, ".", substr(version$minor,1,1),sep="")
         )
}
X11 <- function(display = "", width = 7, height = 7, pointsize = 12,
                gamma = 1, colortype = getOption("X11colortype"),
                maxcubesize = 256, canvas = "white") {
  
  if(display == "" && .Platform$GUI == "AQUA" && Sys.getenv("DISPLAY") == "") {
    Sys.putenv(DISPLAY = ":0")
  }
  
  .Internal(X11(display, width, height, pointsize, gamma, colortype,
                maxcubesize, canvas))
}

x11 <- X11

gnome <- function(display = "", width = 7, height = 7, pointsize = 12)
    .Internal(gnome(display, width, height, pointsize))

## no Gnome <- .Alias(gnome)
GNOME <- gnome

gtk <- function(display = "", width = 7, height = 7, pointsize = 12)
    stop("The gtk device is now available via a separate package - gtkDevice - available from CRAN.")
GTK <- gtk
zip.file.extract <- function(file, zipname = "R.zip")
{
    ## somewhat system-specific.
    unzip <- getOption("unzip")
    if(!nchar(unzip)) unzip <- "internal"
    path <- dirname(file)
    topic <- basename(file)
    if(file.exists(file.path(path, zipname))) {
        tmpd <- tempdir()
        if(unzip != "internal") {
            if(!system(paste(unzip, "-o",
                             file.path(path, zipname), topic, "-d", tmpd,
                             " > /dev/null")))
                file <- file.path(tmpd, topic)
        } else {
            rc <- .Internal(int.unzip(file.path(path, zipname),
                                      topic, tmpd))
            if (rc == 0)
                file <- file.path(tmpd, topic)
        }
    }
    file
}
