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 = ""))
}
dnchisq <- function(x, df, lambda) .Defunct()
pnchisq <- function(q, df, lambda) .Defunct()
qnchisq <- function(p, df, lambda) .Defunct()
#rnchisq <- function(...) .NotYetImplemented()
print.plot <- function() .Defunct()
save.plot <- function(file = "Rplots.ps") .Defunct()
## From print.R :
## This is not used anymore [replaced by  print.anova() -> ./anova.R ]
##- print.tabular <-
##-	function(x, digits = max(3, getOption("digits") - 3), na.print = "")
##- {
##-	cat("\n", if(!is.null(x$title))
##-	x$title else "Analysis of Variance:", "\n\n", sep="")
##-	if(!is.null(x$topnote))
##-	cat(paste(x$topnote, collapse="\n"), "\n\n", sep="")
##-	print.default(x$table, digits=digits, na = "", print.gap = 2)
##-	if(!is.null(x$botnote))
##-	cat("\n", paste(x$botnote, collapse="\n"), sep="")
##-	cat("\n")
##- }
print.tabular <-
    function(table, digits = max(3, getOption("digits") - 3), na.print = "", ...)
	.Defunct()
## From lm.R :
## Unused (0.63, Sept.25 1998) --- print.anova()  now in ./print.R
##- print.anova.lm <- function(x, digits = max(3, getOption("digits") - 3), ...)
##- {
##-	cat("\nAnalysis of Variance:\n\n")
##-	print.default(round(unclass(x), digits), na="", print.gap=2)
##-	cat("\n")
##-	invisible(x)
##- }
print.anova.lm <- function(x, digits = max(3, getOption("digits") - 3), ...)
    .Defunct()
## From glm.R :
## Not used anymore..
##- print.anova.glm <- function(x, digits = max(3, getOption("digits") - 3),
##-			    na.print = "", ...)
##- {
##-	cat("\n", x$title, sep="")
##-	print.default(x$table, digits=digits, na = "", print.gap = 2)
##-	cat("\n")
##- }
print.anova.glm <- .Alias(print.anova.lm)
system.test <- function(...)
  .Defunct()
###----- 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 = ""))
}
##vector <- function(mode = "logical", length = 0).Internal(vector(mode,length))
stop <- function(message = NULL).Internal(stop(message))
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, namevec).Internal(D(expr, namevec))
Machine <- function().Internal(Machine())
R.Version <- function().Internal(Version())
Version <- function() { .Deprecated("R.Version"); R.Version() }
machine <- function().Internal(machine())
colors <- function().Internal(colors())
colours <- .Alias(colors)
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) stop("cbind(.) does not accept deparse.level in R.")
    .Internal(cbind(...))
}
rbind <- function(..., deparse.level=1) {
    if(deparse.level != 1) stop("rbind(.) does not accept deparse.level in R.")
    .Internal(rbind(...))
}
dataentry <- function(data, modes).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)
	stop("duplicated(.. incomparables != FALSE) not yet available in R.")
    .Internal(duplicated(x))
}
format.info <- function(x).Internal(format.info(x))
gc <- function(verbose = getOption("verbose"))
    matrix(.Internal(gc(verbose))/c(1,1,1,1,10,10),2,3,
           dimnames = list(c("Ncells","Vcells"),c("free","total", "(Mb)")))
gcinfo <- function(verbose).Internal(gcinfo(verbose))
gctorture <- function(on=TRUE)invisible(.Internal(gctorture(on)))
gray <- function(level).Internal(gray(level))
grey <- .Alias(gray)
nchar <- function(x).Internal(nchar(x))
##=== FAILS: [	format(pi, dig=2) doesn't work afterwards ]
##- on.exit <- function(expression, add = FALSE) {
##-   if(!is.logical(add) || add)
##-	stop("on.exit(.., add != FALSE) does not yet work in R.")
##-  .Internal(on.exit(expression))
##- }
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) {
    if(!is.logical(na.last) || !na.last)
	stop("rank(.., na.last != TRUE) does not yet work in R.")
    .Internal(rank(x))
}
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)
}
sink <- function(file=NULL, append = FALSE)
    .Internal(sink(file, append))
##-- 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){
    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())
## 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", "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)))
}
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, ...) 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")
    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] <- 1 - pchisq(dev[nas], dfs[nas])
	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] <- 1 - pf(Fs[nnas], df[nnas], rdf - df[nnas])
	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)
    }
    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"
	nas <- !is.na(dev)
	dev[nas] <- 1 - pchisq(dev[nas]/scale, aod$Df[nas])
	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"),
		     x = NULL, k = 2, ...)
{
    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)
    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)
    }
    n <- nrow(x)
    y <- object$y
    if(is.null(y)) y <- model.response(model.frame(object), "numeric")
    wt <- object$prior.weights
    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 (is.null(scale) || scale == 0)
	dispersion <- summary(object, dispersion = NULL)$dispersion
    else dispersion <- scale
    if(object$family$family == "gaussian") {
	if(scale > 0) loglik <- dev/scale - n
	else loglik <- n * log(dev/n)
    } else loglik <- dev/dispersion
    aic <- loglik + k * dfs
    dfs <- dfs - dfs[1]
    dfs[1] <- NA
    aod <- data.frame(Df = dfs, Deviance = dev, AIC = aic,
		      row.names = names(dfs), check.names = FALSE)
    test <- match.arg(test)
    if(test == "Chisq") {
	dev <- loglik[1] - loglik
	dev[1] <- NA
	aod[, "LRT"] <- dev
	nas <- !is.na(dev)
	dev[nas] <- 1 - pchisq(dev[nas]/dispersion, aod$Df[nas])
	aod[, "Pr(Chi)"] <- dev
    }
    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, ...) 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")
    }
    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])
    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"
	nas <- !is.na(dev)
	dev[nas] <- 1 - pchisq(dev[nas]/scale, aod$Df[nas])
	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] <- 1 - pf(Fs[nas], dfs[nas], rdf)
	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"),
		      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)
    if (is.null(scale) || scale == 0)
	dispersion <- summary(object, dispersion = NULL)$dispersion
    else dispersion <- scale
    if(object$family$family == "gaussian") {
	if(scale > 0) loglik <- dev/scale - n
	else loglik <- n * log(dev/n)
    } else loglik <- dev/dispersion
    aic <- loglik + k * dfs
    dfs <- dfs[1] - dfs
    dfs[1] <- NA
    aod <- data.frame(Df = dfs, Deviance = dev, AIC = aic,
		      row.names = scope, check.names = FALSE)
    test <- match.arg(test)
    if(test == "Chisq") {
	dev <- loglik - loglik[1]
	dev[1] <- NA
	nas <- !is.na(dev)
	aod[, "LRT"] <- dev
	dev[nas] <- 1 - pchisq(dev[nas]/dispersion, aod$Df[nas])
	aod[, "Pr(Chi)"] <- dev
    }
    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
}
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")
	    nmdrop <- nmfac[-where]
	    facs <- factor[, -where, drop = FALSE]
	} else nmdrop <- colnames(factor)
	if(ncol(facs) > 1) {
					# now 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) {
					# now 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(deparse(formula(object)[[2]]), "~",
		     paste(tmp, collapse = " + "))
	if (length(offset <- attr(tt, "offset")))
	    tmp <- paste(tmp, deparse(attr(tt, "variables")[offset + 1]),
			 sep = " + ")
	formula(tmp)
    }
    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
    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]
    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))
	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
    dev <- fit$deviance
    if(scale > 0) dev <- dev/scale
    if(scale == 0 && fit$family$family == "Gaussian") dev <- n * log(dev/n)
    c(edf, dev + k * 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)
    nstart <- ceiling(tsp(x)[1] * nfrequency) / nfrequency
    x <- as.matrix(window(x, start = nstart))
    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)
    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 <-
	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 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, sys.frame(sys.parent()))
        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.
        cons <- options("contrasts")
        options(contrasts=c("contr.helmert", "contr.poly"))
        on.exit(options(cons))
        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, sys.frame(sys.parent()))
        options(cons)
        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, sys.frame(sys.parent()))
        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, sys.frame(sys.parent()))
    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, sys.frame(sys.parent()))
    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<-(length(dim(a)):1)
    else {
	if(length(perm) != length(dim(a)))
	    stop("perm has incorrect length")
	if(!all(sort(perm)==1:length(perm)))
	    stop("perm is not a permutation")
    }
    r <- .Internal(aperm(a, perm, resize))
    if(!is.null(dn <- dimnames(a))) dimnames(r) <- dn[perm]
    r
}
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))
#    i.vec <- length(d.call) < 2
    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, function(x) FUN(x, ...)))
    ## answer dims and dimnames
    ans.list <- is.recursive(ans[[1]])
    l.ans <- length(ans[[1]])
    ans.names <- names(ans[[1]])
#    if(i.vec && is.null(ans.names) && length(dn.call) &&
#       l.ans == length(an <- dn.call[[1]]))
#	ans.names <- an
    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)
{
    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]
    nx <-length(x)
    if (nx < 2)
	stop("approx requires at least two non-missing values to interpolate")
    o <- order(x)
    x <- x[o]
    y <- y[o]
    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)
{
    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]
    o <- order(x)
    x <- x[o]
    y <- y[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(o, ok, rule)
    function(v) .C("R_approx", as.double(x), as.double(y),
		   n, xout = as.double(v), length(v), as.integer(method),
		   as.double(yleft), as.double(yright),
		   as.double(f), NAOK=TRUE, PACKAGE="base")$xout
}
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<- function(x,...) UseMethod("as.character")
as.character.default <- function(x) .Internal(as.vector(x,"character"))
as.expression <- function(x,...) UseMethod("as.expression")
as.expression.default <- function(x) .Internal(as.vector(x,"expression"))
as.list <- function(x,...) UseMethod("as.list")
as.list.default <- function (x)
{
    if (is.function(x))
	return(c(formals(x), 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 = sys.frame(sys.parent()))
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.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)
    if(inherits(object, "formula")) object else formula(object)
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))
    }
attach <- function(what, pos=2, name=deparse(substitute(what)))
    .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")
    }
    .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)
