#### Return the object's value of the Akaike Information Criterion
#### (or "A 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 for various fitted objects
AIC.lm <- function(object, ..., k = 2)
{
    if(length(list(...))) {
        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")
        row.names(val) <- as.character(match.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))
#### copyright (C) 1998 B. D. Ripley
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("`", 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
dotplot <- function(...) .Defunct()
stripplot <- function(...) .Defunct()
## </entry>
###----- NOTE:	../man/Deprecated.Rd   must be synchronized with this!
###		--------------------
.Deprecated <- function(new) {
    warning(paste("`", as.character(sys.call(sys.parent())[[1]]), "' ",
		  "is deprecated.\n",
		  if (!missing(new))
		  paste("Use `", new, "' instead.\n", sep = ""),
		  "See ?Deprecated.",
		  sep = ""))
}

## Deprecated in 1.3.0
"httpclient" <-
    function (url, port = 80, error.is.fatal = TRUE, check.MIME.type = TRUE,
              file = tempfile(), drop.ctrl.z = TRUE)
{
    .Deprecated()
    allowed.MIME.types <- c("text/", "application/postscript",
                            "application/x-latex")
    urlel <- strsplit(url, "/")[[1]]
    if (urlel[1] != "http:")
        stop("Not an http:// URL")
    host <- urlel[3]
    rurl <- paste(c("", urlel[-(1:3)]), collapse = "/")
    a <- make.socket(host, port = port)
    on.exit(close.socket(a))
    headreq <- paste("HEAD", rurl, "HTTP/1.0\r\nConnection: Keep-Alive\r\nAccept: text/plain\r\n\r\n")
    write.socket(a, headreq)
    head <- read.socket(a, maxlen = 8000)
    b <- strsplit(head, "\n")[[1]]
    if (length(grep("200 OK", b[1])) == 0) {
        if (error.is.fatal)
            stop(b[1])
        else warning(b[1])
        return(file)
    }
    if (check.MIME.type && length(unlist(lapply(allowed.MIME.types,
                                                function(x) grep(x, strsplit(grep("Content-Type:", b,
                                                                                  value = TRUE), ":")[[1]][2])))) == 0) {
        if (error.is.fatal)
            stop(grep("Content-Type:", b, value = TRUE))
        else warning(grep("Content-Type:", b, value = TRUE))
        return(file)
    }
    len <- as.numeric(strsplit(grep("Content-Length", b, value = TRUE),
                               ":")[[1]][2])
    getreq <- paste("GET", rurl, "HTTP/1.0\r\nConnection: Keep-Alive\r\nAccept: text/plain\r\n\r\n")
    write.socket(a, getreq)
    junk <- read.socket(a, maxlen = nchar(head))
    data <- ""
    b <- strsplit(c(head, junk), "\n")
    nn <- length(b[[1]])
    if (length(b[[2]]) > nn)
        data <- paste(b[[2]][-(1:nn)], collapse = "\n")
    while (nchar(data) < len) {
        data <- paste(data, read.socket(a, maxlen = len - nchar(data)),
                      sep = "")
    }
    if (drop.ctrl.z)
        data <- gsub("\032", "", data, extended = FALSE)
    cat(data, file = file)
    return(file)
}

"read.table.url" <-
    function (url, method, ...)
{
    .Deprecated("read.table(url())")
    f <- tempfile()
    if (download.file(url, destfile=f, method=method) == 0) {
        data <- read.table(f, ...)
        unlink(f)
    } else {
        unlink(f)
        stop("transfer failure")
    }
    return(data)
}

"scan.url" <-
    function (url, file=tempfile(), method, ...)
{
    .Deprecated("scan(url())")
    if (download.file(url, dest=file, method=method) != 0){
        unlink(file)
        stop("transfer failed")
    }
    data <- scan(file, ...)
    unlink(file)
    return(data)
}

"source.url" <-
    function (url, file=tempfile(), method, ...)
{
    .Deprecated("source(url())")
    if (download.file(url, dest=file, method=method) != 0) {
        unlink(file)
        stop("transfer failure")
    }
    m <- match.call()
    m[[1]] <- as.name("source")
    m$url <- NULL
    m$port <- NULL
    m$file <- file
    eval(m, parent.frame())
    unlink(file)
}

parse.dcf <- function(text=NULL, file="", fields=NULL, versionfix=FALSE)
{
    .Deprecated("read.dcf")

    parse.dcf.entry <- function(text, fields=NULL, versionfix=FALSE)
    {
        contlines <- grep("^[ \t]+", text)

        if(is.null(fields)){
            if(length(contlines))
                fields <- sub("^([^:]*):.*$", "\\1", text[-contlines])
            else
                fields <- sub("^([^:]*):.*$", "\\1", text)
        }

        retval <- as.list(rep(NA, length(fields)))
        names(retval) <- fields

        for(d in 1:length(text)){
            if(any(contlines == d))
                y <- sub("^[ \t]+(.*)$", "\\1", text[d])
            else{
                x <- sub("^([^:]*):.*$", "\\1", text[d])
                y <- sub("^[^:]*:[ \t]*(.*)$", "\\1", text[d])
            }

            if(versionfix & x=="Version")
                y <- unlist(strsplit(y, " "))[1]

            if(any(fields==x))
                retval[[x]] <-
                    if(is.na(retval[[x]])) y
                    else paste(retval[[x]], y, sep="\n")
        }
        retval
    }

    if(missing(text))
        text <- scan(file=file, what="",  quote="", sep="\n", quiet=TRUE)

    if(length(text) == 0) {
        warning("zero length `text'")
        return(list())
    }

    ## remove empty lines
    notok <- grep("^[ \t]+$", text)
    if (length(notok) > 0)
        text <- text[-notok]

    ## use the field name of the first line as record separator
    recsep <- sub("^([^:]*):.*$", "\\1", text[1])

    start <- grep(paste("^", recsep, ":", sep=""), text)
    start <- c(start, length(text)+1)
    retval <- list()
    for(k in seq(length = length(start)-1)) {
        retval[[k]] <- parse.dcf.entry(text[start[k]:(start[k+1]-1)],
                                       fields = fields,
                                       versionfix = versionfix)
    }
   if(!is.null(fields))
        return( t(sapply(retval, unlist)) )
    if(length(retval) == 1)
        return( unlist(retval, recursive=FALSE) )
    ## else
    retval
}
## </Deprecated>
La.eigen <- function (x, symmetric, only.values = FALSE)
{
    if(!is.numeric(x) && !is.complex(x))
	stop("argument to La.eigen must be numeric or complex")
    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, 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 <- rev(order(Mod(z$values)))
    }
    list(values = z$values[ord], vectors = if (!only.values) z$vectors[, ord])
}

La.svd <- function(x, nu = min(n, p), nv = min(n, p))
{
    if(!is.numeric(x) && !is.complex(x))
	stop("argument to La.svd must be numeric or complex")
    x <- as.matrix(x)
    n <- nrow(x)
    p <- ncol(x)
    if(!n || !p) stop("0 extent dimensions")

    if(nu == 0) {
	jobu <- 'N'
	u <- double(0)
    }
    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 <- double(0)
    }
    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)")

    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,
                     PACKAGE="base")
    res[c("d", if(nu) "u", if(nv) "vt")]
}
##vector <- function(mode = "logical", length = 0).Internal(vector(mode,length))

warning <- function(message = NULL).Internal(warning(message))
restart <- function(on = TRUE).Internal(restart(on))
geterrmessage <- function() .Internal(geterrmessage())
try <- function(expr, first = TRUE)
{
    restart(first)
    if(is.logical(first) && first) {
        first <- 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))
log <- function(x, base=exp(1))
    if(missing(base)).Internal(log(x)) else .Internal(log(x,base))
log1p <- function(x).Internal(log1p(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())
machine <- function().Internal(machine())
colors <- function().Internal(colors())
colours <- .Alias(colors)
col2rgb <- function(col).Internal(col2rgb(col))
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(md <- sapply(data, is.vector)))
        stop("invalid data argument")
    if(!is.list(modes) ||
       (length(modes) && !all(mm <- sapply(modes, is.character))))
        stop("invalid modes argument")
    .Internal(dataentry(data, modes))
}

deparse <-
    function(expr, width.cutoff = 60).Internal(deparse(expr, width.cutoff))


do.call <- function(what,args).Internal(do.call(what,args))
drop <- function(x).Internal(drop(x))
duplicated <- function(x, incomparables = FALSE) {
    if(!is.logical(incomparables) || incomparables)
	.NotYetUsed("incomparables != FALSE")
    .Internal(duplicated(x))
}
format.info <- function(x).Internal(format.info(x))
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)))
gray <- function(level).Internal(gray(level))
grey <- .Alias(gray)

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))
rank <- function(x, na.last = TRUE) {
    nas <- is.na(x)
    y <- .Internal(rank(x[!nas]))
    if(!is.na(na.last) && any(nas)) {
        if(na.last) {
            ## NOTE that the internal code gets NAs reversed
            x[!nas] <- y
            x[nas] <- seq(from = length(y) + 1, to = length(x))
        }
        else {
            len <- sum(nas)
            x[!nas] <- y + len
            x[nas] <- 1 : len
        }
        y <- x
    }
    y
}
readline <- function(prompt="").Internal(readline(prompt))
search <- function().Internal(search())
searchpaths <- function()
{
    s <- search()
    paths <- lapply(1:length(s), function(i) attr(pos.to.env(i), "path"))
    paths[[length(s)]] <- system.file()
    m <- grep("^package:", s)
    if(length(m)) paths[-m] <- as.list(s[-m])
    unlist(paths)
}


##-- 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))

unique <- function(x, incomparables = FALSE) {
    if(!is.logical(incomparables) || incomparables)
	.NotYetUsed("incomparables != FALSE")
    z <- .Internal(unique(x))
    if(is.factor(x))
	z <- factor(z, levels = 1:nlevels(x), labels = levels(x))
    z
}

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]
}
## 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", "default")
    n.kinds <- c("Kinderman-Ramage", "Ahrens-Dieter", "Box-Muller",
                 "user-supplied", "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.")
        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", "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)))
}
.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
     if(.Platform$OS.type == "mac"){
     .Internal(applescript(file.path(R.home(),"script"),"demo"))
     }
     else system(paste(file.path(R.home(), "bin", "Rcmd"), interpreter, 
         file.path(R.home(), "share", interpreter, script), args), 
         ...)
}
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()
}
#### copyright (C) 1998 B. D. Ripley
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)))
	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) <- class(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) <- class(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(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(...)
    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)))
	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] <- 1 - pchisq(dev[nas], dfs[nas])
        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)
    rank <- object$rank
    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, ...)
    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(1, n)
    rank <- object$rank
    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(as.formula(terms1))
    terms2 <- terms(as.formula(terms2))
    factor.scope(attr(terms1, "factor"),
		 list(add = attr(terms2, "factor")))$add
}

drop.scope <- function(terms1, terms2)
{
    terms1 <- terms(as.formula(terms1))
    f2 <- if(missing(terms2)) numeric(0)
    else attr(terms(as.formula(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(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(is.null(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(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)
	if (length(offset <- attr(tt, "offset")))
	    tmp <- paste(tmp, deparse(attr(tt, "variables")[offset + 1]),
			 sep = " + ")
	form<-formula(tmp)
        environment(form)<-environment(tt)
        form
    }

    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, 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
    }

    ## need to fix up . in formulae in R
    object$formula <- fixFormulaObject(object)
    Terms <- object$formula
    object$call$formula <- object$formula
    attributes(Terms) <- attributes(object$terms)
    object$terms <- Terms
    ## not needed: if(missing(direction)) direction <- "both" else
    direction <- match.arg(direction)
    backward <- direction == "both" | direction == "backward"
    forward  <- direction == "both" | direction == "forward"
    if(missing(scope)) {
	fdrop <- numeric(0)
	fadd <- NULL
    }
    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)
	}
    }
    if(is.null(fadd)) {
	backward <- TRUE
	forward <- FALSE
    }
    models <- vector("list", steps)
    if(!is.null(keep)) {
	keep.list <- vector("list", steps)
	nv <- 1
    }
    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 = deviance(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
	bfit <- fit
	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 all zero df terms first.
	    if(any(aod$Df == 0, na.rm=TRUE)) {
		zdf <- aod$Df == 0 & !is.na(aod$Df)
		change <- paste(rownames(aod)[zdf])
	    }
	}
	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
	fit <- update(fit, paste("~ .", change))
        if(length(fit$residuals) != n)
            stop("number of rows in use has changed: remove missing values?")
	fit$formula <- fixFormulaObject(fit)
	Terms <- fit$formula
	attributes(Terms) <- attributes(fit$terms)
	fit$terms <- Terms
	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")
	if(bAIC >= AIC) break
	nm <- nm + 1
	edf <- models[[nm]] <-
	    list(deviance = deviance(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 <- .Alias(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("`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("`FUN' must always return a scalar")
    z <- y[[1]]
    d <- dim(z)
    w <- NULL
    for (i in seq(along = d)) {
        j <- rep(rep(seq(1 : d[i]),
                     prod(d[seq(length = i - 1)]) * rep(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 :
    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(data.class(target) != data.class(current))
		paste("target is ", data.class(target), ", current is ",
		      data.class(current), sep = "") else
		switch (mode(target),
			logical = ,
                        complex = ,
			numeric	  = all.equal.numeric(target, current, ...),
			character = all.equal.character(target, current, ...),
			NULL))
    if(is.null(msg)) TRUE else msg
}

all.equal.numeric <-
function(target, current, tolerance = .Machine$double.eps ^ .5, scale=NULL)
{
    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 = "")
    else msg <- NULL
    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, ...)
{
    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
    ne <- 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)


#### copyright (C) 1998 W. N. Venables and B. D. Ripley

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", class(fit)) else c("aov", class(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]])
        intercept <- attr(Terms, "intercept")
        ecall <- lmcall
        ecall$formula <- as.formula(paste(deparse(formula[[2]]), "~", eTerm,
                                          if(!intercept) "- 1"))
        ecall$method <- "qr"
        ecall$qr <- TRUE
        ecall$contrasts <- NULL
        er.fit <- eval(ecall, parent.frame())
        options(opcons)
        nmstrata <- attr(terms(er.fit),"term.labels")
        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)))
        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.extract(mf, weights))) {
            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 <- apply(xi^2, 2, sum) > 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", class(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
    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) apply(ef^2, 2, sum) 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 <- apply(as.matrix(x$residuals)^2,2,sum)
            ssp <- sapply(ss, format)
            tmp <- as.matrix(c(ssp, format(rdf)))
            rn <- if(length(ss) > 1) colnames(x$fitted) else "Sum of Squares"
            dimnames(tmp) <- list(c(rn, "Deg. of Freedom"), "Residuals")
            print.matrix(tmp, quote = FALSE, right = TRUE)
            cat("\n")
            cat("Residual standard error:", sapply(sqrt(ss/rdf), format), "\n")
        } else
        print.matrix(matrix(0, 2, 1, dimnames=
                            list(c("Sum of Squares", "Deg. of Freedom"),
                                 "<empty>")))
    } else {
        if(rdf > 0) {
            resid <- as.matrix(x$residuals)
            nterms <- nterms + 1
            df <- c(df, rdf)
            ss <- rbind(ss, apply(resid^2, 2, sum))
            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.matrix(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(apply(as.matrix(x$residuals)^2,2,sum)/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, keep.zero.df = TRUE, ...)
{
    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)
        }
    }
    for (y in 1:nresp) {
        if(is.null(effects)) {
            df <- nterms <- neff <- 0
            ss <- ms <- numeric(0)
            nmrows <- character(0)
        } else {
            nobs <- length(resid[, y])
            df <- ss <- numeric(nterms)
            nmrows <- character(nterms)
            for(i in seq(nterms)) {
                ai <- (asgn == uasgn[i])
                df[i] <- sum(ai)
                ss[i] <- sum(effects[ai, y]^2)
                nmrows[i] <- nmeffect[1 + uasgn[i]]
            }
        }
        nt <- nterms
        if(rdf > 0) {
            nt <- nterms + 1
            df[nt] <- rdf
            ss[nt] <- sum(resid[,y]^2)
            nmrows[nt] <- "Residuals"
        }
        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 <- 1 - pf(TT, df, rdf)
            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 = p > 4,
                              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
                dn <- colnames(R)
                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", append(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))
        effect.sq <- effects[seq(along=asgn), , drop = FALSE]^2
        res <- matrix(0, nrow = nterms, ncol = ncol(effects),
                      dimnames = list(nmeffect, colnames(contrast)))
        for(i in seq(nterms)) {
            select <- (asgn == uasgn[i])
            res[i,] <- rep(1, sum(select)) %*% effect.sq[select, , drop = FALSE]
        }
        res
    }
    if(is.null(data)) contrast.obj <- eval(contrast.obj)
    else contrast.obj <- eval(substitute(contrast.obj), data, parent.frame())
    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")
    }
    if(!is.matrix(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(round(rep(1, nrow(contrast)) %*% contrast, 8) != 0))
            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
    rse <- sum(object$residuals^2)/rdf
    if(!is.matrix(contrast.obj)) sqrt(sum(weights) * rse)
    else sqrt(rse * (rep(1, nrow(weights)) %*% weights))
}

se.contrast.aovlist <-
    function(object, contrast.obj, coef = contr.helmert(ncol(contrast))[, 1],
             data = NULL, ...)
{
    contrast.weight.aovlist <- function(object, contrast, onedf = TRUE)
    {
        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)
        if(length(e.assign) < n.object)
            e.assign[[names(object)[n.object]]] <-
                attr(e.qr$qr, "assign.residual")
        res <- vector(length = n.object, mode = "list")
        names(res) <- names(object)
        for(strata.nm in names(object)) {
            strata <- object[[strata.nm]]
            if(is.qr(strata$qr)) {
                scontrast <- c.qr[e.assign[[strata.nm]], , drop = FALSE]
                effects <- as.matrix(qr.qty(strata$qr, scontrast))
                asgn <- strata$assign
                asgn <- strata$assign[strata$qr$pivot[1:strata$rank]]
                uasgn <- unique(asgn)
                res.i <- matrix(0, nrow = length(asgn), ncol = ncol(effects),
                                dimnames= list(names(asgn), colnames(contrast)))
                for(i in seq(along = asgn)) {
                    select <- (asgn == uasgn[i])
                    res.i[i, ] <- rep(1, length(select)) %*%
                        effect[select, , drop = FALSE]^2
                }
                res[[strata.nm]] <- 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
        }
        sum(aov.object$residuals^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(!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")
    }
    if(!is.matrix(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(round(rep(1, nrow(contrast)) %*% contrast, 8) != 0))
            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, onedf = FALSE)
    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]
    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(class(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

    newX <- aperm(X, c(s.call, s.ans))
    dim(newX) <- c(prod(d.call), d2 <- prod(d.ans))
    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) all(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<-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("approx: x and y must be numeric")
    nx <- length(x)
    if (nx != length(y))
        stop("x and y must have equal lengths")
    if (nx < 2)
        stop("approx requires at least two values to interpolate")
    method <- pmatch(method, c("linear", "constant"))
    if (is.na(method))
        stop("approx: invalid interpolation method")
    ok <- !(is.na(x) | is.na(y))
    x <- x[ok]
    y <- y[ok]
    ## unique xs
    nx <- length(x)
    if (!is.character(ties) || ties!="ordered"){
        if (length(ux<-unique(x))<nx){
            if (missing(ties))
                warning("Collapsing to unique x values")
            y<-tapply(y,x,ties)
            x<-sort(ux)
            nx<-length(x)
        } else {
            o <- order(x)
            x <- x[o]
            y <- y[o]
        }
    }
    if (nx < 2)
        stop("approx requires at least two 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("approx: x and y must be numeric")
    n <- length(x)
    if (n != length(y))
	stop("x and y must have equal lengths")
    if (n < 2)
	stop("approx requires at least two values to interpolate")
    method <- pmatch(method, c("linear", "constant"))
    if (is.na(method))
	stop("Invalid interpolation method")
    ok <- !(is.na(x) | is.na(y))
    x <- x[ok]
    y <- y[ok]
    if (!is.character(ties) || (ties != "ordered")) {
	if (length(ux <- unique(x)) < length(x)) {
	    if (missing(ties))
		warning("Collapsing to unique x values")
            y <- tapply(y,x,ties)
	    ##BETTER y <- as.vector(tapply(y,x,ties))
	    x <- sort(ux)
            rm(ux)
	} else {
	    o <- order(x)
	    x <- x[o]
	    y <- y[o]
	    rm(o)
	}
    }
    if (missing(yleft))
	yleft <- if(rule == 1) NA else y[1]
    if (missing(yright))
	yright <- if(rule == 1) NA else y[length(y)]
    rm(ok, rule)
    n<-as.integer(length(x)) ## may have been changed by tie removal
    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
}
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(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(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
}
arrows <- function(x0, y0, x1, y1, length=0.25, angle=30, code=2,
		   col=par("fg"), lty=NULL, lwd=par("lwd"), xpd=FALSE)
{
 .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 <- .Alias(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"))
## The following just speeds up (the above would be sufficient):
as.character.factor <- function(x,...) levels(x)[x]

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 (l, envir = parent.frame(),...)
if (is.function(l)) l else .Internal(as.function.default(l, 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 <- .Alias(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=pos.to.env(pos), inherits=FALSE,
	     immediate=TRUE)
    {
	if ( is.character(pos) )
	    pos <- match(pos,search())
    	.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(apply(f, 1, sum), apply(f, 2, sum), "*") / 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="")
        .Internal(attach(NULL, pos, name))
        load(what, envir=pos.to.env(pos))
    }
    else
        .Internal(attach(what, pos, name))
}

detach <- function(name, pos=2)
{
    if(!missing(name)) {
        name <- substitute(name)# when a name..
	pos <-
	    if(is.numeric(name)) name
	    else match(if(!is.character(name)) deparse(name) else name,
		       search())
	if(is.na(pos))
	    stop("invalid name")
    }
    if(exists(".Last.lib", where = pos, inherits=FALSE)) {
        .Last.lib <- get(".Last.lib", pos = pos, inherits=FALSE)
        if(is.function(.Last.lib)) {
            libpath <- attr(pos.to.env(pos), "path")
            if(!is.null(libpath)) try(.Last.lib(libpath))
        }
    }
    .Internal(detach(pos))
}

objects <-
    function (name, pos = -1, envir=pos.to.env(pos), all.names = FALSE, pattern)
{
    if (!missing(name)) {
	if(!is.numeric(name) || name != (pos <- as.integer(name))) {
	    name <- substitute(name)
	    if (!is.character(name))
		name <- deparse(name)
	    pos <- match(name, search())
	}
	envir <- pos.to.env(pos)
    }
    all.names <- .Internal(ls(envir, all.names))
    if(!missing(pattern)) {
	if((ll <- length(grep("\\[", pattern))) > 0
	   && ll != (lr <- length(grep("\\]", pattern)))) {
	    ## fix forgotten "\\" for simple cases:
	    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
}

ls <- .Alias(objects)
"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) && all(dm == sapply(dn1,length)))
	    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)
}

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), pos.to.env(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 <- as.factor(l[[i]])
            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=0, pos=NA,
                 outer=FALSE, font=NA, vfont=NULL, ...) {
    if (!is.null(vfont))
	vfont <- c(typeface = pmatch(vfont[1], Hershey$typeface) - 1,
		   fontindex= pmatch(vfont[2], Hershey$fontindex))
    .Internal(axis(side, at, labels, tick, line, pos, outer, font, vfont, ...))
}
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)
}
barplot <- function(height, ...) UseMethod("barplot")

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

    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("`height' must be a vector or a matrix")

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

    if (beside) {
	if (length(space) == 2)
	    space <- rep(c(space[2], rep(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)
	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)
    }
    if (beside)
	w.m <- matrix(w.m, nc = NC)
    if(plot) { ##-------- Plotting :
	opar <-
	    if (horiz)	par(xaxs = "i", xpd = TRUE)
	    else	par(yaxs = "i", xpd = TRUE)
	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, col = col)
	else {
	    for (i in 1:NC) {
		xyrect(height[1:NR, i], w.l[i], height[-1, i], w.r[i],
		       horizontal=horiz, col = col)
	    }
	}
	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 (!)
		    apply(w.m, 2, mean)
		else
		    stop("incorrect number of names")
	    } else w.m
	    axis(if(horiz) 2 else 1, at = at.l, labels = names.arg, lty = 0)
	}
	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)
	    }
	    xy <- par("usr")
	    legend(xy[2] - xinch(0.1), xy[4] - yinch(0.1),
		   legend = legend.text, fill = legend.col,
		   xjust = 1, yjust = 1)
	}
	title(main = main, sub = sub, xlab = xlab, ylab = ylab, ...)
	if (axes) axis(if(horiz) 1 else 2)
	invisible(w.m)
    } else w.m
}

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, names, boxwex = 0.8,
	 data = parent.frame(), 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.language(x)) {
            warning("Using `formula' in boxplot.default -- shouldn't boxplot.formula be called?")
	    if(inherits(x, "formula") && length(x) == 3) {
		groups <- eval(x[[3]], data, parent.frame())
		x <- eval(x[[2]], data, parent.frame())
		split(x, groups)
	    }
	}
	else {
	    groups <- args[!namedargs]
	    if(length(groups) == 1 && is.list(x)) x else groups
	}
    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(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,
            horizontal = horizontal, add = add, at = at)
	invisible(z)
    }
    else z
}