attr <- function(x, which) {
    if (!is.character(which))
	stop("attribute name must be of mode character")
    if (length(which) != 1)
	stop("exactly one attribute name must be given")
    attributes(x)[[which]]
}
"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, file)
{
    if (exists(name,envir=.GlobalEnv,inherits=FALSE))
	stop("Object already exists")
    newcall <- paste("delay(autoloader(\"", name, "\",\"", file, "\"))",
		     sep = "")
    if (is.na(match(file,.Autoloaded)))
	assign(".Autoloaded",c(file,.Autoloaded),env=.AutoloadEnv)
    assign(name, eval(parse(text = newcall)), env = .AutoloadEnv)
}
autoloader <- function (name, file)
{
    name<-paste(name,"",sep="")
    rm(list=name,envir=.AutoloadEnv,inherits=FALSE)
    where <- length(search)
    eval(parse(text = paste("library(\"", file, "\")", sep = "")),
	 .GlobalEnv)
    autoload(name,file)
    where <- length(search) - where + 2
    if (exists(name,where=where,inherits=FALSE))
	eval(as.name(name), pos.to.env(where))
    else
	stop(paste("autoloader didn't find `",name,"' in `",file,"'.",sep=""))
}
ave <- function (x, ..., FUN = mean)
{
    l <- list(...)
    if (is.null(l)) {
	x[] <- FUN(x)
    }
    else {
	g <- 1
	nlv <- 1
	for (i in 1:length(l)) {
	    l[[i]] <- li <- as.factor(l[[i]])
	    g <- g + nlv * (as.numeric(li) - 1)
	    nlv <- nlv * length(levels(li))
	}
	x[] <- unlist(lapply(split(x, g), FUN))[g]
    }
    x
}
axis <- function(side, at=NULL, labels=NULL, ...)
    .Internal(axis(side, at, labels,...))
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")
    if (!missing(border)) .NotYetUsed("border")
    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 <- col
	    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
}
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, data = sys.frame(sys.parent()), plot = TRUE,
         border = par("fg"), col = NULL, log = "", pars = 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)) {
	    if(inherits(x, "formula") && length(x) == 3) {
		groups <- eval(x[[3]], data, sys.frame(sys.parent()))
		x <- eval(x[[2]], data, sys.frame(sys.parent()))
		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)
    if(plot) {
	bxp(groups, width, varwidth = varwidth, notch = notch, border =
            border, col = col, log = log, pars = pars, znames = names) 
	invisible(groups)
    }
    else groups
}
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, sys.frame(sys.parent()))))
        m$data <- as.data.frame(data)
    m$... <- NULL
    m[[1]] <- as.name("model.frame")
    mf <- eval(m, sys.frame(sys.parent()))
    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 <- length(nna)                    # including +/- Inf
    stats <- fivenum(x, na.rm = TRUE)
    iqr <- diff(stats[c(2, 4)])
    out <- x < (stats[2] - coef * iqr) | x > (stats[4] + coef * iqr)
    if(coef > 0) 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,
		border=par("fg"), col=NULL, log="", pars=NULL,
		znames=names(z), ...)
{
    bplt <- function(x, wid, stats, out, conf, notch, border, col)
    {
	## Draw single box plot.
	pars <- c(pars, list(...))# from bxp(...).
	if(!any(is.na(stats))) {
	    ## stats = +/- Inf:	 polygon & segments should handle
	    wid <- wid/2
	    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)))
	stop("invalid first argument")
    limits <- numeric(0)
    nmax <- 0
    for(i in 1:n) {
	nmax <- max(nmax,z[[i]]$n)
	limits <- range(limits,
                        z[[i]]$stats[is.finite(z[[i]]$stats)],
                        z[[i]]$out[is.finite(z[[i]]$out)])
    }
    width <- if(!is.null(width)) {
	if(length(width) != n | any(is.na(width)) | any(width <= 0))
	    stop("invalid boxplot widths")
	0.8 * width/max(width)
    }
    else if(varwidth) 0.8 * sqrt(unlist(lapply(z, "[[", "n"))/nmax)
    else if(n == 1) 0.4
    else rep(0.8, n)
    if(is.null(pars$ylim)) ylim <- limits
    else { ylim <- pars$ylim; pars$ylim <- NULL }
    if(missing(border) || length(border)==0)
	border <- par("fg")
    plot.new()
    plot.window(xlim=c(0.5,n+0.5), ylim=ylim, log=log)
    for(i in 1:n)
	bplt(i, wid=width[i],
	     stats= z[[i]]$stats,
	     out  = z[[i]]$out,
	     conf = z[[i]]$conf,
	     notch= notch,
	     border=border[(i-1)%%length(border)+1],
	     col=if(is.null(col)) col else col[(i-1)%%length(col)+1])
    axes <- is.null(pars$axes)
    if(!axes) { axes <- pars$axes; pars$axes <- NULL }
    if(axes) {
	if(n > 1) axis(1, at=1:n, labels=znames)
	axis(2)
    }
    do.call("title", pars)
    box()
    invisible(1:n)
}
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,], ...)
    ans <- eval(substitute(tapply(1:nrow(data), 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)
    .Internal(cat(list(...),file,sep,fill,labels,append))
strsplit <- function(x,split)
  .Internal(strsplit(as.character(x),as.character(split)))
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)
}
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
}
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])
}
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
}
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.4, drawlabels = TRUE, method = "flattest", vfont = NULL,
	  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)) {
        typeface <- pmatch(vfont[1], c("serif", "sans serif", "script",
		                       "gothic english", "gothic german",
			      	       "gothic italian", "serif symbol",
				       "sans serif symbol"))
        fontindex <- pmatch(vfont[2], c("symbol", "plain", "italic", "bold",
				        "bold italic"))
        vfont <- c(typeface-1, fontindex-1)
    }
    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) {
	axis(1)
	axis(2)
	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")
    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
}
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"), pch = par("pch"),
			 col.smooth = "red", span = 2/3, iter = 3, ...)
{
    points(x, y, pch=pch, col=col)
    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"),
             xlab = paste("Given :", a.name),
             ylab = paste("Given :", b.name),
             number = 6, overlap = 0.5, ...)
{
    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 <- sys.frame(sys.parent())
    x.name <- deparse(x)
    x <- eval(x, data, sys.frame(sys.parent()))
    nobs <- length(x)
    y.name <- deparse(y)
    y <- eval(y, data, sys.frame(sys.parent()))
    if(length(y) != nobs) bad.lengths()
    a.name <- deparse(a)
    a <- eval(a, data, sys.frame(sys.parent()))
    if(length(a) != nobs) bad.lengths()
    if(is.character(a)) a <- as.factor(a)
    a.levels <- NULL
    if (have.b) {
        b.levels <- NULL
	b.name <- deparse(b)
	b <- eval(b, data, sys.frame(sys.parent()))
	if(length(b) != nobs) bad.lengths()
        if(is.character(b)) b <- as.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
    }
    ## 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(is.factor(a)) {
                i <- 1:nlevels(a)
                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(is.factor(b)) {
                    i <- 1:nlevels(b)
                    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(is.factor(a)) {
            if (is.character(a.intervals)) 
                a.intervals <- match(a.intervals, levels(a))
            a.intervals <- cbind(a.intervals - 0.5, a.intervals + 0.5)
            a.levels <- levels(a)
	    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(is.factor(b)) {
                if (is.character(b.intervals)) 
                    b.intervals <- match(b.intervals, levels(b))
                b.intervals <- cbind(b.intervals - 0.5, b.intervals + 0.5)
                b.levels <- levels(b)
		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)) {
		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
    }
    ## Start Plotting only now
    opar <- par(mfrow = c(total.rows, total.columns),
		oma = if(have.b) rep(5, 4) else c(5, 6, 5, 4),
		mar = if(have.b) rep(0, 4) else c(0.5, 0, 0.5, 0),
		new = FALSE)
    on.exit(par(opar))
    plot.new()
    xlim <- range(x[is.finite(x)])
    ylim <- range(y[is.finite(y)])
    pch <- rep(pch, length=nobs)
    col <- rep(col, length=nobs)
    do.panel <- function(index) {
        ## Use `global' variables
        ##	id;     rows, columns,  total.rows, total.columns, nplots
        ##		xlim, ylim
	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, log = "")
        if(any(is.na(id))) id[is.na(id)] <- FALSE
	if(any(id)) {
	    grid(lty="solid")
	    panel(x[id], y[id], col = col[id], pch=pch[id], ...)
	}
	if((i == total.rows) && (j%%2 == 0))
	    axis(1, xpd=NA)
	else if((i == istart || index + columns > nplots) && (j%%2 == 1))
	    axis(3, xpd=NA)
	if((j == 1) && ((total.rows - i)%%2 == 0))
	    axis(2, xpd=NA)
	else if((j == columns || index == nplots) && ((total.rows - i)%%2 == 1))
	    axis(4, xpd=NA)
	## if(i == total.rows)
	##	axis(1, labels = (j%%2 == 0))
	## if(i == istart || index + columns > nplots)
	##	axis(3, labels = (j%%2 == 1))
	## if(j == 1)
	##	axis(2, labels = ((total.rows - i)%%2 == 0))
	## if(j == columns || index == nplots)
	##	axis(4, labels = ((total.rows - i)%%2 == 1))
	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)
		count <- count + 1
	    }
	}
    } else {
	for (i in 1:nplots) {
	    id <- ((a.intervals[i,1] <= a) & (a <= a.intervals[i,2]))
	    do.panel(i)
	}
    }
    mtext(x.name, side=1, at=0.5*f.col, outer=TRUE, line=3.5, xpd=NA)
    mtext(y.name, side=2, at=0.5*f.row, outer=TRUE, line=3.5, xpd=NA)
    if(show.given[1]) {
	mar <- par("mar")
	nmar <- mar + c(4,0,0,0)
	par(fig = c(0, f.col, f.row, 1), mar = nmar, new=TRUE)
	plot.new()
	nint <- nrow(a.intervals)
	plot.window(range(a.intervals[is.finite(a.intervals)]),
                    0.5 + c(0, nint), log="")
        bg <-
            if (is.null(a.levels))
                gray(0.9)
            else {
                mid <- apply(a.intervals, 1, mean)
                text(mid, 1:nint, a.levels)
                NULL
            }
        rect(a.intervals[, 1], 1:nint - 0.3,
             a.intervals[, 2], 1:nint + 0.3, col = bg)
	axis(3, xpd=NA)
	axis(1, labels=FALSE)
	box()
	mtext(xlab, side=3, at=mean(par("usr")[1:2]), line=3, xpd=NA)
    }
    else { ## i. e. !show.given
        mtext(xlab, side=3, at= 0.5*f.col, line= 3.25, outer= TRUE, xpd=NA)
    }
    if(have.b) {
        if(show.given[2]) {
            nmar <- mar + c(0, 4, 0, 0)
	    par(fig = c(f.col, 1, 0, f.row), mar = nmar, new=TRUE)
	    plot.new()
	    nint <- nrow(b.intervals)
	    plot.window(0.5+c(0, nint),
			range(b.intervals, finite=TRUE), log="")
            bg <-
                if (is.null(b.levels)) 
                    gray(0.9)
                else {
                    mid <- apply(b.intervals, 1, mean)
                    text(1:nint, mid, b.levels, srt = 90)
                    NULL
                }
            rect(1:nint - 0.3, b.intervals[, 1],
                 1:nint + 0.3, b.intervals[, 2], col = bg)
	    axis(4, xpd=NA)
	    axis(2, labels=FALSE)
	    box()
	    mtext(ylab, side=4, at=mean(par("usr")[3:4]), line=3, xpd=NA)
	}
        else {
            mtext(ylab, side=4, at=0.5*f.row, line= 3.25, 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)
    .Internal(cor(x, y, na.method))
}
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)
    .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 <- c(y, wt = wt)
    if (cor) {
	sdinv <- diag(1 / sqrt(diag(cov)))
	y <- c(y, cor = sdinv %*% cov %*% sdinv)
    }
    y
}
curve <- function(expr, from, to, n=101, add=FALSE, type="l",
		  ylab = NULL, log=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 <- delay(par("usr"))
    if(missing(from)) from <- lims[1]
    if(missing(to)) to <- lims[2]
    lg <- if(length(log)) log else ""
    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=sys.frame(sys.parent(1)))
    if(add)
	lines(x, y, type=type, ...)
    else
	plot(x, y, type=type, ylab = ylab, 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)
}
## Was in `system.unix.R'.  Now system-independent, thanks to Guido's
## .Platform$show.data() idea.
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) {
        if(!missing(package))
            show.data(package, lib.loc)
        else
            show.data(lib.loc = lib.loc)
    } else for (name in names) {
        paths <-
            if(missing(lib.loc)) {
                paths <- file.path(c(.path.package(package), getwd()), "data")
                paths[file.exists(paths)]
            } else
                system.file("data", pkg = package, lib = lib.loc)
        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)
}
show.data <-
  function (package = .packages(), lib.loc = .lib.loc)
{
    ## give `index' of all possible data sets
    file <- tempfile("R.")
    file.create(file)
    first <- TRUE
    nodata <- noindex <- character(0)
    paths <-
        if(missing(lib.loc)) {
            paths <- file.path(c(.path.package(package), getwd()), "data")
        } else
            system.file(pkg = package, lib = lib.loc)
    for (path in paths) {
        pkg <- sub(".*/([^/]*)$", "\\1", path) # may not work on Mac
        if(!file.exists(path)) next
        if(!file.exists(file.path(path, "data"))) {
            nodata <- c(nodata, pkg)
            next
        }
        INDEX <- file.path(path, "data", "00Index")
        if(INDEX == "")
            INDEX <- file.path(path, "data", "index.doc")
        if (INDEX != "") {
            cat(paste(ifelse(first, "", "\n"), "Data sets in package `",
                      pkg, "':\n\n", sep = ""), file = file, append = TRUE)
            file.append(file, INDEX)
            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) {
        unlink(file)
        warning("no data listings found")
    } else file.show(file, delete.file = TRUE, title = "R data sets")
    if(!missing(package)) {
        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=""))
    invisible(character(0))
}
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) attr(x, "row.names")
"row.names<-" <- 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
}
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) {
	stripplot(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]]
    ncols <- d[[2]]
    dn <- dimnames(x)
    row.names <- dn[[1]]
    collabs <- dn[[2]]
    value <- vector("list", ncols)
    if(mode(x) == "character" || mode(x) == "logical") {
        for(i in 1:ncols)
            value[[i]] <- as.factor(x[,i])
    } else {
        for(i in 1:ncols)
            value[[i]] <- as.vector(x[,i])
    }
    if(length(row.names) != nrows)
        if(optional) row.names <- character(nrows)
        else row.names <- as.character(1:nrows)
    if(length(collabs) == ncols) names(value) <- collabs
    else if(!optional) names(value) <- paste("V", 1:ncols, 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
}
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]]) vnames[[i]] <- deparse(object[[i]])[1]
	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])
	return(structure(NextMethod("["), 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("undefined columns selected")
    }
    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 <- 1: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))
	}
	print.matrix(as.matrix(x), ..., quote = quote, right = right)
    }
    invisible(x)
}
as.matrix.data.frame <- function (x)
{
    X <- x
    dm <- dim(X)
    p <- dm[2]
    n <- dm[1]
    dn <- dimnames(X)
    collabs <- as.list(dn[[2]])
    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)))
	    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) {
	    xj <- X[[j]]
	    if(length(levels(xj)) > 0) {
		X[[j]] <- as.vector(xj)
	    }
	    else X[[j]] <- 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) && mode(xx) != "complex")
	    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 <- sys.frame(sys.parent())
    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 = sys.frame(sys.parent()),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) && mode(x) != "complex")
	stop("only defined on a data frame with all numeric or complex variables")
    NextMethod(.Generic)
}
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 data types 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)
}
dev.list <-
    function()
{
    if(exists(".Devices")) {
	n <- get(".Devices")
    }
    else {
	n <- list("null device")
    }
    n <- unlist(n)
    i <- seq(along = n)[n != ""]
    names(i) <- n[i]
    i <- i[-1]
    if(length(i) == 0)
	return(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()
    dev.off(dev.copy(device = device, ...)) # user must still print this
    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")
diff.default <- function(x, lag = 1, differences = 1, ...)
{
    ismat <- is.matrix(x)
    if (ismat)
	xlen <- dim(x)[1]
    else xlen <- length(x)
    if (lag < 1 | differences < 1)
	stop("Bad value for lag or differences")
    if (lag * differences >= xlen)
	return(x[0])
    r <- x
    class(r) <- NULL # don't want class-specific subset methods
    s <- 1:lag
    if (is.matrix(r)) {
	for (i in 1:differences)
	    r <- r[-s, , drop = FALSE] - r[-(nrow(r) + 1 - s), , drop = FALSE]
    }
    else for (i in 1:differences)
	r <- r[-s] - r[-(length(r) + 1 - s)]
    xtsp <- attr(x, "tsp")
    if (!is.null(xtsp))
        tsp(r) <- c(xtsp[1] + lag*differences*xtsp[3], xtsp[2], xtsp[3])
    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 .not.yet.implemented()
}
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, log = FALSE)
    .Internal(dnbinom(x, size, prob, log))
pnbinom <- function(q, size, prob, lower.tail = TRUE, log.p = FALSE)
    .Internal(pnbinom(q, size, prob, lower.tail, log.p))
qnbinom <- function(p, size, prob, lower.tail = TRUE, log.p = FALSE)
    .Internal(qnbinom(p, size, prob, lower.tail, log.p))
rnbinom <- function(n, size, prob) .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))
"dotplot" <-
    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]
	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, ...)
    }
    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, ...)
	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 = "")
    .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, fileout = "dumpdata")
{
    digits <- options("digits")
    on.exit(options(digits))
    options(digits = 12)
    .Internal(dump(list, fileout))
}
##dump <- function (list, fileout = "dumpdata") { .Internal(dump(list, fileout)) }
##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"))
    .Internal(edit(name, file, editor))
edit.data.frame<-
    function(name,factor.mode=c("numeric","character"),...)
{
    if (getenv("DISPLAY")=="" || .Platform$OS.type == "windows")
        return (edit.default(name,...))
    is.vector.unclass <- function(x) is.vector(unclass(x))
    if (!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)
    {
        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 <- which(sapply(name, is.factor))
    modes <- lapply(datalist, mode)
    out <- .Internal(dataentry(datalist, modes))
    lengths <- sapply(out, length)
    maxlength <- max(lengths)
    for (i in which(lengths != maxlength))
         out[[i]] <- c(out[[i]], rep(NA, maxlength-lengths[i]))
    for (i in factors) {
        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[o <= 0] <- NA
                o[o > length(a$levels)] <- NA
            }
        } else {
            o <- out[[i]]
            if (any(is.na(match(o, c(a$levels, NA)))))
                warning(paste("invalid factor levels in",
                               names(out)[i]))
            o <- match(o, a$levels)
        }
        attributes(o) <- a
        out[[i]] <- o
    }
    as.data.frame(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 != ncol(x))
	stop("non-square matrix in eigen")
    complex.x <- is.complex(x)
    if(complex.x) {
	if(missing(symmetric))
	    symmetric <- all(x == Conj(t(x)))
    }
    else if(is.numeric(x)) {
	storage.mode(x) <- "double"
	if(missing(symmetric))
	    symmetric <- all(x == t(x))
    }
    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) sys.frame(sys.parent(n + 1))
eval <-
    function(expr, envir = parent.frame(),
	     enclos = if(is.list(envir) || is.pairlist(envir))
                       parent.frame())
    .Internal(eval(expr, envir,enclos))
quote <- function(x) substitute(x)
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)
}
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)
    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")
}
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\" 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)
	-2*sum((lchoose(n, n*y) + n*(y*log(mu) + (1-y)*log(1-mu)))*wt/n)
    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")
	}
	else if (NCOL(y) == 2) {
	    n <- y[, 1] + y[, 2]
	    y <- ifelse(n == 0, 0, y[, 1]/n)
	    weights <- weights * n
	}
	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"))
	mustart <- (n * y + 0.5)/(n + 1)
    })
    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")
}
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)}
    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))
	linktemp <- eval(linktemp)
    if (!is.character(linktemp)) {
	linktemp <- deparse(linktemp)
	if (linktemp == "link")
	    linktemp <- eval(link)
    }
    stats <- make.link(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)
    .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))