boxplot.formula <- function(formula, data = NULL, subset, na.action, ...)
{
    if(missing(formula) || (length(formula) != 3))
        stop("formula missing or incorrect")
    if(missing(na.action))
        na.action <- getOption("na.action")
    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("`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,
	        notch.frac = 0.5, boxwex = 0.8,
		border=par("fg"), col=NULL, log="", pars=NULL,
                frame.plot = axes,
                horizontal = FALSE, add = FALSE, at = NULL, ...)
{
    pars <- c(pars, list(...))

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

                if (notch) {
                    xx <- 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])
                    polygon(yy, xx, col = col, border = border)
                    segments(stats[3], x - wid/2, stats[3], x + wid/2,
                             col = border)
                }
                else {
                    xx <- x + wid * c(-1, 1, 1, -1)
                    yy <- stats[c(2, 2, 4, 4)]
                    polygon(yy, xx, col = col, border = border)
                    segments(stats[3], x - wid, stats[3], x + wid,
                             col = border)
                }
                segments(stats[c(1, 5)], rep(x, 2), stats[c(2, 4)], rep(x, 2),
                         lty = "dashed", col = border)
                segments(stats[c(1, 5)], rep(x - wid/2, 2), stats[c(1, 5)],
                         rep(x + wid/2, 2), col = border)
                points(out, rep(x, length(out)), col = border)

            }
            else { ## vertical

                if(notch) {
                    xx <- 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])
                    polygon(xx, yy, col=col, border=border)
                    segments(x-wid/2,stats[3], x+wid/2,stats[3], col=border)
                }
                else {
                    xx <- x+wid*c(-1,1,1,-1)
                    yy <- stats[c(2,2,4,4)]
                    polygon(xx, yy, col=col, border=border)
                    segments(x-wid,stats[3],x+wid,stats[3],col=border)
                }
                segments(rep(x,2),stats[c(1,5)], rep(x,2),
                         stats[c(2,4)], lty="dashed",col=border)
                segments(rep(x-wid/2,2),stats[c(1,5)],rep(x+wid/2,2),
                         stats[c(1,5)],col=border)
                points(rep(x,length(out)), out, col=border)
            }
	    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("`at' must have same length as `z $ n', i.e.",n))
    ## just for compatibility with S
    if(is.null(z$out))	 z$out	 <- vector(length=0)
    if(is.null(z$group)) z$group <- vector(length=0)
    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
    }
    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(boxwex, n)

    if(missing(border) || length(border)==0)
	border <- par("fg")

    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)
    }
    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)

    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")]
        if (n > 1)
            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)
}
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(as.character(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("",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(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[duplicated(x)], 0)
	these <- names.arg[dup2]
    }
    if(any(dups))
	x <- x[match(old,names.arg)]
    if(dot)
	x <- paste(x,".",sep="")
    names(x) <- old
    x
}

make.names <- function(names, unique=FALSE)
{
    names <- .Internal(make.names(as.character(names)))
    if(unique) {
	while(any(dups <- duplicated(names))) {
	    names[dups] <- paste(names[dups],
				 seq(length = sum(dups)), sep = "")
	}
    }
    names
}

chartr <- function(old, new, x) .Internal(chartr(old, new, x))
tolower <- function(x) .Internal(tolower(x))
toupper <- function(x) .Internal(toupper(x))
checkFF <-
function(file, package, lib.loc = .lib.loc,
         verbose = getOption("verbose")) {
    fQuote <- function(s) paste("`", s, "'", sep = "")
    if(missing(file)) {
        if(missing(package))
            stop("you must specify `file' or `package'")
        file <- file.path(.find.package(package, lib.loc), "R", package)
    }
    if(!file.exists(file))
        stop(paste("file", fQuote(file), "does not exist"))
    FFfuns <- c(".C", ".Fortran", ".Call", ".External",
                ".Call.graphics", ".External.graphics")
    checkFFPackageArg <- function(e) {
        if(is.call(e) || is.expression(e)) {
            if(as.character(e[[1]]) %in% FFfuns) {
                parg <- e[["PACKAGE"]]
                if(is.null(parg)) parg <- "MISSING"
                if((parg == "MISSING") || verbose)
                    cat(e[[1]], "(", deparse(e[[2]]), ", ...): ", parg,
                        "\n", sep = "")
            }
            for(i in seq(along = e)) Recall(e[[i]])
        }
    }
    exprs <- parse(file = file, n = -1)
    for(i in seq(along = exprs)) checkFFPackageArg(exprs[[i]])
}
chol <- function(x)
{
    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(!is.double(x)) storage.mode(x) <- "double"

    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("singular matrix in chol")
    z$v
}

chol2inv <- function(x, size=ncol(x))
{
    if(!is.numeric(x))
	stop("non-numeric argument to chol2inv")
    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])
}
codoc <- function(dir, use.values = FALSE, use.positions = TRUE,
                  ignore.generic.functions = FALSE,
                  keep.tempfiles = FALSE,
                  verbose = getOption("verbose")) {
    fQuote <- function(s) paste("`", s, "'", sep = "")
    listFilesWithExts <- function(dir, exts, path = TRUE) {
        ## Return the paths or names of the files in `dir' with
        ## extension in `exts'.
        files <- list.files(dir)
        files <- files[sub(".*\\.", "", files) %in% exts]
        if(path)
            files <- if(length(files) > 0)
                file.path(dir, files)
            else
                character(0)
        files
    }

    if(missing(dir))
        stop("no package directory given")
    if(!file.exists(dir))
        stop(paste("directory", fQuote(dir), "does not exist"))
    else
        ## tilde expansion
        dir <- file.path(dirname(dir), basename(dir))
    if(!file.exists(codeDir <- file.path(dir, "R")))
        stop(paste("directory", fQuote(dir),
                   "does not contain R code"))
    if(!file.exists(docsDir <- file.path(dir, "man")))
        stop(paste("directory", fQuote(dir),
                   "does not contain Rd sources"))

    FILES <- NULL
    if(!keep.tempfiles)
        on.exit(unlink(FILES))

    codeFile <- tempfile("Rcode")
    FILES <- c(FILES, codeFile)
    codeExts <- c("R", "r", "S", "s", "q")
    files <- listFilesWithExts(codeDir, codeExts, path = FALSE)
    if(any(i <- grep("^zzz\\.", files)))
        files <- files[-i]
    files <- file.path(codeDir, files)
    if(file.exists(codeOSDir <- file.path(codeDir, .Platform$OS)))
        files <- c(files, listFilesWithExts(codeOSDir, codeExts))
    file.create(codeFile)
    file.append(codeFile, files)

    docsFile <- tempfile("Rdocs")
    FILES <- c(FILES, docsFile)
    docsExts <- c("Rd", "rd")
    files <- listFilesWithExts(docsDir, docsExts, path = FALSE)
    if(basename(dir) == "base") {
        baseStopList <- c("Devices.Rd") # add more if needed
	files <- files[-grep(baseStopList, files, ignore.case = TRUE)]
    }
    files <- file.path(docsDir, files)
    if(file.exists(docsOSDir <- file.path(docsDir, .Platform$OS)))
        files <- c(files, listFilesWithExts(docsOSDir, docsExts))
    docsList <- tempfile("Rdocs")
    FILES <- c(FILES, docsList)
    cat(files, sep = "\n", file = docsList)
    .Script("perl", "extract-usage.pl", paste(docsList, docsFile))

    lib.source <- function(file, env) {
        oop <- options(keep.source = FALSE)
        on.exit(options(oop))
        exprs <- parse(n = -1, file = file)
        if(length(exprs) == 0)
            return(invisible())
        for(i in exprs) yy <- eval(i, env)
        invisible()
    }
    .DocsEnv <- new.env()
    if(verbose)
        cat("Docs: `lib.source(\"", docsFile, "\", *)'\n", sep="")
    lib.source(docsFile, env = .DocsEnv)
    lsDocs <- ls(envir = .DocsEnv, all.names = TRUE)
    .CodeEnv <- new.env()
    if(verbose)
        cat("Code: `lib.source(\"", codeFile, "\", *)'\n", sep="")
    lib.source(codeFile, env = .CodeEnv)
    lsCode <- ls(envir = .CodeEnv, all.names = TRUE)

    funs <- sapply(lsCode,
                   function(f) is.function(get(f, envir = .CodeEnv)))
    ## Undocumented variables?
    vars <- lsCode[funs == FALSE]
    undocVars <- vars[!vars %in% lsDocs]
    if(verbose) {
        cat("\nVariables without usage information:\n")
        print(undocVars)
    }
    ## Undocumented functions?
    funs <- lsCode[funs]
    undocFuns <- funs[!funs %in% lsDocs]
    if(verbose) {
        cat("\nFunctions without usage information:\n")
        print(undocFuns)
    }

    ## Function objects which are non-primitive (such that args() is
    ## non-NULL) and have wrong usage documentation
    args <- lapply(funs,
                   function(f) args(get(f, envir = .CodeEnv)))
    funs <- funs[(funs %in% lsDocs) & (sapply(args, length) > 0)]
    if(ignore.generic.functions) {
        isGeneric <- function(f) {
            any(grep("UseMethod",
                     deparse(body(get(f, envir = .CodeEnv)))))
        }
        funs <- funs[sapply(funs, isGeneric) == FALSE]
    }

    getCoDoc <- function(f) {
        ffc <- formals(get(f, envir = .CodeEnv))
        ffd <- formals(get(f, envir = .DocsEnv))
        if(!use.positions) {
            ffc <- ffc[sort(names(ffc))]
            ffd <- ffc[sort(names(ffd))]
        }
        if(!use.values) {
            ffc <- names(ffc)
            ffd <- names(ffd)
        }
        list(code = ffc, docs = ffd)
    }
    wrongfuns <- lapply(funs, getCoDoc)
    names(wrongfuns) <- funs
    wrongfuns <-
        wrongfuns[sapply(wrongfuns,
                          function(u) {
                              all(all.equal(u$code, u$docs) == TRUE)
                          }) == FALSE]
    wrongfuns
}
rgb <- function(red, green, blue, names=NULL)
    .Internal(rgb(red, green, blue, 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(...))
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)
{
    if(!inherits(con, "connection")) stop("argument is not a connection")
    invisible(.Internal(open(con, open, blocking)))
}

isOpen <- function(con, rw = "")
{
    if(!inherits(con, "connection")) stop("argument is not a connection")
    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")
{
    if(!inherits(con, "connection")) stop("argument is not a connection")
    invisible(.Internal(close(con, type)))
}

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))

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")
    .Internal(textConnection(deparse(substitute(object)), object, open))

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()
{
    sink() # might be on a user connection
    set <- getAllConnections()
    set <- set[set > 2]
    for(i in seq(along=set)) close(set[i])
    invisible()
}

readBin <- function(con, what, n = 1, size = NA, 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 <- typeof(what)
    .Internal(readBin(con, what, n, size, 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)))
}
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")
contour <-
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()
}
#### copyright (C) 1998 W. N. Venables and B. D. Ripley
####
#### copyright (C) 1998 The R Development Core Team.

#dimnames(x)[[2]] changed to colnames() --pd April 17 '99

contr.poly <- function (n, contrasts = TRUE)
{
    make.poly <- function(n)
    {
	y <- seq(length=n) - n %/% 2 - 1
	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"))
    contr <- make.poly(n)
    if (contrasts) {
	dn <- dimnames(contr)[[2]]
	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
    }
}

## implemented by BDR 29 May 1998
## `coefs' code added by KH
poly <- function(x, degree=1)
{
    if(is.matrix(x)) stop("poly is only implemented for vectors")
    n <- degree + 1
    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 <- diag(crossprod(raw))
    alpha <- (diag(crossprod(raw, x * raw))/norm2 + xbar)[1:degree]
    Z <- raw/rep(sqrt(norm2), rep(length(x), n))
    colnames(Z) <- 1:n - 1
    Z <- Z[, -1]
    attr(Z, "degree") <- 1:degree
    attr(Z, "coefs") <- list(alpha = alpha, norm2 = c(1, norm2))
    Z
}
contrasts <-
    function (x, contrasts = TRUE)
{
    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)) {
	ctr <- get(getOption("contrasts")[[if (is.ordered(x)) 2 else 1]])(levels(x), contrasts = contrasts)
	dimnames(ctr) <- list(levels(x), dimnames(ctr)[[2]])
    }
    else if (is.character(ctr))
	ctr <- get(ctr)(levels(x), contrasts = contrasts)
    #if(ncol(ctr)==1) dimnames(ctr) <- list(dimnames(ctr)[[1]], "")
    ctr
}

"contrasts<-" <-
    function(x, how.many, value)
{
    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("", 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(number,2)
		    if(length(overlap)==1)overlap <- rep(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(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(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) {
	## Use `global' variables
	##	id;	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)
		count <- count + 1
	    }
	}
    } else {
	for (i in 1:nplots) {
	    id <- ((a.intervals[i,1] <= a) & (a <= a.intervals[i,2]))
	    do.panel(i, subscripts)
	}
    }
    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 <- function (x, y=NULL, use="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)
    if(!is.matrix(x) && is.null(y))
        stop("supply both x and y or a matrix-like x")
    .Internal(cor(x, y, na.method))
}
## called by var(.):
cov <- function (x, y=NULL, use="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)
    if(!is.matrix(x) && is.null(y))
        stop("supply both x and y or a matrix-like x")
    .Internal(cov(x, y, na.method))
}
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)
	    apply(wt * x, 2, sum)
	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)))
	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="")
    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, dig=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="_")
    } 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, 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 = c(.packages(), .Autoloaded),
         package = .packages(),
         lib.loc = .lib.loc, verbose = getOption("verbose"))
{
    names <- c(as.character(substitute(list(...))[-1]), list)
    if(!missing(package))
        if(is.name(y <- substitute(package)))
            package <- as.character(y)
    found <- FALSE
    fsep <- .Platform$file.sep

    if(length(names) == 0) {
        ## Give `index' of all possible data sets.
        ## Currently always returns character(0).  To change this, we
        ## would need to parse the `00Index' files ...

        ## <FIXME>
        ## This is different from what is done for loading data sets:
        ## here, we warn/stop if given packages are not found.
        paths <- .find.package(package, lib.loc)
        ## </FIXME>
        if(missing(lib.loc))
            paths <- c(.path.package(package, TRUE), getwd(), paths)
        paths <- unique(paths[file.exists(paths)])
        
        first <- TRUE
        nodata <- noindex <- character(0)
        outFile <- tempfile("Rdata.")
        outConn <- file(outFile, open = "w")

        for(path in paths) {
            pkg <- basename(path)
            if(!file.exists(file.path(path, "data"))) {
                nodata <- c(nodata, pkg)
                next
            }
            INDEX <- file.path(path, "data", "00Index")
            if(!file.exists(INDEX))
                INDEX <- file.path(path, "data", "index.doc")
            if(file.exists(INDEX)) {
                writeLines(paste(ifelse(first, "", "\n"),
                                 "Data sets in package `",
                                 pkg, "':\n\n", sep = ""),
                           outConn)
                writeLines(readLines(INDEX), outConn)
                first <- FALSE
            } else {
                ## no index: check for datasets -- won't work if zipped
                files <- list.files(file.path(path, "data"))
                if(length(files) > 0) noindex <- c(noindex, pkg)
            }
        }
        if(first) {
            warning("no data listings found")
            close(outConn)
            unlink(outFile)
        }
        else {
            if(missing(package))
                writeLines(paste("\n",
                                 "Use `data(package = ",
                                 ".packages(all.available = TRUE))'\n",
                                 "to list the data sets in all ",
                                 "*available* packages.", sep = ""),
                           outConn)
            close(outConn)
            file.show(outFile, delete.file = TRUE,
                      title = "R data sets")
        }
        if(!missing(package) && (length(package) > 0)) {
            if(length(nodata) > 1)
                warning(paste("packages `",
                              paste(nodata, collapse=", "),
                              "' contain no datasets", sep=""))
            else if(length(nodata) == 1)
                warning(paste("package `", nodata,
                              "' contains no datasets", sep=""))
        }
        if(length(noindex) > 1)
            warning(paste("packages `", paste(noindex, collapse=", "),
                          "' contain datasets but no index", sep=""))
        else if(length(noindex) == 1)
            warning(paste("package `", noindex,
                          "' contains datasets but no index", sep=""))
        return(invisible(character(0)))
    }

    for(name in names) {
        paths <- .find.package(package, lib.loc, quiet = TRUE)
        if(missing(lib.loc))
            paths <- c(.path.package(package, TRUE), getwd(), paths)
        paths <- file.path(paths, "data")
        paths <- unique(paths[file.exists(paths)])
        files <- NULL
        for (p in paths) {
            if(file.exists(file.path(p, "Rdata.zip"))) {
                if(file.exists(fp <- file.path(p, "filelist")))
                    files <- c(files,
                               file.path(p, scan(fp, what="", quiet = TRUE)))
                else warning(paste("`filelist' is missing for dir", p))
            } else {
                files <- c(files, list.files(p, full=TRUE))
            }
        }
        files <- files[grep(name, files)]
        found <- FALSE
        if (length(files) > 0) {
            subpre <- paste(".*", fsep, sep = "")
            for (file in files) {
                if (verbose)
                    cat("name=", name, ":\t file= ...", fsep,
                        sub(subpre, "", file), "::\t", sep = "")
                if (found)
                    break
                found <- TRUE
                ext <- sub(".*\\.", "", file)
                ## make sure the match is really for `name.ext'
                ## otherwise
                if (sub(subpre, "", file) != paste(name, ".", ext, sep = ""))
                    found <- FALSE
                else {
                    zfile <- zip.file.extract(file, "Rdata.zip")
                    switch(ext,
                           R = ,
                           r = source(zfile, chdir = TRUE),
                           RData = ,
                           rdata = ,
                           rda = load(zfile, envir = .GlobalEnv),
                           TXT = ,
                           txt = ,
                           tab = assign(name, read.table(zfile, header = TRUE),
                           env = .GlobalEnv), CSV = ,
                           csv = assign(name,
                           read.table(zfile, header = TRUE, sep = ";"),
                           env = .GlobalEnv), found <- FALSE)
                    if (zfile != file) unlink(zfile)
                }
                if (verbose)
                    cat(if (!found)
                        "*NOT* ", "found\n")
            }
        }
        if (!found)
            warning(paste("Data set `", name, "' not found", sep = ""))
    }
    invisible(names)
}
data.matrix <-
    function(frame)
{
    if(!is.data.frame(frame))
	return(as.matrix(frame))
    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")

    d <- dim(frame)
    x <- matrix(nr=d[1],nc=d[2],dimnames=dimnames(frame))
    for(i in 1:length(frame)) {
	xi <- frame[[i]]
	if(is.logical(xi)) x[,i] <- as.numeric(xi)
	else if(is.numeric(xi)) x[,i] <- xi
	else x[,i] <- codes(xi)
    }
    x
}
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")
    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", class(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
}

## OLD:
as.data.frame <- function(x, row.names = NULL, optional = FALSE)
    UseMethod("as.data.frame")
as.data.frame.default <- function(x, row.names = NULL, optional = FALSE)
{
    dcmethod <- paste("as.data.frame", data.class(x), sep=".")
    if(exists(dcmethod, mode="function"))
	(get(dcmethod, mode="function"))(x, row.names, optional)
    else stop(paste("can't coerce",data.class(x), "into a data.frame"))
}
## NEW:
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()))
    if(is.null(class(x))) class(x) <- data.class(x)
    UseMethod("as.data.frame", x, row.names, optional)
}
as.data.frame.default <- function(x, row.names = NULL, optional = FALSE)
    stop(paste("can't coerce", data.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 <- class(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
}

as.data.frame.list <- function(x, row.names = NULL, optional = FALSE)
{
    x <- eval(as.call(c(expression(data.frame), 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  <- .Alias(as.data.frame.vector)
as.data.frame.ordered <- .Alias(as.data.frame.vector)
as.data.frame.integer <- .Alias(as.data.frame.vector)
as.data.frame.numeric <- .Alias(as.data.frame.vector)
as.data.frame.complex <- .Alias(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 <- .Alias(as.data.frame.character)

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)
    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" || mode(x) == "logical") {
	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
}

"[.AsIs" <- function(x, i, ...) structure(NextMethod("["), class = class(x))

as.data.frame.AsIs <- function(x, row.names = NULL, optional = FALSE)
{
    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(adup <- 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]
    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
    value <- vnames <- as.list(vnames)
    nrows <- numeric(n)
    for(i in 1:n) {
	xi <- as.data.frame(x[[i]], optional=TRUE)
	rowsi <- attr(xi, "row.names")
	nnew <- length(xi)
	namesi <- names(xi)
	if(nnew>1) {
	    if(length(namesi) == 0) namesi <- 1:nnew
	    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
	}
	nrows[[i]] <- length(rowsi)
	if(missing(row.names) && (nrows[[i]] > 0) && (rowsi[[1]] != ""))
	    row.names <- data.row.names(row.names, rowsi, i)
	value[[i]] <- xi
    }
    nr <- max(nrows)
    for(i in (1:n)[nrows < nr]) {
	xi <- value[[i]]
	if(length(xi)==1 && nr%%nrows[[i]]==0 && is.vector(xi[[1]]))
	    value[[i]] <- list(rep(xi[[1]], length=nr))
	else stop(paste("arguments imply differing number of rows:",
			paste(unique(nrows), collapse = ", ")))
    }
    value <- unlist(value, recursive=FALSE, use.names=FALSE)
    vnames <- unlist(vnames)
    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(length(row.names) == 0)
	row.names <- seq(length = nr)
    else if(length(row.names) != nr) {
	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]
    }
    row.names <- as.character(row.names)
    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)
{
    if(nargs() < 3) {
	if(missing(i))
	    return(x)
	if(is.matrix(i))
	    return(as.matrix(x)[i])
	y <- NextMethod("[")
	if(any(names(y) == "NA"))
	    stop("undefined columns selected")
	return(structure(y, class = class(x), row.names = row.names(x)))
    }

    ## preserve the attributes for later use ...

    rows <- attr(x, "row.names")
    cols <- names(x)
    cl <- class(x)
    class(x) <- attr(x, "row.names") <- NULL

    ## handle the column only subsetting ...

    if(missing(i)) {
	x <- x[j]
	cols <- names(x)
	if(is.null(cols) || any(nchar(cols) == 0))
	    stop("not all specified columns exist")
    }
    else {
	if(is.character(i))
	    i <- pmatch(i, rows, duplicates.ok = TRUE)
	rows <- rows[i]
	if(!missing(j)) {
	    x <- x[j]
	    cols <- names(x)
	    if(is.null(cols) || any(nchar(cols) == 0))
		stop("undefined columns selected")
	}
	n <- length(x)
	jj <- seq(length = n)
	for(j in jj) {
	    xj <- x[[j]]
	    if(length(dim(xj)) != 2)
		x[[j]] <- xj[i]
	    else x[[j]] <- xj[i, , drop = drop]
	}
    }
    if(drop) {
	drop <- FALSE
	n <- length(x)
	if(n == 1) {
	    x <- x[[1]]
	    drop <- TRUE
	}
	else if(n > 1) {
	    xj <- x[[1]]
	    if(length(dim(xj)) == 2)
		nrow <- dim(xj)[1]
	    else nrow <- length(xj)
	    if(nrow == 1) {
		drop <- TRUE
		names(x) <- cols
		attr(x, "row.names") <- NULL
	    }
	}
    }
    if(!drop) {
	names(x) <- cols
	if(any(duplicated(rows)))
	    rows <- make.names(rows, unique = TRUE)
	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 unclass(x)[[i]])(x, ...)
    else (function(x, i, j)
	  x[[j]][[i]])(unclass(x), ...)
}

"[<-.data.frame" <- function(x, i, j, value)
{
    if((nA <- nargs()) == 4) {
	has.i <- !missing(i)
	has.j <- !missing(j)
    }
    else if(nA == 3) {
	## really ambiguous, but follow common use as if list
	if(is.matrix(i))
	    stop("matrix subscripts not allowed in replacement")
	j <- i
	i <- NULL
	has.i <- FALSE
	has.j <- TRUE
    }
    else if(nA == 2) {
	value <- i
	i <- j <- NULL
	has.i <- has.j <- FALSE
    }
    else {
	stop("Need 0, 1, or 2 subscripts")
    }
    cl <- class(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) {
	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") &&
		   (nrv <- 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 <- c(names(x), 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 <- c(names(x),
			      paste("V", seq(from = nvars + 1,
					     to = max(jseq)),
				    sep = ""))
		if(length(new.cols) - nvars != sum(jseq > nvars))
		    stop(paste("new columns would leave holes",
			       "after existing columns"))
	    }
	}
    }
    else jseq <- seq(along = x)
    n <- length(iseq)
    if(n == 0)
	n <- nrows
    p <- length(jseq)
    m <- length(value)
## careful, as.data.frame turns things into factors.
##    value <- as.data.frame(value)
    if(!is.list(value) && (missing(j) || !missing(i))) { # [i, ] or [i,j]
	value <- matrix(value, n, p)
	dimv <- c(n, p)
	value <- split(value, col(value))
    } else {
	value <- as.data.frame(value)
	dimv <- dim(value)
    }
    nrowv <- dimv[[1]]
    if(nrowv < n) {
	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"))
    vseq <- 1:n
    ncolv <- dimv[[2]]
    jvseq <- 1:p
    if(ncolv < p) jvseq <- rep(1:ncolv, length=p)
    else if(ncolv > p)
	warning(paste("provided", ncolv, "variables to replace", p,
		      "variables"))
    if(has.i)
	for(jjj in 1:p) {
	    jj <- jseq[jjj]
	    vjj <- value[[jvseq[[jjj]] ]]
	    xj <- x[[jj]]
	    if(length(dim(xj)) != 2)
		xj[iseq] <- vjj
	    else xj[iseq,  ] <- vjj
	    x[[jj]] <- xj
	}
    else for(jjj in 1:p) {
	jj <- jseq[jjj]
	x[[jj]] <- value[[jvseq[[jjj]] ]]
    }
    if(length(new.cols) > 0)
	names(x) <- new.cols
    class(x) <- cl
    x
}

"[[<-.data.frame"<- function(x, i, j, value)
{
    cl <- class(x)
    ## delete class: Version 3 idiom
    ## to avoid any special methods for [[, etc
    class(x) <- NULL
    rows <- attr(x, "row.names")
    nrows <- length(rows)
    if(nargs() < 4) {
	## really ambiguous, but follow common use as if list
	## el(x,i) <- value is the preferred approach
	if(is.null(value)) {}
	else {
	    if(!inherits(value, "data.frame"))
		value <- as.data.frame(value)
	    if(length(value) != 1)
		stop(paste("trying to replace one column with",
			   length(value)))
	    if(length(row.names(value)) != nrows)
		stop(paste("replacement has", length(value),
			   "rows, data has", nrows))
	    class(value) <- NULL
	    value <- value[[1]]
	}
	x[[i]] <- value
	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(any(n > 0)) {# drop any(.)?
	    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") &&
	       (nrv <- 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
}

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 <- class(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 && all(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]
	if(inherits(xi, "data.frame")) {
	    if(is.null(cl))
		cl <- class(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]] <- nii <- 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)
		for(j in 1:nvar) {
		    xj <- value[[j]]
		    if( !is.null(levels(xj)) )
			all.levs[[j]] <- levels(xj)
		    has.dim[j] <- length(dim(xj)) == 2
		}
	    }
	    else for(j in 1:nvar)
		if(length(lij <- levels(xi[[j]])) > 0) {
		    if(is.null(pi) || is.na(jj <- pi[[j]]))
			jj <- j
		    all.levs[[jj]] <- unique(c(all.levs[[jj]],
					       lij))
		}
	}
	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)
    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)
		row.names <- dn[[1]]
		if(length(row.names) > 0)
		    length(row.names) <- rmax
		pi <- dim(xi)[2]
		length(xi) <- rmax * pi
		value[[i]] <- array(xi, c(rmax, pi), list(row.names, 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]
	    if(has.dim[jj])
		value[[jj]][ri,	 ] <- xi[[j]]
	    else value[[jj]][ri] <- xi[[j]]
	}
    }
    for(j in 1:nvar) {
	xj <- value[[j]]
	if(!has.dim[j] && !inherits(xj, "AsIs") &&
		(is.character(xj) || is.logical(xj)))
	    value[[j]] <- factor(xj)
    }
    rlabs <- unlist(rlabs)
    while(any(xj <- duplicated(rlabs)))
	rlabs[xj] <- paste(rlabs[xj], 1:sum(xj), sep = "")
    if(is.null(cl)) {
	as.data.frame(value, row.names = rlabs)
    }
    else {
	class(value) <- cl
	## ensure that row names are ok.  Similar to row.names<-
	rlabs <- as.character(rlabs)
	if(any(duplicated(rlabs)))
	    rlabs <- make.names(rlabs, uniq = TRUE)
	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 {
	if(!is.null(digits)) {
	    ## if 'x' has factors & numeric, as.matrix(x) will apply format(.)
	    ## to the numbers -- set options(.) for the following print(.):
	    op <- options(digits = digits)
	    on.exit(options(op))
	}
	## avoiding picking up e.g. format.AsIs
	print.matrix(format.data.frame(x), ..., 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 <- class(xj)) && # 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]]
	    X[[j]] <- if(length(levels(xj))) as.vector(xj) else format(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
}

if(FALSE)
Math.data.frame <- function(x, ...)
{
    X <- x
    class(X) <- NULL
    f <- get(.Generic, mode = "function")
    call <- match.call(f, sys.call())
    call[[1]] <- as.name(.Generic)
    arg <- names(formals(f))[[1]]
    call[[arg]] <- as.name("xx")
    for(j in names(X)) {
	xx <- X[[j]]
	if(!is.numeric(xx) && !is.complex(xx))
	    stop(paste("Non-numeric variable:", j))
	X[[j]] <- eval(call)
    }
    attr(X, "class") <- class(x)
    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) <- class(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(scalar) 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(1:ncol(e1), rep(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(1:ncol(e2), rep(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(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(!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)) return(as.POSIXct(as.POSIXlt(x), tz))
    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 == "") {
        times <- unlist(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 <- .Alias(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) <- class(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(class(e2)))
        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) <- class(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 <- class(x)
    class(x) <- NULL
    val <- NextMethod("[")
    class(val) <- cl
    val
}

"[[.POSIXct" <-
function(x, ..., drop = TRUE)
{
    cl <- class(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 <- class(x)
    class(x) <- class(value) <- NULL
    x <- NextMethod(.Generic)
    class(x) <- cl
    x
}

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

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

as.data.frame.POSIXct <- .Alias(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="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(..., scale=1)
    NextMethod("all.equal")


axis.POSIXct <- function(side, x, format, ...)
{
    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"
    }
    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 = "", ...)
{
    plot.default(x, y, xaxt = "n", xlab = xlab, ...)
    axis.POSIXct(1, x)
}

plot.POSIXlt <- function(x, y, xlab = "", ...)
{
    x <- as.POSIXct(x)
    plot.default(x, y, xaxt = "n", xlab = xlab, ...)
    axis.POSIXct(1, 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)
    zz <- min(abs(z),na.rm=TRUE)
    units <- match.arg(units)
    if(units == "auto") {
        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")
           )
}

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")
}

## for back-compatibility only: POSIXt versions are used as from 1.3.0

"-.POSIXct" <- function(e1, e2)
{
    if(!inherits(e1, "POSIXct"))
        stop("Can only subtract from POSIXct objects")
    if (nargs() == 1) stop("unary - is not defined for POSIXct objects")
    res<- NextMethod()
    if(inherits(e2, "POSIXct")) unclass(res) else res
}

"-.POSIXlt" <- function(e1, e2)
{
    if (nargs() == 1)
        stop("unary - is not defined for dt objects")
    if(inherits(e1, "POSIXlt")) e1 <- as.POSIXct(e1)
    if(inherits(e2, "POSIXlt")) e2 <- as.POSIXct(e2)
    e1 - e2
}

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

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

## ----- 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))
        incr <- (to - from)/length.out
        res <- seq.default(from, to, incr)
        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 <- 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"))
        if(is.na(valid)) stop("invalid string for `by'")
        if(valid <= 5)
            by <- c(1, 60, 3600, 86400, 7*86400)[valid]
        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))
            res <- seq.default(from, to, by)
        }
        return(structure(res, class=c("POSIXt", "POSIXct")))
    } else {  # months or years
        r1 <- as.POSIXlt(from)
        if(valid == 7) {
            if(missing(to)) {
                yr <- seq(r1$year, by = by, length = length.out)
            } else {
                to <- as.POSIXlt(to)
                yr <- seq(r1$year, to$year, by)
            }
            r1$year <- yr
        } else {
            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
        }
        return(as.POSIXct(r1))
    }
}

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

    if (inherits(breaks, "POSIXt")) {
        breaks <- as.POSIXlt(breaks)
    } else if(is.numeric(breaks) && length(breaks) == 1) {
        ## 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))
        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 }
        breaks <- seq(start, max(x) + incr, breaks)
        breaks <- breaks[1:(1+max(which(breaks < max(x))))]
    } else stop("invalid specification of `breaks'")
    res <- cut(unclass(x), unclass(breaks), labels = labels, right = FALSE)
    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)
    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
}

round.POSIXt <- function(x, units=c("secs", "mins", "hours", "days"))
{
    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)
}
read.dcf <- function(file, fields = NULL)
{
    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")
    .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("argument `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(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) <- 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)
    }
}
delay <- function(x, env=.GlobalEnv)
    .Internal(delay(substitute(x), env))
density <-
    function(x, bw, 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))
      bw <-
        if(missing(width)) {
            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.)
            adjust * 0.9 * lo * N^(-0.2)
        } else 0.25 * width
    if (!is.finite(bw)) stop("non-finite `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(s, main=NULL, xlab=NULL, ylab="Density", type="l",
			 zero.line = TRUE, ...)
{
    if(is.null(xlab))
	xlab <- paste("N =", s$n, "  Bandwidth =", formatC(s$bw))
    if(is.null(main)) main <- deparse(s$call)
    plot.default(s, main=main, xlab=xlab, ylab=ylab, type=type, ...)
    if(zero.line) abline(h=0, lwd=0.1, col = "gray")
}

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)
}
### From Doug Bates' 20 Apr 1999 post to R-devel;
### "method" idea from J.K.Lindsey's rmutil
det <- function(x, method = c("qr","eigenvalues"))
{
    if(!is.matrix(x) || (n <- ncol(x)) != nrow(x))
	stop("x must be a square matrix")
    method <- match.arg(method) # ensures one from above
    if(method == "qr") {
        x <- prod(diag(qr(x)$qr)); if(n %% 2 == 1) x else -x
    } else ## method == "eigenvalues"
	Re(prod(eigen(x, only.values=TRUE)$values))
}

## S-plus' Matrix pkg has arg. "logarithm = TRUE" and returns list
##        (which is necessary for keeping the sign when taking log ..)
dev.interactive <- function()
    interactive() && .Device %in% c("X11", "GTK", "gnome", "windows", "Macintosh")

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)")
    if(exists(".Devices")) {
	.Devices <- get(".Devices")
    }
    else {
	.Devices <- list("null device")
    }
    .Devices[[which]] <- ""
    assign(".Devices", .Devices)
    .Internal(dev.off(as.integer(which)))
    assign(".Device", .Devices[[dev.cur()]])
    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", "Macintosh")))
        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", "Macintosh")))
        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)
{
    if(!missing(displaylist)) {
	if(displaylist == "inhibit")
	    .Internal(dev.control())
	else stop(paste("displaylist should be inhibit"))
    }
    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")
    x[cbind(i, i)] <- value
    x
}
diff <- function(x, ...) UseMethod("diff")

## autoload("diff.ts", "ts")   in ../../profile/Common.R

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) <- class(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, scale=1, log = FALSE)
    .Internal(dgamma(x, shape, scale, log))
pgamma <- function(q, shape, scale=1, lower.tail = TRUE, log.p = FALSE)
    .Internal(pgamma(q, shape, scale, lower.tail, log.p))
qgamma <- function(p, shape, scale=1, lower.tail = TRUE, log.p = FALSE)
    .Internal(qgamma(p, shape, scale, lower.tail, log.p))
rgamma <- function(n, shape, scale=1) .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))

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 .NotYetImplemented()
}

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)) error("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)) error("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)) error("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)) error("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, log = FALSE) .Internal(dt(x, df, log))
pt <- function(q, df, ncp, 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) .Internal(dwilcox(x, m, n, log))
pwilcox <- function(q, m, n, lower.tail = TRUE, log.p = FALSE)
    .Internal(pwilcox(q, m, n, lower.tail, log.p))
qwilcox <- function(p, m, n, lower.tail = TRUE, log.p = FALSE)
    .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) .Internal(dsignrank(x, n, log))
psignrank <- function(q, n, lower.tail = TRUE, log.p = FALSE)
    .Internal(psignrank(q, n, lower.tail, log.p))
qsignrank <- function(p, n, lower.tail = TRUE, log.p = FALSE)
    .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", 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)
	if (!is.null(groups))
	    glabels <- levels(groups)
	else glabels <- NULL
    }

    plot.new()
    linch <- 0
    ginch <- 0
    if (!is.null(labels))
	linch <- max(strwidth(labels, "inch"), na.rm = TRUE)
    goffset <- 0
    if (!is.null(glabels)) {
	ginch <- max(strwidth(glabels, "inch"), na.rm = TRUE)
	goffset <- 0.4
    }

    lheight <- strheight("M", "inch")
    if (!(is.null(labels) && is.null(glabels))) {
	nmar <- mar <- 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 <- rev(order(as.numeric(groups)))
	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 = range(x[is.finite(x)]), 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]
	for(i in 1:n)
	    mtext(labs[i], side = 2, line = loffset, at = y[i], 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
	for(i in 1:nlevels(groups))
	    mtext(glabels[i], side = 2, line = goffset, at = gpos[i],
		  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))
#### copyright (C) 1998 B. D. Ripley
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]
    vars <- rownames(facs)
    xl <- object$xlevels
    if(!length(xl)) {			# no factors in model
	return(as.list(coef(object)))
    }
    nxl <- rep(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(1, nl)
	else factor(rep(xl[[i]][1], nl), levels = xl[[i]])
    dummy <- do.call("data.frame", args)
    pos <- 0
    rn <- rep(tl, lterms)
    rnn <- rep("", 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]
    }
    mm <- model.matrix(delete.response(Terms), dummy, object$contrasts, xl)
    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(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(1, nl)
	else factor(rep(xl[[i]][1], nl), levels = xl[[i]])
    dummy <- do.call("data.frame", args)
    pos <- 0
    rn <- rep(tl, lterms)
    rnn <- rep("", 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("", 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("", nm)
    cat(if(missing(title)) "Full coefficients are" else title, "\n")
    print.matrix(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)
{
    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))
}

##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))
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")
        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.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)

    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(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
    }
    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")
        if(.Platform$GUI == "unknown" || Sys.getenv("DISPLAY")=="" )
            return (edit.default(name, ...))
    if(!is.matrix(name) ||
       !(mode(name) == "numeric" || mode(name) == "character")
       || any(dim(name) < 1))
        stop("invalid input matrix")
    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(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(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]]
    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)
{
    x <- as.matrix(x)
    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(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")

    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 <- rev(order(z$values))
    }
    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 <- rev(order(Mod(z$values)))
    }
    list(values = z$values[ord],
	 vectors = if(!only.values) z$vectors[,ord])
}
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 ()
  eval.parent(quote((function() environment())()))

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

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