system.file <- function (..., pkg = .packages(), lib = .lib.loc)
{
    flist <- list(...)
    if(length(flist) > 1 || (length(flist) == 1 && nchar(flist[[1]]) > 0)) {
        FILES <- file.path(t(outer(lib, pkg, paste, sep = .Platform$file.sep)),
                           file.path(...))
    } else {
        if(missing(pkg)) pkg <- "base"
        FILES <- outer(lib, pkg, paste, sep = .Platform$file.sep)
    }
    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))
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")
    if (exists(subx, inherits = TRUE))
        x <- edit(get(subx), ...)
    else
        x <- edit(function(){},...)
    assign(subx, x, env = .GlobalEnv)
}
formals <- function(fun=sys.function(sys.parent())) {
    if(is.character(fun))
	fun <- get(fun, mode = "function", envir = sys.frame(sys.parent()))
    .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 = sys.frame(sys.parent())) {
    if (is.expression(value))
	value <- value[[1]]
    f <- as.function(c(formals(f), value), envir)
}
"formals<-" <- function (f, value, envir = sys.frame(sys.parent())) {
    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 INTERNALLY !
format.default <- function(x, trim=FALSE, digits=NULL)
{
    if(!is.null(digits)) {
	op <- options(digits=digits)
	on.exit(options(op))
    }
    switch(mode(x),
	   NULL = "NULL",
	   list = sapply(
	   lapply(x, function(x)
		  .Internal(format(unlist(x),trim=trim))),
	   paste, collapse=", "),
	   ##else: numeric, complex, character, ??? :
	   structure(.Internal(format(x, trim = trim)), names=names(x)))
}
## Martin Maechler <maechler@stat.math.ethz.ch>
##-- this should also happen in	C(.) :
##	.Internal(format(..) should work  with	'width =' and 'flag=.."
##		at least for the case of character arguments.
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)
	     )
    ##Dbg if(format=="fg"||format == "f")
    ##Dbg   cat("formatC(,.): xEx=",xEx,"\n\t==> i.strlen=",i.strlen,"\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
    ##Dbg if(any(ii <- (nc.res <- nchar(r)) > i.strlen)) {
    ##Dbg  cat("formatC: some  i.strlen[.] were too small:\n")
    ##Dbg  print(cbind(ii=which(ii), strlen=i.strlen[ii], nchar=nc.res[ii]))
    ##Dbg }
    if (some.special)
	r[!Ok] <- format.char(rQ, width=width, flag=flag)
    if (!is.null(x.atr <- attributes(x)))
	attributes(r) <- x.atr
    r
}
subset.data.frame <-
    function (dfr, subset, select)
{
    if(missing(subset))
	r <- TRUE
    else {
	e <- substitute(subset)
	r <- eval(e, dfr, sys.frame(sys.parent()))
	r <- r & !is.na(r)
    }
    if(missing(select))
	vars <- TRUE
    else {
	nl <- as.list(1:ncol(dfr))
	names(nl) <- names(dfr)
	vars <- eval(substitute(select),nl, sys.frame(sys.parent()))
    }
    dfr[r,vars,drop=FALSE]
}
subset<-
    function(x,...)
    UseMethod("subset")
subset.default <-
    function(x,subset)
    x[subset & !is.na(subset)]
transform.data.frame <-
    function (dfr, ...)
{
    e <- eval(substitute(list(...)), dfr, sys.frame(sys.parent()))
    tags <- names(e)
    inx <- match(tags, names(dfr))
    matched <- !is.na(inx)
    if (any(matched)) {
	dfr[inx[matched]] <- e[matched]
	dfr <- data.frame(dfr)
    }
    if (!all(matched))
	data.frame(dfr, e[!matched])
    else dfr
}
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),...)
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 <- ftable2table(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, sys.frame(sys.parent()))
    if(inherits(edata, "ftable")
       || inherits(edata, "table")
       || length(dim(edata)) > 2) {
        if(inherits(edata, "ftable")) {
            data <- ftable2table(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, sys.frame(sys.parent()))
        ftable(mf, row.vars = rvars, col.vars = cvars, ...)
    }
}
print.ftable <- function(x) {
    if(!inherits(x, "ftable"))
        stop("x must be an `ftable'")
    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] <- 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)),
                        names(xrv), makeLabels(xrv)),
                  c(names(xcv), rep("", times = nrow(x) + 1)))
    DATA <- rbind(t(makeLabels(xcv)), rep("", times = ncol(x)), x)
    x <- cbind(apply(LABS, 2, formatC, flag = "-"),
               apply(DATA, 2, formatC))
    cat(t(x), sep = c(rep(" ", ncol(x) - 1), "\n"))
}
ftable2table <- function(x) {
    ## Note: it would be nicer to have as.table() for coercion to a
    ## standard contingency table.  But the term ``table'' is also used
    ## differently, so let's wait until this gets straightened out.
    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
}
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))
    }
## 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 <- sys.frame(sys.parent())
    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, sys.frame(sys.parent()))
    switch(method,
	   "model.frame" = return(mf),
	   "glm.fit"= 1,
	   "glm.fit.null"= 1,
	   ## else
	   stop(paste("invalid `method':", method)))
    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(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, sys.frame(sys.parent())))
    }
    ## 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, sys.frame(sys.nframe()))
    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)
	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)
		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, ..., 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, -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
    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))
    structure(table, heading = title, class= c("anova", "data.frame"))
}
anova.glmlist <- function(object, test=NULL, ...)
{
    ## find responses for all models and remove
    ## any models with a different response
    responses <- as.character(lapply(object, function(x) {
	deparse(formula(x)[[2]])} ))
    sameresp <- responses==responses[1]
    if(!all(sameresp)) {
	object <- object[sameresp]
	warning(paste("Models with response", deparse(responses[!sameresp]),
		      "removed because response differs from",
		      "model 1"))
    }
    ## calculate the number of models
    nmodels <- length(object)
    if(nmodels==1)
	return(anova.glm(object[[1]], test=test, ...))
    ## extract statistics
    resdf  <- as.numeric(lapply(object, function(x) x$df.residual))
    resdev <- as.numeric(lapply(object, function(x) x$deviance))
    ## construct table and title
    table <- data.frame(resdf, resdev, c(NA, -diff(resdf)), c(NA, -diff(resdev)))
    variables <- as.character(lapply(object, function(x) {
	deparse(formula(x)[[3]])} ))
    dimnames(table) <- list(variables, c("Resid. Df", "Resid. Dev", "Df",
					 "Deviance"))
    title <- paste("Analysis of Deviance Table \n\nResponse: ", responses[1],
		   "\n\n", sep="")
    ## calculate test statistic if needed
    if(!is.null(test)) {
	bigmodel <- object[[(order(resdf)[1])]]
	table <- stat.anova(table=table, test=test,
			    scale=sum(bigmodel$weights * bigmodel$residuals^2)/
			    bigmodel$df.residual, df.scale=min(resdf),
			    n=length(bigmodel$residuals))
    }
    structure(table, heading = title, 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|)"= 1-pchisq(abs(table[, dev.col]),
			     abs(table[, "Df"])))
	   },
	   "F" = {
	       Fvalue <- abs((table[, dev.col]/table[, "Df"])/scale)
	       cbind(table, F = Fvalue,
		     "Pr(>F)" = 1-pf(Fvalue, abs(table[, "Df"]), abs(df.scale)))
	   },
	   "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, ...) 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
    mu	<- .Alias(object$fitted.values)
    wts <- .Alias(object$prior.weights)
    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 = object$residuals * sqrt(object$weights),
	   working = object$residuals,
	   response = y - mu,
	   partial = object$residuals + predict(object,type="terms")
	   )
}
## Commented by KH on 1998/06/22
## update.default() should be more general now ...
##update.glm <- function (glm.obj, formula, data, weights, subset, na.action,
##			offset, family, x)
##{ ...... }
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")
	eval(fcall, sys.frame(sys.parent()))
    }
    else formula$model
}
###- 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(topic, fields = c("name", "title"),
                        apropos, keyword, whatis, ignore.case = TRUE,
                        packages = NULL, lib.loc = .lib.loc,
                        help.db = getOption("help.db"),
                        verbose = getOption("verbose"),
                        rebuild = FALSE) {
    TABLE <- c("name", "alias", "title", "keyword")
    if (!missing(topic)) {
        if (!is.character(topic) || (length(topic) > 1))
            stop("`topic' 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 {
            topic <- apropos
            fields <- c("name", "title")
        }
    } else if (!missing(keyword)) {
        if (!is.character(keyword) || (length(keyword) > 1))
            stop("`keyword' must be a single character string")
        else {
            topic <- keyword
            fields <- "keyword"
        }
    } else if (!missing(whatis)) {
        if (!is.character(whatis) || (length(whatis) > 1))
            stop("`whatis' must be a single character string")
        else {
            topic <- whatis
            fields <- "name"
        }
    } 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" = getenv("R_USER"),
                      "unix" = 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
        if(verbose)
            RepC <- function(n, ch = " ") paste(rep(ch, n), collapse="")
        db <- NULL
        for (lib in lib.loc) {
            if(verbose) {
                cat("\nLIBRARY ", lib, "\n",
                    RepC(8), RepC(ch = "=", nchar(lib)), "\n", sep = "")
                np <- 0
            }
            pkgs <- {
                if(is.null(packages))
                    .packages(all.available = TRUE, lib.loc = lib)
                else packages
            }
            for (p in pkgs) {
                if(verbose)
                    cat("", p, if((np <- np + 1)%% 5 == 0) "\n")
                cfile <- system.file("CONTENTS", pkg = p, lib = lib)
                if(cfile != "") {
                    ctext <- scan("", file = cfile, sep = "\n",
                                  quiet = TRUE)
                    if(length(ctext) > 0) {
                        ctext <- parse.dcf(ctext,
                                           fields = c("Entry", "Aliases",
                                           "Description", "Keywords"))
                        nr <- NROW(ctext)
                        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) 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(topic, 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) {
        FILE <- tempfile()
        cat(paste("Objects with ", fields, " matching `", topic,
                  "':\n\n", sep = ""),
            file = FILE)
        dbnam <- paste(db[ , "name"], "(", db[, "pkg"], ")", sep = "")
        dbtit <- paste(db[ , "title"], sep = "")
        cat(paste(format(dbnam), dbtit, sep = "   "),
            sep = "\n", file = FILE, append = TRUE)
        file.show(FILE, delete.file = TRUE)
    } else {
        cat(paste("No objects found with ", fields, " matching `",
                  topic, "'\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" , deparse(substitute(x))),
	      xlim = range(breaks), ylim = range(y, 0),
	      xlab = deparse(substitute(x)), ylab,
	      axes = TRUE, plot = TRUE, labels = FALSE, nclass = NULL, ...)
{
    if (!is.numeric(x))
	stop("hist: x must be numeric")
    main # eval() now: defeat lazy eval
    xlab
    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, eps.corr = 2)
	nB <- length(breaks)
	if(nB <= 1) { ##-- Impossible !
	    stop(paste("hist.default: pretty() error, breaks=",format(breaks)))
	}
    }
    storage.mode(x) <- "double"
    storage.mode(breaks) <- "double"
    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'")
    h <- diff(breaks)
    if (!use.br && any(h <= 0))
	stop("not strictly increasing `breaks'.")
    if (is.null(freq)) {
	freq <- if(!missing(probability))
	    !as.logical(probability)
	else if(use.br) {
	    ##-- Do frequencies if breaks are evenly spaced
	    max(h)-min(h) < 1e-7 * mean(h)
	} else TRUE
    } else if(!missing(probability) && any(probability == freq))
	stop("`probability is an alias for `!freq', however they differ.")
    intensities <- counts/(n*h)
    mids <- 0.5 * (breaks[-1] + breaks[-nB])
    y <- if (freq) counts else intensities
    r <- list(breaks = breaks, counts = counts,
	      intensities = intensities, mids = mids)
    if (plot) {
	plot.new()
	plot.window(xlim, ylim, "") #-> ylim's default from 'y'
	if (missing(ylab))
	    ylab <- paste(if(!freq)"Relative ", "Frequency", sep="")
	if(freq && use.br && max(h)-min(h) > 1e-7 * mean(h))
	    warning("the AREAS in the plot are wrong -- maybe use `freq=FALSE'")
	title(main = main, xlab = xlab, ylab = ylab, ...)
	if(axes) {
	    axis(1, ...)
	    axis(2, ...)
	}
	rect(breaks[-nB], 0, breaks[-1], y,
	     col = col, border = border)
	if(labels)
	    text(mids, y,
		 labels = if(freq) counts else round(intensities,3),
		 adj = c(0.5, -0.5))
	invisible(r)
    }
    else r
}
print.htest <- function(x, digits = 4, quote = TRUE, prefix = "", ...)
{
    cat("\n\t", x$method, "\n\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, ...)
{
    opar <- par(list(...))
    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 = 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, ...)
{
    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 (!add)
	plot(0, 0, xlim = xlim, ylim = ylim, type = "n", xaxs = xaxs,
	     yaxs = yaxs, xlab = xlab, ylab = ylab, ...)
    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)")
    .Internal(image(as.double(x), as.double(y), as.double(z),
		    as.double(zlim), col))
}
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
	if (i == narg) lvs <- l
	else lvs <- 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
}
is.vector <- function(x, mode="any") .Internal(is.vector(x,mode))
## is.finite <- function(x) !is.na(x)
is.symbol <- function(x) typeof(x)=="symbol"
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
    }
}
##---  the argument `make.dimnames'  is  not yet documented
##--- and it doesn't work when TRUE mostly..
##--- (very unclear debugging however ...)  --- Martin Maechler
kronecker <- function (X, Y, FUN = "*", make.dimnames = FALSE, ...)
{
    dX <- dim(X <- as.array(X))
    dY <- dim(Y <- as.array(Y))
    ld <- length(dX) - length(dY)
    ## pad with unit dims if required:
    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 <- seq(along = c(dX, dY))
    ld <- length(dX)
    dp <- as.vector(t(matrix(dp, ncol=2)[, 2:1]))# e.g. = 3 1 4 2
    opobj <- aperm(opobj, dp)
    if(make.dimnames)
        dn <- dimnames(opobj)
    dim(opobj) <- dX * dY
    if(make.dimnames) {
        outerPaste <- function(x,y) {
            if((iNx <- is.null(x)) && (iNy <- is.null(y))) 
                NULL
            else outer(if(iNx) "" else x,
                       if(iNy) "" else y, FUN="paste", sep=":")
        }
        dimnames(opobj) <-
            lapply(0:1, function(i)do.call("outerPaste", dn[i*ld + (1:ld)]))
    }
    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(length(X), function(i) FUN(X[[i]], ...)))
    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"), cex = 1,
              xjust = 0, yjust = 1, x.intersp = 1, y.intersp = 1, adj = 0,
              text.width = NULL, merge = do.lines && has.pch, trace = FALSE)
{
    if(is.list(x)) {
        if(!missing(y)) {               # the 2nd arg maybe really is `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, ...)
    }
    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) cat('  xchar=',formatC(xchar),
		  '; (yextra,ychar)=', format(c(yextra,ychar)),"\n")
    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)
    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
	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.leg * ychar + yc
        w <- text.width + (1.5 + x.intersp) * xchar
        if(!missing(fill))      w <- w + dx.fill
        if(has.pch && !merge)   w <- w + dx.pch
        if(do.lines)		w <- w + (2+x.off) * xchar
        ##-- (w,h) are now the final box width/height.
        left <- x      - xjust  * w
        top  <- y + (1 - yjust) * h
    }
    if (bty != "n")
	rect2(left, top, dx = w, dy = h, col = bg)
    ## (xt[],yt[]) := 'current' vectors of (x/y) legend text
    xt <- rep(left, n.leg) + xchar
    yt <- top - (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 (has.pch) {                      #- draw points -------------------
	pch <- rep(pch, length.out=n.leg)
	ok <- is.character(pch) | pch >= 0
	x1 <- (xt + ifelse(merge, 0.2, 0) * xchar)[ok]
	y1 <- yt[ok]
	if(trace)
	    cat("  points2(", x1,",", y1,", pch=", pch[ok],"...)\n")
	points2(x1, y1, pch=pch[ok], col=col[ok], cex=cex)
	if (!merge) xt <- xt + dx.pch
    }
    if (do.lines) {                     #- draw lines ---------------------
	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)
	    cat("  segments2(",xt[ok.l] + x.off*xchar ,",", yt[ok.l],
		",dx=",2*xchar,", dy=0, ...)\n")
	segments2(xt[ok.l] + x.off*xchar, yt[ok.l], dx= 2*xchar, dy=0,
		  lty = lty[ok.l], lwd = lwd[ok.l], col = col[ok.l])
	## if (!merge)
        xt <- xt + (2+x.off) * xchar
    }
    xt <- xt + x.intersp * xchar
    text2(xt, yt, labels= legend, adj= adj, cex= cex)
    invisible(list(w=w,h=h,xt=xt,yt=yt))
}
##-- Keep  'library' and 'library.dynam'  PLATFORM-Independent !
##-- Use  .Platform  (== Platform() from config.h ) to configure!
##	  ~~~~~~~~~
library <-
  function (package, help, lib.loc = .lib.loc, character.only = FALSE,
	    logical.return = FALSE, warn.conflicts = package != "MASS")
{
    if (!missing(package)) {
	if (!character.only)
	    package <- as.character(substitute(package))
	pkgname <- paste("package", package, sep = ":")
	if (is.na(match(pkgname, search()))) {
	    packagedir <- system.file("", pkg = package, lib = lib.loc)
	    if (packagedir == "") {
		txt <- paste("There is no package called `",
			     package, "'", sep = "")
		if (logical.return) {
		    warning(txt)
		    return(FALSE)
		}
		else stop(txt)
	    }
            lib.loc <- unique(lib.loc)
	    which.lib.loc <-
		lib.loc[match(packagedir[1], file.path(lib.loc, package))]
	    if (length(packagedir) > 1) {
		warning(paste("Package `", package,
                              "' found more than once,\n  ",
			      "using the one found in `", which.lib.loc,
			      "'", sep = ""))
	    }
	    file <- system.file("R", package, pkg = package, lib = lib.loc)
	    ## allowed zipped R source files
	    if (file == "") {
		tfile <- file.path(which.lib.loc, package, "R", package)
		zfile <- zip.file.extract(tfile)
		if (zfile != tfile) {
		    file <- zfile
		    on.exit(unlink(file))
		}
	    }
	    # create environment
	    env <- attach(NULL, name = pkgname)
            lastbit<- file.path("", "R", package)
            path <- gsub(paste(lastbit, "$", sep=""), "", file)
            attr(env, "path") <- path
	    # "source" file into env
	    if (file == "")
		warning(paste("Package `", package, "' contains no R code",
			      sep = ""))
	    else sys.source(file, env)
	    .Internal(lib.fixup(env, .GlobalEnv))
	    if(exists(".First.lib", envir = env, inherits = FALSE)) {
		firstlib <- get(".First.lib", envir = env, inherits = FALSE)
		firstlib(which.lib.loc, package)
	    }
            if(!is.null(firstlib <- getOption(".First")[[package]]))
                firstlib(which.lib.loc, package)
	    if (warn.conflicts &&
		!exists(".conflicts.OK",  envir = env, inherits = FALSE)) {
		##-- Check for conflicts
		dont.mind <- c("last.dump", "last.warning", ".Last.value",
			       ".Random.seed")
		## Currently, package is ALWAYS at "pos=2"
		lib.pos <- 2
		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 \"", pkgname,
				"\":\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")
		    }
		}
	    }
	}
	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
	file <- system.file("INDEX", pkg=help, lib=lib.loc)
	if (file == "")
	    stop(paste("No documentation for package `", help, "'", sep = ""))
        if(length(file) > 1) {
	    which.lib.loc <-
                lib.loc[match(system.file("", pkg = help, lib =
                                          lib.loc)[1],
                              file.path(lib.loc, help))]
            warning(paste("Package `", help, "' found more than once,\n  ", 
                          "using the one found in `", which.lib.loc, 
                          "'", sep = ""))
        }
	file.show(file[1], title = paste("Contents of package", help))
    }
    else {
	## library():
	libfil <- tempfile("R.")
	avail <- NULL
	for (lib in lib.loc) {
	    cat("\nPackages in library `", lib, "':\n\n", sep = "",
		file = libfil, append = TRUE)
	    if (file.exists(libind <- file.path(lib, "LibIndex")))
	    {
		file.append(libfil, libind)
		## This gives warnings and partly garbage,
		## since contrib's LibIndex isn't really "clean":
		## scan(libind, what=list("",""), sep="\t",
		a <- NULL
	    }
	    else {
		a <- .packages(all.available = TRUE, lib.loc = lib)
		for (i in sort(a)) {
		    title <- system.file("TITLE", pkg=i, lib=lib)
		    if (title != "")
			file.append(libfil, title)
		    else cat(i, "\n", file = libfil, append = TRUE)
		}
	    }
	    avail <- c(avail, a)
	}
	file.show(libfil, 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))) {
    file <- system.file(file.path("libs", paste(chname, file.ext,
			      sep = "")), pkg = package, lib = lib.loc)
    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) {
    package <- as.character(substitute(package)) # allowing "require(eda)"
    if (!exists(".Provided", inherits = TRUE))
	assign(".Provided", character(0), envir = .GlobalEnv)
    if (is.na(match(paste("package", package, sep = ":"), search()))
	&& is.na(match(package, .Provided))) {
	if (!quietly)
	    cat("Loading required package:", package, "\n")
	library(package, char = TRUE, logical = TRUE,
		warn.conflicts = warn.conflicts )
    }
    else
	TRUE
}
provide <- function(package) {
    if (!exists(".Provided", inherits = TRUE))
	assign(".Provided", character(0), envir = .GlobalEnv)
    if (missing(package))
	.Provided
    else {
	package <- as.character(substitute(package))
	if (is.na(match(package, .packages())) &&
	    is.na(match(package, .Provided))) {
	    assign(".Provided", c(package, .Provided), envir = .GlobalEnv)
	    TRUE
	}
	else
	    FALSE
    }
}
.packages <- function(all.available = FALSE, lib.loc = .lib.loc) {
    if(all.available) {
	a <- list.files(lib.loc[file.exists(lib.loc)], all.files =
			FALSE, full.names = FALSE)
	ans <- character(0)
	for (nam in a) {
	    pkg <- system.file(file.path("R", nam), pkg = nam, lib =
			       lib.loc)
	    if (pkg != "") ans <- c(ans,nam)
	}
	return(ans)
    } ## else
    s <- search()
    return(invisible(substring(s[substr(s, 1, 8) == "package:"], 9)))
}
.path.package <- function(package = .packages())
{
    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))) {
        miss <- paste(package[m], collapse=", ")
        if(all(m)) error(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)
}
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("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("``Share and Enjoy.''\n\n")
}
lines <- function(x, ...) UseMethod("lines")
lines.default <- function(x, y=NULL, type="l", col=par("col"), ...) {
    plot.xy(xy.coords(x, y), type=type, col=col, ...)
}
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)
    mf <- cl <- match.call()
    mf$singular.ok <- mf$model <- mf$method <- NULL
    mf$x <- mf$y <- mf$qr <- mf$contrasts <- NULL
    mf$drop.unused.levels <- TRUE
    mf[[1]] <- as.name("model.frame")
    mf <- eval(mf, sys.frame(sys.parent()))
    if (method == "model.frame")
	return(mf)
    else if (method != "qr")
	warning(paste("method =", method,
		      "is not supported. Using \"qr\"."))
    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 (length(list(...)))
	warning(paste("Extra arguments", deparse(substitute(...)),
		      "are just disregarded."))
    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")
    }
    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 <- function (x, y, offset = NULL, method = "qr", tol = 1e-07, ...)
{
    if (is.null(n <- nrow(x))) stop("'x' must be a matrix")
    if (is.null(offset)) offset <- rep(0, NROW(y))
    p <- ncol(x)
    if (p == 0) {
        ## oops, null model
        cc <- match.call()
        cc[[1]] <- as.name("lm.fit.null")
        return(eval(cc, sys.frame(sys.parent())))
    }
    ny <- NCOL(y)
    ## treat one-col matrix as vector
    if ( is.matrix(y) && ny == 1 ) y <- drop(y)
    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)
    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
    c(z[c("coefficients", "residuals", "effects", "rank")],
      list(fitted.values= y + offset - z$residuals, 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")
    ny <- NCOL(y)
    if (is.null(offset)) offset <- rep(0, NROW(y))
    ## treat one-col matrix as vector
    if ( is.matrix(y) && ny == 1 ) y <- drop(y)
    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."))
    y <- y - offset
    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, sys.frame(sys.parent())))
    }
    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)
    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 + offset[ok,]
	    save.f[nok, ] <- f0 + offset[nok,]
	}
	else {
	    save.r[ok] <- z$residuals
	    save.r[nok] <- y0 - f0
	    save.f[ok] <- z$fitted.values + offset[ok]
	    save.f[nok] <- f0 + offset[nok]
	}
	z$residuals <- save.r
	z$fitted.values <- save.f
	z$weights <- save.w
    } else
        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
    r <- resid(z)
    f <- fitted(z)
    w <- weights(z)
    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], "degrees of freedom,\tp-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)
}
## Commented by KH on 1998/07/10
## update.default() should be more general now ...
## update.lm <- function(lm.obj, formula, data, weights, subset, na.action)
## .....
residuals.lm <- function(object,
                         type = c("working", "pearson", "deviance"), ...)
{
    type <- match.arg(type)
    r <- .Alias(object$residuals)
    switch(type,
           working = r,
           deviance=,
           pearson =if(is.null(object$weights)) r else r * sqrt(object$weights))
}
fitted.lm <- function(object, ...) object$fitted.values
coef.lm <- function(object, ...) object$coefficients
## need this for results of lm.fit() in drop1():
weights.default <- function(object, ...) 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, ...) 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")
	    eval(fcall, sys.frame(sys.parent()))
	}
	else formula$model
    }