exists <-
    function(x, where=-1, envir=pos.to.env(where), frame,
	     mode="any", inherits=TRUE)
{
    if(!missing(frame))
	envir <- sys.frame(frame)
    .Internal(exists(x, envir, mode, inherits))
}
## file expand.grid.R
## copyright (C) 1998 W. N. Venables and B. D. Ripley
##
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 <= 1)
        return(as.data.frame(if(nargs==0||is.null(args[[1]])) list() else args,
                             optional = TRUE))
    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 <- final.len <- 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(rep(x, rep(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(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(names(value), lapply(value, length))
      value <- unlist(value)
      m <- match(value, xlevs, nomatch=0)
      xlevs[m] <- nlevs
  }
  else {
    if (length(xlevs) > length(value))
      stop("number of levels differs")
    xlevs <- as.character(value)
  }
  factor(xlevs[x], levels=unique(xlevs))
}

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

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

codes.ordered <- .Alias(as.integer)

"codes<-" <- function(x, value, ...)
{
    if ( length(value) == 1 )
	value <- rep(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
}

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


print.factor <- function (x, quote=FALSE, ...)
{
    if(length(x) <= 0)
	cat("factor(0)\n")
    else
	print(levels(x)[x], quote=quote, ...)
    cat("Levels: ", paste(levels(x), collapse=" "), "\n")
    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(paste('"',.Generic,'"', " not meaningful for factors", sep=""))
	return(rep(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)<-class(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 <- class(x)
    nas <- is.na(x)
    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
    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)

print.ordered <- function (x, quote=FALSE, ...)
{
    if(length(x) <= 0)
	cat("ordered(0)\n")
    else
	print(levels(x)[x], quote=quote)
    cat("Levels: ",paste(levels(x), collapse=" < "), "\n")
    invisible(x)
}

Ops.ordered <-
function (e1, e2)
{
    ok <- switch(.Generic,
		 "<" = , ">" = , "<=" = , ">=" = ,"=="=, "!=" =TRUE,
		 FALSE)
    if(!ok) {
	warning(paste('"',.Generic,'"', " not meaningful for ordered factors", sep=""))
	return(rep(NA, max(length(e1),if(!missing(e2))length(e2))))
    }
    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 <- codes(e1)
	e2 <- codes(e2)
    }
    else if (!ord1) {
	e1 <- match(e1, l2)
	e2 <- codes(e2)
    }
    else if (!ord2) {
	e2 <- match(e2, l1)
	e1 <- codes(e1)
    }
    value <- get(.Generic, mode = "function")(e1, e2)
    value[nas] <- NA
    value
}
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(.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, 1 - exp(-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(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(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(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(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(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(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(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, 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(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(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(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(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(0, n1), x)
        n <- length(y <- c(y, rep(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(...)))

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

dir <- .Alias(list.files)

file.path <- function(..., fsep=.Platform$file.sep)
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, from)
    else if (nf > nt)  stop("more `from' files than `to' files")
    if(!overwrite) {
        if(nt > nf) from <- rep(from, length = nt)
        exists <- file.exists(from)
        from <- from[exists]
        to <- to[exists]
    }
    file.create(to)
    file.append(to, from)
}

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))
    while(any(y > 0)) {
        z <- y%%8
        y <- floor(y/8)
        ans0 <- paste(z, ans0, sep="")
    }
    ans <- rep("NA", length(x))
    ans[!isna] <- ans0
    ans
}
as.character.octmode <- .Alias(format.octmode)

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

system.file <-
function(..., package = "base", lib.loc = .lib.loc, pkg, lib) {
    if(nargs() == 0)
        return(file.path(.Library, "base"))
    if(!missing(pkg)) {
        warning("argument `pkg' is deprecated.  Use `package' instead.")
        if(missing(package)) package <- pkg
    }
    if(!missing(lib)) {
        warning("argument `lib' is deprecated.  Use `lib.loc' instead.")
        if(missing(lib.loc)) lib.loc <- lib
    }
    if(length(package) != 1)
        stop("argument `package' must be of length 1")
    packagePath <- .find.package(package, lib.loc,
                                 missing(lib.loc) && missing(lib),
                                 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, ...)
{
    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
    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(NA,5))
    x <- sort(x)
    n <- length(x)
    if(n == 0) rep(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")
    .Internal(body(fun))
}
alist <- function (...) as.list(sys.call())[-1]
"body<-" <- function (f, value, envir = parent.frame()) {
    if (is.expression(value))
	value <- value[[1]]
    f <- as.function(c(formals(f), value), envir)
}
"formals<-" <- function (f, value, envir = parent.frame()) {
    f <- as.function(c(value, body(f)), 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"))
{
    f.char <- function(x, justify) {
	if(length(x) <= 1) return(x)
	nc <- nchar(x)
	w <- max(nc)
	all <- substring(paste(rep(" ", w), collapse=""), 1, w-nc)
	res <- if(justify == "left") paste(x, all, sep="")
	else paste(all, x, sep="")
        dim(res) <- dim(x)
        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, ??? :
	   structure(.Internal(format(x, trim = trim, small=nsmall)),
                     names=names(x)))
}
## 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
    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)
{
    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(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 (!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)
    nc <- dims[2]
    rval <- vector("list", nc)
    for(i in 1:nc)
	rval[[i]] <- format(x[[i]], ..., justify = justify)
    dn <- dimnames(x)
    cn <- dn[[2]]
    m <- match(c("row.names", "check.rows", "check.names"), cn, 0)
    if(any(m > 0)) cn[m] <- paste(".", m[m>0], sep="")
    names(rval) <- cn
    rval$check.names <- FALSE
    rval$row.names <- dn[[1]]
    x <- do.call("data.frame", rval)
    if(any(m > 0)) names(x) <- dn[[2]]
    x
}

format.AsIs <- function(x, width = 12, ...)
{
    if(is.character(x)) return(format.default(x, ...))
    n <- length(x)
    rvec <- rep(NA, n)
    for(i in 1:n)
	rvec[i] <- toString(x[[i]], width, ...)
#    return(format.char(rvec, flag = "+"))
    format.default(rvec, justify = "right")
}

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://hotspur.psych.yorku.ca/ftp/sas/catdata/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(from = 1, to = 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 <- apply(tab, 1, sum)[1]
        n <- apply(tab, 1, sum)[2]
        t <- apply(tab, 2, sum)[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 - (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(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(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)
}
reshapeLong <-
    function(x,
             jvars,
             ilev = row.names(x),
             jlev = names(x)[jvars],
             iname = "reshape.i",
             jname = "reshape.j",
             vname = "reshape.v")
{
    nl <- as.list(1:ncol(x))
    names(nl) <- names(x)
    jvars <- eval(substitute(jvars), nl, parent.frame())
    n <- nrow(x)
    k <- length(jvars)
    if (k == 0) stop("no j variables")
    t1 <- x[,-jvars,drop=FALSE]
    t2 <- as.matrix(x[,jvars])
    i <- gl(n, k, labels = ilev)
    j <- gl(k, 1, length = n*k, labels = jlev)
    t2 <- data.frame(foo=i, bar=j, baz=as.vector(t(t2)))
    names(t2) <- c(iname, jname, vname)
    if(ncol(t1)==0) return(t2)
    t1 <- t1[i,,drop=FALSE]
    rownames(t1) <- 1:(n*k)
    cbind(t1, t2)
}

reshapeWide <-
    function(x,
             i = reshape.i,
             j = reshape.j,
             val = reshape.v,
             jnames = levels(j))
{
    nl <- as.list(1:ncol(x))
    names(nl) <- names(x)
    ijv <- eval(substitute(c(i,j,val)), nl, parent.frame())
    i <- eval(substitute(as.factor(i)), envir=x)
    j <- eval(substitute(as.factor(j)), envir=x)
    val <- eval(substitute(val), envir=x)
    if (any(table(i,j) != 1)) stop("data frame cannot be reshaped")
    xr <- x[,-ijv,drop=FALSE]
    resp <- tapply(val,list(i,j),as.vector)
    resp <- as.data.frame(resp)
    names(resp) <- jnames
    if (ncol(xr) == 0) return(resp)
    reduced <- xr[as.numeric(j)==1,,drop=FALSE]
    cbind(reduced,resp)
}
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("incorrect specification for `row.vars'")
            row.vars <- i
        } else if(any((row.vars < 1) | (row.vars > n)))
            stop("incorrect specification for `row.vars'")
    }
    if(!is.null(col.vars)) {
        if(is.character(col.vars)) {
            i <- pmatch(col.vars, names(dn))
            if(any(is.na(i)))
                stop("incorrect specification for `col.vars'")
            col.vars <- i
        } else if(any((col.vars < 1) | (col.vars > n)))
            stop("incorrect specification for `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("formula has `.' in both left and right hand side")
    if(missing(na.action))
        na.action <- getOption("na.action")
    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("x must be an `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("x must be an `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
    }
    xrv <- attr(x, "row.vars")
    xcv <- attr(x, "col.vars")
    LABS <- cbind(rbind(matrix("", nr = length(xcv), nc = length(xrv)),
                        charQuote(names(xrv)),
                        makeLabels(xrv)),
                  c(charQuote(names(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)
{
    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)
    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, skip = skip, 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[3 : length(z)]
            skip <- skip + 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, skip = skip + k - 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, skip = skip +
                                n.col.vars, quiet = TRUE)
        z <- z[(n.col.vars + 2) : length(z)]
        skip <- skip + 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
    }
    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,
              skip = skip)
    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)
    }
    dim(values) <- c(prod(sapply(row.vars, length)),
                     prod(sapply(col.vars, length)))
    structure(values,
              row.vars = row.vars,
              col.vars = col.vars,
              class = "ftable")
}
get <-
    function(x, pos=-1, envir=pos.to.env(pos), mode="any", inherits=TRUE)
    {
	if (is.character(pos)) 
	    pos<-match(pos,search()) 
	.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)))
}
## gl function of GLIM
gl <- function (n, k, length = n*k, labels=1:n, ordered=FALSE)
    factor(rep(rep(1:n,rep(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, 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)
    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(paste("invalid `method':", method)))
    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

    ## null model support
    X <- if (!is.empty.model(mt)) model.matrix(mt, mf, contrasts)# else NULL
    Y <- model.response(mf, "numeric")
    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(paste("Number of offsets is", length(offset),
		   ", should equal", NROW(Y), "(number of observations)"))

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

    if(any(offset) && attr(mt, "intercept") > 0) {
	fit$null.deviance <-
	    if(is.empty.model(mt)) fit$deviance
	    else glm.fit(x=X[,"(Intercept)",drop=FALSE], y=Y, weights=weights,
			 start=start, 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(if(is.empty.model(mt)) "glm.null", "glm", "lm")
    fit
}


glm.control <- function(epsilon = 0.0001, maxit = 10, 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)
    if (nvars == 0) {
	## oops, you'd want glm.fit.null, then
	cc <- match.call()
	cc[[1]] <- as.name("glm.fit.null")
	return(eval(cc, parent.frame()))
    }
    ## define weights and offset if needed
    if (is.null(weights))
	weights <- rep(1, nobs)
    if (is.null(offset))
	offset <- rep(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))
	## next line calculates mustart and may change y and weights
	eval(family$initialize)
    if (NCOL(y) > 1)
	stop("y must be univariate unless binomial")
    eta <-
	if(!is.null(etastart) && valideta(etastart))
	    etastart
	else if(!is.null(start))
	    if (length(start) != nvars)
		stop(paste("Length of start should equal", nvars,
			   "and correspond to initial coefs for",
			   deparse(xnames)))
	    else 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))
    coefold <- start
    boundary <- 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(paste("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))
	ncols <- as.integer(1)
	## call linpack code
	fit <- .Fortran("dqrls",
			qr = x[good, ] * w, n = as.integer(ngoodobs),
			p = nvars, y = w * z, ny = ncols,
			tol = min(1e-7, control$epsilon/1000),
			coefficients = numeric(nvars),
			residuals = numeric(ngoodobs),
			effects = numeric(ngoodobs),
			rank = integer(1),
			pivot = 1:nvars, qraux = double(nvars),
			work = double(2 * nvars),
			PACKAGE = "base")
	## stop if not enough parameters
	if (nobs < fit$rank)
	    stop(paste("X matrix has rank", fit$rank, "but only",
		       nobs, "observations"))
	## calculate updated values of eta and mu with the new coef:
	start <- coef <- fit$coefficients
	start[fit$pivot] <- coef
#	eta[good] <- drop(x[good, , drop=FALSE] %*% start)
	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.na(dev) || any(is.na(coef))) {
	    warning("Step size truncated due to divergence")
	    ii <- 1
	    while ((is.na(dev) || any(is.na(start)))) {
		if (ii > control$maxit)
		    stop("inner loop 1; can't correct step size")
		ii <- ii+1
		start <- (start + coefold)/2
#		eta[good] <- drop(x[good, , drop=FALSE] %*% start)
		eta <- drop(x %*% start)
		mu <- linkinv(eta <- eta + offset)
		dev <- sum(dev.resids(y, mu, weights))
	    }
	    boundary <- TRUE
	    coef <- start
	    if (control$trace)
		cat("New Deviance =", dev, "\n")
	}
	## check for fitted values outside domain.
	if (!(valideta(eta) && validmu(mu))) {
	    warning("Step size truncated: out of bounds.")
	    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[good] <- drop(x[good, , drop=FALSE] %*% start)
		mu <- linkinv(eta <- eta + offset)
	    }
	    boundary <- TRUE
	    coef <- start
	    dev <- sum(dev.resids(y, mu, weights))
	    if (control$trace)
		cat("New Deviance =", dev, "\n")
	}
	## check for convergence
	if (abs(dev - devold)/(0.1 + abs(dev)) < control$epsilon) {
	    conv <- TRUE
	    break
	} else {
	    devold <- dev
	    coefold <- coef
	}
    }##-------------- 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[seq(fit$rank+1, nvars)] <- NA
	dimnames(fit$qr) <- list(NULL, xnames)
    }
    coef[fit$pivot] <- coef
    xxnames <- xnames[fit$pivot]
    residuals <- rep(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(0, nobs)
    wt[good] <- w^2
    names(wt) <- ynames
    names(weights) <- ynames
    names(y) <- ynames
    names(fit$effects) <-
	c(xxnames[seq(fit$rank)], rep("", 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)
    resdf  <- n.ok - fit$rank
    ## calculate AIC
    aic.model <-
	##Should not be necessary: --pd
	##if(resdf>0) aic(y, n, mu, weights, dev) + 2*fit$rank else -Inf
	aic(y, n, mu, weights, dev) + 2*fit$rank
    list(coefficients = coef, residuals = residuals, fitted.values = mu,
	 effects = fit$effects, R = Rmat, rank = fit$rank,
	 qr = fit[c("qr", "rank", "qraux", "pivot", "tol")], 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),
                      na.print="", ...)
{
    cat("\nCall: ", deparse(x$call), "\n\n")
    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)
    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(paste("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),test=test))
    ##args <- function(...) nargs()
    ##if(args(...)) return(anova.glmlist(list(object, ...), 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(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")
	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],
			  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)
    if (nvars == 0) table <- table[1,,drop=FALSE] # kludge for null model
    dimnames(table) <- list(c("NULL", attr(object$terms, "term.labels")),
			    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
    } else df.scale <- Inf
    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(objects, dispersion=NULL, test=NULL)
{

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

    responses <- as.character(lapply(objects, function(x) {
	deparse(formula(x)[[2]])} ))
    sameresp <- responses==responses[1]
    if(!all(sameresp)) {
	objects <- objects[sameresp]
	warning(paste("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.glm(objects[[1]], dispersion=dispersion, test=test))

    ## extract statistics

    resdf  <- as.numeric(lapply(objects, function(x) x$df.residual))
    resdev <- as.numeric(lapply(objects, function(x) x$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("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 <- objects[[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"))
}


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, ...)
{
    Qr <- .Alias(object$qr)
    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(paste("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
    p1 <- 1:p

    ## WATCHIT! doesn't this rely on pivoting not permuting 1:p?
    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)
    }
    ## 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"),
		  aic = object$aic,
		  coefficients=coef.table,
		  dispersion=dispersion,
		  df=c(object$rank, df.r),
		  cov.unscaled=covmat.unscaled,
		  cov.scaled=covmat))

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

print.summary.glm <- function (x, digits = max(3, getOption("digits") - 3),
			       na.print = "", symbolic.cor = p > 4,
			       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)

    cat("\nCoefficients:\n")
    print.coefmat(x$coef, digits=digits, signif.stars=signif.stars, ...)
    ##
    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)) {
	p <- NCOL(correl)
	if(p > 1) {
	    cat("\nCorrelation of Coefficients:\n")
	    if(symbolic.cor)
		print(symnum(correl)[-1,-p])
	    else {
                correl[!lower.tri(correl)] <- NA
                print(correl[-1, -p, drop=FALSE],
                      digits = digits, na = "")
            }
	}
    }
    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 <- .Alias(object$residuals)
    mu	<- .Alias(object$fitted.values)
    wts <- .Alias(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(0, length(mu)),
                  pearson = (y-mu)/sqrt(object$weights),
                  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)
}
###- FIXME --- This is UGLY :  a lot of coding is just doubled from  ./glm.R --

anova.glm.null <- function (object, ..., test = NULL, na.action = na.omit)
{
    ## check for multiple objects
    if (length(list(object, ...)) > 1)
	return(anova.glmlist(list(object, ...), test = test))
    ## extract variables from model
    varlist <- attr(object$terms, "variables")
    nvars <- 0
    resdev <- resdf <- NULL
    ## if there is more than one explanatory variable then
    ## recall glm.fit to fit variables sequentially
    ## add values from null and full model
    resdf <- c(object$df.null)
    resdev <- c(object$null.deviance)
    ## construct table and title
    table <- data.frame(c(NA), c(NA), resdf, resdev)
    dimnames(table) <- list(c("NULL", attr(object$terms, "term.labels")),
                            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
    ## return output
    if (!is.null(test))
	table <- stat.anova(table = table, test = test,
			    scale = sum(object$weights * object$residuals^2)/
                            	object$df.residual,
			    df.scale = object$df.residual, n = NROW(x))
    output <- list(title = title, table = table)
    class(output) <- c("anova.glm.null", "anova.glm")
    return(output)
}
print.glm.null <- function(x, digits = max(3, getOption("digits") - 3),
                           na.print = "", ...)
{
    cat("\nCall: ", deparse(x$call), "\n\n")
    cat("No coefficients\n")
    cat("\nDegrees of Freedom:", length(x$residuals), "Total;",
	x$df.residual, "Residual\n")
    cat("Null Deviance:", format(signif(x$null.deviance, digits)), "\n")
    cat("Residual Deviance:", format(signif(x$deviance, digits)), "\t")
    cat("AIC:", format(signif(x$aic, digits)), "\n")
    invisible(x)
}
print.summary.glm.null <- function (x, digits = max(3, getOption("digits") - 3),
                                    na.print = "", ...)
{
    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)
	names(x$deviance.resid) <- c("Min", "1Q", "Median",
				     "3Q", "Max")
    }
    print.default(x$deviance.resid, digits = digits, na = "", print.gap = 2)
    cat("\nNo coefficients\n")
    cat(paste("\n(Dispersion parameter for ", x$family$family,
	      " family taken to be ", x$dispersion, ")\n\n    Null deviance: ",
	      x$null.deviance, " on ", x$df.null, " degrees of freedom\n\n",
	      "Residual deviance: ", x$deviance, " on ", x$df.residual,
	      " degrees of freedom\n\n", "Number of Fisher Scoring iterations: ",
	      x$iter, "\n\n", sep = ""))
    invisible(x)
}
summary.glm.null <- function (object, dispersion = NULL, correlation = TRUE,
                              na.action = na.omit, ...)
{
    ## calculate dispersion if needed
    ## extract x to get column names
    ## calculate scaled and unscaled covariance matrix
    if (is.null(dispersion)) {
	if (any(object$family$family == c("poisson",
		"binomial")))
	    dispersion <- 1
	else {
	    if (any(object$weights == 0))
		warning(paste("observations with zero weight",
			      "not used for calculating dispersion"))
	    dispersion <- sum(object$weights * object$residuals^2)/
                object$df.residual
	}
    }
    p <- 0
    ## return answer
    ans <- list(call = object$call, terms = object$terms,
		family = object$family,
                deviance.resid = residuals(object, type = "deviance"),
                dispersion= dispersion, df = c(object$rank,object$df.residual),
                deviance = object$deviance, df.residual = object$df.residual,
                null.deviance = object$null.deviance,
		df.null = object$df.null, iter = object$iter,
		)
    class(ans) <- c("summary.glm.null", "summary.glm")
    return(ans)
}
glm.fit.null <- function (x, y, weights = rep(1, nobs), start = NULL,
                          offset = rep(0, nobs), family = gaussian(),
                          control = glm.control(), intercept = FALSE)
{
    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(1, nobs)
    if (is.null(offset))
	offset <- rep(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
    eta <- rep(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))
}
model.matrix.glm.null<-function(x,...){
  rval<-matrix(ncol=0,nrow=length(object$y))
  attr(rval,"assign")<-integer(0)
}
grep <-
    function(pattern, x, ignore.case=FALSE, extended=TRUE, value=FALSE)
{
    .Internal(grep(pattern, x, ignore.case, extended, value))
}

sub <-
    function(pattern, replacement, x, ignore.case=FALSE, extended=TRUE)
{
    .Internal(sub(pattern, replacement, x, ignore.case, extended))
}

gsub <-
    function(pattern, replacement, x, ignore.case=FALSE, extended=TRUE)
{
    .Internal(gsub(pattern, replacement, x, ignore.case, extended))
}

regexpr <- function(pattern, text, extended=TRUE)
{
    .Internal(regexpr(pattern, text, extended))
}
grid <- function (nx=NULL, ny=NULL, col="lightgray", lty="dotted")
{
    if (is.null(nx)|| nx >= 1) {
        axp <- par("xaxp")
        if(is.null(nx)) nx <- axp[3]
	abline(v = seq(axp[1],axp[2],len=1+nx), col = col, lty = lty)
    }
    if (is.null(ny)|| ny >= 1) {
        axp <- par("yaxp")
        if(is.null(ny)) ny <- axp[3]
	abline(h = seq(axp[1],axp[2],len=1+ny), col = col, lty = lty)
    }
}
help.search <- function(pattern, fields = c("alias", "title"),
                        apropos, keyword, whatis, ignore.case = TRUE,
                        package = NULL, lib.loc = .lib.loc,
                        help.db = getOption("help.db"),
                        verbose = getOption("verbose"),
                        rebuild = FALSE) {
    TABLE <- c("name", "alias", "title", "keyword")
    if (!missing(pattern)) {
        if (!is.character(pattern) || (length(pattern) > 1))
            stop("`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("`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("`keyword' must be a single character string")
        else {
            pattern <- keyword
            fields <- "keyword"
        }
    } else if (!missing(whatis)) {
        if (!is.character(whatis) || (length(whatis) > 1))
            stop("`whatis' must be a single character string")
        else {
            pattern <- whatis
            fields <- "alias"
        }
    } else {
        stop("don't know what to search")
    }

    ## Set up the help db
    if(rebuild || is.null(help.db) || !file.exists(help.db)) {
        ## Check whether we can save the help db lateron
        save.db <- FALSE
        dir <- switch(.Platform$OS.type,
                      "windows" = Sys.getenv("R_USER"),
                      "unix" = Sys.getenv("HOME"),
                      "")
        if(nchar(dir) == 0) dir <- getwd()
        dir <- file.path(dir, ".R")
        dbfile <- file.path(dir, "help.db")
        if((file.exists(dir) || dir.create(dir)) && (unlink(dbfile) == 0))
            save.db <- TRUE
        ## Create the help db
        db <- NULL
        if(verbose) {
            cat("Packages:\n")
            np <- 0
        }
        if(is.null(package))
            package <-.packages(all.available = TRUE, lib.loc = lib.loc)
        for(p in package) {
            if(verbose)
                cat("", p, if((np <- np + 1)%% 5 == 0) "\n")
            path <- .find.package(p, lib.loc)
            lib <- dirname(path)
            cfile <- file.path(path, "CONTENTS")
            if(file.exists(cfile)) {
                ctext <- read.dcf(cfile,
                                 fields = c("Entry", "Aliases",
                                 "Description", "Keywords"))
                if((nr <- NROW(ctext)) > 0){
                    db <- rbind(db,
                                cbind(rep(p, nr), rep(lib, nr), ctext))
                } else {
                    warning(paste("Empty `CONTENTS' file of pkg", p,
                                  "in", lib))
                }
            }
        }
        if(verbose && (np %% 5 == 0)) cat("\n")
        colnames(db) <- c("pkg", "lib", TABLE)
        ## Maybe save the help db
        if(save.db) {
            save(db, file = dbfile)
            options(help.db = dbfile)
        }
    } else {
        load(file = help.db)
    }

    ## Matching
    if(verbose) cat("\nDatabase of dimension", dim(db))
    i <- NULL
    for (f in fields)
        i <- c(i, grep(pattern, db[, f], ignore.case = ignore.case))

    db <- db[sort(unique(i)), , drop = FALSE]
    if(verbose) cat(", matched", NROW(db),"entries.\n")

    ## Output
    fields <- paste(fields, collapse = " or ")
    if (NROW(db) > 0) {
        outFile <- tempfile()
        outConn <- file(outFile, open = "w")
        writeLines(paste("Help files with ", fields, " matching `",
                         pattern, "':\n", "Type `?FOO' to inspect ",
                         "entry `FOO(PKG) TITLE'.\n\n", sep = ""),
                   outConn)
        dbnam <- paste(db[ , "name"], "(", db[, "pkg"], ")", sep = "")
        dbtit <- paste(db[ , "title"], sep = "")
        writeLines(formatDL(dbnam, dbtit), outConn)
        close(outConn)
        file.show(outFile, delete.file = TRUE)
    } else {
        cat(paste("No help files found with ", fields, " matching `",
                  pattern, "'\n", sep = ""))
    }

    return(invisible())
}
hist <- function(x, ...) UseMethod("hist")

hist.default <-
    function (x, breaks, freq= NULL, probability = !freq, include.lowest= TRUE,
              right= TRUE, col = NULL, border = par("fg"),
              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
        rx <- range(x)
        nnb <-
            if(missing(breaks)) 1 + log2(n)
            else {                      # breaks = `nclass'
                if (is.na(breaks) | breaks < 2)
                    stop("invalid number of breaks")
                breaks
            }
        breaks <- pretty (rx, n = nnb, 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(diddle, length(breaks) - 1))
    else
	c(rep(-diddle, length(breaks) - 1),
	    if(include.lowest) diddle else -diddle)

    breaks <- breaks + fuzz
    h <- diff(breaks)

    storage.mode(x) <- "double"
    storage.mode(breaks) <- "double"
    ## With the fuzz adjustment above, the "right" and "include"
    ## arguments are really irrelevant
    counts <- .C("bincount",
                 x,
                 n,
                 breaks,
                 nB,
                 counts = integer(nB - 1),
                 right = as.logical(right),
                 include= as.logical(include.lowest),
                 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'")
    density <- counts/(n*h)
    mids <- 0.5 * (breaks[-1] + breaks[-nB])
    r <- structure(list(breaks = breaks, counts = counts,
                        intensities = density,
			density = density, mids = mids,
                        xname = xname, equidist = equidist),
                   class="histogram")
    if (plot) {
##-         if(missing(ylim))
##-             y <- if (freq) .Alias(counts) else .Alias(density)
        plot(r, freq = freq, col = col, border = border,
             main = main, xlim = xlim, ylim = ylim, xlab = xlab, ylab = ylab,
             axes = axes, labels = labels, ...)
        invisible(r)
    }
    else r
}

plot.histogram <-
    function (x, freq = equidist, col = NULL, border = par("fg"), lty = NULL,
              main = paste("Histogram of", x$xname),
              xlim = range(x$breaks), ylim = NULL,
              xlab = x$xname, ylab,
              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
    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, xlab = xlab, ylab = ylab, ...)
        if(axes) {
            axis(1, ...)
            axis(2, ...)
        }
    }
    rect(x$breaks[-nB], 0, x$breaks[-1], y,
         col = col, border = border, 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)
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")
    if(!is.null(x$statistic))
	cat(names(x$statistic), " = ", format(round(x$statistic, 4)),
	    ", ", sep = "")
    if(!is.null (x$parameter))
	cat(paste(names(x$parameter), " = ", format(round(x$parameter, 3)),
                  ",", sep = ""), "")
    cat("p-value =", format.pval(x$p.value, digits= digits), "\n")
    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)
}
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)
    z <- .Internal(identify(xy$x, xy$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)
{
    ans <- test
    test <- as.logical(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[1]+dx[1], x[-1]+dx)
    }
    if (length(y) > 1 && length(y) == ncol(z)) { # midpoints
        dy <- 0.5*diff(y)
        y <- c(y[1] - dy[1], y[1]+dy[1], y[-1]+dy)
    }
    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),
             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))
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 <- 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 = as.integer(limit),
                        PACKAGE = "base")
        res <- wk[c("value", "abs.error", "subdivisions")]
    } else {
        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 = as.integer(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]
    }
    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), ...)
{
    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 <- if(legend) xlim + c(-0.2/nr, 0.2 + 0.02*nch) * diff(xlim)
    else xlim + c(-0.2/nr, 0.2/nr) * diff(xlim)
    matplot(xvals, cells, ..., type = type,  xlim = xlim, ylim = ylim,
            xlab = xlab, ylab = ylab, xaxt = "n",
            col = col, lty = lty, pch = pch)
    mtext(xlabs, 1, at = xvals)
    if(legend) {
        yrng <- diff(ylim)
        yleg <- ylim[2] - 0.1 * yrng
        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 <- rev(order(cells[nr,  ]))
            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, bty = "n", legend = ylabs, lty = lty, col = col)
        else
            legend(xleg, yleg, bty = "n", legend = ylabs, col = col, pch = pch)
    }
    invisible()
}

is.vector <- function(x, mode="any") .Internal(is.vector(x,mode))
## is.finite <- function(x) !is.na(x)

is.name <- .Alias(is.symbol) # which is Primitive
##Was is.symbol <- function(x) typeof(x)=="symbol"


### 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)
}
#### copyright (C) 1998 B. D. Ripley
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(1, -ld))
    else if (ld > 0) 
        dY <- dim(Y) <- c(dY, rep(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(list(NULL), length(dX))
        else if (ld < 0)
            dnx <- c(dnx, rep(list(NULL), -ld))
        tmp <- which(sapply(dnx, is.null))
        dnx[tmp] <- lapply(tmp, function(i) rep("", dX[i]))

        if (is.null(dny))
            dny <- rep(list(NULL), length(dY))
        else if (ld > 0)
            dny <- c(dny, rep(list(NULL), ld))
        tmp <- which(sapply(dny, is.null))
        dny[tmp] <- lapply(tmp, function(i) rep("", 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
}

"%x%" <- .Alias(kronecker)
#### copyright (C) 1998 B. D. Ripley
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)
    cm.heights <- if (is.character(heights))grep("cm", heights)

    ## 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(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(0,4))
    par(oma=oma.saved)

    o.par <- par(mar=rep(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, legend, fill, col = "black", lty, lwd, pch, bty = "o",
         bg = par("bg"), pt.bg = NA, cex = 1,
         xjust = 0, yjust = 1, x.intersp = 1, y.intersp = 1, adj = 0,
         text.width = NULL, merge = do.lines && has.pch, trace = FALSE,
         ncol = 1, horiz = FALSE)
{
    if(is.list(x)) {
	if(!missing(y)) {	# the 2nd arg may really be `legend'
            if(!missing(legend))
                stop("`y' and `legend' when `x' is list (need no `y')")
            legend <- y
        }
        y <- x$y; x <- x$x
    } else if(missing(y)) stop("missing y")
    if (!is.numeric(x) || !is.numeric(y))
	stop("non-numeric coordinates")
    if ((nx <- length(x)) <= 0 || nx != length(y) || nx > 2)
	stop("invalid coordinate lengths")

    xlog <- par("xlog")
    ylog <- par("ylog")

    rect2 <- function(left, top, dx, dy, ...) {
	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, ...)
    }
    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, u="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)
    ychar <- yextra + max(yc, strheight(legend, u="user", cex=cex))
    if(trace) catn("  xchar=", xchar, "; (yextra,ychar)=", c(yextra,ychar))

    if(!missing(fill)) {
        ##= sizes of filled boxes.
        xbox <- xc * 0.8
        ybox <- yc * 0.5
        dx.fill <- xbox ## + x.intersp*xchar
    }
    do.lines <- (!missing(lty) && any(lty > 0)) || !missing(lwd)
    n.leg <- length(legend)

    ## legends per column:
    n.legpercol <-
        if(horiz) {
            if(ncol != 1)
                warning(paste(
             "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) && 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(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(!missing(fill))      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 (bty != "n") {
        if(trace)
            catn("  rect2(",left,",",top,", w=",w,", h=",h,"...)",sep="")
	rect2(left, top, dx = w, dy = h, col = bg)
    }
    ## (xt[],yt[]) := `current' vectors of (x/y) legend text
    xt <- left + xchar + (w0 * rep(0:(ncol-1), rep(n.legpercol,ncol)))[1:n.leg]
    yt <- top - rep(1:n.legpercol,ncol)[1:n.leg] * ychar

    if (!missing(fill)) {               #- draw filled boxes -------------
	fill <- rep(fill, length.out=n.leg)
	rect2(left=xt, top=yt+ybox/2, dx = xbox, dy = ybox, col = fill)
	xt <- xt + dx.fill
    }
    if(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
	ok.l <- if(missing(lty)) { lty <- 1; TRUE } else 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, ...)", sep="")
	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.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],"...)")
	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
    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, lib.loc = .lib.loc, character.only = FALSE,
             logical.return = FALSE, warn.conflicts = TRUE,
             keep.source = getOption("keep.source.pkgs"))
{
    fQuote <- function(s) paste("`", s, "'", sep = "")
    if(!missing(package)) {
	if(!character.only)
	    package <- as.character(substitute(package))
	pkgname <- paste("package", package, sep = ":")
	if(is.na(match(pkgname, search()))) {
            pkgpath <- .find.package(package, lib.loc, quiet = TRUE)
            if(length(pkgpath) == 0) {
                txt <- paste("There is no package called",
                             fQuote(package))
                if (logical.return) {
                    warning(txt)
		    return(FALSE)
		}
		else stop(txt)
            }
            which.lib.loc <- dirname(pkgpath)
            codeFile <- file.path(which.lib.loc, package, "R", package)
	    ## create environment
	    env <- attach(NULL, 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)
	    ## source file into env
	    if(file.exists(codeFile))
                sys.source(codeFile, env, keep.source = keep.source)
            else
		warning(paste("Package ",
                              fQuote(package),
                              "contains no R code"))
	    .Internal(lib.fixup(env, .GlobalEnv))
	    if(exists(".First.lib", envir = env, inherits = FALSE)) {
		firstlib <- get(".First.lib", 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")
            }
	    if (warn.conflicts &&
		!exists(".conflicts.OK",  envir = env, inherits = FALSE)) {
		##-- Check for conflicts
		dont.mind <- c("last.dump", "last.warning", ".Last.value",
			       ".Random.seed")
		lib.pos <- match(pkgname, search())
		ob <- objects(lib.pos)
		fst <- TRUE
		ipos <- seq(along = sp <- search())[-c(lib.pos,
			    match("Autoloads", sp))]
		for (i in ipos) {
		    obj.same <- match(objects(i), ob, nomatch = 0)
		    if (any(obj.same > 0) &&
			length(same <- (obs <- ob[obj.same])
			       [!obs %in% dont.mind])) {
			if (fst) {
			    fst <- FALSE
			    cat("\nAttaching package ", fQuote(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")
		    }
		}
	    }
            on.exit()
	}
	else {
	    if (getOption("verbose"))
		warning(paste("Package",
                              pkgname,
                              "already present in search()"))
	}
    }
    else if(!missing(help)) {
	if(!character.only)
	    help <- as.character(substitute(help))
        help <- help[1]                 # only give help on one package

        pkgpath <- .find.package(help, lib.loc)
        outFile <- tempfile("Rlibrary")
        outConn <- file(outFile, open = "w")
        docFiles <- file.path(pkgpath,
                              c("TITLE", "DESCRIPTION", "INDEX"))
        headers <- c("", "Description:\n\n", "Index:\n\n")
        footers <- c("\n", "\n", "")
        for(i in which(file.exists(docFiles))) {
            writeLines(headers[i], outConn)
            writeLines(readLines(docFiles[i]), outConn)
            writeLines(footers[i], outConn)
        }
        close(outConn)
        file.show(outFile, delete.file = TRUE,
                  title = paste("Documentation for package",
                  fQuote(help)))
    }
    else {
	## library():
	outFile <- tempfile("Rlibrary")
        outConn <- file(outFile, open = "w")
	avail <- NULL
	for(lib in lib.loc) {
	    cat("\nPackages in library `", lib, "':\n\n", sep = "",
		file = outConn, append = TRUE)
            a <- .packages(all.available = TRUE, lib.loc = lib)
            for (i in sort(a)) {
                title <- file.path(lib, i, "TITLE")
                if(file.exists(title))
                    writeLines(readLines(title), outConn)
                else
                    writeLines(i, outConn)
	    }
	    avail <- c(avail, a)
	}
        close(outConn)
	file.show(outFile, delete.file = TRUE,
                  title = "R packages available")
	return(invisible(avail))
    }
    if (logical.return)
	TRUE
    else invisible(.packages())
}

library.dynam <-
function(chname, package = .packages(), lib.loc = .lib.loc, verbose =
         getOption("verbose"), file.ext = .Platform$dynlib.ext, ...)
{
    if (!exists(".Dyn.libs"))
        assign(".Dyn.libs", character(0), envir = .AutoloadEnv)
    if (missing(chname) || (LEN <- nchar(chname)) == 0)
        return(.Dyn.libs)
    nc.ext <- nchar(file.ext)
    if (substr(chname, LEN - nc.ext + 1, LEN) == file.ext)
        chname <- substr(chname, 1, LEN - nc.ext)
    if (is.na(match(chname, .Dyn.libs))) {
        for(pkg in .find.package(package, lib.loc, missing(lib.loc),
                                 quiet = TRUE)) {
            file <- file.path(pkg, "libs",
                              paste(chname, file.ext, sep = ""))
            if(file.exists(file)) break
            else
                file <- ""
        }
        if(file == "") {
            stop(paste("dynamic library `", chname, "' not found",
                       sep = ""))
        }
        if (verbose)
            cat("now dyn.load(", file, ")..\n", sep = "")
        dyn.load(file, ...)
        assign(".Dyn.libs", c(.Dyn.libs, chname), envir = .AutoloadEnv)
    }
    invisible(.Dyn.libs)
}

require <- function(package, quietly = FALSE, warn.conflicts = TRUE,
                    keep.source = getOption("keep.source.pkgs"))
{
    package <- as.character(substitute(package)) # allowing "require(eda)"
    if (is.na(match(paste("package", package, sep = ":"), search()))) {
	if (!quietly) cat("Loading required package:", package, "\n")
	library(package, char = TRUE, logical = TRUE,
		warn.conflicts = warn.conflicts, keep.source = keep.source)
    } else TRUE
}

.packages <- function(all.available = FALSE, lib.loc = .lib.loc) {
    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, "R", nam))
                   || file.exists(file.path(lib, nam, "data")))
                    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(pos.to.env(i), "path"))
    searchpaths[[length(s)]] <- system.file()
    pkgs <- paste("package", package, sep=":")
    pos <- match(pkgs, s)
    if(any(m <- is.na(pos))) {
        if(!quiet) {
            miss <- paste(package[m], collapse=", ")
            if(all(m)) stop(paste("none of the packages are not loaded"))
            else warning(paste("package(s)", miss, "are not loaded"))
        }
        pos <- pos[!m]
    }
    unlist(searchpaths[pos], use.names=FALSE)
}

.find.package <-
function(package, lib.loc = .lib.loc, use.attached, quiet = FALSE) {

    if(missing(use.attached))
        use.attached <- missing(lib.loc)
    else if(is.null(use.attached))
        use.attached <- FALSE
    else if(!is.logical(use.attached))
        stop("incorrect value for `use.attached'")

    fQuote <- function(s) paste("`", s, "'", sep = "")

    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(use.attached)
            fp <- c(.path.package(pkg, TRUE), fp)
        fp <- unique(fp[file.exists(fp)])
        if(length(fp) == 0) {
            bad <- c(bad, pkg)
            next
        }
        if(length(fp) > 1) {
            fp <- fp[1]
            warning(paste("package `", pkg, "' found more than once,\n",
                          "using the one found in `", dirname(fp), "'",
                          sep = ""))
        }
        paths <- c(paths, fp)
    }

    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", fQuote(pkg)))
    }

    paths
}
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(paste("method =", method,
		      "is not supported. Using \"qr\"."))
    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(paste("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 + offset, weights = w, rank = 0,
		  df.residual = length(y))
	class(z) <-
	    if (is.matrix(y))
		c("mlm.null", "lm.null", "mlm", "lm")
	    else c("lm.null", "lm")
    }
    else {
	x <- model.matrix(mt, mf, contrasts)
	z <- if(is.null(w)) lm.fit(x, y, offset=offset, ...)
	else lm.wfit(x, y, w, offset=offset, ...)
	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, ...)
{
    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
        cc <- match.call()
        cc[[1]] <- as.name("lm.fit.null")
        return(eval(cc, parent.frame()))
    }
    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(paste("method =",method,
		      "is not supported. Using \"qr\"."))
    if(length(list(...)))
	warning(paste("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")
    coef <- z$coefficients
    pivot <- z$pivot
    r1 <- 1:z$rank
    dn <- colnames(x); if(is.null(dn)) dn <- paste("x", 1:p, sep="")
    nmeffects <- c(dn[pivot[r1]], rep("", n - z$rank))
    if (is.matrix(y)) {
	coef[-r1, ] <- NA
	coef[pivot, ] <- coef
	dimnames(coef) <- list(dn, colnames(y))
	dimnames(z$effects) <- list(nmeffects,colnames(y))
    } else {
	coef[-r1] <- 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
    c(z[c("coefficients", "residuals", "effects", "rank")],
      list(fitted.values = r1, assign = attr(x, "assign"),
	   qr = z[c("qr", "qraux", "pivot", "tol", "rank")],
	   df.residual = n - z$rank))
}

lm.wfit <- function (x, y, w, offset = NULL, method = "qr", tol = 1e-7, ...)
{
    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(paste("method =",method,
		      "is not supported. Using \"qr\"."))
    if(length(list(...)))
	warning(paste("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
        cc <- match.call()
        cc[[1]] <- as.name("lm.wfit.null")
        return(eval(cc, parent.frame()))
    }
    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")
    coef <- z$coefficients
    pivot <- z$pivot
    r1 <- 1:z$rank
    dn <- colnames(x); if(is.null(dn)) dn <- paste("x", 1:p, sep="")
    nmeffects <- c(dn[pivot[r1]], rep("", n - z$rank))
    if (is.matrix(y)) {
	coef[-r1, ] <- NA
	coef[pivot, ] <- coef
	dimnames(coef) <- list(dn, colnames(y))
	dimnames(z$effects) <- list(nmeffects,colnames(y))
    } else {
	coef[-r1] <- 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
    c(z[c("coefficients", "residuals", "fitted.values", "effects",
	  "weights", "rank")],
      list(assign = x.asgn,
	   qr = z[c("qr", "qraux", "pivot", "tol", "rank")],
	   df.residual = n - z$rank))
}

print.lm <- function(x, digits = max(3, getOption("digits") - 3), ...)
{
    cat("\nCall:\n",deparse(x$call),"\n\n",sep="")
    cat("Coefficients:\n")
    print.default(format(coef(x), digits=digits),
		  print.gap = 2, quote = FALSE)
    cat("\n")
    invisible(x)
}

summary.lm <- function (object, correlation = FALSE, ...)
{
    z <- .Alias(object)
    Qr <- .Alias(object$qr)
    if (is.null(z$terms) || is.null(Qr))
	stop("invalid \'lm\' object:  no terms or qr component")
    n <- NROW(Qr$qr)
    p <- z$rank
    rdf <- n - p
    if(rdf != z$df.residual)
        warning("inconsistent residual degrees of freedom. -- please report!")
    p1 <- 1:p
    ## do not want missing values substuted here
    r <- z$resid
    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*(1 - pt(abs(tval), rdf)))
    dimnames(ans$coefficients)<-
	list(names(z$coefficients)[Qr$pivot[p1]],
	     c("Estimate", "Std. Error", "t value", "Pr(>|t|)"))
    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)
    }
    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)
    }
    class(ans) <- "summary.lm"
    ans
}

print.summary.lm <-
    function (x, digits = max(3, getOption("digits") - 3),
              symbolic.cor = p > 4,
	      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 (nsingular <- df[3] - df[1])
	cat("\nCoefficients: (", nsingular,
	    " not defined because of singularities)\n", sep = "")
    else cat("\nCoefficients:\n")

    print.coefmat(x$coef, digits=digits, signif.stars=signif.stars, ...)
    ##
    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,d=digits),
	    "\nF-statistic:", formatC(x$fstatistic[1], digits=digits),
	    "on", x$fstatistic[2], "and",
	    x$fstatistic[3], "DF,  p-value:",
	    formatC(1 - pf(x$fstatistic[1], x$fstatistic[2],
			   x$fstatistic[3]), dig=digits),
	    "\n")
    }
    correl <- x$correlation
    if (!is.null(correl)) {
	p <- NCOL(correl)
	if (p > 1) {
	    cat("\nCorrelation of Coefficients:\n")
	    if(symbolic.cor)
		print(symnum(correl)[-1,-p])
	    else {
		correl[!lower.tri(correl)] <- NA
		print(correl[-1, -p, drop=FALSE],
		      digits = digits, na = "")
	    }
	}
    }
    cat("\n")#- not in S
    invisible(x)
}

## KH on 1998/07/10: update.default() is now used ...

residuals.lm <-
    function(object,
             type = c("working","response", "deviance","pearson", "partial"),
             ...)
{
    type <- match.arg(type)
    r <- .Alias(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)
}

weights.lm <- .Alias(weights.default)
df.residual.lm <- function(object, ...) object$df.residual
deviance.lm <- function(object, ...) sum(weighted.residuals(object)^2)
formula.lm <- function(object, ...)
{
    form <- object$formula
    if( !is.null(form) )
        return(form)
    formula(object$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	dimnames(object$qr$qr)[[2]][1:object$rank]
}

case.names.lm <- function(object, full=FALSE)
{
    w <- weights(object)
    dn <- .Alias(names(object$residuals))
    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)
    p1 <- 1:object$rank
    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)
    dfr <- df.residual(object)
    df <- c(unlist(lapply(split(asgn,  asgn), length)), dfr)
    ms <- ss/df
    f <- ms/(ssr/dfr)
    p <- 1 - pf(f,df,dfr)
    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(paste("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"))
}


anovalist.lm <- function (object, ..., test = NULL)
{
    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(paste("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(NA,nmodels)
    for(i in 2:nmodels) {
	if(df[i] > 0) {
	    f[i] <- ms[i]/(ss.r[i]/df.r[i])
	    p[i] <- 1 - pf(f[i], df[i], df.r[i])
	}
	else if(df[i] < 0) {
	    f[i] <- ms[i]/(ss.r[i-1]/df.r[i-1])
	    p[i] <- 1 - pf(f[i], -df[i], df.r[i-1])
	}
	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"
}

## code 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, ...)
{
## june 24 2000 (3 minor changes from JM's May 7 version)
    attrassign <- function (object, ...) UseMethod("attrassign")
    attrassign.lm <- function (lmobj)
        attrassign(model.matrix(lmobj), terms(lmobj))
    attrassign.default <- function (mmat, tt) {
      if (!inherits(tt, "terms"))
        stop("need terms object")
      aa <- attr(mmat, "assign")
      if (is.null(aa))
        stop("argument is not really a model matrix")
      ll <- attr(tt, "term.labels")
      if (attr(tt, "intercept") > 0)
        ll <- c("(Intercept)", ll)
      aaa <- factor(aa, labels = ll)
      split(order(aa), aaa)
    }
    tt <- terms(object)
    if(missing(newdata)) {
        X <- model.matrix(object)
        offset <- object$offset
    }
    else {
        X <- model.matrix(delete.response(tt), newdata,
			  contrasts = object$contrasts, xlev = object$xlevels)
	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)
    }
    n <- NROW(object$qr$qr)
    p <- object$rank
    p1 <- 1:p
    piv <- object$qr$pivot[p1]
## 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") {
	if (is.null(scale)) {
	    r <- object$resid
	    f <- object$fitted
	    w <- object$weights
	    rss <- sum(if(is.null(w)) r^2 else r^2 * w)
	    df <- n - p
	    res.var <- rss/df
	} else {
	    res.var <- scale^2
	}
 ## type!="terms"
    if(type!="terms"){
       if(missing(newdata))
       XRinv <- qr.Q(object$qr)[, p1]
       else {
             Rinv <- qr.solve(qr.R(object$qr)[p1, p1])
             XRinv <- X[, piv]%*%Rinv
             }
	ip <- drop(XRinv^2%*%rep(res.var, p))
	}
    }
## type=="terms"
    if (type=="terms"){
      asgn <- attrassign(object)
      hasintercept <- attr(tt, "intercept")>0
      if (hasintercept){
        asgn$"(Intercept)" <- NULL
        avx <- rep(1/n, n)%*%model.matrix(object)
	termsconst <- sum(avx[piv]*beta[piv])
	}
      nterms <- length(asgn)
      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(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
	if(any(iipiv)>0)
	        predictor[, i] <- X[, iipiv, drop=FALSE]%*%(beta[iipiv])
		else predictor[, i] <- rep(0, NROW(predictor))
        if (se.fit||interval!="none"){
	  if(any(iipiv)>0)

              ip[, i] <- as.matrix(X[, iipiv, drop=FALSE] %*%
                                  Rinv[ii, , drop=FALSE])^2 %*% rep(res.var, p)
	  else ip[, i] <- rep(0, NROW(ip))
        }
      }

      if (!is.null(terms)){
        predictor <- predictor[, terms, drop=FALSE]
        if (se.fit)
          ip <- ip[, terms, drop=FALSE]
    }
      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)
	w <- tfrac * switch(interval,
			    confidence=sqrt(ip),
			    prediction=sqrt(ip+res.var)
			    )
        if(type!="terms") {
            predictor <- cbind(predictor, predictor + w %o% c(1, -1))
            colnames(predictor) <- c("fit", "lwr", "upr")
        }
        else {
            lwr <- predictor + w
            upr <- predictor - w
        }
    }
    if(missing(newdata) && !is.null(na.act <- object$na.action)) {
        predictor <- napredict(na.act, predictor)
        if(se.fit) se.fit <- napredict(na.act, sqrt(ip))
    }
    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 = sqrt(ip), lwr=lwr,upr=upr,
	     df = df, residual.scale = sqrt(res.var))
    } else if (se.fit)
        list(fit = predictor, se.fit = sqrt(ip),
	     df = df, residual.scale = sqrt(res.var))
    else predictor
}

effects.lm <- function(object, set.sign = FALSE)
{
    eff <- object$effects
    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 {
	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, ...)
{
    if(missing(newdata)) return(object$fitted)
    if(se.fit)
	stop("The 'se.fit' argument is not yet implemented for mlm objects")
    x <- model.matrix(object, newdata) # will use model.matrix.lm
    piv <- object$qr$pivot[1:object$rank]
    pred <- X[, piv, drop = FALSE] %*% object$coefficients[piv,]
    if(inherits(object, "mlm")) pred else pred[, 1]
}
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 (lm.obj)
{
    if (is.empty.model(lm.obj$terms)) {
	warning("Can\'t compute influence on an empty model")
	return(NULL)
    }
    n <- as.integer(nrow(lm.obj$qr$qr))
    k <- as.integer(lm.obj$qr$rank)
    e <- weighted.residuals(lm.obj)
    .Fortran("lminfl",
	     lm.obj$qr$qr,
	     n,
	     n,
	     k,
	     lm.obj$qr$qraux,
	     e,
	     hat = double(n),
	     coefficients = matrix(0, nr = n, nc = k),
	     sigma = double(n),
	     DUP = FALSE, PACKAGE="base")[c("hat", "coefficients", "sigma")]
}

rstandard <- function(lm.obj, infl = lm.influence(lm.obj),
                      res = weighted.residuals(lm.obj),
                      sd = sqrt(deviance(lm.obj)/df.residual(lm.obj)))
    res / (sd * sqrt(1 - infl$hat))
## OLD (<= 0.90.1); fails for glm objects:
##  res / (summary(lm.obj)$sigma * sqrt(1 - infl$hat))


rstudent <- function(lm.obj, infl = lm.influence(lm.obj),
                     res = weighted.residuals(lm.obj))
    res / (infl$sigma * sqrt(1 - infl$hat))

dffits <- function(lm.obj, infl = lm.influence(lm.obj),
                   res = weighted.residuals(lm.obj))
    res * sqrt(infl$hat)/(infl$sigma*(1-infl$hat))

dfbetas <- function (lm.obj, infl = lm.influence(lm.obj))
{
    xxi <- chol2inv(lm.obj$qr$qr, lm.obj$qr$rank)
    d <- infl$coefficients/(outer(infl$sigma, sqrt(diag(xxi))))
    dimnames(d) <- list(case.names(lm.obj), variable.names(lm.obj))
    d
}

covratio <- function(lm.obj, infl = lm.influence(lm.obj),
                     res = weighted.residuals(lm.obj))
{
    n <- nrow(lm.obj$qr$qr)
    p <- lm.obj$rank
    omh <- 1-infl$hat
    e.star <- res/(infl$sigma*sqrt(omh))
    1/(omh*(((n - p - 1)+e.star^2)/(n - p))^p)
}

## Used in plot.lm(); allow passing of known parts:
cooks.distance <- function(lm.obj, infl = lm.influence(lm.obj),
                           res = weighted.residuals(lm.obj),
                           sd = sqrt(deviance(lm.obj)/df.residual(lm.obj)))
{
    p <- lm.obj$rank
    hat <- .Alias(infl$hat)
    ((res/(sd * (1 - hat)))^2 * hat)/p
}

influence.measures <- function(lm.obj)
{
    is.influential <- function(infmat)
    {
	## Argument is result of using influence.measures
	## Returns a matrix  of logicals structured like the argument
	n <- nrow(infmat)
	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(lm.obj)
    p <- lm.obj$rank
    e <- weighted.residuals(lm.obj)
    s <- sqrt(sum(e^2)/df.residual(lm.obj))
    xxi <- chol2inv(lm.obj$qr$qr, lm.obj$qr$rank)
    si <- infl$sigma
    h <- infl$hat
    dfbetas <- infl$coefficients / outer(infl$sigma, sqrt(diag(xxi)))
    vn <- variable.names(lm.obj); 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(lm.obj$qr$qr)
    infmat <- cbind(dfbetas, dffit = dffits, cov.r = cov.ratio,
		    cook.d = cooks.d, hat=h)
    is.inf <- is.influential(infmat)
    ans <- list(infmat = infmat, is.inf = is.inf, call = lm.obj$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)
    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
    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)
    }
}
###-------- This is  UGLY :  a lot of coding is just doubled from  ./lm.R  ----

anova.lm.null <- function (object, ...)
{
    if (length(list(object, ...)) > 1)
	return(anova.lmlist(object, ...))
    w <- weights(object)
    ssr <- sum(if (is.null(w))resid(object)^2 else w * resid(object)^2)
    ##comp <- object$effects[1:object$rank]
    ##asgn <- object$assign[object$qr$pivot][1:object$rank]
    dfr <- df.residual(object)
    ss <- ssr
    df <- dfr
    ms <- ss/df
    f <- ms/(ssr/dfr)
    p <- 1 - pf(f, df, dfr)
    table <- data.frame(df, ss, ms, f, p)
    table[length(p), 4:5] <- NA
    dimnames(table) <- list(c(attr(object$terms, "term.labels"), "Residuals"),
			    c("Df", "Sum Sq", "Mean Sq", "F value", "Pr(>F)"))
    structure(table, heading = c("Analysis of Variance Table\n",
                     paste("Response:", formula(object)[[2]])),
	      class= c("anova", "data.frame"))# was "tabular"
}

print.lm.null <- function (x, digits = max(3, getOption("digits") - 3), ...)
{
    cat("\nCall:\n", deparse(x$call), "\n\n", sep = "")
    cat("No coefficients:\n\n")
    invisible(x)
}

print.summary.lm.null <- function (x, digits = max(3, getOption("digits") - 3), ...)
{
    cat("\nCall:\n")
    cat(paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n\n", sep = "")
    resid <- x$residuals
    df <- x$df
    rdf <- df[2]
    if (rdf > 5) {
	cat("Residuals:\n")
	if (length(dim(resid)) == 2) {
	    rq <- apply(t(resid), 1, quantile)
	    dimnames(rq) <- list(c("Min", "1Q", "Median", "3Q", "Max"),
				 dimnames(resid)[[2]])
	}
	else {
	    rq <- quantile(resid)
	    names(rq) <- c("Min", "1Q", "Median", "3Q", "Max")
	}
	print(rq, digits = digits, ...)
    }
    else if (rdf > 0) {
	cat("Residuals:\n")
	print(resid, digits = digits, ...)
    }
    else cat("\nNo Coefficients:\n")
    cat("\nResidual standard error:",
	format(signif(x$sigma, digits)), "on", rdf, "degrees of freedom\n")
    cat("\n")
    invisible(x)
}

summary.lm.null <- function (z, correlation = FALSE, ...)
{
    n <- length(z$fitted.values)
    p <- 0
    r <- resid(z)
    f <- fitted(z)
    w <- weights(z)
    if (is.null(z$terms)) {
	stop("invalid \'lm\' object:  no terms component")
    }
    else {
	rss <- sum(r^2)
	mss <- sum(f^2)
    }
    resvar <- rss/(n - p)
###R <- chol2inv(z$qr$qr[p1, p1, drop = FALSE])
###se <- sqrt(diag(R) * resvar)
###est <- z$coefficients[z$qr$pivot[p1]]
###tval <- est/se
    ans <- z[c("call", "terms")]
    ans$residuals <- r
    ans$coefficients <- NULL
    ans$sigma <- sqrt(resvar)
    ans$df <- c(p, n - p, n - p)
    ans$r.squared <- 0
    ans$cov.unscaled <- NULL
    class(ans) <- "summary.lm.null"
    ans
}

### The next two are used by lm.fit when it detects a null design
### matrix. A bit of a kludge, but it makes drop1 and friends work
### with no-intercept models

lm.fit.null <- function (x, y, method = "qr", tol = 1e-07, ...)
    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, ...)
    list(coefficients = numeric(0), residuals = y, fitted.values = 0 *
         y, weights = w, rank = 0, df.residual = length(y))

model.matrix.lm.null <- function(x,...)
{
  rval <- matrix(ncol=0, nrow=length(object$y))
  attr(rval,"assign") <- integer(0)
}
load <- function(file,envir = parent.frame())
    .Internal(load(file,envir))

save <- function(..., list = character(0), file = "", ascii = FALSE)
{
    names <- as.character( substitute( list(...)))[-1]
    list<- c(list, names)
    invisible(.Internal(save(list, file, ascii)))
}

save.image <- function (file = ".RData")
    eval(substitute(save(list = ls(all.names = TRUE), file = file)),
         .GlobalEnv)
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)
## from package:nls
logLik <- function(object, ...) UseMethod("logLik")

## from package:nlme 

## 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(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
}

print.logLik <- function(x, ...) print(c(x), ...)
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("Incorrect specification of `table' or `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(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 <- (1 : nvar)[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)
    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(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)
    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(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] <- apply(as.matrix(q^2), 1, sum)

    ## calculate diagnostics

    stddev <- (apply(as.matrix(resids^2), 2, sum)/(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)-apply(is.na(resids), 2, sum)
    lsqr <- ls.out$qr
    p <- lsqr$rank

    ## calculate total sum sq and df

    if(ls.out$intercept) {
	if(is.matrix(lsqr$qt))
	    totss <- apply(lsqr$qt[-1, ]^2, 2, sum)
	else totss <- sum(lsqr$qt[-1]^2)
	degfree <- p - 1
    } else {
	totss <- apply(as.matrix(lsqr$qt^2), 2, sum)
	degfree <- p
    }

    ## calculate residual sum sq and regression sum sq

    resss <- apply(resids^2, 2, sum, na.rm=TRUE)
    resse <- (resss/(n-p))^.5
    regss <- totss - resss
    rsquared <- regss/totss
    fstat <- (regss/degfree)/(resss/(n-p))
    pvalue <- 1 - pf(fstat, degfree, (n-p))

    ## 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*(1 - pt(abs(coef[, i]/se), n[i]-p)))
	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)
{
    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))),
    ##			1, sum)
    if(!inverted)
	cov <- solve(cov)
    retval <- apply((x%*%cov) * x, 1, sum)
    ##-
    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", class(result[[i]]))
        }
        attr(result, "call") <- Call
    } else {
        if(!inherits(result, "maov")) stop("need multiple response")
        class(result) <- c("manova", class(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"))
    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)
    if(nresp <= 1) stop("need multiple response")

    if (is.null(effects)) {
        df <- nterms <- neff <- 0
        ss <- list(0)
        nmrows <- character(0)
    } else {
        nobs <- length(resid[, 1])
        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)
        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)
}
## 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))  else NULL
    ##
    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) NULL else 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)
    ndn <- names(dn)
    dn <- list(value, if(!is.null(dn)) dn[[2]])
    names(dn) <- ndn
    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)
    ndn <- names(dn)
    dn <- list(if(!is.null(dn)) dn[[1]], value)
    names(dn) <- ndn
    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=x) .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"
# Originally file MASS/max.col.q
# copyright (C) 1994-9 W. N. Venables and B. D. Ripley
#
# nrow() & ncol() are guaranteed to return integer
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 (na.rm)
	x <- x[!is.na(x)]
    trim <- trim[1]
    n <- length(c(x, recursive=TRUE)) # for data.frame
    if(trim > 0 && n > 0) {
	if(mode(x) == "complex")
	    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(x)/n
}

weighted.mean <- function(x, w, na.rm = FALSE ){
    if(missing(w)) w <- rep(1,length(x))
    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 {
            bx <- matrix(as.character(as.matrix.data.frame(x[, by.x,
                                                             drop=FALSE])), nx)
            by <- matrix(as.character(as.matrix.data.frame(y[, by.y,
                                                             drop=FALSE])), ny)
            bx <- drop(apply(bx, 1, function(x) paste(x, collapse="\r")))
            by <- drop(apply(by, 1, function(x) paste(x, collapse="\r")))
        }
        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(1:1, nxx), if(all.y) m$y.alone),
               -by.y, drop=FALSE]
        if(all.x) y[(lxy+1):(lxy+nxx), ] <- NA

        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
}
#### copyright (C) 1998 B. D. Ripley

## 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 <- class(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(...) 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(1, nrow(res)) %*% res)
}