variable.names.lm <- function(obj, full=FALSE)
{
    if(full)	dimnames(obj$qr$qr)[[2]]
    else	dimnames(obj$qr$qr)[[2]][1:obj$rank]
}
case.names.lm <- function(obj, full=FALSE)
{
    w <- weights(obj)
    dn <- .Alias(names(obj$residuals))
    if(full || is.null(w)) dn else dn[w!=0]
}
anova.lm <- function(object, ...)
{
    if(length(list(object, ...)) > 1)
	return(anovalist.lm(object, ...))
    w <- weights(object)
    ssr <- sum(if(is.null(w)) resid(object)^2 else w*resid(object)^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"
}
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"
}
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, ...)
{
    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)
    }
    if(missing(newdata)) {
        X <- model.matrix(object)
        offset <- object$offset
        tt<-terms(object)
    }
    else {
        tt <- terms(object)
	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]
    est <- object$coefficients[piv]
    predictor <- drop(X[, piv, drop = FALSE] %*% est)
    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 <- resid(object)
	    f <- fitted(object)
	    w <- weights(object)
	    rss <- sum(if(is.null(w)) r^2 else r^2 * w)
	    df <- n - p
	    res.var <- rss/df
	} else {
	    res.var <- scale^2
	}
	R <- chol2inv(object$qr$qr[p1, p1, drop = FALSE])
	vcov <- res.var * R
        if (type != "terms"){
            ip <- real(NROW(X))
	    for (i in (1:NROW(X))) {
	       xi <- X[i, piv]
	       ip[i] <- xi %*% vcov %*% xi
            }
	}
    }
    if (type=="terms"){
      asgn <- attrassign(object)
      beta<-coef(object)
      hasintercept<-attr(tt,"intercept")>0
      if (hasintercept)
        asgn$"(Intercept)"<-NULL
      nterms<-length(asgn)
      predictor<-matrix(ncol=nterms,nrow=NROW(X))
      dimnames(predictor)<-list(rownames(X),names(asgn))
      if (se.fit){
        ip<-matrix(ncol=nterms,nrow=NROW(X))
        dimnames(ip)<-list(rownames(X),names(asgn))
      }
      for (i in seq(1,nterms,length=nterms)){
        if (hasintercept)
          i0<-1
        else
          i0<-NULL
        ii<-piv[asgn[[i]]]
        predictor[,i]<-X[,ii,drop=F]%*%(beta[ii])
        X[,ii]<-X[,ii]-mean(X[,ii])
        if (se.fit){
          vci<-R[ii,ii]*res.var
          for(j in (1:NROW(X))){
            xi<-X[j,ii,drop=F]*(beta[ii])
            ip[j,i]<-sum(xi%*% vci %*%t(xi))
          }
        }
      }
      if (!is.null(terms)){
        predictor<-predictor[,terms,drop=F]
        if (se.fit)
          ip<-ip[,terms,drop=F]
      }
      attr(predictor, 'constant') <- if (hasintercept) coef(object)["(Intercept)"] else 0
    }
    if(interval != "none") {
	tfrac <- qt((1 - level)/2,df)
	w <- tfrac * switch(interval,
			    confidence=sqrt(ip),
			    prediction=sqrt(ip+res.var)
			    )
	predictor <- cbind(predictor, predictor + w %o% c(1,-1))
	colnames(predictor) <- c("fit","lwr","upr")
    }
    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(anovalist.lm(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 = sys.frame(sys.parent()))
    .Internal(load(file,envir))
save <- function(..., list = character(0), file = "",
                 ascii = FALSE, oldstyle = FALSE)
{
    names <- as.character( substitute( list(...)))[-1]
    list<- c(list, names)
    invisible(.Internal(save(list, file, ascii, oldstyle)))
}
save.image <- function (file = ".RData", oldstyle = FALSE)
    eval(substitute(save(list = ls(all.names = TRUE), file = file,
                         oldstyle = oldstyle)),
         .GlobalEnv)
###-- 'msg' interface should be device dependent... -> "next" version
locator <- function(n=512, msg = "Click left to locate points;  right to end")
{
    do.msg <- is.character(msg) && nchar(msg) > 0
    if(do.msg) cat(msg,": ",sep="")
    z <- .Internal(locator(n))# n <= 0 gives error
    if(do.msg) cat("\n")
    x <- z[[1]]
    y <- z[[2]]
    if((n <- z[[3]]) > 0) list(x=x[1:n], y=y[1:n])
}
locator <- function(n=512, type="n")
{
    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)
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(y, center, constant = 1.4826, na.rm = FALSE) {
    if(na.rm)
	y <- y[!is.na(y)]
    if(missing(center))
	constant * (median(abs(y - median(y))))
    else constant * (median(abs(y - 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
}
match <- function(x, table, nomatch=NA)
    .Internal(match(as.character(x), as.character(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, lty=1:5, lwd = 1, pch=NULL, col=1:6, ...)
    matplot(x=x, y=y, type = 'p', lty=lty, lwd=lwd, pch=pch, col=col,
            add=TRUE, ...)
matlines  <- function(x, y, lty=1:5, lwd = 1, pch=NULL, col=1:6, ...)
    matplot(x=x, y=y, type = 'l', 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"))
{
    types <- c("p", "l", "b", "o", "h", "n")
    paste.ch <- function(chv) paste('"',chv,'"', sep="", collapse=" ")
    str2vec <- function(string)
	if((nch <- nchar(string))>1) substr(rep(string[1], nch), 1:nch, 1:nch)
	else string
    ##--- These are 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)
    do.points <- any(type=='p') || any(type=='o')
    if(do.points) {
	if(is.null(pch)) pch <- c(paste(c(1:9,0)),letters)[1:k]
	else if(is.character(pch)) pch <- str2vec(pch)
    }
    if(verbose)
	cat("matplot: doing ", k, " plots with ",
	    paste(" col= (", paste.ch(col), ")", sep=''),
	    if(do.points) 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) {
	tp <- type[i]
	if(tp=='l' || tp=='b'|| tp=='o'|| tp=='h')
	    lines(x[,i],y[,i], type=tp,
                  lty=lty[i], lwd=lwd[i],pch=pch[i],col=col[i], cex=cex[i])
	if(do.points && tp=='p')
	    points(x[,i],y[,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)||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)
    dimnames(x) <- list(value, if(!is.null(dn)) dn[[2]])
    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)
    dimnames(x) <- list(if(!is.null(dn)) dn[[1]], value)
    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"
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) {
	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(na.rm)
	x <- x[!is.na(x)]
    else if(any(is.na(x)))
	return(NA)
    n <- length(x)
    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, sort = TRUE)
{
    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(!all(0 <= 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)
    }
    x <- as.data.frame(x); y <- as.data.frame(y)
    if (nrow(x) == 0 || nrow(y) == 0)
        stop("no rows to match")
    by.x <- fix.by(by.x, x); by.y <- fix.by(by.y, y)
    if(length(by.x) && 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
    }
    if(length(by.x) == 0) stop("no columns to match on")
    if(length(by.x) != length(by.y))
        stop("by.x and by.y specify different numbers of columns")
    row.names(x) <- 1:nrow(x)
    row.names(y) <- 1:nrow(y)
    ## create keys from by cols.
    bx <- matrix(as.character(as.matrix.data.frame(x[, by.x, drop=FALSE])),
                 nrow(x))
    bx <- drop(apply(bx, 1, function(x) paste(x, collapse="\r")))
    by <- matrix(as.character(as.matrix.data.frame(y[, by.y, drop=FALSE])),
                 nrow(y))
    by <- drop(apply(by, 1, function(x) paste(x, collapse="\r")))
    comm <- match(bx, by, 0)
    bxy <- bx[comm > 0]
    xinds <- match(bx, bxy, 0)
    yinds <- match(by, bxy, 0)
    o <- outer(xinds, yinds, function(x, y) (x > 0) & x==y)
    xi <- row(o)[o]
    yi <- col(o)[o]
    nm <- nm.x <- names(x)[-by.x]
    nm.y <- names(y)[-by.y]
    cnm <- match(nm.x, nm.y, 0)
    nm.x[cnm > 0] <- paste(nm.x[cnm > 0], "x", sep=".")
    x <- x[xi, c(by.x, seq(length=ncol(x))[-by.x]), drop=FALSE]
    names(x) <- c(names(x)[seq(along=by.x)], nm.x)
    cnm <- match(nm.y, nm, 0)
    nm.y[cnm > 0] <- paste(nm.y[cnm > 0], "y", sep=".")
    y <- y[yi, -by.y, drop=FALSE]
    names(y) <- nm.y
    res <- cbind(x, y)
    if (sort) res  <- res[sort.list(bx[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)
}
"mode<-" <- function(x, value)
{
    mde <- paste("as.",value,sep="")
    atr <- attributes(x)
    x <- eval(call(mde,x), sys.frame(sys.parent()))
    attributes(x) <- atr
    if(value == "single") attr(x, "Csingle") <- TRUE
    else attr(x, "Csingle") <- NULL
    x
}
storage.mode <- function(x) {
    x <- typeof(x)
    if (x == "closure" || x == "builtin" || x == "special") return("function")
    x
}
"storage.mode<-" <- get("mode<-", envir=NULL)
#### 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), sys.frame(sys.parent()))
    }
    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, ...)
{
    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 switch(mode(x),
		NULL = structure(NULL, class = "formula"),
		character = formula(eval(parse(text = x)[[1]])),
		call = eval(x), stop("invalid formula"))
}
formula.formula <- function(x, ...) x
formula.terms <- function(x, ...) {
    attributes(x) <- list(class="formula")
    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 = "~"))
    eval(ff)
}
print.formula <- function(x, ...) print.default(unclass(x), ...)
"[.formula" <- function(x,i) {
    ans <- NextMethod("[")
    if(as.character(ans[[1]]) == "~")
	class(ans) <- "formula"
    ans
}
terms <- function(x, ...) UseMethod("terms")
terms.default <- function(x, ...) x$terms
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="")
	eval(parse(text=termtext)[[1]])
    } else {
	termtext <- paste("response", "~", termtext, collapse="")
	termobj <- eval(parse(text=termtext)[[1]])
	termobj[[2]] <- response
	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)
	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 deparse(form[[2]])
	rhs <- if(length(tmp)) paste(tmp, collapse = " + ") else "1"
	if(!attr(terms(object), "intercept")) rhs <- paste(rhs, "- 1")
	formula(paste(lhs, "~", rhs))
    }
    if (!is.null(data) && !is.environment(data) && !is.data.frame(data))
	data <- as.data.frame(data)
    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)
    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
    terms
}
coef <- function(object, ...) UseMethod("coef")
coef.default <- function(object, ...) object$coefficients
coefficients <- .Alias(coef)
residuals <- function(object, ...) UseMethod("residuals")
residuals.default <- function(object, ...) 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, ...) 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
## ?
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 data frame");
}
na.omit <- function(object, ...)UseMethod("na.omit")
na.omit.default <- 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 = F]
    if (any(omit)) {
	temp <- seq(omit)[omit]
	names(temp) <- row.names(object)[omit]
	attr(temp, "class") <- "omit"
	attr(xx, "na.action") <- temp
    }
    xx
}
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 <- sys.frame(sys.parent())
    else if (!is.data.frame(data) && !is.environment(data) && !is.null(class(data)))
        data<-as.data.frame(data)
    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, sys.frame(sys.parent()))
    extranames <- as.character(substitute(list(...))[-1])
    extras <- substitute(list(...))
    extras <- eval(extras, data, sys.frame(sys.parent()))
    if(length(extras)) { # remove NULL args
        keep <- !sapply(extras, is.null)
        extras <- extras[keep]
        extranames <- extranames[keep]
    }
    subset <- eval(substitute(subset), data, sys.frame(sys.parent()))
    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 = sys.frame(sys.parent()),
				 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():