plot.mlm <- function (...) .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
}
#### copyright (C) 1998 B. D. Ripley
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(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(nms <- 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 <- append(result, list(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(1, length(terms)))
	tables[[i]] <- tapply(data, mf[mf.cols[[i]]], get(fun))
	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(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))
	    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(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(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"))) 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) <-
		    append(list(format(c(rownames(table), rep("rep", dim.t[1])))),
			   dimnames(table)[-1])
		ctable <- eval(parse(text = paste(
				     "ctable[as.numeric(t(matrix(seq(nrow(ctable)),ncol=2)))", paste(rep(", ", 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.matrix(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(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),
					"+", deparse(errorterm[[2]])))
    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("[")
    if(as.character(ans[[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))
#delete.response <- function (termobj)
#{
#    intercept <- if (attr(termobj, "intercept")) "1" else "0"
#    terms(reformulate(c(attr(termobj, "term.labels"), intercept), NULL),
#	  specials = names(attr(termobj, "specials")))
#}

delete.response <- function (termobj)
{
    f <- formula(termobj)
    if (length(f) == 3)
        f[[2]] <- NULL
    tt <- terms(f, specials = names(attr(termobj, "specials")))
    attr(tt, "intercept") <- attr(termobj, "intercept")
    tt
}

reformulate <- function (termlabels, response=NULL)
{
    termtext <- paste(termlabels, collapse="+")
    if (is.null(response)) {
	termtext <- paste("~", termtext, collapse="")
	rval<-eval(parse(text=termtext)[[1]])
        environment(rval)<-parent.frame()
        rval
    } else {
	termtext <- paste("response", "~", termtext, collapse="")
	termobj <- eval(parse(text=termtext)[[1]])
	termobj[[2]] <- response
        environment(termobj)<-parent.frame()
	termobj
    }
}

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.formula <- function(x, specials = NULL, abb = NULL, data = NULL,
			  neg.out = TRUE, keep.order = 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")
	ff <- formula(paste(lhs, "~", rhs))
        environment(ff) <- environment(form)
        ff
    }
    if (!is.null(data) && !is.environment(data) && !is.data.frame(data))
	data <- as.data.frame(data)
    new.specials <- unique(c(specials, "offset"))
    tmp <- .Internal(terms.formula(x, new.specials, abb, data, keep.order))
    ## need to fix up . in formulae in R
    terms <- fixFormulaObject(tmp)
    attributes(terms) <- attributes(tmp)
    environment(terms) <- environment(x)
    offsets <- attr(terms, "specials")$offset
    if (!is.null(offsets)) {
	names <- dimnames(attr(terms, "factors"))[[1]][offsets]
	offsets <- match(names, dimnames(attr(terms, "factors"))[[2]])
	offsets <- offsets[!is.na(offsets)]
	if (length(offsets) > 0) {
	    attr(terms, "factors") <- attr(terms, "factors")[, -offsets, drop = FALSE]
	    attr(terms, "term.labels") <- attr(terms, "term.labels")[-offsets]
	    attr(terms, "order") <- attr(terms, "order")[-offsets]
	    attr(terms, "offset") <- attr(terms, "specials")$offset
	}
    }
    attr(terms, "specials")$offset <- NULL
    if( !inherits(terms, "formula") )
        class(terms) <- c(class(terms), "formula")
    terms
}

coef <- function(object, ...) UseMethod("coef")
coef.default <- function(object, ...) object$coefficients
coefficients <- .Alias(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 <- .Alias(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 <- .Alias(fitted)

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

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

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

df.residual <- function(object, ...)UseMethod("df.residual")

variable.names <- function(object, ...) UseMethod("variable.names")
variable.names.default <- .Alias(colnames)

case.names <- function(object, ...) UseMethod("case.names")
case.names.default <- .Alias(rownames)

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(class(data)))
        data <- as.data.frame(data)
    env<-environment(formula)
    if(!inherits(formula, "terms"))
	formula <- terms(formula, data = data)
    rownames <- attr(data, "row.names")
    varnames <- as.character(attr(formula, "variables")[-1])
    variables <- eval(attr(formula, "variables"), data, env)
    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(formula, data = environment(formula),
				 contrasts.arg = NULL, xlev = NULL)
{
    t <- terms(formula)
    if (is.null(attr(data, "terms")))
	data <- model.frame(formula, 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]
    }
    contr.funs <- as.character(getOption("contrasts"))
    isF <- sapply(data, is.factor)[-1]
    isOF <- sapply(data, is.ordered)
    namD <- names(data)
    for(nn in namD[-1][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 contrasts(data[[ni]]) <- contrasts.arg[[nn]]
	}
    }
    ans <- .Internal(model.matrix(t, data))
    cons <- if(any(isF))
	lapply(data[-1][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)
}
## 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
## - mosaic.cell():
### Changes by KH:
##   Shading of boxes to visualize deviations from independence by
##   displaying sign and magnitude of the standardized residuals.

mosaicplot.default <-
function(X, main = NULL, xlab = NULL, ylab = NULL, sort = NULL, off = NULL,
         dir = NULL, color = FALSE, shade = FALSE, margin = NULL,
         type = c("pearson", "deviance", "FT"))
{
    mosaic.cell <- function(X, x1, y1, x2, y2,
                            off, dir, color, lablevx, lablevy,
                            maxdim, currlev, label)
    {
        ## Recursive function doing `the job'
        ##
        ## explicitely 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(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(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=0, adj=.5, cex=.66, this.lab)
            }
            if (p > 2) {          # recursive call.
                for (i in 1:xdim) {
                    if (XP[i] > 0) {
                        mosaic.cell(as.matrix(X[X[,1]==i, 2:(p+2)]),
                                    x.l[i], y1, x.r[i], y2,
                                    off[2:length(off)],
                                    dir[2:length(dir)],
                                    color, lablevx-1, (i==1)*lablevy,
                                    maxdim[2:length(maxdim)],
                                    currlev+1, label[2:p])
                    } else {
                        segments(rep(x.l[i],3), y1+(y2-y1)*c(0,2,4)/5,
                                 rep(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(shade) X[i, p+1] else 1,
                                col = if(shade) {
                                    color[X[i, p+2]]
                                } else color[i])
                        ## <KH 2000-08-29>
                        ## Is this really needed?
                        ## segments(c(rep(x.l[i],3),x.r[i]),
                        ##          c(y1,y1,y2,y2),
                        ##          c(x.r[i],x.l[i],x.r[i],x.r[i]),
                        ##          c(y1,y2,y2,y1))
                        ## </KH>
                    } else {
                        segments(rep(x.l[i],3), y1+(y2-y1)*c(0,2,4)/5,
                                 rep(x.l[i],3), y1+(y2-y1)*c(1,3,5)/5)
                    }
                }
            }
        } else { ## dir[1] - "horizontal" : split here on the Y-axis.
            ydim <- maxdim[1]
            YP <- rep(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(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=90, adj=.5, cex=.66, this.lab)
            }
            if (p > 2) {          # recursive call.
                for (j in 1:ydim) {
                    if (YP[j] > 0) {
                        mosaic.cell(as.matrix(X[X[,1]==j,2:(p+2)]),
                                    x1, y.b[j], x2, y.t[j],
                                    off[2:length(off)],
                                    dir[2:length(dir)], color,
                                    (j==1)*lablevx, lablevy-1,
                                    maxdim[2:length(maxdim)],
                                    currlev+1, label[2:p])
                    } else {
                        segments(x1+(x2-x1)*c(0,2,4)/5, rep(y.b[j],3),
                                 x1+(x2-x1)*c(1,3,5)/5, rep(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(shade) X[j, p+1] else 1,
                                col = if(shade) {
                                    color[X[j, p+2]]
                                } else color[j])
                        ## <KH 2000-08-29>
                        ## Is this really needed?
                        ## segments(c(x1,x1,x1,x2),
                        ##          c(y.b[j],y.b[j],y.t[j],y.t[j]),
                        ##          c(x2,x1,x2,x2),
                        ##          c(y.b[j],y.t[j],y.t[j],y.b[j]))
                        ## </KH>
                    } else {
                        segments(x1+(x2-x1)*c(0,2,4)/5, rep(y.b[j],3),
                                 x1+(x2-x1)*c(1,3,5)/5, rep(y.b[j],3))
                    }
                }
            }
        }
    }

    ##-- Begin main function
    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("`X' must not have 0 dimensionality")
    ##-- Set up `Ind' matrix : to contain indices and data
    Ind <- 1:dX[1]
    if(dimd > 1) {
        Ind <- rep(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) {
        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")
        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(!shade && ((is.null(color) || length(color) != ncolors))) {
        color <- if (is.null(color) || !color[1])
            rep(0, ncolors)
        else
            2:(ncolors+1)
    }

    ##-- Plotting
    plot.new()
    if(!shade) {
        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 = "i") * 12),
                       pin[2] / (strwidth (rtxt, units = "i") / 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(2, len), rep(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 = 0.66)
    }

    if (!is.null(main) || !is.null(xlab) || !is.null(ylab))
        title(main, xlab=xlab, ylab=ylab)

    mosaic.cell(Ind,
                x1=50, y1=5, x2=950, y2=950,
                off/100, dir,
                color, 2, 2,
                maxdim= apply(as.matrix(Ind[,1:dimd]), 2, max),
                currlev= 1, label)

}

mosaicplot.formula <- function(formula, data = NULL, subset, na.action,
                               ...) {
    if (missing(na.action))
        na.action <- getOption("na.action")
    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())
    mosaicplot(table(mf), ...)
}
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.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(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(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<-" <- function(x, ...) UseMethod("names<-")

names.default <- function(x) .Internal(names(x))

"names<-.default" <- function(x, value) .Internal("names<-"(x, value))
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 <- c(9,1,17)[1+print.level]
    if(!check.analyticals) msg <- msg + 6
    .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 <- .Alias(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(paste("`", as.character(sys.call(sys.parent())[[1]]), "' ",
	       "is not implemented yet", sep = ""))
}

.NotYetUsed <- function(arg, error = TRUE) {
    msg <- paste("argument `", arg, "' is not used (yet)", sep = "")
    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)
{
    an <- lapply(seq(along=(sp <- search())), ls)
    names(an) <- sp
    if (!missing(generic.function)) {
	if (!is.character(generic.function))
	    generic.function <- deparse(substitute(generic.function))
	name <- paste("^", generic.function, ".", sep = "")
    }
    else if (!missing(class)) {
	if (!is.character(class))
	    class <- paste(deparse(substitute(class)))
	name <- paste(".", class, "$", sep = "")
    }
    else stop("must supply generic.function or class")
    grep(gsub("([.[])", "\\\\\\1", name), unlist(an), value = TRUE)
}

data.class <- function(x) {
    if (length(cl <- class(x)))
	cl[1]
    else {
	l <- length(dim(x))
	if (l == 2)	"matrix"
	else if (l > 0)	"array"
	else mode(x)
    }
}
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(1, length(par)),
                ndeps = rep(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 (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)
    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]]
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(Y, rep(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
}

"%o%" <- .Alias(outer)
p.adjust.methods<- c("holm", "hochberg", "bonferroni","none")

p.adjust <- function(p, method = p.adjust.methods, n = length(p)) {
    method <- match.arg(method)
    if ( n == 1 ) return(p)
    switch (method,
            hochberg = {
                r <- rank(p)
                index <- order(p)
                qi <- p*(n+1-r)
                for (i in (length(p)-1):1)
                    qi[index[i]] <- min(qi[index[i]], qi[index[i+1]])
                qi
            },
            holm = {
                r <- rank(p)
                index <- order(p)
                qi <- p*(n+1-r)
                for (i in 2:length(p))
                    qi[index[i]] <- max(qi[index[i]], qi[index[i-1]])
                pmin(qi, 1)
            },
            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."))
    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"))

    ## Structural files
   
    description<-file(file.path(path,name,"DESCRIPTION"),"wt")
    cat("Package: the_name_of_the_package\n",file=description)
    cat("Title: What the package does\n",file=description)
    cat("Version: 1.0\n",file=description)
    cat("Author: Who wrote it\n",file=description)
    cat("Description: More about what it does\n",file=description)
    cat("Maintainer: Who to complain to <yourfault@somewhere.net>\n",file=description)
    cat("License: What license is it under?\n",file=description)
    close(description)
    
    ##README
    src<-file(file.path(path,name,"src","README"),"wt")
    cat("Put C/Fortran code here\n",file=src)
    cat("If you have compiled code add a .First.lib() function\n",file=src)
    cat("in the R/ subdirectory to load it.\n",file=src)
    close(src)
    
    man<-file(file.path(path,name,"man","README"),"wt")
    cat("Edit these help files.\n",file=man)
    cat("You may want to combine the help files for multiple functions.\n",file=man)
    close(man)
    
    top<-file(file.path(path,name,"README"),"wt")
    cat("1. Put any C/Fortran code in src/ \n",file=top)
    cat("2. If you have compiled code, add a .First.lib() function in R/\n",file=top)
    cat("   to load the shared library\n",file=top)
    cat("3. Edit the help file skeletons in man/.\n",file=top)
    cat("4. Run R CMD build to create INDEX and data/00Index\n",file=top)
    cat("5. (Optionally) edit INDEX and data/O0Index\n",file=top)
    cat("6. Run R CMD check to check the package\n",file=top)
    cat("7. Run R CMD build to make the package file\n",file=top)
    cat("\n\n Read \"Writing R Extensions\" for more information.\n",file=top)
    close(top)

    ## dump the items in data/ or R/
    cat("Saving functions and data\n")
    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")
    for (item in list){
        ## work around bug in prompt()
        filename<-file.path(path,name,"man",paste(item,"Rd",sep="."))
        if (is.data.frame(get(item)))
            do.call("prompt.data.frame",list(item,filename=filename))
        else{
            do.call("prompt.default",list(item,filename=filename))
            if(!is.function(get(item))){
                dta<-file(filename,"at")
                cat("\\keyword{datasets}\n",file=dta)
                close(dta)
            }
        }
    }
    
    cat("Done.\n")
    cat(paste("Further steps are described in",file.path(path,name,"README"),"\n"))
}
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)
    }
    read.dcf(file=tmpf, fields=c("Package", "Version",
                       "Priority", "Bundle", "Depends"))
}

update.packages <- function(lib.loc=.lib.loc, CRAN=getOption("CRAN"),
                            contriburl=contrib.url(CRAN),
                            method, instlib=NULL, ask=TRUE,
                            available=NULL, destdir=NULL)
{
    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)
    }
}

old.packages <- function(lib.loc=.lib.loc, CRAN=getOption("CRAN"),
                         contriburl=contrib.url(CRAN),
                         method, available=NULL)
{
    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
    for(b in unique(instp[,"Bundle"])){
        if(!is.na(b)){
            ok <- which(instp[,"Bundle"] == b)
            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(is.na(a))
            return(FALSE)
        if(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"] != "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=.lib.loc){

    file <- system.file("CONTENTS", package = pkg, lib.loc = lib)
    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=.lib.loc, fields=NULL)
{
    file <- system.file("DESCRIPTION", package = pkg, lib.loc = lib)
    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 = .lib.loc)
{
    retval <- 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=c("Version", "Priority",
                                        "Bundle", "Depends"))

            retval <- rbind(retval, c(p, lib, desc))
        }
    }
    if (!is.null(retval))
        colnames(retval) <- c("Package", "LibPath", "Version",
                              "Priority", "Bundle", "Depends")
    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) {

    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 <- .lib.loc[1]
        warning(paste("argument `lib' is missing: using", lib))
    }

    paths <- .find.package(pkgs, lib)
    unlink(paths, TRUE)
    for(lib in unique(dirname(paths)))
        updateIndices(lib)
}
page <- function(x)
{
    subx <- substitute(x)
    if( is.name(subx) )
	subx <- deparse(subx)
    if (!is.character(subx) || length(subx) != 1)
	stop("page requires a name")
    if(exists(subx, inherits=TRUE)) {
        file <- tempfile("Rpage.")
        dput(get(subx, inherits=TRUE), file)
	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")

## For new version, see below

if(FALSE){ ## old version
pairs.default <- function(x, labels, panel=points, main = NULL,
			  font.main=par("font.main"),
			  cex.main=par("cex.main"),  oma=NULL, ...)
{
    if(!is.matrix(x)) x <- data.matrix(x)
    if(!is.numeric(x)) stop("non-numeric argument to pairs")
    nc <- ncol(x)
    if(nc < 2) stop("only one column in the argument to pairs")
    if (missing(labels)) {
	labels <- dimnames(x)[[2]]
	if (is.null(labels))
	    labels <- paste("var", 1:nc)
    }
    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(0.5, 4), oma = oma)
    on.exit(par(opar))
    for (i in 1:nc) for (j in 1:nc) {
	if (i == j) {
	    plot(x[, j], x[, i], xlab = "", ylab = "", axes = FALSE,
                 type = "n", ...)
	    box()
	    text(mean(par("usr")[1:2]), mean(par("usr")[3:4]), labels[i])
	}
	else {
	    plot(x[, j], x[, i], type="n", xlab = "", ylab = "", axes =
                 FALSE, ...)
	    box()
	    panel(x[, j], x[, i], ...)
	}
	if (j == 1 & 2 * floor(i/2) == i)
	    axis(2, xpd=NA)
	if (i == 1 & 2 * floor(j/2) == j)
	    axis(3, xpd=NA)
	if (j == nc & 2 * floor(i/2) != i)
	    axis(4, xpd=NA)
	if (i == nc & 2 * floor(j/2) != j)
	    axis(1, xpd=NA)
    }
    if (!is.null(main))
        mtext(main, 3, 3, TRUE, 0.5, cex = cex.main, font = font.main)
    invisible(NULL)
}
}

pairs.formula <- function(formula, data = NULL, subset, na.action, ...)
{
    if (missing(na.action))
        na.action <- getOption("na.action")
    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)
{
    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(0.5, 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"
	   )
.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(.Pars.readonly, .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))
}

## we don't use white; it's for compatibility

parse <- function(file = "", n = NULL, text = NULL, prompt = "?",
                  white = FALSE)
{
    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 = NULL, 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, xlab, ylab, 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)
}
piechart <-
    function (x, labels=names(x), edges=200, radius=0.8, col=NULL, main=NULL, ...)
{
    if (!is.numeric(x) || any(is.na(x) | x <= 0))
	stop("piechart: `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)
    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.new()
    plot.window(xlim, ylim, "", asp=1)
    for (i in 1:length(dx)) {
	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, col=col[(i-1)%%length(col)+1])
	t2p <- 2*pi * mean(x[i + 0:1])
	xc <- cos(t2p) * radius
	yc <- sin(t2p) * radius
	lines(c(1,1.05)*xc, c(1,1.05)*yc)
	text(1.1*xc, 1.1*yc, labels[i],
	     xpd = TRUE, adj = ifelse(xc < 0, 1, 0))
    }
    title(main = main, ...)
    invisible(NULL)
}
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)
	}
    }

    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, ...) {
    if(is.null(class(x)) && is.function(x)) {
	if("ylab" %in% names(list(...)))
	    plot.function(x, ...)
	else
	    plot.function(x, 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(fn, from = 0, to = 1, xlim = NULL, ...) {
    if(!is.null(xlim)) {
	if(missing(from)) from <- xlim[1]
	if(missing(to))	  to   <- xlim[2]
    }
    curve(fn, 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
    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
plot.table <- function(x, type = "h", ylim = c(0, max(x)), lwd = 2,
                       xlab = NULL, ylab = deparse(substitute(x)),
                       frame.plot = is.num,
                       ...)
{
    rnk <- length(d <- 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 <- ""
        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")
        axis(1, at = x0, labels = nx)
    } else
	mosaicplot(x, ...)
}

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$... <- 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(mf)
	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]]
	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 (is.null(dots[["xlab"]])) {
	    for (i in xn)
		if( length(dots) > 0 )
		    do.call(funname,
			    c(list(mf[[i]], y, ylab = ylab, xlab = i),
			      dots))
		else
		    do.call(funname,
			    c(list(mf[[i]], y, ylab = ylab, xlab = i)))
	} else {
	    for (i in xn)
		if( length(dots) > 0 )
		    do.call(funname,
			    c(list(mf[[i]], y, ylab = ylab), dots))
		else
		    do.call(funname,
			    c(list(mf[[i]], y, ylab = ylab)))
	}
	if (length(xn) == 0)
	    if (is.null(dots[["xlab"]])) {
		if( length(dots) > 0 )
		    do.call(funname,
			    c(list(y, ylab = ylab, xlab = i), dots))
		else
		    do.call(funname,
			    c(list(y, ylab = ylab, xlab = i)))
	    } else {
		if(length(dots) > 0 )
		    do.call(funname,
			    c(list(y, ylab = ylab), dots))
		else
		   do.call(funname,
			    c(list(y, ylab = ylab)))
	    }
    }
    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 <- .Alias(plot.new)
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 = nb.fig < 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")
    show <- rep(FALSE, 4)
    if(!is.numeric(which) || any(which < 1) || any(which > 4))
        stop("`which' must be in 1: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))
    if (any(show[2:3])) {
        ylab23 <- if(inherits(x, "glm"))
          "Std. deviance resid." else "Standardized residuals"
        hii <- lm.influence(x)$hat
        w <- weights(x)
        # r.w := weighted.residuals(x):
        r.w <- if(is.null(w)) .Alias(r) else (sqrt(w)*r)[w!=0]
        rs <- r.w/(s * sqrt(1 - hii))
    }
    if (any(show[c(1,3)]))
        l.fit <- if(inherits(x,"glm"))
            "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(paste("`id.n' must be in { 1,..,",n,"}"))
    }
    if(id.n > 0) {
        if(is.null(labels.id))
            labels.id <- paste(1:n)
        iid <- 1:id.n
	show.r <- order(-abs(r))[iid]
        if(any(show[2:3]))
            show.rs <- order(-abs(rs))[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)
    }
    nb.fig <- prod(par("mfcol"))
    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)
	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]) {
	ylim <- range(rs)
	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))
	yl <- as.expression(substitute(sqrt(abs(YL)), list(YL=as.name(ylab23))))
        yhn0 <- if(is.null(w)) .Alias(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 <- cooks.distance(x, sd=s)
	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,...)
}
polygon <- function(x, y=NULL, col=NA, border=NULL, lty=NULL, xpd=NULL,
		    density = -1, angle = 45, ...)
{
    if (!missing(density)) .NotYetUsed("density", error = FALSE)
    if (!missing(angle))   .NotYetUsed("angle",   error = FALSE)
    xy <- xy.coords(x, y)
    ##-- FIXME: what if `log' is active, for x or y?
    .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	= "white",
	 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, ...)
{
    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 or 4
    if(!missing(family)) old$family <- family
    if(is.null(old$encoding) || old$encoding  == "default")
        old$encoding <- switch(machine(),
                               "Macintosh" = "MacRoman.enc",
                               "Win32" = "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))
}

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, ...)
{
    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(machine(),
                               "Macintosh" = "MacRoman.enc",
                               "Win32" = "WinAnsi.enc",
                               "ISOLatin1.enc")
    .Internal(PDF(file, old$family, old$encoding, old$bg, old$fg,
                  width, height, old$pointsize, old$onefile))
}

.ps.prolog <- c(
"/gs  { gsave } def",
"/gr  { grestore } def",
"/ep  { showpage gr gr } def",
"/m   { moveto } def",
"/l   { lineto } def",
"/np  { newpath } def",
"/cp  { closepath } def",
"/f   { fill } def",
"/o   { stroke } def",
"/c   { newpath 0 360 arc } def",
"/r   { 3 index 3 index moveto 1 index 4 -1 roll",
"       lineto exch 1 index lineto lineto 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)
}
#### copyright (C) 1998 W. N. Venables and B. D. Ripley
## "terms" added 10/99 T Lumley

predict.glm <-
  function(object, newdata = NULL, type = c("link", "response", "terms"),
           se.fit = FALSE, dispersion = NULL, terms=NULL, ...)
{
    ## 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)
	    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))
	if ( missing(newdata) ) newdata <- model.frame(object)
	pred <- predict.lm(object, newdata, se.fit, scale = residual.scale,
                           type=ifelse(type=="link", "response", type),
                           terms=terms)
	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")
    seq(z$l, z$u, length=z$n+1)
}
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,
             ...)
    .Internal(print.default(x,digits,quote,na.print,print.gap,right))

print.atomic <- function(x,quote=TRUE,...) print.default(x,quote=quote)

print.matrix <- function (x, rowlab = dn[[1]], collab = dn[[2]],
			  quote = TRUE, right = FALSE,
			  na.print=NULL, print.gap=NULL, ...) {
    x <- as.matrix(x)
    dn <- dimnames(x)
    if(!is.null(print.gap)) .NotYetUsed("print.gap", error = FALSE)
    ## and `na.print' could be done in .Internal(.) as well:
    if(!is.null(na.print) && any(ina <- is.na(x)))
	x[ina] <- na.print
    .Internal(print.matrix(x, rowlab, collab, quote, right))
}
prmatrix <- .Alias(print.matrix)

## print.tabular is now deprecated !

noquote <- function(obj) {
    ## constructor for a useful "minor" class
    if(!inherits(obj,"noquote")) class(obj) <- c(class(obj),"noquote")
    obj
}
as.matrix.noquote <- function(x) noquote(NextMethod("as.matrix", x))

"[.noquote" <- function (x, ...) {
    attr <- attributes(x)
    r <- unclass(x)[...]
    attributes(r) <- c(attributes(r),
		       attr[is.na(match(names(attr),
                                        c("dim","dimnames","names")))])
    r
}

print.noquote <- function(x, ...) {
    if(!is.null(cl <- class(x)))
	class(x) <- cl[cl != "noquote"]
    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))), ...)

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(",
	     na.print = "", ...)
{
    ## 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)
	## #{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)
	    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 <- (d <- 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)]

    print.coefmat(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 <- 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 {
         if (!is.null(digits)) {
             op <- options(digits = digits)
             on.exit(options(op))
         }
         print.matrix(format(x), ..., quote = quote, right = right)
     }
    invisible(x)
}
profile <- function(fitted, ...) UseMethod("profile")
#### copyright (C) 1998 B. D. Ripley
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(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(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(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(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(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, ...) UseMethod("prompt")

## Fixme : Both methods share a lot of code;  really re-use with namespace
## -----   For now, often change *both*

prompt.default <-
    function(object, filename = paste0(name, ".Rd"), force.function = FALSE)
{
    paste0 <- function(...) paste(..., sep = "")
    is.missing.arg <- function(arg)
        typeof(arg) == "symbol" && deparse(arg) == ""

    name <-
        if(is.character(object))
            object
        else {
            name <- substitute(object)
            if(is.language(name) && !is.name(name)) name <- eval(name)
            as.character(name)
        }
    fn <- get(name)
    if(is.data.frame(fn))
       return(prompt.data.frame(fn, filename = filename))

    ## `file' [character(NN)] will contain the lines to be put in the
    ## Rdoc file
    file <- paste0("\\name{", name, "}")
    if(is.function(fn) || force.function) {
        file <- c(file,
                  paste0("\\alias{", name, "}"),
                  "%- Also NEED an `\\alias' for EACH other topic documented here.",
                  "\\title{ ~~function to do ... ~~ }",
                  "\\description{",
		  "  ~~ A concise (1-5 lines) description of what the function does. ~~",
		  "}")
	s <- seq(length = n <- length(argls <- formals(fn)))
	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]])))
	    if(i != n) call <- paste0(call, ", ")
	}
	file <- c(file, "\\usage{", paste0(call, ")"), "}",
		  "%- maybe also `usage' for other objects documented here.")
	if(length(s))
	    file <- c(file, "\\arguments{",
		      paste0("  \\item{", arg.n, "}{",
			     " ~~Describe \\code{", arg.n, "} here~~ }"),"}")
	fn.def <- attr(fn, "source")
	if(is.null(fn.def))
            fn.def <- deparse(fn)
	if(any(br <- substr(fn.def,1,1) == "}"))
	    fn.def[br] <- paste(" ", fn.def[br])
	file <- c(file,
		  "\\details{",
		  "  ~~ If necessary, more details than the __description__  above ~~",
		  "}",
		  "\\value{",
		  "  ~Describe the value returned",
		  "  If it is a LIST, use",
		  "  \\item{comp1 }{Description of `comp1'}",
		  "  \\item{comp2 }{Description of `comp2'}",
		  "  ...",
		  "}",

		  "\\references{ ~put references to the literature/web site here ~ }",
		  "\\author{ ~~who you are~~ }",
		  "\\note{ ~~further notes~~ }",
		  "",
		  " ~Make other sections like WARNING with \\section{WARNING }{....} ~",
		  "",
		  "\\seealso{ ~~objects to SEE ALSO as \\code{\\link{~~fun~~}}, ~~~ }",
		  "",
		  "\\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",
		  fn.def,
		  "}",
		  "\\keyword{ ~kwd1 }% at least one, from doc/KEYWORDS",
		  "\\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line"
		  )
    } else {#-- not function, assume dataset --
        tf <- tempfile(); on.exit(unlink(tf))
        sink(tf) ; str(object) ; sink()
        str.txt <- scan(tf, "", quiet = !getOption("verbose"), sep = "\n")
	file <-
            c(file, paste0("\\alias{", name, "}"),
              "\\non_function{}",
              "\\title{ ~~data-name / kind ...  }",
              paste0("\\usage{data(", name, ")}"),
              "\\format{", "  The format is:", str.txt, "}",
              ## remaining lines are IDENTICAL to those in prompt.data.frame():
              "\\source{",
              " ~~ reference to a publication or URL from which the data were obtained ~~",
              "}",
              "\\references{","~~ possibly secondary sources and usages ~~","}",
              "\\examples{",
              paste0("data(", name, ")"),
              paste0("## maybe str(",name,") ; plot(",name,") ..."),
              "}",
              "\\keyword{datasets}")
    }
    cat(file, file = filename, sep = "\n")
    RHOME <- R.home()
    if(substr(RHOME, 1, 8) == "/tmp_mnt") RHOME <- substr(RHOME, 9, 1000)
    cat("created file named ", filename, " in the current directory.\n",
	" Edit the file and move it to the appropriate directory, possibly\n",
	paste(RHOME,"src/library/<pkg>/man/",sep="/"), "\n")
    invisible(file)
}