mosaicplot.default <- function(X, main = NULL, xlab = NULL, ylab = NULL,
                               sort = NULL, off = NULL,
                               dir = NULL, color = FALSE) {
    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)
        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]),
                                    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), col=color[i])
                        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))
                    } 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]),
                                    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]), col=color[j])
                        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]))
                    } 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))
    ## 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 <- Ind[,c(sort,dimd+1)]
        off <- off[sort]
        dir <- dir[sort]
        label <- label[sort]
    }
    ncolors <- length(tabulate(Ind[,dimd]))
    if (is.null(color) || length(color) != ncolors)
        color <- if (is.null(color) || !color[1])
            rep(0, ncolors) else 2:(ncolors+1)
    ##-- Plotting
    frame()
    opar <- par(usr = c(1, 1000, 1, 1000), mgp = c(1, 1, 0))
    on.exit(par(opar))
    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, sys.frame(sys.parent()))))
        m$data <- as.data.frame(data)
    m$... <- NULL
    m[[1]] <- as.name("model.frame")
    mf <- eval(m, sys.frame(sys.parent()))
    mosaicplot(table(mf), ...)
}
mtext <-
  function (text, side = 3, line = 0, outer = FALSE, at = NA,
            adj = NA, cex = NA, col = NA, font = NA, ...) 
  .Internal(mtext(as.char.or.expr(text), side, line, outer, at, 
                  adj, cex, col, font, ...))
##> ../../../main/plot.c
names <-
    function(x, ...)
    UseMethod("names")
names.default <-
    function(x)
    .Internal(names(x))
"names<-" <-
    function(x, ...)
    UseMethod("names<-")
"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(f, 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
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(x, ...) UseMethod("deriv")
deriv.formula <- function(expr, namevec, function.arg=NULL, tag=".expr") {
    if((le <- length(expr)) > 1)
	.Internal(deriv.default(expr[[le]], namevec, function.arg, tag))
    else stop("invalid formula in deriv")
}
deriv.default <- function(expr, namevec, function.arg=NULL, tag=".expr")
    .Internal(deriv.default(expr, namevec, function.arg, tag))
.NotYetImplemented <- function() {
    stop(paste("`", as.character(sys.call(sys.parent())[[1]]), "' ",
	       "is not implemented yet", sep = ""))
}
.NotYetUsed <- function(x) {
    warning(paste("argument `", x, "' is not used (yet)", sep = ""))
}
## 'objects <- function(....) ...    --->>> ./attach.R
inherits <- function(x, name)
    any(!is.na(match(name,class(x))))
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, ...)
{
    method <- match.arg(method)
    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[names(control)] <- control
    npar <- length(par)
    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"
    }
    lower <- as.double(rep(lower, , npar))
    upper <- as.double(rep(upper, , npar))
    if(is.null(gr))
    res <- .Internal(optim(par, function(par) fn(par, ...), gr,
                           method, con, lower, upper))
    else
    res <- .Internal(optim(par, function(par) fn(par, ...),
                           function(par) gr(par, ...),
                           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, fn, gr, 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 = "*", ...)
{
    FUN <- match.fun(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)
    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)
}
CRAN.packages <- function(CRAN=getOption("CRAN"), method="auto",
                          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)
    }
    parse.dcf(file=tmpf, fields=c("Package", "Version",
                         "Priority", "Bundle", "Depends"),
              versionfix=TRUE)
}
update.packages <- function(lib.loc=.lib.loc, CRAN=getOption("CRAN"),
                            contriburl=contrib.url(CRAN),
                            method="auto", instlib=NULL, ask=TRUE,
                            available=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)
    }
}
old.packages <- function(lib.loc=.lib.loc, CRAN=getOption("CRAN"),
                         contriburl=contrib.url(CRAN),
                         method="auto", 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
    for(k in 1:nrow(instp)){
        ok <- (instp[k, "Priority"] != "base") &
                (available[,"Package"] == instp[k, "Package"])
        ok[ok] <- available[ok, "Version"] > 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", pkg=pkg, lib=lib)
    if(file == ""){
        warning(paste("Cannot find CONTENTS file of package", pkg))
        return(NA)
    }
    contents <- scan("", file=file, sep="\n", quiet=TRUE)
    parse.dcf(contents, fields=c("Entry", "Keywords", "Description"))
}
package.description <- function(pkg, lib=.lib.loc, fields=NULL){
    file <- system.file("DESCRIPTION", pkg=pkg, lib=lib)
    if(file == ""){
        warning(paste("Cannot find DESCRIPTION file of package", pkg))
        if(!is.null(fields)){
            retval <- rep(NA, length(fields))
            names(retval) <- fields
        }
        else
            retval <- NA
        return(retval)
    }
    contents <- scan("", file=file, sep="\n", quiet=TRUE)
    parse.dcf(contents, fields=fields, versionfix=TRUE)
}
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))
        }
    }
    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
            deps[[k]] <- cbind(sub("^([^[:space:]\\(]*).*", "\\1", z),
                               sub(".*\\((.*)\\).*", "\\1", 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"))
            {
                if(!is.na(deps[[k]][ok,2])){
                    comptext <-
                        paste('"', R.version$major, ".",
                              R.version$minor, '" ', 
                              deps[[k]][ok,2], ' "',
                              deps[[k]][ok,3], '"', sep="")
                }
                z[k] <- eval(parse(text=comptext))
            }
        }
        names(z) <- x[,"Package"]
        return(z)
    }
    else{
        names(deps) <- x[,"Package"]
        return(deps)
    }
}
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")
if(FALSE){
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, sys.frame(sys.parent()))))
        m$data <- as.data.frame(data)
    m$... <- NULL
    m[[1]] <- as.name("model.frame")
    mf <- eval(m, sys.frame(sys.parent()))
    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",
           "lab", "las", "lty", "lwd",
           "mai", "mar", "mex", "mfcol", "mfg", "mfrow", "mgp", "mkh",
	   "new", "oma", "omd", "omi", "pch", "pin", "plt", "ps", "pty",
	   "smo", "srt", "tck", "tmag", "type", "usr",
	   "xaxp", "xaxs", "xaxt", "xlog", "xpd",
	   "yaxp", "yaxs", "yaxt", "ylog",
	   ##-- newer ones:
	   "gamma", "tcl"
	   )
.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
}
## we don't use white; it's for compatibility
parse <- function(file="", n=NULL, text=NULL, prompt=NULL, white=FALSE)
    .Internal(parse(file, n, text, prompt))