prompt.data.frame <- function (object, filename = paste0(name, ".Rd"))
{
    paste0 <- function(...) paste(..., sep = "")
##    describe <- function(object) UseMethod()

    name <- substitute(object)
    if (is.language(name) && !is.name(name))
        name <- eval(name)
    name <- as.character(name)
    dat <- get(name)
    ## `file' [character(NN)] will contain the lines to be put in the
    ## Rdoc file
    file <- c(paste0("\\name{", name, "}"), paste0("\\alias{", name, "}"))
    file <- c(file, "\\non_function{}",
              "\\title{ ~~ 1-line description of the data frame ~~ }",
              paste0("\\usage{data(", name, ")}"),
              "\\description{",
              paste0("The \\code{", name, "} data frame has ", nrow(dat),
                     " rows and ", ncol(dat), " columns."),
              "~~ Give a concise description here ~~", "}",
              "\\format{",
              "  This data frame contains the following columns:",
              "  \\describe{")
    for (i in names(dat)) {
      file <- c(file,
                paste0("    \\item{", i, "}{",
                       if (inherits(dat[[i]], "ordered")) {
                           c(paste0("an ", data.class(dat[[i]]),
                                    " factor with levels"),
                             paste(paste0("\\code{", levels(dat[[i]]), "}"),
                                   collapse = " < "))
                       } else if (inherits(dat[[i]], "factor")) {
                           c("a factor with levels",
                             paste0("\\code{", levels(dat[[i]]), "} "))
                       } else if (is.vector(dat[[i]])) {
                           paste0("a ", data.class(dat[[i]]), " vector")
                       } else if (is.matrix(dat[[i]])) {
                           paste0("a matrix with ", ncol(dat[[i]]), " columns")
                       } else {
                           paste0("a ", data.class(dat[[i]]))
                       },
                       "}"))
    }
    file <- c(file, "  }\n}",
              "\\details{",
              " ~~ If necessary, more details than the _description_ above ~~",
              "}",
              "\\source{",
              " ~~ reference to a publication or URL from which the data were obtained ~~",
              "}",
              "\\references{","~~ possibly secondary sources and usages ~~","}",
              "\\examples{",
              paste0("data(", name, ")"),
              paste0("## maybe str(",name,") ; plot(",name,") ..."),
              "}",
              "\\keyword{datasets}")
    cat(file, file = filename, sep = "\n")
    RHOME <- R.home()
    if (substr(RHOME, 1, 8) == "/tmp_mnt")
        RHOME <- substr(RHOME, 9, 1000)
    cat("created file named ", filename, " in the current directory.\n",
	" Edit the file and move it to the appropriate directory, possibly\n",
        paste(RHOME, "src/library/<pkg>/man/", sep = "/"), "\n")
    invisible(file)
}
qqnorm <- function(y, ...) UseMethod("qqnorm")

qqnorm.default <-
    function(y, ylim, main="Normal Q-Q Plot",
	     xlab="Theoretical Quantiles", ylab="Sample Quantiles",
	     plot.it=TRUE, ...)
{
    y <- y[!is.na(y)]
    if(0 == (n <- length(y))) stop("y is empty")
    if (missing(ylim)) ylim <- range(y)
    x <- qnorm(ppoints(n))[order(order(y))]
    if(plot.it)
	plot(x, y, main= main, xlab= xlab, ylab= ylab, ylim= ylim, ...)
    invisible(list(x = x, y = y))
}

## Splus also has qqnorm.aov(), qqnorm.aovlist(), qqnorm.maov() ...

qqline <- function(y, ...)
{
    y <- quantile(y[!is.na(y)],c(0.25, 0.75))
    x <- qnorm(c(0.25, 0.75))
    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)

qr <- function(x, tol= 1e-07)
{
    x <- as.matrix(x)
    if(is.complex(x)) return(.Call("La_zgeqp3", x, PACKAGE = "base"))
    p <- as.integer(ncol(x))
    n <- as.integer(nrow(x))
    if(!is.double(x))
	storage.mode(x) <- "double"
    .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")
}

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 <- as.integer(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.double(NA),nr=p,nc=ny)
        coef[qr$pivot,] <- .Call("qr_coef_cmplx", qr, y, PACKAGE = "base")
        if(im) return(coef) else return(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(im) coef else c(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"))
    }
    n <- as.integer(nrow(qr$qr))
    p <- as.integer(ncol(qr$qr))
    k <- as.integer(qr$rank)
    ny <- as.integer(NCOL(y))
    storage.mode(y) <- "double"
    if(NROW(y) != n)
	stop("qr and y must have the same number of rows")
    qy <- if(is.matrix(y)) matrix(double(n*ny), n, ny) else double(n)
    .Fortran("dqrqy",
	     as.double(qr$qr),
	     n, k,
	     as.double(qr$qraux),
	     y,
	     ny,
	     qy=qy,
	     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"))
    }
    n <- as.integer(nrow(qr$qr))
    p <- as.integer(ncol(qr$qr))
    k <- as.integer(qr$rank)
    ny <- as.integer(NCOL(y))
    storage.mode(y) <- "double"
    if(NROW(y) != n)
	stop("qr and y must have the same number of rows")
    qty <- if(is.matrix(y)) matrix(double(n*ny), n, ny) else double(n)
    .Fortran("dqrqty",
	     as.double(qr$qr),
	     n, k,
	     as.double(qr$qraux),
	     y,
	     ny,
	     qty=qty,
             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")
    k <- as.integer(qr$rank)
    if (k==0) return(y)
    n <- as.integer(nrow(qr$qr))
    p <- as.integer(ncol(qr$qr))
    y <- as.matrix(y)
    ny <- as.integer(ncol(y))
    storage.mode(y) <- "double"
    if( nrow(y) != n )
	stop("qr and y must have the same number of rows")
    .Fortran("dqrrsd",
	     as.double(qr$qr),
	     n, k,
	     as.double(qr$qraux),
	     y,
	     ny,
	     rsd=mat.or.vec(n,ny),
	     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")
    n <- as.integer(nrow(qr$qr))
    p <- as.integer(ncol(qr$qr))
    k <- as.integer(k)
    if(k > qr$rank) stop("k is too large")
    y <- as.matrix(y)
    ny <- as.integer(ncol(y))
    storage.mode(y) <- "double"
    if( nrow(y) != n )
	stop("qr and y must have the same number of rows")
    .Fortran("dqrxb",
	     as.double(qr$qr),
	     n, k,
	     as.double(qr$qraux),
	     y,
	     ny,
	     xb=mat.or.vec(n,ny), 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")
    R <- qr.R(qr, complete = TRUE)
    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)
    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)][qs[i] > -Inf]
        .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, dig=dig)
			   else format(100 * probs, trim=TRUE, dig=dig),
			   "%", sep = "")
    }
    if(na.p) { # do this more elegantly (?!)
        o.pr[p.ok] <- qs
        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))
quit <- function(save = "default", status=0, runLast=TRUE)
    .Internal(quit(save, status, runLast))
q <- .Alias(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)]
    if(length(x)) c(min(x), max(x)) else NA
}
read.fwf <- function(file, widths, 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] <- "NA"
        x
    }
    FILE <- tempfile("Rfwf.")
    on.exit(unlink(FILE))
    raw <- scan(file, what="", sep="\n", quote="", quiet=TRUE, 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(widths)-1), "\n"))
    read.table(file = FILE, header = FALSE, 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)
{
    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))
}

read.table <-
    function (file, header = FALSE, sep = "", quote = "\"'", dec = ".",
              row.names, col.names, as.is = FALSE,
	      na.strings = "NA", skip = 0,
              check.names = TRUE, fill = !blank.lines.skip,
              strip.white = FALSE, blank.lines.skip = TRUE)
{
    type.convert <- function(x, na.strings = "NA",
                             as.is = FALSE, dec = ".")
	.Internal(type.convert(x, na.strings, as.is, dec))

    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(skip > 0) readLines(file, skip)
    ## read a few lines to determine header, no of cols.
    lines <- readLines(file, 5)
    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)
    col1 <- if(missing(col.names)) length(first) else length(col.names)
    col <- numeric(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))
    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)
    if (rlabp) col.names <- c("row.names", col.names)

    ##	set up for the scan of the file.
    ##	we read all values as character strings and convert later.

    what <- rep(list(""), cols)
    names(what) <- col.names
    data <- scan(file = file, what = what, sep = sep, quote = quote, skip = 0,
		 na.strings = na.strings, quiet = TRUE, fill = fill,
                 strip.white = strip.white,
                 blank.lines.skip = blank.lines.skip, multi.line = FALSE)

    nlines <- length(data[[1]])

    ##	now we have the data;
    ##	convert to numeric or factor variables
    ##	(depending on the specifies 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 (length(as.is) != cols)
	stop(paste("as.is has the wrong length",
		   length(as.is),"!= cols =", cols))
    for (i in 1:cols)
        data[[i]] <- type.convert(data[[i]], as.is = as.is[i], dec = dec)

    ##	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 <- vector("list", 2)
    res[1] <- list(.Internal(getDL()))
    res[[2]] <- .Internal(getGPar())
    names(res) <- c("displaylist", "gpar")
    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()
    .Internal(setGPar(x[[2]]))
    .Internal(playDL(x[[1]]))
}

print.recordedplot <- function(x)
{
    replayPlot(x)
    invisible(x)
}
rect <-
    function(xleft, ybottom, xright, ytop,
	     col=NULL, border=par("fg"), lty=NULL, lwd=par("lwd"), xpd=FALSE)
    .Internal(rect(as.double(xleft),
                   as.double(ybottom),
                   as.double(xright),
                   as.double(ytop),
                   col=col, border=border,
                   lty=lty, lwd=lwd, xpd=xpd))

#### copyright (C) 1998 B. D. Ripley
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, length.out)
{
    if (length(x) == 0)
	return(x)
    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)
}
replace <-
    function (x, list, values)
{
    x[list] <- values
    x
}
rev <- 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 = numeric(0), values = x))
    y <- x[-1] != x[-n]
    i <- c(which(y | is.na(y)), n)
    list(lengths = diff(c(0, i)), values = x[i])
}
rm <-
    function(..., list=character(0), pos=-1, envir=pos.to.env(pos), inherits=FALSE)
{
    names<- as.character(substitute(list(...)))[-1]
    list<-.Primitive("c")(list, names)
    .Internal(remove(list, envir, inherits))
}

remove <- rm
rowsum <- function(x, group, reorder=TRUE) {
    if (!is.numeric(x)) stop("x must be numeric")
    if (is.matrix(x)) dd <- dim(x)
    else              dd <- c(length(x), 1)
    n <- dd[1]

    if (length(group) !=n)  stop("Incorrect length for 'group'")
    if (any(is.na(group)))  stop("Missing values for 'group'")
    na.indicator <- 1+max(1,x[!is.na(x)]) * n   #larger than any possible sum
    x[is.na(x)] <- na.indicator

    if (!is.numeric(group)) group <- as.factor(group)
    storage.mode(x) <- 'double'
    temp <- .C("R_rowsum", dd= as.integer(dd),
			 as.double(na.indicator),
			 x = x,
			 as.double(group), PACKAGE="base")
    new.n <- temp$dd[1]
    ugroup <- unique(group)
    if (is.matrix(x)){
	new.x <- temp$x[1:new.n, , drop=FALSE]
	dimnames(new.x) <- list(ugroup, dimnames(x)[[2]])
	if (reorder) new.x <- new.x[order(ugroup), , drop=FALSE]
	}
    else {
	new.x <- temp$x[1:new.n]
	names(new.x) <- ugroup
	if (reorder) new.x <- new.x[order(ugroup)]
	}

    ifelse(new.x ==na.indicator, NA, new.x)
    }
rug<- function(x, ticksize = 0.03, side = 1, lwd = 0.5, col) {
    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)
    }
    usr <- par("usr")
    usr <- if (side %% 2 == 1)  usr[1:2] else usr[3:4]
    if(any(x < usr[1] | x > usr[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= list(names(answer[[1]]), names(answer)))
	else answer
    } else answer
}

scale <- function(x, ..., 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)
	    x <- sweep(x, 2, apply(x, 2, mean, na.rm=TRUE))
    }
    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))
	    }
	    x <- sweep(x, 2, apply(x, 2, f), "/")
	}
    }
    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")
    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)
{
    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))
}
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(x[-(nc+1)], nr), rep(x[-1], nr),
			 rep(y[-1], rep(nc, nr)),
			 rep(y[-(nr+1)], rep(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(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(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)
    else if (is.vector(x))
	sqrt(var(x, na.rm=na.rm))
    else if (is.data.frame(x))
	sapply(x, sd)
    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(x, ...) 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'
	    n <- (del <- to - from)/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 < sqrt(.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(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)
}
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(!inherits(file, "connection") || !isopen(connection))
            error("`file' must be 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(port <- 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 (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]])
}


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))
}

solve.default <- function(a, b, tol = 1e-7)
{
    if(is.complex(a) || (!missing(b) && is.complex(b))) {
        ## call overwrites a and b, so need to force copies
        A <- a
        if(missing(b)) B <- diag(1+0i, nrow(a)) else B <- b
        if(!is.complex(A)) A[] <- as.complex(A)
        if(!is.complex(B)) B[] <- as.complex(B)
        return (.Call("La_zgesv", A, B, PACKAGE = "base"))
    }
    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)
    }
    qr.coef(a, b)
}

solve <- function(a, b, ...) UseMethod("solve")
solve.qr <- .Alias(qr.solve)
sort <- function(x, partial=NULL, na.last=NA)
{
    isfact <- is.factor(x)
    if(isfact){
	lev <- levels(x)
	nlev <- nlevels(x)
    }
    nas <- x[is.na(x)]
    x <- c(x[!is.na(x)])
    if(!is.null(partial)) {
        if(!all(is.finite(partial))) stop("non-finite `partial'")
	y <- .Internal(psort(x, partial))
    } else {
	nms <- names(x)
	if(!is.null(nms)) {
	    o <- order(x)
	    y <- x[o]
	    names(y) <- nms[o]
	}
	else
	    y <- .Internal(sort(x))
    }
    if(!is.na(na.last)) {
	if(!na.last) y <- c(nas, y)
	else if (na.last) y <- c(y, nas)
    }
    if(isfact) y <- factor(y,levels=1:nlev,labels=lev)
    y
}

order <- function(..., na.last = TRUE) {
    if(!is.logical(na.last) || !na.last)
	.NotYetUsed("na.last != TRUE")
    .Internal(order(...))
}

sort.list <- function(x, partial = NULL, na.last = TRUE)
{
    if(!is.logical(na.last) || !na.last)
        .NotYetUsed("na.last != TRUE")
    if(!is.null(partial))
        .NotYetUsed("partial != NULL")
    .Internal(order(x))
}
source <-
function(file, local = FALSE, echo = verbose, print.eval = echo,
         verbose = getOption("verbose"),
         prompt.echo = getOption("prompt"), 
         max.deparse.length = 150, chdir = FALSE)
{
##-     if(!(is.character(file) && file.exists(file)))
##- 	stop(paste('"',file,'" is not an existing file', sep=""))
    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("verbose is TRUE, echo not; ... coercing `echo <- TRUE'")
	    echo <- TRUE
	}
    }
    if (verbose) {
	cat("`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 `", 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("`", file, "' is not an existing file", sep = ""))
    oop <- options(keep.source = as.logical(keep.source))
    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) {
	yy <- eval(i, envir)
    }
    invisible()
}

demo <- function(topic, device = getOption("device"),
                 package = .packages(), lib.loc = .lib.loc,
                 character.only = FALSE)
{
    fQuote <- function(s) paste("`", s, "'", sep = "")
    
    paths <- .find.package(package, lib.loc, missing(lib.loc),
                           quiet = TRUE)

    if(missing(topic)) {
        ## List all available demos.
        ## This code could be made more similar to data().
        first <- TRUE
        outFile <- tempfile("Rdemo.")
        outConn <- file(outFile, open = "w")
        for(path in paths) {
            INDEX <- file.path(path, "demo", "00Index")
            if(file.exists(INDEX)) {
                writeLines(paste(ifelse(first, "", "\n"),
                                 "Demos in package ",
                                 fQuote(basename(path)),
                                 ":\n\n", sep = ""),
                           outConn)
                writeLines(readLines(INDEX), outConn)
                first <- FALSE
            }
        }
        if(first) {
            warning("no demo listings found")
            close(outConn)
            unlink(outFile)
        }
        else {
            if(missing(package))
                writeLines(paste("\n",
                                 "Use `demo(package = ",
                                 ".packages(all.available = TRUE))'\n",
                                 "to list the demos in all ",
                                 "*available* packages.", sep = ""),
                           outConn)
            close(outConn)
            file.show(outFile, delete.file = TRUE, title = "R demos")
        }
        return(invisible(character(0)))
    }
            
    if(!character.only)
        topic <- as.character(substitute(topic))
    available <- character(0)
    for(p in paths) {
        if(file.exists(p <- file.path(p, "demo"))) {
            files <- list.files(p)
            ## Files with extension `R' or `r'
            files <- files[sub(".*\\.", "", files) %in% c("R", "r")]
            ## Files with base names matching topic
            files <- files[grep(topic, files)]
            if(length(files) > 0)
                available <- c(available, file.path(p, files))
        }
    }
    if(length(available) == 0)
        stop(paste("No demo found for topic", fQuote(topic)))
    if(length(available) > 1) {
        available <- available[1]
        warning("Demo for topic",
                fQuote(topic),
                "found more than once,\n",
                "using the one found in",
                fQuote(dirname(available[1])))
    }
    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 = .lib.loc, 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, missing(lib.loc),
                             quiet = TRUE)
    file <- index.search(topic, INDICES, "AnIndex", "R-ex")
    if (file == "") {
	warning(paste("No help file found for `", topic, "'", sep = ""))
	return(invisible())
    }
    comp <- strsplit(file, .Platform$file.sep)[[1]]
    pkg <- comp[length(comp) - 2]
    if(length(file) > 1)
	warning(paste("More than one help file found: using package", pkg))
    lib <- sub(file.path("", pkg, "R-ex", ".*\\.R"), "", file[1])
    ## 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("`", topic, "' has a help file but no examples file",
		      sep = ""))
	return(invisible())
    }
    if (pkg != "base")
	library(pkg, lib = lib, character.only = TRUE)
    source(zfile, 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 <- factor(do.call("interaction", f))
    else
        f <- factor(f)                  # drop extraneous levels
    if(is.null(class(x)) && 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(1:nrow(x), f), function(ind) x[ind, , drop = FALSE ])
}
### T. Dye <tdye@lava.net>, July 1999
### This code started life as spatial star plots by David A. Andrews.
### See http://www.udallas.edu:8080/~andrews/software/software.html