parse.dcf <- function(text=NULL, file="", fields=NULL, versionfix=FALSE)
{
    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))
                if(is.na(retval[[x]]))
                    retval[[x]] <- y
                else
                    retval[[x]] <- paste(retval[[x]], y, sep="\n")
        }
        retval
    }
    if(missing(text))
        text <- scan(file=file, what="",  sep="\n", quiet=TRUE)
    ## 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 1:(length(start)-1)){
        retval[[k]] <- parse.dcf.entry(text[start[k]:(start[k+1]-1)],
                                               fields=fields,
                                               versionfix=versionfix)
    }
    if(!is.null(fields))
        retval <- t(sapply(retval, unlist))
    else if(length(retval)==1)
        retval <- unlist(retval, recursive=FALSE)
    retval
}
paste <- function (..., sep = " ", collapse=NULL)
{
    args <- list(...)
    if(is.null(args)) ""
    else {
	for (i in 1:length(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 = 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,
    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)) 
        xlabel <- if (!missing(x)) deparse(substitute(x)) else "X"
    else
	xlabel <- xlab
    if (is.null(ylab)) 
        ylabel <- if (!missing(y)) deparse(substitute(y)) else "Y"
    else
	ylabel <- ylab
    if (is.null(zlab)) 
        zlabel <- if (!missing(z)) deparse(substitute(z)) else "Z"
    else
	zlabel <- zlab
    ## 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"))
    .Internal(persp(x, y, z, xlim, ylim, zlim, theta, phi, r, d,
              scale, expand, col, border, ltheta, lphi, shade,
              box, axes, nticks, ticktype, xlabel, ylabel, zlabel, ...))
}
pictex <-
    function(file="Rplots.tex", width=5, height=4, debug = FALSE,
	     bg="white", fg="black")
{
    .Internal(PicTeX(file, bg, fg, width, height, 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]], sys.frame(sys.parent()))
		x <- eval(x[[3]], sys.frame(sys.parent()))
	    }
	    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")
}
plot.function <- function(fn, from=0, to=1, ...) {
    curve(fn, from, to, ...)
}
### 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(.)
        axisnames <- if(length(dargs <- list(...)) > 0) {
            nam <- names(dargs)
            ((any("axes" == nam) && dargs$axes) ||
             (any("xaxt" == nam) && 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")
}
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(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) {
	    opar <- par(ask = ask)
	    on.exit(par(opar))
	}
	xn <- varnames[-response]
	if (is.null(dots[["xlab"]])) {
	    for (i in xn)
                do.call("plot",
                        c(list(mf[[i]], y, ylab = ylab, xlab = i), dots))
	} else {
	    for (i in xn)
                do.call("plot",
                        c(list(mf[[i]], y, ylab = ylab), dots))
        }
        if (length(xn) == 0)
            if (is.null(dots[["xlab"]]))
                do.call("plot",
                        c(list(y, ylab = ylab, xlab = i), dots))
            else
                do.call("plot",
                        c(list(y, ylab = ylab), dots))
    }
    else plot.data.frame(mf)
}
lines.formula <- function(formula, ..., data = parent.frame(), subset)
{
    m <- match.call(expand.dots = FALSE)
    if (is.matrix(eval(m$data, parent.frame())))
	m$data <- as.data.frame(data)
    dots <- m$...
    dots <- lapply(dots, eval, data, parent.frame())
    m$... <- NULL
    m[[1]] <- as.name("model.frame")
    m <- as.call(c(as.list(m), list(na.action = NULL)))
    mf <- eval(m, parent.frame())
    if (!missing(subset)) {
        s <- eval(m$subset, data, parent.frame())
        l <- nrow(data)
        dosub <- function(x) if (length(x) == l) x[s] else x
        dots <- lapply(dots, dosub)
    }
    response <- attr(attr(mf, "terms"), "response")
    if (response) {
	varnames <- names(mf)
	y <- mf[[response]]
	if (length(varnames) > 2)
	    stop("cannot handle more than one x coordinate")
	xn <- varnames[-response]
        if (length(xn) == 0)
            do.call("lines",
                    c(list(y), dots))
        else
            do.call("lines",
                    c(list(mf[[xn]], y), dots))
    }
    else
        stop("must have a response variable")
}
points.formula <- function(formula, ..., data = parent.frame(), subset)
{
    m <- match.call(expand.dots = FALSE)
    if (is.matrix(eval(m$data, parent.frame())))
	m$data <- as.data.frame(data)
    dots <- m$...
    dots <- lapply(dots, eval, data, parent.frame())
    m$... <- NULL
    m[[1]] <- as.name("model.frame")
    m <- as.call(c(as.list(m), list(na.action = NULL)))
    mf <- eval(m, parent.frame())
    if (!missing(subset)) {
        s <- eval(m$subset, data, parent.frame())
        l <- nrow(data)
        dosub <- function(x) if (length(x) == l) x[s] else x
        dots <- lapply(dots, dosub)
    }
    response <- attr(attr(mf, "terms"), "response")
    if (response) {
	varnames <- names(mf)
	y <- mf[[response]]
	if (length(varnames) > 2)
	    stop("cannot handle more than one x coordinate")
	xn <- varnames[-response]
        if (length(xn) == 0)
            do.call("points",
                    c(list(y), dots))
        else
            do.call("points",
                    c(list(mf[[xn]], y), dots))
    }
    else
        stop("must have a response variable")
}
plot.xy <- function(xy, type, pch = 1, lty = "solid", col = par("fg"),
                    bg = NA, cex = 1, ...) {
    .Internal(plot.xy(xy, type, pch, lty, col, bg, cex, ...))
}
plot.new <- function(ask = NA) .Internal(plot.new(ask))
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 = interactive() && one.fig && .Device != "postscript",
		     ...,
		     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:3])) {
        ylab23 <- if(inherits(x, "glm"))
          "Std. deviance resid." else "Standardized residuals"
        hii <- lm.influence(x)$hat
        s <- sqrt(deviance(x)/df.residual(x))
        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)
    }
    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)
	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")
    if (!missing(angle))
	.NotYetUsed("angle")
    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",
			    pointsize = 12,
			    bg = "white",
			    fg = "black",
			    onefile = TRUE,
			    print.it = FALSE,
			    append = FALSE,
                            pagecentre = TRUE)
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
}
postscript <- function (file = "Rplots.ps", ...)
{
    new <- list(...)# eval
    old <- check.options(new = new, name.opt = ".PostScript.Options",
			 reset = FALSE, assign.opt = FALSE)
    .Internal(PS(file, old$paper, old$family, old$bg, old$fg,
		 old$width, old$height, old$horizontal, old$pointsize,
                 old$onefile, old$pagecentre))
}
##--> source in ../../../main/devices.c	 and ../../../main/devPS.c
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)
    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)
                           )
	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 = {
		   fit <- family(object)$linkinv(fit)
		   se.fit <- se.fit * abs(family(object)$mu.eta(fit))
	       },
	       link =, terms=)
	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)) warning("'print.gap' is not yet used")
    ## 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")))])
    r
}
print.noquote <- function(obj,...) {
    if(!is.null(cl <- class(obj)))
	class(obj) <- cl[cl != "noquote"]
    NextMethod("print", obj, 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))
	P.values <- has.Pvalue && getOption("show.coef.Pvalues")
    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) {
	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)
    if(length(i <- which(substr(cn,2,7) == " value")))
	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)
}
profile <-
  function(fitted, which, maxpts, ...)
  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(as.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)
	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")
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 <- substitute(object)
    if(is.language(name) && !is.name(name)) name <- eval(name)
    name <- as.character(name)
    fn <- get(name)
    ## `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 <- 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{ ~keyword }%-- one or more ..."
		  )
    } else {#-- not function --
	file <- c(file,"\\non_function{}",
		  paste("\\title{ ~~data-name / kind ...  }"),
		  "\\description{",
		  "~~ a precise description of what the object does. ~~",
		  "}")
    }
    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,\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 ~~ }", 
              "\\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 ~~",
              "}",
              "\\examples{",
              "##---- Should be DIRECTLY executable !! ----",
              paste0("data(", 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,\n", 
        paste(RHOME, "src/library/<pkg>/man/", sep = "/"), "\n")
    invisible(file)
}
qqnorm <-
    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))
}
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)
qr <- function(x, tol= 1e-07)
{
    x <- as.matrix(x)
    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 (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")
    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")
    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)$qty
}
qr.resid <- function(qr, y)
{
    if(!is.qr(qr)) stop("argument is not a QR decomposition")
    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")
    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
    }
    qr.qy(qr, R)
}
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(probs < 0 | probs > 1))
	stop("probs outside [0,1]")
    n <- length(x)
    np <- length(probs)
    if(np == 0) return(numeric(0))
    if(n > 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]
	qs[i] <- qs[i] + (x[hi[i]] - x[lo[i]]) * (index[i] - lo[i])
    } else {
	qs <- rep(as.numeric(NA), np)
    }
    if(names) {
	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 = "")
    }
    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
}
"httpclient" <-
    function (url, port = 80, error.is.fatal = TRUE, check.MIME.type = TRUE, 
              file = tempfile(), drop.ctrl.z = TRUE) 
{
    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 = T), ":")[[1]][2])))) == 0) {
        if (error.is.fatal) 
            stop(grep("Content-Type:", b, value = T))
        else warning(grep("Content-Type:", b, value = T))
        return(file)
    }
    len <- as.numeric(strsplit(grep("Content-Length", b, value = T), 
                               ":")[[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("\026", "", data, extended = FALSE)
    cat(data, file = file)
    return(file)
}
"read.table.url" <-
    function (url, method="auto", ...) 
{
    f<-tempfile()
    if (download.file(url, destfile=f,method=method)==0)
        data <- read.table(f, ...)
    else {
        unlink(f)
        stop("transfer failure")
    }
    return(data)
}
"scan.url" <-
    function (url, file=tempfile(),method="auto", ...) 
{
    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(),...) 
{
    if (download.file(url,dest=file)!=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)
}
"url.show" <-
    function (url,  title = url, 
              delete.file = TRUE, file = tempfile(), method="auto",...) 
{
    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)
    .Internal(count.fields(file, sep, quote, skip))
read.table <-
    function (file, header=FALSE, sep="", quote="\"\'", dec=".",
              row.names, col.names, as.is=FALSE,
	      na.strings="NA", skip=0)
{
    type.convert <- function(x, na.strings = "NA",
                             as.is = FALSE, dec = ".")
	.Internal(type.convert(x, na.strings, as.is, dec))
    ##	basic column counting and header determination;
    ##	rlabp (logical) := it looks like we have column names
    row.lens <- count.fields(file, sep, quote, skip)
    nlines <- length(row.lens)
    rlabp <- nlines > 1 && (row.lens[2] - row.lens[1]) == 1
    if(rlabp && missing(header))
	header <- TRUE
    if (header) { # read in the header
	col.names <- scan(file, what="", sep=sep, quote=quote, nlines=1,
			  quiet=TRUE, skip=skip)
	skip <- skip + 1
	row.lens <- row.lens[-1]
	nlines <- nlines - 1
    } else if (missing(col.names))
	col.names <- paste("V", 1:row.lens[1], sep="")
    ##	check that all rows have equal lengths
    cols <- unique(row.lens)
    if (length(cols) != 1) {
	cat("\nrow.lens=\n"); print(row.lens)
	stop("all rows must have the same length.")
    }
    ##	set up for the scan of the file.
    ##	we read all values as character strings and convert later.
    what <- rep(list(""), cols)
    if (rlabp)
	col.names <- c("row.names", col.names)
    names(what) <- col.names
    data <- scan(file=file, what=what, sep=sep, quote=quote, skip=skip,
		 na.strings=na.strings, quiet=TRUE)
    ##	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(1:nlines)
    } else if (is.null(row.names)) {
	row.names <- as.character(1: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=".",
              row.names, col.names, as.is=FALSE, na.strings="", skip=0)
    read.table(file, header, sep, quote, dec, row.names, col.names,
               as.is, na.strings, skip)
read.csv2 <-
    function (file, header = TRUE, sep = ";", quote="\"", dec=",",
              row.names, col.names, as.is=FALSE, na.strings="", skip=0)
    read.table(file, header, sep, quote, dec, row.names, col.names,
               as.is, na.strings, skip)
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))
    i <- c(which(x[-1] != x[-length(x)]), 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<-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 <- 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) {
    x <- as.vector(x)
    ok <- is.finite(x)
    x <- x[ok]
    oldtick <- par(tck = ticksize)
    on.exit(par(oldtick))
    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, 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) {
		nas <- is.na(v)
		if(any(is.na(nas)))
		    v <- v[!is.na(nas)]
		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="", 
             dec=".", skip=0, nlines=0, 
	     na.strings="NA", flush=FALSE, strip.white=FALSE, quiet=FALSE) {
	if(!missing(sep) && missing(na.strings))
	    na.strings <- c(na.strings,"")
	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.")
	}
	.Internal(scan(file, what, nmax, sep, dec, quote, skip, nlines,
		       na.strings,flush,strip.white, quiet))
    }
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) frame()
	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.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
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)
    }
    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)
    }
    ## pre 0.63.3: b <- as.matrix(b)
    return(qr.coef(a,b))
}
solve <- function(a, b, ...) UseMethod("solve")
solve.default <- .Alias(qr.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))
	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)
	stop("order(..., na.last != TRUE) does not yet work in R.")
    .Internal(order(...))
}
sort.list <- function(x, partial = NULL, na.last = TRUE)
{
     if(!is.logical(na.last) || !na.last)
	stop("sort(x, na.last != TRUE) does not yet work in R.")
    .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)
	sys.frame(sys.parent())
    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)
{
    if(!(is.character(file) && file.exists(file)))
	stop(paste('"',file,'" is not an existing file', sep=""))
    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, envir)
    }
    invisible()
}
demo <- function(topic, device = getOption("device")) {
    if (is.character(device)) device <- get(device)
    Topics <-cbind(graphics	= c("graphics", "graphics.R",	"G"),
		   image	= c("graphics", "image.R",	"G"),
		   lm.glm	= c("models",	"lm+glm.R",	"G"),
		   glm.vr	= c("models",	"glm-v+r.R",	""),
		   nlm		= c("nlm",	"valley.R",	""),
		   recursion	= c("language", "recursion.R",	"G"),
		   scoping	= c("language", "scoping.R",	""),
		   is.things	= c("language", "is-things.R",	""),
		   dyn.load	= c("dynload",	"zero.R",	"")
		   )
    dimnames(Topics)[[1]] <- c("dir", "file", "flag")
    topic.names <- dimnames(Topics)[[2]]
    demo.help <- function() {
	cat("Use `demo(topic)' where choices for argument `topic' are:\n")
	cbind(topics = topic.names)
    }
    if(missing(topic)) return(demo.help())
    topic <- substitute(topic)
    if (!is.character(topic)) topic <- deparse(topic)[1]
    i.top <- pmatch(topic, topic.names)
    if (is.na(i.top) || i.top == 0) {
	cat("unimplemented `topic' in demo.\n")
	print(demo.help())
	stop()
    } else {
	topic <- topic.names[i.top]
	cat("\n\n\tdemo(",topic,")\n\t---- ",rep("~",nchar(topic)),
	    "\n\nType  <Return>	 to start : ",sep="")
	readline()
	if(dev.cur()<=1 && Topics["flag",i.top] == "G")
	    device()
	source(file.path(R.home(),
		     "demos",
		     Topics["dir",  i.top],
		     Topics["file", i.top]),
	       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 <-
            if(missing(lib.loc)) .path.package(package)
            else system.file(pkg = package, lib = lib.loc)
    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) {
    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.stat.rice.edu/~andrewsd/software/software.html.
"stars" <-
function(x, full = TRUE, scale = TRUE, radius = TRUE,
	 labels = dimnames(x)[[1]], locations = NULL, xlimit = NULL,
	 ylimit = NULL, len = 1, colors = NULL, key.loc = NULL,
	 key.labels = NULL, draw.segments = FALSE, draw.axes = FALSE, ...) {
    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
	mat.dim <- ceiling(sqrt(n.loc))
	temp.loc.1 <- rep(x=2.1* 1:mat.dim, times=mat.dim, length=n.loc)
	temp.loc.2 <- rep(x=2.1* mat.dim:1,
			  rep(x=mat.dim, times=mat.dim), length=n.loc)
	loc <- matrix(data=c(temp.loc.1,temp.loc.2),ncol=2)
    }
    else {
	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="/")
    x <- x * len
    temp.xlim <-
	if(is.null(xlimit))
	    range(loc[,1] + max(x), loc[,1] - max(x)) else xlimit
    temp.ylim <-
	if(is.null(ylimit))
	    range(loc[,2] + max(x), loc[,2] - max(x)) else ylimit
    opar <- par(no.readonly = TRUE)
    on.exit(par(opar))
    ## The asp argument keeps everything square
    plot(0, type="n", ..., xlim=temp.xlim, ylim=temp.ylim,
	 xlab="", ylab="", asp = 1, axes = draw.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.coord <- x[i,] * cos( angles ) + loc[i,1]
	    start.y.coord <- x[i,] * sin( angles ) + loc[i,2]
	    for (j in 1:n.seg) {
		poly.x <- c(poly.x,loc[i,1],start.x.coord[j])
		poly.y <- c(poly.y,loc[i,2],start.y.coord[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)
	    }
	    par(lwd=0.25)
	    polygon(poly.x, poly.y, col = seg.colors)
	    par(lwd=1)
	    if (!is.null(labels))
		text(loc[i,1], loc[i,2] - if(full)max(x) else 0.1 * max(x),
		     labels[i], cex=0.5, adj=c(0.5,1))
	}
    } # Segment diagrams are drawn
    else { # Draw stars instead
	for ( i in 1:n.loc ) {
	    temp.x.coord <- x[i,] * cos( angles ) + loc[i,1]
	    temp.y.coord <- x[i,] * sin( angles ) + loc[i,2]
	    if ( radius ) {
		par(lwd=0.25)
		segments(rep(loc[i,1],n.seg),
			 rep(loc[i,2],n.seg),
			 temp.x.coord, temp.y.coord)
		par(lwd=1)
	    }
	    lines(c(temp.x.coord, temp.x.coord[1]),
		  c(temp.y.coord, temp.y.coord[1]), lwd=0.25)
	    if (!is.null(labels))
		text(loc[i,1], loc[i,2] - if(full)max(x) else 0.1 * max(x),
		     labels[i], cex=0.5, adj=c(0.5,1))
	}
    }
    if ( ! is.null(key.loc) ) {		# Draw unit key
	if ( draw.segments ) {
	    key.x <- NA
	    key.y <- NA
	    key.x.coord <- cos( angles ) * len + key.loc[1]
	    key.y.coord <- sin( angles ) * len + key.loc[2]
	    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)
	    }
	    par(lwd=0.25)
	    polygon(key.x, key.y, col = seg.colors)
	    par(lwd=1)
	}
	else { # draw a star
	    temp.x.coord <- cos( angles ) * len + key.loc[1]
	    temp.y.coord <- sin( angles ) * len + key.loc[2]
	    par(lwd=0.25)
	    if ( radius )
		segments(rep(key.loc[1],n.seg), rep(key.loc[2],n.seg),
			 temp.x.coord, temp.y.coord)
	    lines(c(temp.x.coord, temp.x.coord[1]),
		  c(temp.y.coord, temp.y.coord[1]))
	    par(lwd=1)
	}
	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.coord <- cos( lab.angl ) * len * 1.1 + key.loc[1]
	label.y.coord <- sin( lab.angl ) * len * 1.1 + key.loc[2]
	for (k in 1:n.seg) {
	    text.adj <-
		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
	    if (lab.angl[k] <= (90 * deg))
		text.adj <-
		    c(text.adj, 0.5 * (1 - lab.angl[k] / (90 * deg)))
	    else if (lab.angl[k] > (90 * deg) & lab.angl[k] <= (270 * deg))
		text.adj <-
		    c(text.adj, (lab.angl[k] - (90 * deg)) / (180 * deg))
	    else if (lab.angl[k] > (270 * deg))
		text.adj <-
		    c(text.adj, 1 - (0.5 * (lab.angl[k] - (270 * deg)) /
				     (90 * deg)))
	    text.default(x=label.x.coord[k], y=label.y.coord[k],
			 labels= key.labels[k], cex = 0.5, 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)
}
####------ 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.14 2000/01/31 10:01:52 hornik 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",":\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,
			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.14 2000/01/31 10:01:52 hornik 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 ""
    ## 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); dp[-length(dp)] },"\n")
    } else if (is.null(object))
	cat(" NULL\n")
    else if(is.list(object)) {
	i.pl <- is.pairlist(object)
	if(le == 0) { cat(" ", if(i.pl)"pair", "list()\n",sep="")
		      return(invisible()) }
	is.d.f <- is.data.frame(object)
	if(is.d.f ||
	   (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,".."),
		    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 = "")
	    vec.len <- switch(t.cl,rts=.8, cts=.6, its=.9) * vec.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) {
	    ## str1 <- paste("Class '",cl,"' of length ", le, " :", sep="")
	    ##===== NB. cl may be of length > 1 !!! ===========
	    cat("Class ", cl, " ", sep="'")
	    ## has.method <- exists( paste("str", cl, sep=".") )
	    ##== If there is a str.METHOD,
	    ##== it should have been called BEFORE this !
	    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,
		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 elseif elseif .. --------------------------
	##-- 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
		vec.len <- round(.5 * vec.len)
	    } else if (mod == "expression") {
		format.fun <- function(x) deparse(as.expression(x))
		vec.len <- round(.75 * vec.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)) {
	    vec.len <- 3 * vec.len
	    format.fun <- format
	} else if(is.numeric(object)) {
	    ivec.len <- round(2.5 * vec.len)
	    if(!is.integer(object)){
		ob <- if(le > ivec.len) object[1:ivec.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)))) {
		vec.len <- ivec.len
		format.fun <- function(x)x
	    } else {
		vec.len <- round(1.25 * vec.len)
		format.fun <- format
	    }
	} else if(is.complex(object)) {
	    vec.len <- round(.75 * vec.len)
	    format.fun <- format
	}
	if(char.like) {
	    bracket <- if (le>0) '"' else ""
	    format.fun <- function(x)x
	    vec.len <- sum(cumsum(3 + if(le>0) nchar(object) else 0) <
			   wid - (4 + 5*nest.lev + nchar(str1)))
				##    5*nest  is 'arbitrary'
	} 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}
	vec.len <- max(1,round(vec.len))
	cat(str1, " ", bracket,
	    paste(format.fun(if(le>1) object[1:min(vec.len, le)] else object),
		  collapse = paste(bracket, " ", bracket, sep="")),
	    bracket, if(le > vec.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, vec.len= vec.len, digits.d= digits.d,
		    give.attr= give.attr, give.length = give.length, wid = wid)
	    }
    }
    invisible()	 ## invisible(object)#-- is SLOOOOW on large objects
} #-- end of function 'str.default' --
ls.str <- function(..., mode = "any", max.level = 1, give.attr = FALSE)
{
    ##--- An extended "ls()" using  str(.) --
    for(name in ls(..., envir = sys.frame(sys.parent())))
	if(exists(name, mode = mode)) {
	    cat(name, ": ")
	    str(get(name, mode = mode), max.level = max.level,
		give.attr = give.attr)
	}
    invisible()
}
lsf.str <- function(...)
{
    ##--- An extended "ls()" -- find ONLY functions -- using  str(.) --
    r <- character(0)
    for(name in ls(..., envir = sys.frame(sys.parent())))
	if(is.function(get(name))) {
	    cat(name, ": ")
	    r <- c(r,name)
	    str(get(name))
	}
    invisible(r)
}
## Dotplots a la Box, Hunter and Hunter
stripplot <- 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]], sys.frame(sys.parent()))
		x <- eval(x[[2]], sys.frame(sys.parent()))
		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))
}
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, ...))
    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))
	class(sumry) <- "table"
	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, ...)
{
    z <- lapply(as.list(object), summary, maxsum = maxsum)
    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), "  ", 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)) {
    if(!is.numeric(x))
	stop("argument to svd must be numeric")
    x <- as.matrix(x)
    dx <- dim(x)
    n <- dx[1]
    p <- dx[2]
    if(!n || !p) stop("0 extent dimensions")
    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]
    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(...) .NotYetImplemented()
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 -----------------------------
    has.na <- any(nax <- is.na(x))
    num.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  {				# 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(which=0)
    .Internal(sys.function(which))
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)]
    y <- array(tabulate(bin + 1, 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, ...)
}
prop.table<-function (x, margin) 
sweep(x, margin, margin.table(x, margin), "/")
margin.table<-function (x, margin) 
apply(x, margin, sum)
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, ...)
{
    if (is.character(FUN))
	FUN <- get(FUN, mode = "function")
    if (!is.null(FUN) && mode(FUN) != "function")
	stop(paste("'", FUN, "' is not a function",sep=""))
    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
}
as.char.or.expr <- function(x) {
    if (is.expression(x)) x 
    else if (is.call(x)) as.expression(x)
    else as.character(x)
}
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 = NA, ...) {
    if (!missing(y) && (is.character(y) || is.expression(y))) {
	labels <- y; y <- NULL
    }
    if (!is.null(vfont)) {
        typeface <- pmatch(vfont[1], c("serif", "sans serif", "script",
		                       "gothic english", "gothic german",
			      	       "gothic italian", "serif symbol",
				       "sans serif symbol"))
        fontindex <- pmatch(vfont[2], c("symbol", "plain", "italic", "bold",
				        "bold italic", "cyrillic",
					"oblique cyrillic", "EUC"))
        vfont <- c(typeface-1, fontindex-1)
    }
    .Internal(text(xy.coords(x,y, recycle=TRUE),
		   as.char.or.expr(labels), adj, pos, offset, vfont,
		   cex, col, font, xpd, ...))
}
system.time <- function(expr) {
    if(!exists("proc.time")) return(rep(NA, 5))
    loc.frame <- sys.frame(sys.parent(1))
    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, ...) {
    .Internal(title(
		    as.char.or.expr(main),
		    as.char.or.expr(sub),
		    as.char.or.expr(xlab),
		    as.char.or.expr(ylab),
		    ...
		    ))
}
traceback <-
    function() unlist(.Traceback)
## 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(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(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, ...)
{
    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")
    }
    x.orig <- x
    x <- as.ts(x)
    fr.x <- frequency(x)
    if(missing(calendar))
	calendar <- any(fr.x==c(4,12))
    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) { # 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 + floor(fr.x*(tm %%1))
            p1 <- format(floor(tm))
            if(fr.x == 12) {
                p2 <- month.abb[t2]
                rownames(x) <- paste(p2, p1, sep=" ")
            } else {
                if(fr.x == 4)
                    p2 <- c("Q1", "Q2", "Q3", "Q4")[t2]
                else p2 <- format(t2)
                rownames(x) <- paste(p1, p2, 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"), ...)
{
    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 <- xy$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
	plot.default(xy, type = "n", 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, ...)
	text(xy, labels =
             if(all(tsp(x)==tsp(y))) formatC(time(x), wid = 1)
             else seq(along = x),
	     col = col, cex = cex)
	lines(xy, col = col, lty = lty, lwd = lwd)
	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"),
                      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)
    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 = F, xlab="", ylab="",
             log = log, col = col, bg = bg, pch = pch, ann = ann,
             ...)
        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, ...)
{
    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]) {
	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]) {
	end <- xtsp[2]
	warning("end value not changed")
    }
    if(start > end)
	stop("start cannot be after end")
    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)
    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
}
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)
{
    if (is.null(call <- object$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, sys.frame(sys.parent()))
    else call
}
update.formula <- function (old, new) {
    tmp <- .Internal(update.formula(as.formula(old), as.formula(new)))
    formula(terms.formula(tmp))
}
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=x, na.rm = FALSE, use) {
    if(missing(use)) 
	use <- if(na.rm) "complete.obs" else "all.obs"
    cov(x, y, use=use)
}
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(...)
{
        n<-length(last.warning)
        names<-names(last.warning)
        if( n == 1 )
                cat("Warning message:\n")
        else
                cat("Warning messages:\n")
        for(i in 1:n) {
                if( n == 1 )
                        out<-names[i]
                else
                        out<-paste(i,": ",names[i],sep="")
                if(length(last.warning[[i]])) {
                        temp<-deparse(last.warning[[i]])
                        if(length(temp)>1)
                                out<-paste(out, "in:", temp[1]," ...")
                        else
                                out<-paste(out, "in:", temp[1])
                }
                cat(out, ..., fill = T)
        }
}
which <- function(logic, arr.ind = FALSE)
{
    if(!is.logical(logic))
	stop("argument to \"which\" is not logical")
    wh <- seq(along=logic)[ll <- logic & !is.na(logic)]
    if ((m <- length(wh)) > 0) {
	dl <- dim(logic)
	if (is.null(dl) || !arr.ind) {
	    names(wh) <- names(logic)[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(logic)[[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
}
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, row.names = TRUE, col.names = TRUE)
{
    if (!is.data.frame(x))
	x <- data.frame(x)
    else if (is.logical(quote) && quote)
	quote <- which(unlist(lapply(x, is.character)))
    x <- as.matrix(x)
    p <- ncol(x)
    d <- dimnames(x)
    x[is.na(x)] <- na
    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")
    if (is.logical(row.names)) {
	if (row.names)
	    x <- cbind(d[[1]], x)
    }
    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 (col.names) d[[2]] else NULL
    else {
	col.names <- as.character(col.names)
	if (length(col.names) != p)
	    stop("invalid col.names specification")
    }
    if (!is.null(col.names)) {
	if (append)
	    warning("appending column names to file")
	if (!is.null(quote))
	    col.names <- paste("\"", col.names, "\"", sep = "")
	cat(col.names, file = file, sep = rep(sep, p - 1), append = append)
	cat(eol, file = file, append = TRUE)
	append <- TRUE
    }
    for (i in quote)
	x[, i] <- paste("\"", x[, i], "\"", sep = "")
    cat(t(x), file = file, sep = c(rep(sep, ncol(x) - 1), eol),
	append = append)
}
xor <- function(x, y) { (x | y) & !(x & y) }
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)
}
bug.report <- function(subject="", ccaddress=getenv("USER"),
                       method=getOption("mailer"), file = "R.bug.report",
                       address="r-bugs@biostat.ku.dk", wait = TRUE)
{
    body <- paste("\\n<<insert bug report here>>\\n\\n\\n\\n",
		  "--please do not edit the information below--\\n\\n",
		  "Version:\\n ",
		  paste(names(version), version, sep=" = ", collapse="\\n "),
                  "\\n\\n",
                  win.version(),
		  "\\n\\n",
		  "Search Path:\\n ",
		  paste(search(), collapse=", "),
		  "\\n", sep="", collapse="")
    if(missing(subject)) stop("Subject missing")
    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), wait = wait)
    cat("The unsent bug report can be found in file", file, "\n")
    invisible()
}
win.version <- function() .Internal(win.version())
dev2bitmap <- function(file, type="png256", height=6, width=6, res=72,
                   pointsize, ...)
{
    gsexe <- getenv("R_GSCMD")
    if(is.null(gsexe) || nchar(gsexe) == 0) gsexe <- "gswin32c.exe"
    gshelp <- system(paste(gsexe, "-help"), intern=TRUE, invisible=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))
    dev.print(device=postscript, file=tmp, width=width, height=height,
              pointsize=pointsize, paper="special", horizontal=FALSE, ...)
    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=TRUE)
    invisible()
}
winDialog <- function(type = c("ok", "okcancel", "yesno", "yesnocancel"),
                       message)
{
    type <- match.arg(type)
    res <- .Internal(winDialog(type, message))
    if(res == 10) return(invisible(NULL))
    c("NO", "CANCEL", "YES", "OK")[res+2]
}
winDialogString <- function(message, default)
    .Internal(winDialogString(message, default))
winMenuAdd <- function(menuname)
    invisible(.Internal(winMenuAdd(menuname, NULL, NULL)))
winMenuAddItem <- function(menuname, itemname, action)
    invisible(.Internal(winMenuAdd(menuname, itemname, action)))
winMenuDel <- function(menuname)
    invisible(.Internal(winMenuDel(menuname, NULL)))
winMenuDelItem <- function(menuname, itemname)
    invisible(.Internal(winMenuDel(menuname, itemname)))
download.file <- function(url, destfile, method="auto", quiet=FALSE)
{
    method <- match.arg(method,
                        c("auto", "wget", "lynx", "cp","socket"))
    if(method == "auto") {
        if(length(grep("^file:", url)))
            method <- "cp"
        else if(system("wget --help", invisible=TRUE)==0)
            method <- "wget"
        else if(shell("lynx -help", invisible=TRUE)==0)
            method <- "lynx"
        else if (length(grep("^http:",url))==0)
            method <- "socket"
        else
            stop("No download method found")
    }
    if(method=="wget")
        if(quiet)
            status <- system(paste("wget --quiet", url, "-O", destfile))
        else
            status <- system(paste("wget", url, "-O", destfile))
    else if(method=="lynx")
        status <- shell(paste("lynx -dump", url, ">", destfile))
    else if(method=="cp") {
        url <- sub("^file:", "", url)
        status <- system(paste("cp", url, destfile))
    }
    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)
}
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)
    }
}
index.search <- function(topic, path, file="AnIndex", type="help")
    .Internal(index.search(topic, path, file, .Platform$file.sep, type))