stars <-
function(x, full = TRUE, scale = TRUE, radius = TRUE,
	 labels = dimnames(x)[[1]],
         locations = NULL, xlim = NULL, ylim = NULL, len = 1,
         colors = NULL,
         key.loc = NULL, key.labels = NULL, key.xpd = TRUE,
         draw.segments = FALSE, axes = FALSE,
         cex = 0.8, lwd = 0.25, ...) 
{
    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 (!is.numeric(x))
	stop("data in x must be numeric")

    n.loc <- nrow(x)
    n.seg <- ncol(x)
    deg <- pi / 180			# segments only

    seg.colors <- if(!is.null(colors)) colors else 1:n.seg

    if (is.null(locations)) {		# make loc matrix
	md <- ceiling(sqrt(n.loc)) # =>  md^2 >= n.loc
        loc0 <- 2.1* 1:md
        loc <- expand.grid(loc0, rev(loc0))[1:n.loc, ]
    }
    else {
        if (is.numeric(locations) && length(locations) == 2) {
            ## all stars around the same origin
            loc <- cbind(rep(locations[1],n.loc),
                         rep(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.")
            loc <- .Alias(locations)
            if (n.loc != nrow(loc))
                stop("number of rows of locations and x must be equal.")
        }
    }

    ## 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
    x[is.na(x)] <- 0

    if (scale) {
	x <- sweep(x,2,apply(x,2,max),FUN="/")
	## Columns of 0s will put NAs in x, next line gets rid of them
	x[is.na(x)] <- 0
    }

    x <- x * len

    if(is.null(xlim)) xlim <- range(loc[,1] + max(x), loc[,1] - max(x))
    if(is.null(ylim)) ylim <- range(loc[,2] + max(x), loc[,2] - max(x))

    ## The asp argument keeps everything square
    plot(0, type="n", ..., xlim=xlim, ylim=ylim,
	 xlab="", ylab="", asp = 1, axes = axes)

    if ( draw.segments ) {
	## for each location, draw a segment diagram
	for ( i in 1:n.loc ) {
	    poly.x <- NA
	    poly.y <- NA
	    start.x <- x[i,] * cos( angles ) + loc[i,1]
	    start.y <- x[i,] * sin( angles ) + loc[i,2]

### FIXME : we can do without the following inner loop !

	    for (j in 1:n.seg) {
		poly.x <- c(poly.x,loc[i,1],start.x[j])
		poly.y <- c(poly.y,loc[i,2],start.y[j])

		next.angle <-
		    if(j < n.seg)
			angles[j+1]
		    else (if(full) 360 else 180) * deg

		k <- seq(from = angles[j], to = next.angle, by = deg)
		poly.x <- c(poly.x, x[i,j] * cos( k ) + loc[i,1], NA)
		poly.y <- c(poly.y, x[i,j] * sin( k ) + loc[i,2], NA)
	    }
	    polygon(poly.x, poly.y, col = seg.colors, lwd=lwd)
	    if (!is.null(labels))
		text(loc[i,1], loc[i,2] - if(full)max(x) else 0.1 * max(x),
		     labels[i], cex=cex, adj=c(0.5,1))
	}
    } # Segment diagrams

    else { # Draw stars instead
	for ( i in 1:n.loc ) {
	    temp.x <- x[i,] * cos( angles ) + loc[i,1]
	    temp.y <- x[i,] * sin( angles ) + loc[i,2]
	    if (radius)
		segments(rep(loc[i,1],n.seg),
			 rep(loc[i,2],n.seg),
			 temp.x, temp.y, lwd=lwd)
	    lines(c(temp.x, temp.x[1]),
		  c(temp.y, temp.y[1]), lwd=lwd)
	    if (!is.null(labels))
		text(loc[i,1], loc[i,2] - if(full)max(x) else 0.1 * max(x),
		     labels[i], cex=cex, adj=c(0.5,1))
	}
    }

    if ( !is.null(key.loc) ) { ## Draw unit key

        ## allow drawing outside plot region (inside figure region):
        op <- par(xpd = key.xpd); on.exit(par(op))
        key.x.coord <- cos( angles ) * len + key.loc[1]
        key.y.coord <- sin( angles ) * len + key.loc[2]
	if ( draw.segments ) {
	    key.x <- NA
	    key.y <- NA
	    for (j in 1:n.seg){
		key.x <- c(key.x,key.loc[1],key.x.coord[j])
		key.y <- c(key.y,key.loc[2],key.y.coord[j])
		k <- angles[j] + deg
		next.angle <-
		    if (j < n.seg) angles[j+1]
		    else (if(full) 360 else 180) * deg

		while (k < next.angle) {
		    key.x <- c(key.x, len * cos( k ) + key.loc[1])
		    key.y <- c(key.y, len * sin( k ) + key.loc[2])
		    k <- k + deg
		}
		key.x <- c(key.x, len * cos( next.angle ) + key.loc[1], NA)
		key.y <- c(key.y, len * sin( next.angle ) + key.loc[2], NA)
	    }
	    polygon(key.x, key.y, col = seg.colors, lwd=lwd)
	}
	else { # draw unit star
	    if ( radius )
		segments(rep(key.loc[1],n.seg), rep(key.loc[2],n.seg),
			 key.x.coord, key.y.coord, lwd=lwd)
	    lines(c(key.x.coord, key.x.coord[1]),
		  c(key.y.coord, key.y.coord[1]), lwd=lwd)
	}
	if (is.null(key.labels))
	    key.labels <- dimnames(x)[[2]]

	lab.angl <- angles +
	    if(draw.segments) (angles[2] - angles[1]) / 2 else 0

	label.x <- cos( lab.angl ) * len * 1.1 + key.loc[1]
	label.y <- sin( lab.angl ) * len * 1.1 + key.loc[2]

        ##-- FIXME : Do the following witout loop !
	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
    invisible()
}
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(message = NULL, call. = TRUE)
    .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)
}
####------ str : show STRucture of an R object
str <- function(object, ...) UseMethod("str")

str.data.frame <- function(object, ...)
{
    ## Method to 'str' for  'data.frame' objects
    ## $Id: str.R,v 1.19 2001/06/11 16:48:44 maechler Exp $
    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 <- class(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).
    ## ------------------------------------------------------------------------
    ## Arguments: --- see HELP file --
    ##	max.level: Maximal level of nesting to be reported (0: as many as nec.)
    ##
    ## ------------------------------------------------------------------------
    ## Author: Martin Maechler <maechler@stat.math.ethz.ch>	1990--1997
    ## ------ Please send Bug-reports, -fixes and improvements !
    ## ------------------------------------------------------------------------
    ## $Id: str.R,v 1.19 2001/06/11 16:48:44 maechler Exp $

    oo <- options(digits = digits.d); on.exit(options(oo))
    le <- length(object)
    ## le.str: not used for arrays:
    le.str <-
	if(is.na(le)) " __no length(.)__ "
	else if(give.length) {
	    if(le > 0) paste("[1:", paste(le), "]", sep = "")
	    else "(0)"
	} else ""
    v.len <- vec.len # modify v.len, not vec.len!
    ## NON interesting attributes:
    std.attr <- "names"

    has.class <- !is.null(cl <- class(object))
    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 <- paste(ifelse(di>1, "1:",""), di,
				ifelse(di>0, "" ," "), sep = "")
		    le.str <- paste(c("[", paste(di[-length(di)], ", ", sep=""),
				      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) paste(NULL, mod)
		else	   paste(" ", mod, if(le>0)" ", le.str, sep = "")
	    } 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)
			       )
	    }
	} 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 <- paste(ts.kind, " Time-Series ", le.str, " ", pars, ":",
			  sep = "")
	    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 <- paste(" Time-Series ", le.str, " from ", format(tsp.a[1]),
			  " to ", format(tsp.a[2]), ":", sep = "")
	    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
	    }
	    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] <-
			paste(substring(lev.att[ml],1, nchar(lev.att[ml])-d),
			      "..", sep="")
	    }
	    else # nl == 0
		ml <- length(lev.att <- "")

	    str1 <- paste(" Factor w/ ", nl, " level",if(nl != 1) "s",
			  if(nl)' "', paste(lev.att[1:ml], collapse ='","'),
			  if(nl)'"', if(ml < nl)",..", ":", sep="")
	    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 (mod == "call" || mod == "language" || mod == "symbol"
		|| is.environment(object)) {
		##give.mode <- !is.vector(object)#--then it has not yet been done
		object <- deparse(object)
		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 <- paste(str1, ', mode "', mod,'":', sep = "")

	} 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(!is.integer(object)){
		ob <- if(le > iv.len) object[seq(len=iv.len)] else object
		ao <- abs(ob <- ob[!is.na(ob)])
	    }
	    if(is.integer(object) || mod == "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
	}

	if(char.like) {
	    bracket <- if (le>0) '"' else ""
	    format.fun <- function(x)x
	    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] <- paste(substr(object[ii], 1, nchar.max),
					"| __truncated__", sep="")
	    }
	} else {
	    bracket <- ""
	    if(!exists("format.fun", inherits=TRUE)) #-- define one --
		format.fun <-
		    if(mod == 'num' || mod == 'cplx') format else as.character
	}
	if(is.na(le)) { warning("'str.default': 'le' is NA !!"); le <- 0}

	## v.len <- max(1,round(v.len))
	ile <- min(v.len, le)
	cat(str1, " ", bracket,
	    paste(format.fun(if(ile >= 1) object[1:ile] else
			     if(v.len > 0) object),
		  collapse = paste(bracket, " ", bracket, sep="")),
	    bracket, 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,paste('- attr(*, "',nam[i],'")=',sep=''),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()'

ls.str <- function(pos = 1, pattern, ...,
                   mode = "any", max.level = 1, give.attr = FALSE)
{
    ## An extended "ls()" using  str(.) 
    r <- character(0)
    for(nam in ls(pos = pos, ..., envir = pos.to.env(pos), pattern=pattern))
	if(exists(nam, where = pos, mode = mode)) {
	    cat(nam, ": ")
	    r <- c(r,nam)
	    str(get(nam, pos = pos, mode = mode), max.level = max.level,
		give.attr = give.attr)
	}
    invisible(r)
}

lsf.str <- function(pos = 1, pattern, ...)
    ls.str(pos = pos, pattern = pattern, mode = "function", ...)
## Dotplots a la Box, Hunter and Hunter

stripchart <-
function(x, method="overplot", jitter=0.1, offset=1/3, vertical=FALSE,
         group.names, xlim=NULL, ylim=NULL, main="", ylab="", xlab="",
         pch=0, col=par("fg"), cex=par("cex"))
{
    method <- pmatch(method, c("overplot", "jitter", "stack"))[1]
    if(is.na(method) || method==0)
	error("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
    dlim <- rep(NA, 2)
    for(i in groups)
	dlim <- range(dlim, i[is.finite(i)], na.rm = TRUE)
    glim <- c(1, n)
    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)
    box()
    if(vertical) {
	if(n > 1) axis(1, at=1:n, lab=names(groups))
	axis(2)
    }
    else {
	axis(1)
	if(n > 1) axis(2, at=1:n, 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(i,length(x))
	if(method == 2)
	    y <- y + runif(length(y), -jitter, jitter)
	else if(method == 3) {
	    xg <- split(x, factor(x))
	    xo <- lapply(xg, f)
	    x <- unlist(xg, use.names=FALSE)
	    y <- y + (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(" ", indent), collapse = "")
    exdentString <- paste(rep(" ", 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(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(length(x) != length(y))
        stop("`x' and `y' must have the same length")
    x <- as.character(x)
    y <- as.character(y)

    style <- match.arg(style)

    if(missing(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(" ", 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
}
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.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 <- class(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 <- rev(order(tt))
	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, length)))
    for(i in 1:nv) {
	sms <- z[[i]]
	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=FALSE)
    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("", 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(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))
{
    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(!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, circles, squares, rectangles, stars,
	  thermometers, boxplots, inches = TRUE, add = FALSE,
	  fg = 1, bg = NA,
	  xlab = "", ylab = "", 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")
    if (!add) {
	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, ...)
    }
    .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,
		   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) {
	eval(corr)
	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) {
	Scor <- character(length(iS))
	if((has.na <- is.character(na)))
	    Scor[nax] <- na
	Scor[!nax] <- symbols[iS[!nax]]
    } else Scor <- symbols[iS]
    if(num.x) {
	if(!is.null(show.max)) Scor[x >= maxc - eps] <-
	    if(is.character(show.max)) show.max else format(maxc, dig=1)
	if(!is.null(show.min)) Scor[x <= minc + eps] <-
	    if(is.character(show.min)) show.min else format(minc, dig=1)
    }
    if(lower.triangular && is.matrix(x))
	Scor[!lower.tri(x, diag = diag.lower.tri)] <- ""
    attributes(Scor) <- attributes(x)
    if(is.array(Scor)&& (rank <- length(dim(x))) >= 2) { # `fix' column names
	if(is.null(dimnames(Scor)))
	    dimnames(Scor) <- vector("list",rank)
	coln <- dimnames(Scor)[[2]]
	dimnames(Scor)[[2]] <-
	    if(length(coln)) {
		ch <- abbreviate(coln, minlength=1)
		if(sum(1+nchar(ch)) + max(nchar(coln))+ 1 > getOption("width"))
					#-- would not fit on one line
		    abbreviate(ch, minlength=2, use.classes=FALSE)
		else ch
	    }
	    else rep("", dim(Scor)[2])
    }
    if(legend) {
	legend <- c(rbind(sapply(cutpoints,format),
			  c(paste("`",symbols,"'",sep=""),"")),
		    if(has.na) paste("	    ## NA: `",na,"'",sep=""))
	attr(Scor,"legend") <- paste(legend[-2*(ns+1)], collapse=" ")
    }
    noquote(Scor)
}
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,
		"",
		if (is.symbol(x)) as.character(x) else "",
		deparse(x)[1]
	    )
        )
        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")
	if (is.factor(a))
	    cat <- a
	else
	    cat <- factor(a, exclude = exclude)
	nl <- length(l <- levels(cat))
	dims <- c(dims, nl)
	dn <- c(dn, list(l))
	## 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
}

print.table <- function(x, digits = getOption("digits"), quote = FALSE,
                        na.print = "", ...)
{
    print.default(unclass(x), digits = digits, quote = quote,
                  na.print = na.print, ...)
}


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)
        for(k in seq(along = m)) {
            m[[k]] <- apply(object, k, sum) / n.cases
        }
        expected <- apply(do.call("expand.grid", m), 1, prod) * n.cases
        statistic <- sum((c(object) - expected)^2 / expected)
        parameter <- prod(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("x must inherit from class `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 <- .Alias(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)) {
        class(x) <- c("table", class(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)
{
    y <- if (length(margin)) {
        z <- apply(x, margin, sum)
        dim(z)<-dim(x)[margin]
        dimnames(z)<-dimnames(x)[margin]
        z
    }
    else sum(x)
    class(y) <- class(x)
    y
}
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
}





termplot <- function(model, data=model.frame(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",
                     ...)
{
    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)
    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) else ""
    else if(!is.character(main))
        stop("`main' must be TRUE, FALSE, NULL or character (vector).")
    main <- rep(main, length = n.tms) # recycling
    pf <- parent.frame()
    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 <- codes(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], ...)
	    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(jitter(xx), rep(3,n)),
                  rep(ylims[1] + c(0,0.05,NA)*diff(ylims), n))
	    if (partial.resid)
		lines(rep(xlims[1] + c(0,0.05,NA)*diff(xlims), n),
                      rep(pres[,i],rep(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  ../../../main/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 <- .Alias(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(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.matrix(data) || is.data.frame(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) {
	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, ]
	    }
    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 <- class(x)
    attr(x, "tsp") <- value # does error-checking internally
    if (inherits(x, "ts") && is.null(value))
        class(x) <- cl["ts" != cl]
    if (inherits(x, "mts") && is.null(value))
        class(x) <- 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")

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)
}

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 <- floor((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("", start.pad), format(x, ...),
                                  rep("", 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 %%1))# round() was floor()
	    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, 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 = c("multiple", "single"),
	  xy.labels = n <= 150, xy.lines = do.lab, panel=lines, ...)
{
    xlabel <- if (!missing(x)) deparse(substitute(x)) else NULL
    ylabel <- if (!missing(y)) deparse(substitute(y)) else NULL
    plot.type <- match.arg(plot.type)
    if(plot.type == "multiple" && NCOL(x) > 1) {
	m <- match.call()
	m[[1]] <- as.name("plot.mts")
	return(eval(m, parent.frame()))
    }
    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(!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(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())
    }
    if(missing(ylab)) ylab <- xlabel
    time.x <- time(x)
    if(is.null(xlim)) xlim <- range(time.x)
    if(is.null(ylim)) ylim <- range(x[is.finite(x)])
    plot.new()
    plot.window(xlim, ylim, log, ...)
    if(is.matrix(x)) {
	for(i in 1:ncol(x))
	    lines.default(time.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(time.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(...)
}

lines.ts <- function(x, ...)
    lines.default(time(as.ts(x)), x, ...)


plot.mts <- function (x, plot.type = c("multiple", "single"), panel = lines,
                      log = "", col = par("col"),  bg = NA, pch = par("pch"),
                      cex = par("cex"), lty = par("lty"), lwd = par("lwd"),
                      ann = par("ann"),  xlab = "Time", main=NULL,
                      oma=c(6, 0, 5, 0),...)
{
    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, ...)
    }
    plot.type <- match.arg(plot.type)
    panel <- match.fun(panel)
    nser <- NCOL(x)
    if(plot.type == "single" || nser == 1) {
        m <- match.call()
        m[[1]] <- as.name("plot.ts")
        m$plot.type <- "single"
        return(eval(m, parent.frame()))
    }
    if(nser > 10) stop("Can't plot more than 10 series")
    if(is.null(main)) main <- deparse(substitute(x))
    nm <- colnames(x)
    if(is.null(nm)) nm <- paste("Series", 1:nser)
    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(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, ...)
        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, ...)
        }
    }
    invisible()
}

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(nold+1, max(0, -stoff)),
                   (1+max(0, stoff)):(nold + min(0, enoff)),
                   rep(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
}
undoc <- function(package, dir, lib.loc = .lib.loc)
{
    fQuote <- function(s) paste("`", s, "'", sep = "")
    listFilesWithExts <- function(dir, exts, path = TRUE) {
        ## Return the paths or names of the files in `dir' with
        ## extension in `exts'.
        files <- list.files(dir)
        files <- files[sub(".*\\.", "", files) %in% exts]
        if(path)
            files <- if(length(files) > 0)
                file.path(dir, files)
            else
                character(0)
        files
    }

    if(!missing(package)) {
        packageDir <- .find.package(package, lib.loc)
        isBase <- package == "base"
        objsdocs <- sort(scan(file = file.path(packageDir, "help",
                              "AnIndex"),
                              what = list("", ""),
                              quiet = TRUE, sep="\t")[[1]])
        codeFile <- file.path(packageDir, "R", package)
        dataDir <- file.path(packageDir, "data")
    }
    else {
        if(missing(dir))
            stop("you must specify `package' or `dir'")
        if(!file.exists(dir))
            stop(paste("directory", fQuote(dir), "does not exist"))
        isBase <- basename(dir) == "base"
        if(!file.exists(docsDir <- file.path(dir, "man")))
            stop("no directory with Rd sources found")
        docsExts <- c("Rd", "rd")
        files <- listFilesWithExts(docsDir, docsExts)
        if(file.exists(docsOSDir <- file.path(docsDir, .Platform$OS)))
            files <- c(files, listFilesWithExts(docsOSDir, docsExts))
        files <- paste(files, collapse = " ")
        shQuote <- function(s) {
            if(.Platform$OS.type == "unix")
                paste("'", s, "'", sep = "")
            else
                s
        }
        fname  <- system(paste("grep -h", shQuote("^\\\\name"), files),
                         intern = TRUE)
        falias <- system(paste("grep -h", shQuote("^\\\\alias"), files),
                         intern = TRUE)
        objsdocs <- c(gsub("\\\\name{(.*)}.*",  "\\1", fname),
                      gsub("\\\\alias{(.*)}.*", "\\1", falias))
        objsdocs <- gsub("\\\\%", "%", objsdocs)
        objsdocs <- gsub(" ", "", objsdocs)
        objsdocs <- sort(unique(objsdocs))

        if(file.exists(codeDir <- file.path(dir, "R"))) {
            codeFile <- tempfile("Rbuild")
            on.exit(unlink(codeFile))
            codeExts <- c("R", "r", "S", "s", "q")
            files <- listFilesWithExts(codeDir, codeExts, path = FALSE)
            if(any(i <- grep("^zzz\\.", files)))
               files <- files[-i]
            if(length(files) > 0)
                files <- file.path(codeDir, files)
            if(file.exists(codeOSDir <- file.path(codeDir, .Platform$OS)))
                files <- c(files, listFilesWithExts(codeOSDir, codeExts))
            file.create(codeFile)
            file.append(codeFile, files)
        }
        else
            codeFile <- ""

        dataDir <- file.path(dir, "data")
    }

    if(isBase)
        allObjs <- ls("package:base", all.names = TRUE)
    else if(file.exists(codeFile)) {
        codeEnv <- new.env()
        sys.source(codeFile, envir = codeEnv)
        allObjs <- ls(envir = codeEnv, all.names = TRUE)
    }
    else
        allObjs <- NULL

    if(file.exists(dataDir)) {
        dataExts <- c("R", "r", "RData", "rdata", "rda", "TXT", "txt",
                      "tab", "CSV", "csv")
        files <- listFilesWithExts(dataDir, dataExts, path = FALSE)
        files <- files[!duplicated(sub("\\.[A-Za-z]*$", "", files))]
        dataEnv <- new.env()
        dataObjs <- NULL
        if(any(i <- grep("\\.\(R\|r\)$", files))) {
            for (f in file.path(dataDir, files[i])) {
                sys.source(f, envir = dataEnv, chdir = TRUE)
                new <- ls(envir = dataEnv, all.names = TRUE)
                dataObjs <- c(dataObjs, new)
                rm(list = new, envir = dataEnv)
            }
            files <- files[-i]
        }
        if(any(i <- grep("\\.\(RData\|rdata\|rda\)$", files))) {
            for (f in file.path(dataDir, files[i])) {
                load(f, envir = dataEnv)
                new <- ls(envir = dataEnv, all.names = TRUE)
                dataObjs <- c(dataObjs, new)
                rm(list = new, envir = dataEnv)
            }
            files <- files[-i]
        }
        if(length(files) > 0)
            dataObjs <- c(dataObjs, sub("\\.[A-Za-z]*$", "", files))
        allObjs <- c(allObjs, dataObjs)
    }

    ## Undocumented objects?
    if(is.null(allObjs))
        warning("Neither code nor data objects found")
    else
        allObjs[! allObjs %in% c(objsdocs, ".First.lib", ".Last.lib")]
}
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
}
## file update.R
## copyright (C) 1998 W. N. Venables and B. D. Ripley
##
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))
    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"

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))
}
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 <- .Alias(double)
numeric <- .Alias(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)
warnings <- function(...)
{
    if(!(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(" ",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 != ".") {
    	num <- which(unlist(lapply(x, is.numeric)))
	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("invalid numbers in `quote'")
    }
    else
	stop("invalid `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("invalid `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("invalid `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("argument `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, x[, i]), '"', sep = "")

    writeLines(paste(c(t(x)), c(rep(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")
    if(missing(na.action))
	na.action <- getOption("na.action")
    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", mf)
	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)
}
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 <- 1:length(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 <- 1:length(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")
}
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.png", width=480, height=480, pointsize=12,
                gamma = 1, colortype = getOption("X11colortype"),
                maxcubesize = 256)
    .Internal(X11(paste("png::", filename, sep=""),
                  width, height, pointsize, gamma,
                  colortype, maxcubesize))

jpeg <- function(filename = "Rplot.jpeg", width=480, height=480, pointsize=12,
                 quality = 75,
                 gamma = 1, colortype = getOption("X11colortype"),
                 maxcubesize = 256)
    .Internal(X11(paste("jpeg::", quality, ":", filename, sep=""),
                  width, height, pointsize, gamma,
                  colortype, maxcubesize))
download.file <- function(url, destfile, method,
                          quiet = FALSE, mode = "w")
{
    method <- if(missing(method)) "auto" else
    match.arg(method,
              c("auto", "internal", "wget", "lynx", "socket"))

    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 if (length(grep("^http:",url))==0)
            method <- "socket"
        else
            stop("No download method found")
    }
    if(method == "internal")
        status <- .Internal(download(url, destfile, quiet, mode))
    else if(method == "wget")
        if(quiet)
            status <- system(paste("wget --quiet '", url,
                                   "' -O", destfile, sep=""))
        else
            status <- system(paste("wget '", url,
                                   "' -O", destfile, sep=""))
    else if(method == "lynx")
        status <- system(paste("lynx -dump '", url, "' >", destfile, sep=""))
    else if (method == "socket") {
        status <- 0
        httpclient(url, check.MIME.type=TRUE, file=destfile)
    }

    if(status > 0)
        warning("Download had nonzero exit status")

    invisible(status)
}

### NOTE: This is for Unix only (cf. ../{mac,windows}/help.R)

help <- function(topic, offline = FALSE, package = .packages(),
                 lib.loc = .lib.loc, 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)) {
        topic <- substitute(topic)
        if (is.name(topic))
            topic <- as.character(topic)
        else if (!is.character(topic))
            stop("Unimplemented help feature")
        # 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, missing(lib.loc),
                                 quiet = TRUE)
        file <- index.search(topic, INDICES, "AnIndex", type)
        if (length(file) && file != "") {
            if (verbose)
                cat("\t\t\t\t\t\tHelp file name `", sub(".*/", "", file),
                    ".Rd'\n", sep = "")
            if (!offline) {
                if (htmlhelp) {
                    if(file.exists(file)) {
                        ofile <- file
                        base.pos <- match("package:base", search())
                        if (exists("help.start.has.been.run",
                                   where=base.pos, mode="logical") &&
                            get("help.start.has.been.run",
                                   pos=base.pos, mode="logical")) {
                        ## we need to use the version in ~/.R if we can.
                            lnkfile <-
                                file.path(Sys.getenv("HOME"), ".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(getOption("browser")))
                            stop("options(\"browser\") not set")
                        browser <- getOption("browser")
                        system(paste(browser, " -remote \"openURL(",
                                     file, ")\" 2>/dev/null || ", browser, " ",
                                     file, " &", sep = ""))
                        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 `", 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 `", topic, "'", sep=""),
                              delete.file = (zfile!=file),
                              pager = pager)
                else
                    stop(paste("The help file for `", topic, "' is missing",
                               sep = ""))
                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)
                    system(paste(paste("TEXINPUTS=",
                                       file.path(R.home(), "share",
                                                 "texmf"),
                                       ":",
                                       "$TEXINPUTS",
                                       sep = ""),
                                 file.path(R.home(), "bin", "help"),
                                 "PRINT",
                                 FILE,
                                 topic,
                                 getOption("latexcmd"),
                                 getOption("dvipscmd")))
                    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
                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) {
                    cat("  topic `", topic, "' is not in any loaded package\n",
                        "  but can be found in package `", pkgs,
                        "' in library `", libs, "'\n", sep = "")
                } else if(length(pkgs) > 1) {
                    cat("  topic `", topic, "' is not in any loaded package\n",
                        "  but can be found in the following packages:\n\n",
                        sep="")
                    A <- cbind(package=pkgs, library=libs)
                    rownames(A) <- 1:nrow(A)
                    print(A, quote=F)
                } else {
                    stop(paste("No documentation for `", topic,
                               "' in specified packages and libraries:\n",
                               "  you could try `help.search(\"", topic,
                               "\")'",
                               sep = ""))
                }
            } else {
                    stop(paste("No documentation for `", topic,
                               "' in specified packages and libraries:\n",
                               "  you could try `help.search(\"", topic,
                               "\")'",
                               sep = ""))
            }
        }
    }
    else if (!missing(package))
        library(help = package, lib = lib.loc, character.only = TRUE)
    else if (!missing(lib.loc))
        library(lib = 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\").")
    cat("Making links in ~/.R ...\n")
    .Script("sh", "help-links.sh", paste(unique(.lib.loc), collapse = " "))
    url <- paste(if (is.null(remote)) "$HOME/.R" else remote,
		 "/doc/html/index.html", sep = "")
    cat("If", browser, " is already running,\tit is *not* restarted,\n",
	"and you must switch to its window.\nOtherwise, be patient..\n")
    system(paste(browser, " -remote \"openURL(", url, ")\" 2>/dev/null || ",
		 browser, " ", url, " &", sep = ""))
    assign("help.start.has.been.run", TRUE,
           pos=match("package:base", search()))
    options(htmlhelp=TRUE)
}
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)
}

tempfile <- function(pattern = "file") .Internal(tempfile(pattern))

##--- 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)
{
    if(missing(lib) || is.null(lib)) {
        lib <- .lib.loc[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 -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)
        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) paste(CRAN,"/src/contrib",sep="")
X11 <- function(display="", width=7, height=7, pointsize=12,
                gamma=1, colortype = getOption("X11colortype"),
                maxcubesize = 256)
    .Internal(X11(display, width, height, pointsize, gamma, colortype, maxcubesize))

x11 <- .Alias(X11)

gnome <- function(display="", width=7, height=7, pointsize=12)
    .Internal(gnome(display, width, height, pointsize))

## no Gnome <- .Alias(gnome)
GNOME <- .Alias(gnome)

gtk <- function(display="", width=7, height=7, pointsize=12)
    .Internal(GTK(display, width, height, pointsize))
GTK <- .Alias(gtk)
zip.file.extract <- function(file, zipname="R.zip")
{
    ## somewhat system-specific.
    unzip <- getOption("unzip")
    if(!length(unzip)) return(file)
    path <- sub("[^/]*$","", file)
    topic <- substr(file, nchar(path)+1, 1000)
    if(file.exists(file.path(path, zipname))) {
        tempdir <- sub("[^/]*$", "", tempfile())
        if(!system(paste(unzip, "-o",
                         file.path(path, zipname), topic, "-d", tempdir,
                         " > /dev/null")))
            file <- paste(tempdir,  topic, sep="")
    }
    file
}