help <-
    function(topic, offline = FALSE, package = .packages(),
             lib.loc = .lib.loc, verbose = getOption("verbose"),
             chmhelp = getOption("chmhelp"), htmlhelp = getOption("htmlhelp"),
             winhelp = getOption("winhelp"))
{
    chmhelp <- is.logical(chmhelp) && chmhelp
    htmlhelp <- is.logical(htmlhelp) && htmlhelp
    winhelp <- is.logical(winhelp) && winhelp
    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 <-
            if(missing(lib.loc)) .path.package(package)
            else system.file(pkg = package, lib = lib.loc)
#        INDICES <- system.file(pkg=package, lib=lib.loc)
        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(chmhelp) {
                    chm.dll <- file.path(R.home(), "bin", "Rchtml.dll")
                    if(!file.exists(chm.dll))
                        stop("Compiled HTML is not installed")
                    if(!is.loaded(symbol.C("Rchtml")))
                        dyn.load(chm.dll)
                    wfile <- sub("/help/([^/]*)$", "", file)
                    thispkg <- sub(".*/([^/]*)$", "\\1", wfile)
                    hlpfile <- paste(wfile, "/chtml/", thispkg, ".chm",
                                     sep = "")
                    if(verbose) print(hlpfile)
                    if(file.exists(hlpfile)) {
                        err <- .C("Rchtml", hlpfile, topic, err=integer(1))$err
                        if(verbose)
                            cat("help() for `", topic,
                                "' is shown in Compiled HTML\n",
                                sep="")
                        return(invisible())
                    } else {
                       if(verbose)
                           cat("No `", thispkg, ".chm' is available\n", sep="")
                        file <- index.search(topic, INDICES, "AnIndex", "help")
                    }
                }
                if(htmlhelp) {
                    file <- gsub("/", "\\\\", file)
                    if(file.exists(file)) {
                        .Internal(show.help.item(file, 1, ""))
                        cat("help() for `", topic, "' is shown in browser\n",
                            sep="")
                        return(invisible())
                    } else {
                        if(verbose)
                            cat("no HTML help for `", topic,
                                "' is available\n", sep = "")
                        file <- index.search(topic, INDICES, "AnIndex", "help")
                    }
                }
                if(winhelp) {
                    wfile <- sub("/help/([^/]*)$", "", file)
                    thispkg <- sub(".*/([^/]*)$", "\\1", wfile)
                    hlpfile <- paste(wfile, "/winhlp/", thispkg, ".hlp",
                                     sep = "")
                    hlpfile <- gsub("/", "\\\\", hlpfile)
                    if(verbose) print(hlpfile)
                    if(file.exists(hlpfile)) {
                        .Internal(show.help.item(topic, 2, hlpfile))
                        if(verbose)
                            cat("help() for `", topic, "' is shown in WinHelp\n",
                                sep="")
                        return(invisible())
                    } else {
                       if(verbose)
                           cat("No `", thispkg, ".hlp' 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,
                              header = paste("Help for `", topic, "'", sep=""),
                              delete.file = (zfile!=file))
                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 <- "Rdoc"
                    tFILE <- paste(FILE, ".tex", sep="")
                    cat("\\documentclass[",
                        getOption("papersize"),
                        "paper]{article}",
                        "\n",
                        "\\usepackage[",
                        if(nchar(opt <- getenv("R_RD4DVI"))) opt else "ae",
                        "]{Rd}",
                        "\n",
                        "\\InputIfFileExists{Rhelp.cfg}{}{}\n",
                        "\\begin{document}\n",
                        file = tFILE, sep = "")
                    file.append(tFILE, zfile)
                    cat("\\end{document}\n", file = tFILE, append = TRUE)
                    cmd <- paste('"',
                                 paste(R.home(), "bin", "helpPRINT", sep="/"),
                                 '"', sep="")
                    texpath <- gsub("\\\\", "/",
                                    file.path(R.home(), "doc", "manual"))
                    system(paste(cmd, FILE, topic, texpath), wait=F)
                    return(invisible())
                }
                else
                    stop(paste("No offline documentation for", topic,
                               "is available"))
            }
        }
        else
            stop(paste("No documentation for `", 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 = "irrelevant")
{
    a <- system.file("rwin.html", pkg="doc/html", lib=R.home())
    if (a == "")
        a <- system.file("rwin.htm", pkg="doc/html", lib=R.home())
    if (a == "")
        stop("I can't find the html help\n")
    else {
        a <- gsub("/", "\\\\", a)
        cat("If nothing happens, you have to open `",a,"' yourself\n")
        .Internal(help.start());
    }
    invisible("")
}
link.html.help <- function(verbose=FALSE)
{
    if(!file.exists(file.path(R.home(), "doc", "html")))
       return(invisible(NULL))
    if(verbose) {
        cat("updating HTML package descriptions\n")
        flush.console()
    }
    make.packages.html()
    make.function.html()
    make.search.html()
}
make.packages.html <- function()
{
    f.tg <- file.path(R.home(), "doc/html/packages.html")
    f.hd <- file.path(R.home(), "doc/html/packages-head.html")
    f.ft <- file.path(R.home(), "doc/html/packages-foot.html")
    file.create(f.tg)
    file.append(f.tg, f.hd)
    cat("<P><TABLE align=center>\n", file=f.tg, append=TRUE)
    pg <- sort(.packages(all.available = TRUE, lib.loc = .Library))
    for (i in  pg) {
        t.file <- system.file("TITLE", pkg = i)
        if (nchar(t.file) > 0)
            f.t <- scan(t.file, what="c", quiet=TRUE)
        else {
            title <- package.description(i, field="Title")[1]
            if (title == "NA") title <- "-- Title is missing --"
            f.t <- c(i, title)
        }
        cat("<TR ALIGN=LEFT VALIGN=TOP>",
            "<TD><A HREF=\"../../library/", i ,"/html/00Index.html\">",
            f.t[1], "</A><TD>", paste(f.t[-1], collapse=" "),
            "</TD></TR>\n", file=f.tg, append=TRUE, sep="")
    }
    cat("</TABLE>\n", file=f.tg, append=TRUE)
    file.append(f.tg, f.ft)
    invisible(pg)
}
make.function.html <- function()
{
    f.tg <- file.path(R.home(), "/doc/html/function.html")
    f.hd <- file.path(R.home(), "/doc/html/function-head.html")
    file.create(f.tg)
    file.append(f.tg,f.hd)
    pg <- .packages(all.available=TRUE, lib.loc=.Library)
    for (p in pg) {
        f1 <- system.file("/help/AnIndex", pkg=p)
        if (f1=="") next
        b <- scan(f1, what="c", sep="\t", quiet = TRUE)
        b <- matrix(b, ncol=2, byrow=TRUE)
        f1 <- system.file("/help/00Titles", pkg = p)
        d <- scan(f1, what="c", sep="\t", quiet = TRUE)
        d <- matrix(d, ncol=2, byrow=TRUE)
        m <- match(b[,2], d[, 1])
        b <- cbind(b, d[m, 2], p)
        if (p == pg[1]) fun <- b
        else            fun <- rbind(fun, b)
    }
    for (which in 0:length(letters)) {
        i <- 0
        if (which==0) {
            i <- grep("^[^a-z,^A-Z]", fun[,1])
            tl <- "-- Operators, Global Variables, ... --"
        } else {
            cat("<a name=\"", LETTERS[which], "\">\n", file=f.tg,
                append=TRUE, sep="")
            i <- grep(paste("^[", letters[which], LETTERS[which],"]", sep=""),
                      fun[,1])
            tl <- paste("--", LETTERS[which],"--")
        }
        if (i==0) break
        cat("<h2 align=center><FONT FACE=\"Courier New,Courier\" COLOR=\"#999999\">",
            tl,"</FONT></h2>\n\n<table width=100%>\n",
            file=f.tg, append=TRUE, sep="")
        ll <- i[order(substring(fun[i,1], 1 + (which > 0)))]
        for (l in ll)
            cat("<TR><TD width=25%><A HREF=\"../../library/",
                fun[l,4], "/html/", fun[l,2], ".html\">",
                fun[l,1], "</A></TD>\n<TD>",
                fun[l,3], " (", fun[l,4], ")</TD></TR>\n",
                file=f.tg, append=TRUE, sep="")
        cat("</table>\n", file=f.tg, append=TRUE)
    }
    cat("</BODY>", file=f.tg, append=TRUE)
    invisible(fun)
}
make.search.html <- function()
{
    f.tg <- system.file("html/search/index.txt", pkg="doc", lib=R.home())
    if (f.tg != "")
        unlink(f.tg)
    else
        f.tg <- file.path(R.home(), "doc/html/search/index.txt")
    for (i in  .packages(all.available=TRUE, lib.loc=.Library)) {
        cfile <- system.file("CONTENTS", pkg = i)
        if(nchar(cfile)) {
            f.t <- scan(cfile, what="", quiet=TRUE, sep="\n")
            cat(paste(f.t, collapse="\n"), "\n", file=f.tg, append=TRUE)
        }
    }
}
read.fwf <- function(file, widths, sep = "", as.is = FALSE,
		     skip = 0, row.names, col.names)
{
    FILE <- tempfile("R.")
    on.exit(unlink(FILE))
    args <- paste("-f", deparse(paste("A", widths, sep = "", collapse = " ")),
                  "-s", deparse(sep), "-o",
                  paste('"', FILE, '"', sep=''), paste('"', file, '"', sep=''))
    cmd <- paste('"',file.path(R.home(), "bin", "fwf2table"), '"', sep='')
    system(paste("perl", cmd, args), invisible=TRUE)
    read.table(file = FILE, header = FALSE, sep = sep, as.is = as.is,
	       skip = skip, row.names = row.names, col.names = col.names)
}
system <- function(command, intern = FALSE, wait = TRUE, input = "",
                   show.output.on.console = FALSE, minimized = FALSE,
                   invisible = FALSE)
{
    f <- ""
    if (input!="") {
        f <- tempfile()
        on.exit(unlink(f))
        cat(input,file=f,sep="\n")
    }
    if (intern)
        flag <- 3
    else {
        if  (wait)
            flag <- ifelse(show.output.on.console, 2, 1)
        else
            flag <- 0
    }
    if (invisible) flag <- 20 + flag
    else if (minimized) flag <- 10 + flag
    .Internal(system(command, as.integer(flag), f))
}
unix <- function(call, intern = FALSE)
{
    .Deprecated("system")
    system(call, intern)
}
tempfile <- function(pattern = "file") .Internal(tempfile(pattern))
unlink <- function(x) invisible(.Internal(unlink(x)))
flush.console <- function() .Internal(flush.console())
shell <- function(cmd, shell, flag="/c", intern=FALSE,
                  wait=TRUE, translate=FALSE, mustWork=FALSE, ...)
{
    if(missing(shell)) {
        shell <- getenv("R_SHELL")
        if(!nchar(shell)) shell <- getenv("SHELL")
        if(!nchar(shell)) shell <- getenv("COMSPEC")
    }
    if(missing(flag) && any(!is.na(match(c("bash", "tcsh"), shell))))
        flag <- "-c"
    if(translate) cmd <- gsub("/", "\\\\", cmd)
    if(!is.null(shell)) cmd <- paste(shell, flag, cmd)
    res <- system(cmd, intern=intern, wait=wait | intern,
                  show.output.on.console=wait, ...)
    if(!intern && res !=0)
        if(mustWork)
            if(res == -1) stop("cmd could not be run")
            else stop(paste("cmd execution failed with error code", res))
        else
            if(res == -1) warning("cmd could not be run")
            else warning(paste("cmd execution failed with error code", res))
    if(intern) res else invisible(res)
}
shell.exec <- function(file) invisible(.Internal(shell.exec(file)))
dir.create <- function(path)
    invisible(.Internal(dir.create(path)))
install.packages <- function(pkgs, lib, CRAN=getOption("CRAN"),
                             contriburl=contrib.url(CRAN),
                             method="auto", available=NULL)
{
    if(missing(lib) || is.null(lib)) {
        lib <- .lib.loc[1]
        warning(paste("argument `lib' is missing: using", lib))
    }
    if(is.null(CRAN) & missing(contriburl)) {
        for(pkg in pkgs) zip.unpack(pkg, lib)
        link.html.help(verbose=TRUE)
        return(invisible())
    }
    localcran <- length(grep("^file:", contriburl)) > 0
    if(!localcran) {
        tmpd <- tempfile("Rinstdir")
        dir.create(tmpd)
    }
    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){
                    for(pkg in foundpkgs[okp, 2]) zip.unpack(pkg, lib)
                }
            }
        }
        cat("\n")
        if(!localcran){
            answer <- substr(readline("Delete downloaded files (y/N)? "), 1, 1)
            if(answer == "y" | answer == "Y") {
                for(file in foundpkgs[, 2]) unlink(file)
                unlink(tmpd)
            } else
                cat("The packages are in", tmpd)
            cat("\n")
        }
        link.html.help(verbose=TRUE)
    }
    else
        unlink(tmpd)
    invisible()
}
download.packages <- function(pkgs, destdir, available=NULL,
                              CRAN=getOption("CRAN"),
                              contriburl=contrib.url(CRAN),
                              method="auto")
{
    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, ".zip", 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,"bin", "windows", "windows-NT", "contrib", sep="/")
windows <- function(width = 7, height = 7, pointsize = 12)
    .Internal(devga("", width=width, height=height, pointsize=pointsize, 1))
win.graph <- function(width = 7, height = 7, pointsize = 12)
    .Internal(devga("", width=width, height=height, pointsize=pointsize, 1))
win.print <- function(width = 7, height = 7, pointsize = 12)
    .Internal(devga("win.print", width=width, height=height, pointsize=pointsize, 1))
win.metafile <- function(filename = "", width = 7, height = 7, pointsize = 12)
    .Internal(devga(paste("win.metafile:", filename, sep=""),
                  width=width, height=height, pointsize=pointsize, 1))
png <- function(filename = "Rplot.png", width = 480, height = 480,
                pointsize = 12)
    .Internal(devga(paste("png:", filename, sep=""),
                  width=width, height=height, pointsize=pointsize, 1))
bmp <- function(filename = "Rplot.bmp", width = 480, height = 480,
                pointsize = 12)
    .Internal(devga(paste("bmp:", filename, sep=""),
                  width=width, height=height, pointsize=pointsize, 1))
jpeg <- function(filename = "Rplot.jpg", width = 480, height = 480,
                 pointsize = 12, quality=75)
    .Internal(devga(paste("jpeg:", quality, ":",filename, sep=""),
                  width=width, height=height, pointsize=pointsize, 1))
savePlot <- function(filename = "Rplot",
                     type = c("wmf", "png", "jpeg", "jpg", "bmp","ps"),
                     device = dev.cur())
{
    type <- match.arg(type)
    devlist <- dev.list()
    devcur <- match(device, devlist, NA)
    if(is.na(devcur)) stop("no such device")
    devname <- names(devlist)[devcur]
    if(devname != "windows") stop("can only copy from `windows' devices")
    if(filename == "clipboard" && type == "wmf") filename <- ""
    if(nchar(filename) > 0) filename <- paste(filename, type, sep=".")
    invisible(.Internal(saveDevga(device, filename, type)))
}
x11 <- .Alias(windows)
X11 <- .Alias(windows)
zip.file.extract <- function(file, zipname="R.zip")
{
    ofile <- gsub("\\\\", "/", file)
    path <- sub("[^/]*$","", ofile)
    topic <- substr(ofile, nchar(path)+1, 1000)
    if(file.exists(file.path(path, zipname))) {
        tempdir <- sub("[^\\]*$","", tempfile())
        if((unzip <- getOption("unzip")) != "internal") {
            if(!system(paste(unzip, ' -oq "',
                             file.path(path, zipname), '" ', topic,
                             " -d ", tempdir, sep=""), invisible = TRUE))
                file <- paste(tempdir,  topic, sep="")
        } else {
            rc <- .Internal(int.unzip(file.path(path, zipname), topic, tempdir))
            if (rc == 10)
                warning(paste(R.home(),
                              "unzip\\unzip32.dll cannot be loaded", sep="\\"))
            if (rc == 0)
                file <- paste(tempdir, topic, sep="")
        }
    }
    file
}
### the following function supports update.packages()
zip.unpack <- function(zipname, dest)
{
    if(file.exists(zipname)) {
        if((unzip <- getOption("unzip")) != "internal") {
            system(paste(unzip, "-oq", zipname, "-d", dest),
                   show = FALSE, invisible = TRUE)
        } else {
            rc <- .Internal(int.unzip(zipname, NULL, dest))
            if (rc == 10)
                warning(paste(R.home(),
                              "unzip\\unzip32.dll cannot be loaded", sep="\\"))
            rc
        }
    } else stop(paste("zipfile", zipname, "not found"))
}
