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 <- options("contrasts")$contrasts
	if(length(oc) < 2)		# should not happen
	    contr <- if(is.ordered(object)) contr.poly else contr.treatment
	else contr <- oc[1 + is.ordered(object)]
    }
    if(missing(how.many)) 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 = ""))
}
###----- 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 = ""))
}
dnchisq <- function(x, df, lambda) {
    .Deprecated("dchisq")
    .Internal(dnchisq(x, df, lambda))
}
pnchisq <- function(q, df, lambda) {
    .Deprecated("pchisq")
    .Internal(pnchisq(q, df, lambda))
}
qnchisq <- function(p, df, lambda) {
    .Deprecated("qchisq")
    .Internal(qnchisq(p, df, lambda))
}
rnchisq <- function(...) .NotYetImplemented()
print.plot <- function() {
    .Deprecated("dev.print")
    FILE <- tempfile()
    dev.print(file = FILE)
    system(paste(options()$printcmd, FILE))
    unlink(FILE)
}
save.plot <- function(file = "Rplots.ps") {
    .Deprecated("dev.print")
    dev.print(file = file)
}
## From print.R :
## This is not used anymore [replaced by  print.anova() -> ./anova.R ]
##- print.tabular <-
##-	function(x, digits = max(3, .Options$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, .Options$digits - 3), na.print = "") {
	.Deprecated("print.anova")
	print.anova(table, digits=digits, na.print=na.print)
    }
## From lm.R :
## Unused (0.63, Sept.25 1998) --- print.anova()  now in ./print.R
##- print.anova.lm <- function(x, digits = max(3, .Options$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, .Options$digits - 3), ...)
{
    .Deprecated("print.anova")
    print.anova(x, digits=digits, ...)
}
## From glm.R :
## Not used anymore..
##- print.anova.glm <- function(x, digits = max(3, .Options$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)
##vector <- function(mode = "logical", length = 0).Internal(vector(mode,length))
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))
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())
Version <- function().Internal(Version())
machine <- function().Internal(machine())
colors <- function().Internal(colors())
colours <- .Alias(colors)
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)) ### NO DOC
gc <- function(verbose = .Options$verbose)
    matrix(.Internal(gc(verbose)),2,2,
           dimnames = list(c("Ncells","Vcells"),c("free","total")))
gcinfo <- function(verbose).Internal(gcinfo(verbose))
gctorture <- function(on=TRUE)invisible(.Internal(gctorture(on)))
gray <- function(level).Internal(gray(level))
lib.fixup <- function(env, globenv).Internal(lib.fixup(env, globenv)) ### NO DOC
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))
##- }
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(...))
}
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().Internal(readline())
search <- function().Internal(search())
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
}
stop <- function(message = NULL).Internal(stop(message))
warning <- function(message = NULL).Internal(warning(message))
## Random Number Generator[s]
## The available kinds are in
## ../../../include/Random.h  and ../../../nmath/sunif.c [RNG_Table]
RNGkind <- function(kind = NULL) 
{
    kinds <- c("Wichmann-Hill", "Marsaglia-Multicarry", "Super-Duper",
               ## NOT yet: "Mersenne-Twister",
               ##BUG "Rand"
               )
    do.set <- length(kind) > 0
    if(do.set) {
	if(!is.character(kind) || length(kind) > 1)
	    stop("'kind' must be a character 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=""))
    } else i.knd <- NULL
    r <- kinds[1 + .Internal(RNGkind(i.knd))]
    if(do.set) invisible(r) else r
}
abline <-
    function(a=NULL, b=NULL, h=NULL, v=NULL, reg=NULL, coef=NULL,
	     col=par("col"), lty=par("lty"), ...)
{
    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, col, lty, ...))
    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 <- model.weights(model.frame(object))
    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, ...)
{
    setdiff <- function(x, y)
	if(length(x) == 0 || length(y) == 0) x else x[match(x, y, 0) == 0]
    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, ...)
{
    setdiff <- function(x, y)
	if(length(x) == 0 || length(y) == 0) x else x[match(x, y, 0) == 0]
    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 <- model.weights(model.frame(object))
    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)
    c(edf, -2 * fit$loglik[2] + k * edf)
}
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)
}
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, .Options$digits - 3),
                              symbolic.cor = p > 4,
                              signif.stars= .Options$show.signif.stars,	...)
{
    if (length(x) == 1)  print(x[[1]], ...)
    else NextMethod()
    invisible(x)
}
coef.aov <- function(x)
{
    z <- x$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(x, ...) 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, ...)
{
    ## Ensure that FUN is a function
    if(is.character(FUN))
	FUN <- get(FUN, mode = "function")
    else if(mode(FUN) != "function") {
	f <- substitute(FUN)
	if(is.name(f))
	    FUN <- get(as.character(f), mode = "function")
	else stop(paste("\"", f, "\" is not a function", sep = ""))
    }
    ## 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), prod(d.ans))
    d2 <- dim(newX)[2]
    ans <- vector("list", d2)
    for(i in 1:d2)
	ans[[i]] <- FUN(array(newX[,i], d.call, dn.call), ...)
    ## answer dims and dimnames
    ans.names <- names(ans[[1]])
    ans.list <- is.recursive(ans[[1]])
    ans.length <- length(ans[[1]])
    if(!ans.list)
	ans.list <- any(unlist(lapply(ans, length)) != ans.length)
    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]]) > 0) 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),
		     dimnames = if(is.null(dn.ans)) 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]
    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("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)$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("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)$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) {
    warning("type single is not supported in R")
    .Internal(as.vector(x,"double"))
}
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)) {
	l <- vector("list")
	for (sub in x) l <- c(l, sub[[1]])
	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()))
    .Internal(as.function.default(l, envir))
as.array <- function(x)
{
    if(is.array(x))
	return(x)
    dim(x) <- length(x)
    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)
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)
    .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]]
}
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 <- 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)[c("x","info")]
    if(z$info != 0)
	stop(paste("singular matrix in backsolve. First zero in diagonal [",
		   z$info,"].",sep=""))
    z$x
}
barplot <-
    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,
	     xlab = NULL, ylab = NULL, xlim = NULL, ylim = NULL,
	     axes = TRUE, inside = TRUE, ...)
{
    if (!missing(inside))
	.NotYetUsed("inside")
    opar <- if (horiz)	par(xaxs = "i", xpd = TRUE)
    else	par(yaxs = "i", xpd = TRUE)
    on.exit(par(opar))
    if (missing(space))
	space <- if (is.matrix(height) && beside) c(0, 1) else 0.2
    space <- space * mean(width)
    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 (missing(names.arg))
	names.arg <- if(is.matrix(height)) colnames(height) else names(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)
	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)
    }
    ## -------- Plotting :
    plot.new()
    plot.window(xlim, ylim, log = "")
    if (beside) {
	if (horiz)
	    rect(0, w.l, c(height), w.r, col = col)
	else
	    rect(w.l, 0, w.r, c(height), col = col)
    } else {
	for (i in 1:NC) {
	    if (horiz)
		rect(height[1:NR, i], w.l[i], height[-1, i], w.r[i], col = col)
	    else
		rect(w.l[i], height[1:NR, i], w.r[i], height[-1, i], col = col)
	}
    }
    if (!is.null(names.arg)) {
	if (length(names.arg) != length(w.m)) {
	    if (length(names.arg) == NC)
		w.m <- apply(matrix(w.m, nc = NC), 2, mean)
	    else
		stop("incorrect number of names")
	}
	axis(if(horiz) 2 else 1, at = w.m, labels = names.arg, lty = 0)
    }
    if (!is.null(legend.text)) {
	xy <- par("usr")
	legend(xy[2] - xinch(0.1), xy[4] - yinch(0.1),
	       legend = rev(legend.text), fill = rev(col),
	       xjust = 1, yjust = 1)
    }
    title(main = main, xlab = xlab, ylab = ylab, ...)
    if (axes) axis(if(horiz) 1 else 2)
    invisible(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, ..., range=1.5, width=NULL, varwidth=FALSE,
		    notch=FALSE, names.x, 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(!missing(names.x))
	attr(groups, "names") <- names.x
    else if(is.null(attr(groups, "names")))
	attr(groups, "names") <- 1:n
    for(i in 1:n)
	groups[i] <- list(boxplot.stats(groups[[i]], range))
    if(plot) {
	bxp(groups, width, varwidth=varwidth, notch=notch,
	    border=border, col=col, log=log, pars=pars)
	invisible(groups)
    }
    else groups
}
boxplot.stats <- function(x, coef = 1.5)
{
    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 <- stats[3]+c(-1.58, 1.58)*diff(stats[c(2, 4)])/sqrt(n)
    list(stats=stats, n=n, conf=conf, out=x[out&nna])
}
bxp <- function(z, notch=FALSE, width=NULL, varwidth=FALSE,
		notch.frac = 0.5,
		border=par("fg"), col=NULL, log="", pars=NULL, ...)
{
    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, z[[i]]$out, finite=TRUE)
    }
    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)
    ylim <- if(is.null(pars$ylim)) limits else pars$ylim
    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])
    if(is.null(pars$axes) || pars$axes) {
	if(n > 1) axis(1, at=1:n, labels=names(z))
	axis(2)
    }
    do.call("title", pars)
    box()
    invisible(1:n)
}
builtins <- function(internal=FALSE)
    .Internal(builtins(internal))
cat <- function(...,file="",sep=" ", fill=FALSE, labels=NULL,append=FALSE)
    .Internal(cat(list(...),file,sep,fill,labels,append))
##nchar <- function(x) {
##	x<-as.character(x)
##	.Internal(nchar(x))
##}
substr <- function(x,start,stop) {
    x <- as.character(x)
    .Internal(substr(x,as.integer(start),as.integer(stop)))
}
strsplit <- function(x,split) {
    x <- as.character(x)
    split <- as.character(split)
    .Internal(strsplit(x,split))
}
substring <- function(text,first,last=1000000)
{
    storage.mode(text) <- "character"
    n <- max(length(text), length(first), length(last))
    text <- rep(text, length = n)
    first <- rep(first, length = n)
    last <- rep(last, 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
}
chisq.test <- function(x, y = NULL, correct = TRUE,
		       p = rep(1 / length(x), length(x)))
{
    DNAME <- deparse(substitute(x))
    if (is.data.frame(x))
        x <- as.matrix(x)
    if (is.matrix(x)) {
	if (min(dim(x)) == 1)
	    x <- as.vector(x)
    }
    if (!is.matrix(x) && !is.null(y)) {
	if (length(x) != length(y))
	    stop("x and y must have the same length")
	DNAME <- paste(DNAME, "and", deparse(substitute(y)))
	OK <- complete.cases(x, y)
	x <- as.factor(x[OK])
	y <- as.factor(y[OK])
	if ((nlevels(x) < 2) || (nlevels(y) < 2))
	    stop("x and y must have at least 2 levels")
	x <- table(x, y)
    }
    if (any(x < 0) || any(is.na(x)))
	stop("all entries of x must be nonnegative and finite")
    if (is.matrix(x)) {
	METHOD <- "Pearson's Chi-square test"
	E <- outer(apply(x, 1, sum), apply(x, 2, sum), "*") / sum(x)
	if (correct && nrow(x) == 2 && ncol(x) == 2) {
	    YATES <- .5
	    METHOD <- paste(METHOD, "with Yates' continuity correction")
	}
	else
	    YATES <- 0
	dimnames(E) <- dimnames(x)
	STATISTIC <- sum((abs(x - E) - YATES)^2 / E)
	PARAMETER <- (nrow(x) - 1) * (ncol(x) - 1)
    }
    else {
	if (length(x) == 1)
	    stop("x must at least have 2 elements")
	if (length(x) != length(p))
	    stop("x and p must have the same number of elements")
	METHOD <- "Chi-square test for given probabilities"
	E <- sum(x) * p
	names(E) <- names(x)
	STATISTIC <- sum((x - E) ^ 2 / E)
	PARAMETER <- length(x) - 1
    }
    names(STATISTIC) <- "X-squared"
    names(PARAMETER) <- "df"
    if (any(E < 5))
	warning("Chi-square approximation may be incorrect")
    PVAL <- 1 - pchisq(STATISTIC, PARAMETER)
    structure(list(statistic = STATISTIC,
		   parameter = PARAMETER,
		   p.value = PVAL,
		   method = METHOD,
		   data.name = DNAME,
		   observed = x,
		   expected = E),
	      class = "htest")
}
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)
    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)
    if(z$info)
	stop("singular matrix in chol2inv")
    z$v
}
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) {
	j <- n %/% 3
	k <- n %/% 3
	i <- n - j - k
	c(hsv(23/60, 1, v = seq(0.6, 0.85, length = i)),
	  if(j > 0)
	  hsv(h = seq(22/60, 10/60, length = j), s = 1,
	      v = seq(0.85 ,	 1, length = j)),
	  if(k > 0)
	  hsv(h = seq(from = 9/60, to = 6/60, length = k),
	      s = seq(from =	1, to = 0.3,  length = k), v = 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)
}
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(range(z, finite = TRUE),
			       nlevels), labcex = 0, xlim = range(x, finite = TRUE),
	      ylim = range(y, finite = TRUE), col = par("fg"), lty = par("lty"),
	      add = FALSE, ...)
{
    ## 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")
    if (!add) {
	plot.new()
	plot.window(xlim, ylim, "")
	title(...)
    }
    if (!is.matrix(z) || nrow(z) <= 1 || ncol(z) <= 1)
	stop("no proper `z' matrix specified")
    ##- don't lose  dim(.)
    if (!is.double(z)) storage.mode(z) <- "double"
    .Internal(contour(as.double(x), as.double(y), z, as.double(levels),
		      col = col, lty = lty))
    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.
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))), "/")
	dimnames(Z)[[2]] <- 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)]
	dimnames(contr)[[2]] <- dn
	contr[, -1, drop = FALSE]
    }
    else {
	contr[, 1] <- 1
	contr
    }
}
## implemented by BDR 29 May 1998
poly <- function(x, degree=1)
{
    if(is.matrix(x)) stop("poly is only implemented for vectors")
    n <- degree + 1
    X <- outer(x, seq(length=n) - 1, "^")
    QR <- qr(X)
    z <- QR$qr
    z <- z *(row(z) == col(z))
    raw <- qr.qy(QR, z)
    s <- apply(raw, 2, function(x) sqrt(sum(x^2)))
    Z <- sweep(raw, 2, s, "/")
    dimnames(Z)[[2]] <- 1:n - 1
    Z <- Z[, -1]
    attr(Z, "degree") <- 1:degree
    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(options("contrasts")[[1]] [[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, 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))
    contr[seq(1, n^2, n + 1)] <- 1
    if(contrasts) {
	if(n < 2)
	    stop(paste("Contrasts not defined for", n - 1,
		       "degrees of freedom"))
	contr <- contr[, -1, 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 <- 0:(number - 1) * (1 - overlap) * r
    cbind(x[round(1+ii)], x[round(r+ii)])
}
panel.smooth <- function(x, y, col = par("col"), pch = par("pch"),
			 col.smooth = "red", f = 2/3, iter = 3, ...)
{
    points(x, y, pch=pch, col=col)
    lines(lowess(x, y, f=f, iter=iter), col = col.smooth, ...)
}
coplot <- function (formula, data, given.values, panel=points, rows, columns,
		    show.given = TRUE, col = par("fg"), pch=par("pch"), ...)
{
    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 (have.b) {
	b.name <- deparse(b)
	b <- eval(b, data, sys.frame(sys.parent()))
	if(length(b) != nobs) bad.lengths()
    }
    else b <- NULL
    ## generate the given value intervals
    bad.givens <- function() stop("invalid given.values")
    if(missing(given.values)) {
	if(is.factor(a)) {
	    a.intervals <- cbind(1:nlevels(a), 1:nlevels(a))
	    a <- as.numeric(a)
	}
	else a.intervals <- co.intervals(a)
	b.intervals <- NULL
	if (have.b)  {
	    if(is.factor(b)) {
		b.intervals <- cbind(1:nlevels(b), 1:nlevels(b))
		b <- as.numeric(b)
	    }
	    else b.intervals <- co.intervals(b)
	}
    } 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.levels <- match(a.levels, levels(a))
	    else a.levels <- cbind(a.levels, a.levels)
	    a <- as.numeric(a)
	} else if(is.numeric(a)) {
	    if(!is.numeric(a)) bad.givens()
	    if(!is.matrix(a.intervals) || ncol(a.intervals) != 2)
		a.intervals <- cbind(a.intervals, a.intervals)
	}
	if(have.b) {
	    b.intervals <- given.values[[2]]
	    if(is.factor(b)) {
		if(is.character(b.intervals))
		    b.levels <- match(b.levels, levels(b))
		else b.levels <- cbind(b.levels, b.levels)
		b <- as.numeric(b)
	    } else if(is.numeric(b)) {
		if(!is.numeric(b)) bad.givens()
		if(!is.matrix(b.intervals) || ncol(b.intervals) != 2)
		    b.intervals <- cbind(b.intervals, b.intervals)
	    }
	}
    }
    if(any(is.na(a.intervals))) bad.givens()
    if(have.b)
	if(any(is.na(b.intervals))) bad.givens()
    ## compute the page layout
    if (have.b) {
	rows <- nrow(b.intervals)
	columns <- nrow(b.intervals)
	nplots <- rows * columns
	total.rows <- rows + if (show.given) 1 else 0
	total.columns <- columns + if (show.given) 1 else 0
    } 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.rows <- rows + if (show.given) 1 else 0
	total.columns <- 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, finite = TRUE)
    ylim <- range(y, finite = TRUE)
    pch <- rep(pch, length=nobs)
    col <- rep(col, length=nobs)
    do.panel <- function(index) {
	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(id)) {
	    grid(lty="solid")
	    panel(x[id], y[id], col = col[id], pch=pch[id], ...)
	}
	if ((i == total.rows) && (j%%2 == 0))
	    axis(1)
	if ((i == istart || index + columns > nplots) && (j%%2 == 1))
	    axis(3)
	if ((j == 1) && ((total.rows - i)%%2 == 0))
	    axis(2)
	if ((j == columns || index == nplots) && ((total.rows - i)%%2 == 1))
	    axis(4)
	## 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()
    }## 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*(columns/total.columns),
	  outer=TRUE, line=3.5, xpd=TRUE)
    mtext(y.name, side=2, at=0.5*(rows/total.rows),
	  outer=TRUE, line=3.5, xpd=TRUE)
    if(show.given) {
	mar <- par("mar")
	nmar <- mar + c(4,0,0,0)
	par(fig = c(0, columns/total.columns, rows/total.rows, 1),
	    mar = nmar, new=TRUE)
	plot.new()
	nint <- nrow(a.intervals)
	plot.window(range(a.intervals, finite=TRUE), .5+c(0, nint), log="")
	rect(a.intervals[,1], 1:nint-0.3,
	     a.intervals[,2], 1:nint+0.3, col=gray(0.9))
	axis(3)
	axis(1, labels=FALSE)
	box()
	mtext(paste("Given :", a.name),
	      side=3, at=mean(par("usr")[1:2]), line=3, xpd=TRUE)
	if(have.b) {
	    nmar <- mar + c(0, 4, 0, 0)
	    par(fig = c(columns/total.columns, 1, 0, rows/total.rows),
		mar = nmar, new=TRUE)
	    plot.new()
	    nint <- nrow(b.intervals)
	    plot.window(.5+c(0, nint),
			range(b.intervals, finite=TRUE), log="")
	    rect(1:nint-0.3, b.intervals[,1],
		 1:nint+0.3, b.intervals[,2], col=gray(0.9))
	    axis(4)
	    axis(2, labels=FALSE)
	    box()
	    mtext(paste("Given :", b.name),
		  side=4, at=mean(par("usr")[3:4]), line=3, xpd=TRUE)
	}
    }
}
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, ...)
{
    sexpr <- substitute(expr)
    if(is.call(sexpr)) expr <- sexpr
    expr.t <- paste(deparse(expr), collapse=" ")
    if(!(lx <- length(grep("\\<x\\>", expr.t)))
       || length(grep(pat <- "^function *\\(x\\) *", expr.t))) {
        is.f <- is.function(expr)
        fun <- if(is.f) expr else eval(parse(text=expr.t))
        if(!(is.f ||is.function(fun)))
            stop("'expr' must be a function or contain 'x'")
        if(is.null(ylab))
            ylab <-
                if(is.f) paste(deparse(sexpr), "(x)")
                else if(lx) sub(pat, "", expr.t)# drop "function(x)"
                else paste(expr.t,"(x)")
    } else {
        fun <- NULL
        if(is.null(ylab)) ylab <- expr.t
    }
    lims <- delay(par("usr"))
    if(missing(from)) from <- lims[1]
    if(missing(to)) to <- lims[2]
    x <- seq(from,to,length=n)
    y <- if(is.null(fun)) eval(expr) else fun(x)
    if(add)
	lines(x, y, ...)
    else
	plot(x, y, type="l", ylab = ylab, ...)
}
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) $code
    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),
		 lib.loc = .lib.loc, verbose = .Options$verbose) 
{
    names <- c(as.character(substitute(list(...))[-1]), list)
    if (!missing(package))
	if (is.name(y <- substitute(package)))# && !is.character(package))
	    package <- as.character(y)
    found <- FALSE
    fsep <- .Platform$file.sep
    if (length(names) == 0) ## give `index' of all possible data sets
        .Platform$ show.data(package,lib.loc,fsep)
    else for (name in names) {
	dn <- paste("data", name, sep = fsep)
	files <- system.file(paste(dn, ".*", sep = ""), package, lib.loc)
	found <- FALSE
	if (files != "") {
	    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'
		if (sub(subpre, "", file) != paste(name, ".", ext, sep = ""))
		    found <- FALSE
		else
		    switch(ext,
			   "R" =, "r" = source(file),
			   "RData" =, "rdata" =, "rda" = load(file),
			   "TXT" =, "txt" =, "tab" =
			   assign(name, read.table(file, header= TRUE),
				  env = .GlobalEnv),
			   "CSV" =, "csv" =
			   assign(name, read.table(file, header= TRUE, sep=";"),
				  env = .GlobalEnv),
			   ## otherwise
			   found <- FALSE)
		if (verbose) cat(if(!found) "*NOT* ", "found\n")
	    }
	}
	if (!found)
	    warning(paste("Data set `", name, "' not found", sep = ""))
    }
    invisible(names)
}
data.matrix <-
    function(frame)
{
    if(!is.data.frame(frame))
	return(as.matrix(frame))
    log <- unlist(lapply(frame, is.logical))
    num <- unlist(lapply(frame, is.numeric))
    fac <- unlist(lapply(frame, is.factor))
    if(!all(log|fac|num))
	stop("non-numeric data type in frame")
    d <- dim(frame)
    x <- matrix(nr=d[1],nc=d[2],dimnames=dimnames(frame))
    for(i in 1:length(frame)) {
	xi <- frame[[i]]
	if(is.logical(xi)) x[,i] <- as.numeric(xi)
	else if(is.numeric(xi)) x[,i] <- xi
	else x[,i] <- codes(xi)
    }
    x
}
row.names <- function(x) 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")
    attr(x, "row.names") <- as.character(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
}
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"))
}
###  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[ - seq(length = 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(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.numeric <- .Alias(as.data.frame.vector)
as.data.frame.complex <- .Alias(as.data.frame.vector)
as.data.frame.integer <- .Alias(as.data.frame.vector)
as.data.frame.factor <- .Alias(as.data.frame.vector)
as.data.frame.ordered <- .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)
    for(i in seq(length=ncols))
	value[[i]] <- x[,i]
    if(length(row.names)==nrows) {}
    else if(optional) row.names <- character(nrows)
    else row.names <- as.character(seq(length=nrows))
    if(length(collabs) == ncols) names(value) <- collabs
    else if(!optional) names(value) <- paste("V", seq(length=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(seq(length=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) && !any(duplicated(new <- as.character(new))))
		new
	    else current
	}
    object <- as.list(substitute(list(...)))[-1]
    x <- list(...)
    n <- length(x)
    if(n < 1)
	return(structure(list(), 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 <- seq(length=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) && rowsi[[1]]!="")
	    row.names <- data.row.names(row.names, rowsi, i)
	value[[i]] <- xi
    }
    nr <- max(nrows)
    for(i in seq(length=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 <- 1: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 <- seq(length = n)
	for(j in jj) {
	    xj <- x[[j]]
	    if(length(dim(xj)) != 2)
		x[[j]] <- xj[i]
	    else x[[j]] <- xj[i, , drop = drop]
	}
    }
    if(drop) {
	drop <- FALSE
	n <- length(x)
	if(n == 1) {
	    x <- x[[1]]
	    drop <- TRUE
	}
	else if(n > 1) {
	    xj <- x[[1]]
	    if(length(dim(xj)) == 2)
		nrow <- dim(xj)[1]
	    else nrow <- length(xj)
	    if(nrow == 1) {
		drop <- TRUE
		names(x) <- cols
		attr(x, "row.names") <- NULL
	    }
	}
    }
    if(!drop) {
	names(x) <- cols
	if(any(duplicated(rows)))
	    rows <- make.names(rows, unique = TRUE)
	attr(x, "row.names") <- rows
	class(x) <- cl
    }
    x
}
"[[.data.frame" <- function(x, ...)
{
    ## use in-line functions to refer to the 1st and 2nd ... arguments
    ## explicitly. Also will check for wrong number or empty args
    if(nargs() < 3)
	(function(x, i)
	 if(is.matrix(i))
	 as.matrix(x)[[i]]
	 else unclass(x)[[i]])(x, ...)
    else (function(x, i, j)
	  x[[j]][[i]])(unclass(x), ...)
}
"[<-.data.frame" <- function(x, i, j, value)
{
    if((nA <- nargs()) == 4) {
	has.i <- !missing(i)
	has.j <- !missing(j)
    }
    else if(nA == 3) {
	## really ambiguous, but follow common use as if list
	if(is.matrix(i))
	    stop("Matrix-subscripts not allowed in replacement")
	j <- i
	i <- NULL
	has.i <- FALSE
	has.j <- TRUE
    }
    else if(nA == 2) {
	value <- i
	i <- j <- NULL
	has.i <- has.j <- FALSE
    }
    else {
	stop("Need 0, 1, or 2 subscripts")
    }
    cl <- class(x)
    ## delete class: Version 3 idiom
    ## to avoid any special methods for [[, etc
    class(x) <- NULL
    rows <- attr(x, "row.names")
    new.cols <- NULL
    nvars <- length(x)
    nrows <- length(rows)
    if(has.i) {
	if(char.i <- is.character(i)) {
	    ii <- match(i, rows)
	    nextra <- sum(new.rows <- is.na(ii))
	    if(nextra > 0) {
		ii[new.rows] <- seq(from = nrows + 1, length =
				    nextra)
		new.rows <- i[new.rows]
	    }
	    i <- ii
	}
	if(all(i >= 0) && (nn <- max(i)) > nrows) {
	    ## expand
	    if(!char.i) {
		nrr <- as.character((nrows + 1):nn)
		if(inherits(value, "data.frame") &&
		   (nrv <- dim(value)[1]) >= length(nrr)) {
		    new.rows <- attr(value, "row.names")[1:length(nrr)]
		    repl <- duplicated(new.rows) | match(new.rows, rows, 0)
		    if(any(repl))
			new.rows[repl] <- nrr[repl]
		}
		else new.rows <- nrr
	    }
	    x <- xpdrows.data.frame(x, nrows, nn, 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("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)
    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),]
	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, nrows, nn, 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
}
### 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 == seq(length = ni)))
	    seq(from = nrow + 1, length = ni)
	else ri
    }
    allargs <- list(...)
    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], seq(length = 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 seq(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
}
#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)
    }
    names(value) <- cn
    data.frame(value, row.names=rn)
}
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)
}
delay <- function(x, env=.GlobalEnv)
    .Internal(delay(substitute(x), env))
density <- function(x, bw, adjust = 1, kernel="gaussian", window = kernel,
		    n = 512, width, from, to, cut = 3, na.rm = FALSE)
{
    if (!is.numeric(x))
	stop("argument must be numeric")
    name <- deparse(substitute(x))
    x.na <- is.na(x)
    if(na.rm) x <- x[!x.na]
    has.na <- !na.rm && any(x.na)
    N <- length(x)
    k.list <- c("gaussian", "rectangular", "triangular", "cosine")
    method <- pmatch(kernel, k.list)
    if(is.na(method))
	stop(paste("kernel must be a 'pmatch' of",
		   paste(k.list,collapse=', ')))
    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))
		adjust * 0.9 * min(sd (x, na.rm=has.na),
				   IQR(x, na.rm=has.na)/1.34) * N^-0.2
	    else 0.25 * width
    if (missing(from))
	from <- min(x, na.rm = has.na) - cut * bw
    if (missing(to))
	to   <- max(x, na.rm = has.na) + cut * bw
    lo <- from - 4 * bw
    up <- to + 4 * bw
    y <- .C("massdist",
	    x = as.double(x),
	    nx= N,
	    xlo = as.double(lo),
	    xhi = as.double(up),
	    y = double(2 * n),
	    ny= as.integer(n),
	    NAOK = has.na) $ y
    xords <- seq(lo, up + (up-lo), length = 2 * n)
    kords <- xords - lo
    kords[(n + 2):(2 * n)] <- -kords[n:2]
    kords <- switch(method,
		    dnorm(kords, sd = bw),# 1
		{ a <- bw/0.2886751
		  ifelse(abs(kords) < 0.5 * a, 1/a, 0) },# 2
		{ a <- bw/0.4082483
		  ifelse(abs(kords) < a, (1 - abs(kords)/a)/a, 0) },# 3
		{ a <- bw/1.135724
		  ifelse(abs(kords) < a*pi,
			 (1+cos(kords/a))/(2*pi*a), 0)}# 4
		    )
    kords <- convolve(y, kords)[1:n]
    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 = has.na),
	      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)
	return(c(x)[1 + 0:(min(dim(x)) - 1) * (dim(x)[1] + 1)])
    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))
    y[1 + 0:(min(n, p) - 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 <- 1: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
    s <- 1:lag
    if (is.matrix(r)) {
	for (i in 1:differences) {
	    rlen <- dim(r)[1]
	    r <- r[-s, , drop = FALSE] - r[-(rlen + 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)) r
    else ts(r, end = xtsp[2], freq = xtsp[3])
}
dexp <- function(x, rate=1) .Internal(dexp(x, 1/rate))
pexp <- function(q, rate=1) .Internal(pexp(q, 1/rate))
qexp <- function(p, rate=1) .Internal(qexp(p, 1/rate))
rexp <- function(n, rate=1) .Internal(rexp(n, 1/rate))
dunif <- function(x, min=0, max=1) .Internal(dunif(x, min, max))
punif <- function(q, min=0, max=1) .Internal(punif(q, min, max))
qunif <- function(p, min=0, max=1) .Internal(qunif(p, min, max))
runif <- function(n, min=0, max=1) .Internal(runif(n, min, max))
dnorm <- function(x, mean=0, sd=1) .Internal(dnorm(x, mean, sd))
pnorm <- function(q, mean=0, sd=1) .Internal(pnorm(q, mean, sd))
qnorm <- function(p, mean=0, sd=1) .Internal(qnorm(p, mean, sd))
rnorm <- function(n, mean=0, sd=1) .Internal(rnorm(n, mean, sd))
dcauchy <-
    function(x, location=0, scale=1) .Internal(dcauchy(x, location, scale))
pcauchy <-
    function(q, location=0, scale=1) .Internal(pcauchy(q, location, scale))
qcauchy <-
    function(p, location=0, scale=1) .Internal(qcauchy(p, location, scale))
rcauchy <-
    function(n, location=0, scale=1) .Internal(rcauchy(n, location, scale))
dgamma <- function(x, shape, scale=1) .Internal(dgamma(x, shape, scale))
pgamma <- function(q, shape, scale=1) .Internal(pgamma(q, shape, scale))
qgamma <- function(p, shape, scale=1) .Internal(qgamma(p, shape, scale))
rgamma <- function(n, shape, scale=1) .Internal(rgamma(n, shape, scale))
dlnorm <- function(x, meanlog=0, sdlog=1) .Internal(dlnorm(x, meanlog, sdlog))
plnorm <- function(q, meanlog=0, sdlog=1) .Internal(plnorm(q, meanlog, sdlog))
qlnorm <- function(p, meanlog=0, sdlog=1) .Internal(qlnorm(p, meanlog, sdlog))
rlnorm <- function(n, meanlog=0, sdlog=1) .Internal(rlnorm(n, meanlog, sdlog))
dlogis <- function(x, location=0, scale=1) .Internal(dlogis(x, location, scale))
plogis <- function(q, location=0, scale=1) .Internal(plogis(q, location, scale))
qlogis <- function(p, location=0, scale=1) .Internal(qlogis(p, location, scale))
rlogis <- function(n, location=0, scale=1) .Internal(rlogis(n, location, scale))
dweibull <- function(x, shape, scale=1) .Internal(dweibull(x, shape, scale))
pweibull <- function(q, shape, scale=1) .Internal(pweibull(q, shape, scale))
qweibull <- function(p, shape, scale=1) .Internal(qweibull(p, shape, scale))
rweibull <- function(n, shape, scale=1) .Internal(rweibull(n, shape, scale))
dbeta <- function(x, shape1, shape2, ncp=0) {
    if(missing(ncp)) .Internal(dbeta(x, shape1, shape2))
    else .Internal(dnbeta(x, shape1, shape2, ncp))
}
pbeta <- function(q, shape1, shape2, ncp=0) {
    if(missing(ncp)) .Internal(pbeta(q, shape1, shape2))
    else .Internal(pnbeta(q, shape1, shape2, ncp))
}
qbeta <- function(p, shape1, shape2) .Internal(qbeta(p, shape1, shape2))
rbeta <- function(n, shape1, shape2) .Internal(rbeta(n, shape1, shape2))
dbinom <- function(x, size, prob) .Internal(dbinom(x, size, prob))
pbinom <- function(q, size, prob) .Internal(pbinom(q, size, prob))
qbinom <- function(p, size, prob) .Internal(qbinom(p, size, prob))
rbinom <- function(n, size, prob) .Internal(rbinom(n, size, prob))
dchisq <- function(x, df, ncp=0) {
    if(missing(ncp)) .Internal(dchisq(x, df))
    else .Internal(dnchisq(x, df, ncp))
}
pchisq <- function(q, df, ncp=0) {
    if(missing(ncp)) .Internal(pchisq(q, df))
    else .Internal(pnchisq(q, df, ncp))
}
qchisq <- function(p, df, ncp=0) {
    if(missing(ncp)) .Internal(qchisq(p, df))
    else .Internal(qnchisq(p, df, ncp))
}
rchisq <- function(n, df, ncp=0) {
    if(missing(ncp)) .Internal(rchisq(n, df))
    else .not.yet.implemented()
}
df <- function(x, df1, df2) .Internal(df(x, df1, df2))
pf <- function(q, df1, df2, ncp=0) {
    if(missing(ncp)) .Internal(pf(q, df1, df2))
    else .Internal(pnf(q, df1, df2, ncp))
}
qf <- function(p, df1, df2) .Internal(qf(p, df1, df2))
rf <- function(n, df1, df2) .Internal(rf(n, df1, df2))
dgeom <- function(x, prob) .Internal(dgeom(x, prob))
pgeom <- function(q, prob) .Internal(pgeom(q, prob))
qgeom <- function(p, prob) .Internal(qgeom(p, prob))
rgeom <- function(n, prob) .Internal(rgeom(n, prob))
dhyper <- function(x, m, n, k) .Internal(dhyper(x, m, n, k))
phyper <- function(q, m, n, k) .Internal(phyper(q, m, n, k))
qhyper <- function(p, m, n, k) .Internal(qhyper(p, m, n, k))
rhyper <- function(nn, m, n, k) .Internal(rhyper(nn, m, n, k))
dnbinom <- function(x, size, prob) .Internal(dnbinom(x, size, prob))
pnbinom <- function(q, size, prob) .Internal(pnbinom(q, size, prob))
qnbinom <- function(p, size, prob) .Internal(qnbinom(p, size, prob))
rnbinom <- function(n, size, prob) .Internal(rnbinom(n, size, prob))
dpois <- function(x, lambda) .Internal(dpois(x, lambda))
ppois <- function(q, lambda) .Internal(ppois(q, lambda))
qpois <- function(p, lambda) .Internal(qpois(p, lambda))
rpois <- function(n, lambda) .Internal(rpois(n, lambda))
dt <- function(x, df) .Internal(dt(x, df))
pt <- function(q, df, ncp) {
    if(missing(ncp))
	.Internal(pt(q, df))
    else
	.Internal(pnt(q, df, ncp))
}
qt <- function(p, df) .Internal(qt(p, df))
rt <- function(n, df) .Internal(rt(n, df))
ptukey <- function(q, nmeans, df, nranges=1)
    .Internal(ptukey(q, nranges, nmeans, df))
qtukey <- function(p, nmeans, df, nranges=1)
    .Internal(qtukey(p, nranges, nmeans, df))
dwilcox <- function(x, m, n) .Internal(dwilcox(x, m, n))
pwilcox <- function(q, m, n) .Internal(pwilcox(q, m, n))
qwilcox <- function(p, m, n) .Internal(qwilcox(p, m, n))
rwilcox <- function(nn, m, n) .Internal(rwilcox(nn, m, n))
dsignrank <- function(x, n) .Internal(dsignrank(x, n))
psignrank <- function(q, n) .Internal(psignrank(q, n))
qsignrank <- function(p, n) .Internal(qsignrank(p, n))
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
    }
    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.new()
    plot.window(xlim = range(x, finite = TRUE), 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 = digits))
    options(digits = 12)
    .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)
    .Internal(dyn.load(x))
edit <- function(name=NULL, file="", editor=options()$editor)
    .Internal(edit(name,file, editor))
vi <- function(name=NULL, file="") edit(name, file, editor="vi")
emacs <- function(name=NULL, file="") edit(name, file, editor="emacs")
xemacs <- function(name=NULL, file="") edit(name, file, editor="xemacs")
xedit <- function(name=NULL, file="") edit(name, file, editor="xedit")
pico <- function(name=NULL, file="") edit(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))
	    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))
	    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))
	    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))
	    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()
eval <-
    function(expr, envir = sys.frame(sys.parent()),
	     enclos = if(is.list(envir) || is.pairlist(envir))
                       sys.frame(sys.parent()))
    .Internal(eval(expr, envir,enclos))
quote <- function(x) substitute(x)
evalq <-
    function (expr, envir, enclos) 
    eval(substitute(eval(quote(expr), envir, enclos)), 
	 sys.frame(sys.parent()))
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
    args <- list(...)
    if(!length(args)) return(NULL)
    a1 <- args[[1]]
    if(length(args) == 1 && is.list(a1)) args <- a1
    nargs <- length(args)
    if(nargs == 1) return (args[[1]])
    cargs <- args
    nmc <- paste("Var", 1:nargs, sep="")
    nm <- names(args)
    if(is.null(nm)) nm <- nmc
    nmc[nchar(nm)>0] <- nm[nchar(nm)>0]
    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 (length(x) == 0)
	return(character(0))
    exclude <- as.vector(exclude, typeof(x))
    levels <- levels[is.na(match(levels, exclude))]
    f <- match(x, levels)
    names(f) <- names(x)
    attr(f, "levels") <- if (length(labels) == length(levels))
	as.character(labels)
    else if(length(labels) == 1)
	paste(labels, seq(along = levels), sep = "")
    else
	stop("invalid labels argument in \"factor\"")
    attr(f, "class") <- c(if(ordered)"ordered", "factor")
    f
}
"is.factor" <- function(x) inherits(x, "factor")
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.factor" <- function (x) if (is.factor(x)) x else factor(x)
"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")
}
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) stop(paste('"',.Generic,'"', " not meaningful for factors", sep=""))
    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,"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, levels = sort(unique(x), na.last = TRUE), labels = levels,
	      exclude = NA, ordered = TRUE)
{
    if (length(x) == 0)
	return(character(0))
    exclude <- as.vector(exclude, typeof(x))
    levels <- levels[is.na(match(levels, exclude))]
    f <- match(as.character(x), levels)
    names(f) <- names(x)
    attr(f, "levels") <-
	if (length(labels) == length(levels))
	    as.character(labels)
	else if (length(labels) == 1)
	    paste(labels, seq(along = levels), sep = "")
	else
	    stop("invalid labels argument in \"ordered\"")
    attr(f, "class") <- c(if (ordered) "ordered", "factor")
    f
}
"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")
    }
"Ops.ordered" <- function(e1, 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 <- 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)
	return("log")
    return(lambda)
}
## Written by Simon Davies Dec 1995
## Modified by Thomas Lumley 26 Apr 97
## added valideta(eta) function returning TRUE if all of eta
## is in the domain of linkinv
make.link <- function (link)
{
    ## This function is used with  glm().
    ## Given a link, it returns a link function, an inverse link
    ## function and the derivative dmu/deta.
    switch (link,
	    "logit" = {
		linkfun <- function(mu) log(mu/(1 - mu))
		linkinv <- function(eta) exp(eta)/(1 + exp(eta))
		mu.eta <- function(eta) exp(eta)/(1 + exp(eta))^2
		valideta <- function(eta) TRUE
	    },
	    "probit" = {
		linkfun <- function(mu) qnorm(mu)
		linkinv <- pnorm
		mu.eta <- function(eta) 0.3989422 * exp(-0.5 * eta^2)
		valideta <- function(eta) TRUE
	    },
	    "cloglog" = {
		linkfun <- function(mu) log(-log(1 - mu))
		linkinv <- function(eta) 1 - exp(-exp(eta))
		mu.eta <- function(eta) 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) exp(eta)
		mu.eta <- function(eta) 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 :
	{
	    if (!is.na(as.numeric(link))) {
		lambda <- as.numeric(link)
		linkfun <- function(mu) mu^lambda
		linkinv <- function(eta) eta^(1/lambda)
		mu.eta <- function(eta) (1/lambda) * eta^(1/lambda - 1)
		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(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(.)
    initialize <- expression({ n <- rep(1, nobs); mustart <- y })
    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),
	      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) {
    n <- length(x)
    if(length(y) != n)
	stop("length mismatch in convolution")
    Re(fft(fft(x)* (if(conj)Conj(fft(y)) else fft(y)), inv=TRUE))/n
}
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
	stop(paste("no object named \"", subx, "\" to edit",sep=""))
    assign(subx, x, env=.GlobalEnv)
}
formals <- function(fun=sys.function(sys.parent())) {
    if(is.character(fun))
	fun <- get(fun, mode = "function")
    .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())) {
    value <- substitute(value)
    if (is.expression(value))
	value <- value[[1]]
    f <- as.function(c(formals(f), value), envir)
}
"formals<-" <- function (f, value, envir = sys.frame(sys.parent())) {
    value <- substitute(value)
    if (is.expression(value))
	value <- value[[1]]
    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 }
    pad <- sapply(pmax(0,width - nc),
		  function(no) paste(character(no+1), collapse =" "))
    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, .Options$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 (missing(mode))	  mode <- storage.mode(x)
    else if (any(mode == c("double", "real", "integer")))
	storage.mode(x) <- if(mode=="real")"double" else 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))
    }
    some.special <- !all(Ok <- is.finite(x))
    if (some.special) {
	rQ <- as.character(x[!Ok])
	x[!Ok] <- 0
    }
    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"}')
    }
    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))$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),...)
get <-
    function(x, pos=-1, envir=pos.to.env(pos), mode="any", inherits=TRUE)
    .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),
	   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(expand.dots = FALSE)
    ## 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()
    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 + offset)
    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) {
	mu.eta.val <- mu.eta(eta + offset)
	if (any(ina <- is.na(mu.eta.val)))
	    mu.eta.val[ina] <- mu.eta(mu)[ina]
	if (any(is.na(mu.eta.val)))
	    stop("NAs in d(mu)/d(eta)")
	## calculate z and w using only values where mu.eta != 0
	good <- mu.eta.val != 0
	if (all(!good)) {
	    conv <- FALSE
	    warning(paste("No observations informative at iteration",
			  iter))
	    break
	}
	z <- eta[good] + (y - mu)[good]/mu.eta.val[good]
	w <- sqrt((weights * mu.eta.val^2)[good]/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)
			)
	## 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] <-
	    if (nvars == 1) x[good] * start else as.vector(x[good, ] %*% start)
	mu <- linkinv(eta + offset)
	if (family$family == "binomial") {
	    if (any(mu == 1) || any(mu == 0))
		warning("fitted probabilities of 0 or 1 occurred")
	    mu0 <- 0.5 * control$epsilon/length(mu)
	    mu[mu == 1] <- 1 - mu0
	    mu[mu == 0] <- mu0
	}
	else if (family$family == "poisson") {
	    if (any(mu == 0))
		warning("fitted rates of 0 occured")
	    mu[mu == 0] <- 0.5 * control$epsilon/length(mu)^2
	}
	dev <- sum(dev.resids(y, mu, weights))
	if (control$trace)
	    cat("Deviance =", dev, "Iterations -", iter, "\n")
	## check for divergence
	boundary <- FALSE
	if (any(is.na(dev)) || any(is.na(coef))) {
	    warning("Step size truncated due to divergence")
	    ii <- 1
	    while ((any(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] <-
		    if (nvars == 1) x[good] * start else as.vector(x[good, ] %*% start)
		mu <- linkinv(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] <-
		    if (nvars == 1) x[good] * start else as.vector(x[good, ] %*% start)
		mu <- linkinv(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")
    ## 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[good]
    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
    names(w) <- ynames
    names(weights) <- ynames
    names(y) <- ynames
    names(fit$effects) <-
	c(xxnames[seq(fit$rank)], rep("", nobs - fit$rank))
    ## calculate null deviance
    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 = w^2,
	 prior.weights = weights, df.residual = resdf, df.null = nulldf,
	 y = y, converged = conv, boundary = boundary)
}
print.glm <- function (x, digits= max(3, .Options$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, na.action=na.omit)
{
    ## 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,
			     na.action=na.action))
    ##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, na.action=na.omit)
{
    ## 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]], na.action=na.action, 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, na.action=na.omit)
{
    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, .Options$digits - 3),
			       na.print = "", symbolic.cor = p > 4,
			       signif.stars= .Options$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\n", sep="")
    correl <- x$correlation
    if(!is.null(correl)) {
	p <- dim(correl)[2]
	if(p > 1) {
	    cat("Correlation of Coefficients:\n")
	    correl[!lower.tri(correl)] <- NA
	    print(correl[-1, -NCOL(correl), drop=FALSE],
		  digits=digits, na="")
	}
	cat("\n")
    }
    invisible(x)
}
## GLM Methods for Generic Functions :
coef.glm <- function(x) x$coefficients
deviance.glm <- function(x) x$deviance
effects.glm <- function(x) x$effects
fitted.glm <- function(x) x$fitted.values
family.glm <- function(x) x$family
residuals.glm <- function(x, type="deviance")
{
    ntyp <- match(type, c("deviance", "pearson", "working", "response"))
    if(is.na(ntyp))
	stop(paste("invalid `type':", type))
    y  <- x$y
    mu <- x$fitted.values
    wts <- x$prior.weights
    switch(ntyp,
	   deviance = if(x$df.res > 0) {
	       d.res <- sqrt((x$family$dev.resids)(y, mu, wts))
	       ifelse(y > mu, d.res, -d.res)
	   } else rep(0, length(mu)),
	   pearson	 = x$residuals * sqrt(x$weights),
	   working	 = x$residuals,
	   response = y - mu
	   )
}
## 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)
##{
##	call <- glm.obj$call
##	if (!missing(formula))
##	  call$formula <- update.formula(call$formula, formula)
##	if (!missing(data))	call$data <- substitute(data)
##	if (!missing(subset))	call$subset <- substitute(subset)
##	if (!missing(na.action))call$na.action <- substitute(na.action)
##	if (!missing(weights))	call$weights <- substitute(weights)
##	if (!missing(offset))	call$offset <- substitute(offset)
##	if (!missing(family))	call$family <- substitute(family)
##	if (!missing(x))	call$x <- substitute(x)
####	notparent <- c("NextMethod", "update", methods(update))
####	for (i in 1:(1+sys.parent())) {
####		parent <- sys.call(-i)[[1]]
####		if (is.null(parent))
####		break
####	if (is.na(match(as.character(parent), notparent)))
####			break
####	}
####	eval(call, sys.frame(-i))
##	eval(call, sys.frame(sys.parent()))
##}
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, .Options$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, .Options$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))
}
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))
}
"grid" <-
    function (nx=3, ny=3, col="lightgray", lty="dotted")
{
    lims <- par("usr")
    if (nx > 1) {
	coord <- seq(lims[1], lims[2], len = nx + 2)[c(-1, -(nx + 2))]
	abline(v = coord, col = col, lty = lty)
    }
    if (ny > 1) {
	coord <- seq(lims[3], lims[4], len = ny + 2)[c(-1, -(ny + 2))]
	abline(h = coord, col = col, lty = lty)
    }
}
# Don't wrap hdf5save yet.  It doesn't work ...
# hdf5save <- function(file, ...) .Internal(hdf5save(file, ...))
hdf5load <- function(file, load=TRUE) .Internal(hdf5load(file, load))
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, ...)
{
    if (!is.numeric(x))
	stop("hist: x must be numeric")
    eval(main)
    eval(xlab)
    n <- length(x <- x[!is.na(x)])
    use.br <- !missing(breaks) && (nB <- length(breaks)) > 1
    if(use.br)
	breaks <- sort(breaks)
    else {
	dx <- diff(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) $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)) {
	if(!is.null(x$null.value)) {
	    if(length(x$null.value) == 1) {
		if (x$alternative == "two.sided" )
		    alt.char <- "not equal to"
		else if( x$alternative == "less" )
		    alt.char <- "less than"
		else if( x$alternative == "greater" )
		    alt.char <- "greater than"
		cat("alternative hypothesis:", "true", names(x$
							     null.value), "is", alt.char, x$null.value,
		    "\n")
	    }
	    else {
		cat("alternative hypothesis:", x$alternative,
		    "\n")
		cat("null values:\n")
		print(x$null.value)
	    }
	}
	else cat("alternative hypothesis:", 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)
    ans[test] <- rep(yes, length = length(ans))[test]
    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, finite = TRUE), xlim = range(x, finite = TRUE),
	      ylim = range(y, finite = TRUE), 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 {
		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 (!add)
	plot(0, 0, xlim = xlim, ylim = ylim, type = "n", xaxs = xaxs,
	     yaxs = yaxs, xlab = xlab, ylab = ylab, ...)
    .Internal(image(as.double(x), as.double(y), as.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"
#### 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)) $ k
    }
}
#### 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, ...) {
    if (is.character(FUN))
	FUN <- get(FUN, mode = "function")
    if (mode(FUN) != "function")
	stop(paste("\"", FUN, "\" is not a function", sep = " "))
    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)
}
##--- NOTE:
##    when no device is open, layout() should open the default device,
## as  par(.) does
##
## !!!!
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)
{
    ## show the regions that will be allocated to the next
    ## n figures
    ## 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 1: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 = NULL,
	      y.intersp = NULL, text.width = NULL, merge = FALSE, trace = FALSE)
{
    if (missing(y)) {
	if (is.list(x)) { y <- x$y; x <- x$x } else stop("missing y")
    }
    if (!is.numeric(x) || !is.numeric(y))
	stop("non-numeric coordinates")
    if (length(x) <= 0 || length(x) != length(y))
	stop("differing 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")
    ## These defaults should  DEPEND  on  text.width (& maybe x/y log):
    if(is.null(x.intersp)) x.intersp <- min(4, 1.8 + 1.2* Cex^-1.25)
    if(is.null(y.intersp)) y.intersp <- min(2, 0.2 + Cex^-1.25)
    if(trace) cat('Legend: Cex=',formatC(Cex),' ==>  x.intersp=',
		  format(x.intersp),'; y.intersp=', format(y.intersp),"\n")
    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")
    xbox <- xc * 0.8 ##= sizes of filled boxes.
    ybox <- yc * 0.8
    n.leg <- length(legend)
    ## -- (w,h) := (width,height) of the box to draw -- computed stepwise...
    w <- 2 * xchar + text.width
    h <- (n.leg + 1) * ychar
    if(!missing(fill))
	w <- w + (dx.fill <- xbox + xchar)
    if(!missing(pch)) {
	if(is.character(pch) && nchar(pch) > 1) {
	    np <- nchar(pch)
	    pch <- substr(rep(pch[1], np), 1:np, 1:np)
	}
	if(!merge) w <- w + (dx.pch <- x.intersp/2 * xchar)
    }
    do.lines <- (!missing(lty) && any(lty > 0)) || !missing(lwd)
    if(do.lines)
	if(!merge) w <- w + x.intersp * xchar
    if(merge) # we didn't add space above, so must do now
	w <- w + x.intersp * xchar
    ##
    ##-- (w,h) are now the final box width/height. --> Adjust (x,y) :
    if (xlog) x <- log10(x)
    if (ylog) y <- log10(y)
    if(length(x) != 1) { # in which situations do we need/want this ??
	x <- mean(x)
	y <- mean(y)
	xjust <- 0.5
	yjust <- 0.5
    }
    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 -------------
	if(trace)
	    cat("  fill: rect2(", xt,",", yt+ybox/2,", dx=", xbox,", dy=", ybox/2,")\n")
	rect2(xt, yt + ybox/2, dx = xbox, dy = ybox/2, col = fill)
	xt <- xt + dx.fill
    }
    col <- rep(col,length.out=n.leg)
    if (!missing(pch)) {		  #- draw points -------------------
	pch <- rep(pch,length.out=n.leg)
	ok <- is.character(pch) | pch > 0
	x1 <- (xt + ifelse(merge,0, 0.25) * 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 ---------------------
	if(missing(lty)) { lty <- 1; ok.l <- TRUE }
	else ok.l <- lty > 0
	if(missing(lwd)) lwd <- 1
	lty <- rep(lty, length.out = n.leg)
	lwd <- rep(lwd, length.out = n.leg)
	x.off <- if(merge) -0.8 else 0
	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 + 3 * xchar
    }
    if (merge) xt <- xt + x.intersp * xchar
    ## adj = (x,y) text-box adjustment
    if(trace)
	cat("  text(xt=", xt,", yt=", yt,",.. adj.y=", 0.3*y.intersp,")\n")
    text2(xt, yt, labels= legend, adj= c(0, 0.3*y.intersp), cex= cex)
}
##-- Keep  'library' and 'library.dynam'  PLATFORM-Indepedent !
##-- Use  .Platform  in	 ./system.unix.R [./system.win.R , ...] to configure!
##	  ~~~~~~~~~
library <- function (name, help, lib.loc = .lib.loc, character.only = FALSE,
		     logical.return = FALSE, warn.conflicts = name != "MASS")
{
    fsep <- .Platform$file.sep
    if (!missing(name)) {
	if (!character.only)
	    name <- as.character(substitute(name))
	lib.source <- function(file, env) {
	    exprs <- parse(n = -1, file = file)
	    if (length(exprs) == 0)
		return(invisible())
	    for (i in exprs) yy <- eval(i, env)
	    invisible()
	}
	pkgname <- paste("package", name, sep = ":")
	if (is.na(match(pkgname, search()))) {
	    packagedir <- system.file("", name, lib.loc)
	    if (packagedir == "") {
		txt <- paste("There is no package called `", name, "'", sep= "")
		if (logical.return) {
		    warning(txt)
		    return(FALSE)
		}
		else stop(txt)
	    }
	    which.lib.loc <-
		lib.loc[match(packagedir[1], paste(lib.loc, name, "",sep=fsep))]
	    if (length(packagedir) > 1) {
		warning(paste("Package `", name, "' found more than once,\n  ",
			      "using the one found in `", which.lib.loc, "'",
			      sep = ""))
	    }
	    file <- system.file(paste("R", name, sep = fsep), name, lib.loc)
	    env <- attach(NULL, name = pkgname)# create environment
	    if (file == "")
		warning(paste("Package `",name,"' contains no R code", sep=""))
	    else
		lib.source(file, env)	# "source" file into env
	    lib.fixup(env, .GlobalEnv)
	    if (exists(".First.lib", envir = env, inherits = FALSE)) {
		firstlib <- get(".First.lib", envir = env, inherits = FALSE)
		firstlib(which.lib.loc, name)
	    }
	    if(warn.conflicts) {
		##-- Check for conflicts
		dont.mind <- c("last.dump", "last.warning",
			       ".Last.value", ".Random.seed")
		lib.pos <- 2		## Currently, package is ALWAYS at "pos=2"
		ob <- objects(lib.pos)
		ipos <- seq(along = sp <- search())[
			    -c(lib.pos, match("Autoloads",sp))]
		for(i in ipos) {
		    obj.same <- match(objects(i), ob, nomatch = 0)
		    fst <- TRUE
		    if(any(obj.same > 0) && 
		       length(same<-(ob <- ob[obj.same])[!ob %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(options()$verbose)
		warning(paste("Package",pkgname,"already present in search()"))
	}
    } else if (!missing(help)) {
	if (!character.only)
	    help <- as.character(substitute(help))
	file <- system.file("INDEX", help, lib.loc)
	if (file == "")
	    stop(paste("No documentation for package `",
		       help, "'", sep = ""))
	else
	    .Platform$ show.file(file)
    } else {				## library():
	libfil <- tempfile("R.")
	avail <- NULL
	file.exists <- function(f) system.test("-r",f)# yes, a hack..
	for (lib in lib.loc) {
	    cat("\nPackages in library `",
		lib, "':\n\n", sep = "", file = libfil, append = TRUE)
	    if(file.exists(libind <- paste(lib, "LibIndex", sep = fsep))) {
		.Platform$ append.file(libfil, libind)
		## This gives warnings and partly garbage,
		## since contrib's LibIndex isn't really "clean":
		a <- NULL## scan(libind, what=list("",""), sep="\t",
		##-		 quiet = TRUE, flush=TRUE)[[1]]
	    } else {
		a <- .packages(all.available = TRUE, lib.loc=lib)
		for (i in a) {
		    title <- system.file("TITLE",i,lib)
		    if (title != "") 
			.Platform$ append.file(libfil, title)
		    else
			cat(i,"\n", file=libfil, append = TRUE)
		}
	    }
	    avail <- c(avail, a)
	}
	.Platform$ show.file(libfil)
	unlink(libfil)
	return(invisible(avail))
    }
    if (logical.return)
	TRUE
    else invisible(.packages())
}
library.dynam <-
    function(chname, package = .packages(), lib.loc = .lib.loc,
	     verbose = .Options$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)
    fsep <- .Platform$file.sep
    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(paste("libs", fsep, chname, file.ext, sep = ""),
			    package, lib.loc)
	if (file == "") {
	    stop(paste("dynamic library `", chname, "' not found", sep = ""))
	}
	if(verbose) cat("now dyn.load(",file,")..\n", sep="")
	.Internal(dyn.load(file))
	assign(".Dyn.libs", c(.Dyn.libs, chname), envir = .AutoloadEnv)
    }
    invisible(.Dyn.libs)
}
require <- function(name, quietly = FALSE) {
    name <- as.character(substitute(name)) # allowing "require(eda)"
    if (!exists(".Provided", inherits = TRUE))
	assign(".Provided", character(0), envir = .GlobalEnv)
    if (is.na(match(paste("package", name, sep = ":"), search()))
	&& is.na(match(name, .Provided))) {
	if (!quietly)
	    cat("Loading required package:", name, "\n")
	library(name, char = TRUE, logical = TRUE)
    }
    else
	TRUE
}
provide <- function(name) {
    if (!exists(".Provided", inherits = TRUE))
	assign(".Provided", character(0), envir = .GlobalEnv)
    if (missing(name))
	.Provided
    else {
	name <- as.character(substitute(name))
	if (is.na(match(name, .packages())) &&
	    is.na(match(name, .Provided))) {
	    assign(".Provided", c(name, .Provided), envir = .GlobalEnv)
	    TRUE
	}
	else
	    FALSE
    }
}
.packages <- function(all.available = FALSE, lib.loc = .lib.loc) {
    if(all.available) {
	fsep <- .Platform$ file.sep
	a <- strsplit(system.file("*","",lib.loc), fsep)
	ans <- character(0)
	for (i in a) {
	    name <- i[length(i)]
	    pkg <- system.file(paste("R",name, sep=fsep), name, lib.loc) 
	    if (pkg != "") ans <- c(ans,name)
	}
	return(ans)
    } ## else
    s <- search()
    return(invisible(substring(s[substr(s, 1, 8) == "package:"], 9)))
}
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, ...)
{
    ret.x <- x
    ret.y <- y
    mt <- terms(formula, data = data)
    mf <- 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 (!is.null(model.offset(mf)))
	stop("offset() not available in lm(), use glm()")
    if (!singular.ok)
	warning("only `singular.ok = TRUE' is currently implemented.")
    y <- model.response(mf, "numeric")
    w <- model.weights(mf)
    if (is.empty.model(mt)) {
	x <- NULL
	z <- list(coefficients = numeric(0), residuals = y,
		  fitted.values = 0 * y, weights = w, rank = 0,
		  df.residual = length(y))
	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) else lm.wfit(x, y, w)
	class(z) <- c(if(is.matrix(y)) "mlm", "lm")
    }
    z$contrasts <- attr(x, "contrasts")
    z$xlevels <- xlev
    z$call <- match.call()
    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, method = "qr", tol = 1e-07, ...)
{
    if(is.null(n <- nrow(x))) stop("'x' must be a matrix")
    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)
    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))
    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 - 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, method = "qr", tol = 1e-7, ...)
{
    if(is.null(n <- nrow(x))) stop("'x' must be a matrix")
    ny <- NCOL(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."))
    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, ]
	x <- x[ok, ]
	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))
    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
	    save.f[nok, ] <- f0
	}
	else {
	    save.r[ok] <- z$residuals
	    save.r[nok] <- y0 - f0
	    save.f[ok] <- z$fitted.values
	    save.f[nok] <- f0
	}
	z$residuals <- save.r
	z$fitted.values <- save.f
	z$weights <- save.w
    }
    c(z[c("coefficients", "residuals", "fitted.values", "effects",
	  "weights", "rank")],
      list(assign = attr(x, "assign"),
	   qr = z[c("qr", "qraux", "pivot", "tol", "rank")],
	   df.residual = n - z$rank))
}
print.lm <- function(x, digits = max(3, .Options$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)
    n <- NROW(Qr$qr)
    p <- z$rank
    rdf <- n - p
    p1 <- 1:p
    r <- resid(z)
    f <- fitted(z)
    w <- weights(z)
    if (is.null(z$terms)) {
	stop("invalid \'lm\' object:  no terms component")
    } else {
	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, .Options$digits - 3), symbolic.cor = p > 4,
	      signif.stars= .Options$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("Residuals:\n")
    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 <- dim(correl)[2]
	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],
		      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(x) x$residuals
fitted.lm <- function(x) x$fitted.values
coef.lm <- function(x) x$coefficients
weights.lm <- function(x) x$weights
df.residual.lm <- function(x) x$df.residual
deviance.lm <- function(x) sum((x$residuals)^2)
formula.lm <- function(x) formula(x$terms)
family.lm <- function(x) { 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]
    dfr <- df.residual(object)
    ss <- c(as.numeric(lapply(split(comp^2,asgn),sum)),ssr)
    df <- c(as.numeric(lapply(split(asgn,  asgn),length)), dfr)
    if(attr(object$terms,"intercept")) {
	ss <- ss[-1]
	df <- df[-1]
    }
    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"
}
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)
{
    if(missing(newdata)) X <- model.matrix(object)
    else
	X <- model.matrix(delete.response(terms(object)), newdata,
			  contrasts = object$contrasts, xlev = object$xlevels)
    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)
    interval <- match.arg(interval)
    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
	ip <- real(NROW(X))
	for (i in (1:NROW(X))) {
	    xi <- X[i, piv]
	    ip[i] <- xi %*% vcov %*% xi
	}
    }
    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")
}
## Old version below, did it ever work?
## effects.lm <- function(z, term) {
##  term <- deparse(substitute(term))
##  k <- match(term,attr(z$terms,"term.labels"))
##  if(is.na(k)) stop("effect not found")
##  pattern <- attr(z$terms,"factors")[,k]
##  factors <- as.logical(lapply(z$model.frame,is.factor))
##  y <- model.response(z$model.frame,"numeric")
##  k <- range(seq(length(z$assign))[z$assign==k])
##  yhat0 <- if(k[1] > 1) qr.fitted(z$qr,y,k[1]-1) else 0
##  yhat1 <- qr.fitted(z$qr,y,k[2])
##  effects <- yhat1-yhat0
##  tapply(effects,z$model.frame[factors & pattern!=0],mean,na.rm=TRUE)
##}
plot.lm <- function(x,...) {
    if(!any(class(x) == "lm")) stop("Use only with 'lm' objects")
    r <- residuals(x)
    yh<- fitted(x)
    hii <- lm.influence(x)$hat
    if(prod(par("mfcol")) < 2 && interactive()) {
	op <- par(ask = TRUE); on.exit(par(op))
    }
    plot(yh,r, xlab="Fitted values", ylab="Residuals",
	 main = paste("Tukey-Anscombe plot of", deparse(x$call)))
    abline(h=0, lty=3, col = "gray")
    qqnorm(r/sqrt(1-hii), ylab = "Standardized Residuals")
}
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)
{
    w <- weights(obj)
    if(is.null(w)) residuals(obj)
    else (sqrt(w)*residuals(obj))[w!=0]
}
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,
	     lm.obj$coefficients,
	     e,
	     hat = double(n),
	     coefficients = matrix(0, nr = n, nc = k),
	     sigma = double(n),
	     DUP = FALSE)[c("hat", "coefficients", "sigma")]
}
rstudent <- function(lm.obj)
{
    infl <- lm.influence(lm.obj)
    weighted.residuals(lm.obj)/(infl$sigma * sqrt(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
}
dffits <- function(lm.obj)
{
    infl <- lm.influence(lm.obj)
    sqrt(infl$hat)*residuals(lm.obj)/(infl$sigma*(1-infl$hat))
}
covratio <- function(lm.obj)
{
    infl <- lm.influence(lm.obj)
    n <- nrow(lm.obj$qr$qr)
    p <- lm.obj$rank
    e.star <- residuals(lm.obj)/(infl$sigma*sqrt(1-infl$hat))
    1/((((n - p - 1)+e.star^2)/(n - p))^p*(1-infl$hat))
}
cooks.distance <- function(lm.obj)
{
    p <- lm.obj$rank
    e <- weighted.residuals(lm.obj)
    s <- sqrt(sum(e^2)/df.residual(lm.obj))
    h <- lm.influence(lm.obj)$hat
    ((e/(s * (1 - h)))^2 * h)/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,
			absmat[, k + 1] > 3 * sqrt(k/(n - k)),
			abs(1 - infmat[, k + 2]) > (3 * k)/(n - k),
			qf(infmat[, k + 3], k, n - k) > 0.9,
			infmat[, k + 4] > (3 * k)/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)
    ##is.star <- apply(is.inf, 1, any)
    ans <- list(infmat = infmat, is.inf = is.inf, call = lm.obj$call)
    class(ans) <- "infl"
    ans
}
print.infl <- function(x, digits = max(3, .Options$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, .Options$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, .Options$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, .Options$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))
load <- function(file)
    .Internal(load(file))
save <- function(..., list = character(0), file = "", ascii = FALSE) {
    names <- as.character( substitute( list(...)))[-1]
    list<- c(list, names)
    invisible(.Internal(save( list, file, ascii)))
}
save.image <- function (f = ".RData")
    eval(substitute(save(list = ls(), file = f)), .GlobalEnv)
locator <- function(n=1) {
    z <- .Internal(locator(n))
    x <- z[[1]]
    y <- z[[2]]
    n <- z[[3]]
    if(n==0) NULL else 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))
    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))[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))
    ## 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))
}
macintosh <- function (display = "", width = 7, height = 7, pointsize = 12) 
.Internal(Macintosh(display, width, height, pointsize))
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, y) match(x, y, 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 must be character")
    y <- .Internal(charmatch(input,target))
    if(any(is.na(y))) eval(nomatch)
    target[y]
}
## 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,
		    xlab=NULL, ylab=NULL, xlim=NULL, ylim=NULL,
		    ..., add= FALSE, verbose = .Options$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 <- 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, finite = TRUE)  else xlim
    ylim <- if (is.null(ylim)) range(xy$y, finite = TRUE)  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)
    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], ...)
    }
    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])
	if(do.points && tp=='p')
	    points(x[,i],y[,i], pch=pch[i], col=col[i])
    }
}
matrix <- function(data=NA, nrow=1, ncol=1, byrow=FALSE, dimnames=NULL) {
    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 {
	cat("Selection: ")
	ind <- .Internal(menu(as.character(choices)))
	if(ind <= nc)
	    return(ind)
	cat("Enter an item from the menu, or 0 to exit\n")
    }
}
#### 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]]),
		      "(" = "(",
		      ## otherwise
		      "call"))
    if(is.name(x)) "name" else
    switch(tx <- typeof(x),
	   double=, real=, integer= "numeric",# 'real' not used anymore [4/98,MM]
	   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
    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 = na.fail)
{
    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) && !is.null(tj <- attr(data, "na.action")))
	na.action <- tj
    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 = .Options$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 (df) 
{
    nm <- sapply(names(df), 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")))
}
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(x, ...) UseMethod("coef")
coef.default <- function(x, ...) x$coefficients
coefficients <- .Alias(coef)
residuals <- function(x, ...) UseMethod("residuals")
resid <- .Alias(residuals)
deviance <- function(x, ...) UseMethod("deviance")
fitted <- function(x, ...) UseMethod("fitted")
fitted.default <- function(x) x$fitted
fitted.values <- .Alias(fitted)
anova <- function(x, ...)UseMethod("anova")
effects <- function(x, ...)UseMethod("effects")
weights <- function(x, ...)UseMethod("weights")
df.residual <- function(x, ...)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(x) x
## ?
na.action <- function(x, ...)UseMethod("na.action")
na.action.default <- function(x) attr(x, "na.action")
na.fail <- function(frame)
{
    ok <- complete.cases(frame)
    if(all(ok)) frame else stop("missing values in data frame");
}
na.omit <- function(frame)  {
    n <- length(frame)
    omit <- FALSE
    vars <- seq(length = n)
    for(j in vars) {
	x <- frame[[j]]
	if(!is.atomic(x)) next
    # variables are assumed to be either some sort of matrix, numeric or cat'y
	x <- is.na(x)
	d <- dim(x)
	if(is.null(d) || length(d) != 2)
		omit <- omit | x
	else {
	    for(ii in 1:d[2])
		    omit <- omit | x[, ii]
	    }
	}
    xx <- frame[!omit,  , drop = F]
    if (any(omit)) {
	temp <- seq(omit)[omit]
	names(temp) <- row.names(frame)[omit]
	attr(temp, 'class') <- 'omit'
	attr(xx, "na.action") <- temp
	}
    xx
    }
##-- used nowhere (0.62)
##- model.data.frame <- function(...) {
##-	cn <- as.character(substitute(list(...))[-1])
##-	rval<-data.frame(..., col.names=cn, as.is=TRUE)
##-	names(rval)<-cn
##-	rval
##- }
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 <- options("na.action")[[1]]))
	    na.action <- naa
    }
    if(missing(data))
	data <- sys.frame(sys.parent())
    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()))
    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("variable", nm, "is not a factor")
		else {
		    xi <- xi[, drop= TRUE] # drop unused levels
		    if(any(m <- is.na(match(nxl, xl))))
			stop("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(.Options$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, main = NA, sort = NA, off = NA, dir = NA,
                       color = FALSE) {
    mosaic.cell <- function(X, x1, y1, x2, y2, off, dir, color, lablevx,
                            lablevy, maxdim, currlev, label) {
        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,ncol(X)]) / sum(X[,ncol(X)])
            }
            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) {
                if (is.na(label[[1]][1])) {
                    this.lab <- paste(rep(as.character(currlev),
                                          length(currlev)),
                                      as.character(1:xdim), sep=".")
                } else { this.lab <- label[[1]] }
                text(x=(x.l + (x.r - x.l) / 2),
                     y=(965 + 22 * (lablevx - 1)), 
                     srt=0,adj=.5, cex=.5, this.lab)
            }
            if (ncol(X) > 2) {          # recursive call.
                for (i in 1:xdim) {
                    if (XP[i] > 0) {
                        mosaic.cell(as.matrix(X[X[,1]==i,2:ncol(X)]),
                                    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:ncol(X)])
                    } 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 {
                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 {                        # 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,ncol(X)]) / sum(X[,ncol(X)])
            }
            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) {
                if (is.na(label[[1]][1])) {
                    this.lab <- paste(rep(as.character(currlev),
                                          length(currlev)), 
                                      as.character(1:ydim), sep=".")
                } else { this.lab <- label[[1]] }
                text(x=(35 - 20 * (lablevy - 1)),
                     y=(y.b + (y.t - y.b) / 2),
                     srt=90, adj=.5, cex=.5, this.lab)
            }
            if (ncol(X) > 2) {          # recursive call.
                for (j in 1:ydim) {
                    if (YP[j] > 0) {
                        mosaic.cell(as.matrix(X[X[,1]==j,2:ncol(X)]),
                                    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:ncol(X)])
                    } 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{                     # 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))
                    }
                }
            }
        }
    }
    frame()
    opar <- par(usr = c(1,1000,1,1000))
    on.exit(par(opar))
    if (is.vector(X)) { X <- array(X) }
    dimd <- length(dim(X))
    if (!is.null(dimnames(X))) { label <- dimnames(X) } else { label <- NA }
    if (dimd>1) {
        Ind <- rep(1:(dim(X)[1]), prod(dim(X)[2:dimd]))
        for (i in 2:dimd) {
            Ind <- cbind(Ind,
                         c(matrix(1:(dim(X)[i]), byrow=TRUE,
                                  prod(dim(X)[1:(i-1)]),
                                  prod(dim(X)[i:dimd]))))
        }
    } else {
        Ind <- 1:(dim(X)[1])
    }
    Ind <- cbind(Ind, c(X))
    if (!is.na(main)) { title(main) }   # Make the title.
    if ((is.na(off[1]))||(length(off)!=dimd)) { # Initialize spacing.
        off <- rep(10,50)[1:dimd]
    }
    if (is.na(dir[1])||(length(dir)!=dimd)) { # Initialize directions.
        dir <- rep(c("v","h"),50)[1:dimd]
    }
    if ((!is.na(sort[1]))&&(length(sort)==dimd)) { # Sort columns.
        Ind <- Ind[,c(sort,dimd+1)]
        off <- off[sort]
        dir <- dir[sort]
        label <- label[sort]
    }
    ncolors <- length(tabulate(Ind[,dimd]))
    if (is.na(color[1])) {
        color <- rep(0, ncolors)
    } else {
        if (length(color) != ncolors) {
            if (!color[1]) { color <- rep(0, ncolors) }
            else { color <- 2:(ncolors+1) }
        }
    }
    mosaic.cell(Ind, 50, 5, 950, 950,
        off/100, dir, color, 2, 2, apply(as.matrix(Ind[,1:dimd]), 2, max),
        1, label)
}
mtext <- function(text, side=3, line=0, outer=FALSE, at=NULL, adj=NA, ...)
    .Internal(mtext(as.char.or.expr(text), side, line, outer, at, adj, ...))
##> ../../../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)
{
    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]
    .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(length(expr) == 2)
	.Internal(deriv.default(expr[[2]], 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)
    }
}
options <-
    function(...) .Internal(options(...))
outer <- function(x, y, FUN="*", ...) {
    if(is.character(FUN))
	FUN <- get(FUN, mode="function", inherits=TRUE)
    nr <- length(x)
    nc <- length(y)
    matrix(
	   FUN(matrix(x, nr, nc), matrix(y, nr, nc, byrow=TRUE), ...),
	   nr, nc)
}
"%o%"<-outer
as.pairlist <- function(x) .Internal(as.vector(x, "pairlist"))
pairlist <- function(...) as.pairlist(list(...))
## This is now .Primitive:
##is.pairlist <- function(x) typeof(x) == "pairlist"
pairs <- function(x, ...) UseMethod("pairs")
pairs.default <- function(x, labels, panel=points, main = NULL,
			  font.main=par("font.main"),
			  cex.main=par("cex.main"), ...)
{
    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)
    }
    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)
	if (i == 1 & 2 * floor(j/2) == j)
	    axis(3)
	if (j == nc & 2 * floor(i/2) != i)
	    axis(4)
	if (i == nc & 2 * floor(j/2) != j)
	    axis(1)
    }
    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",
	   "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","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))
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),
	     theta = 0, phi = 15, r = sqrt(3), d = 1,
	     scale = TRUE, expand = 1, col, border, ...)
{
    ## 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")
    if(missing(col)) col <- par("bg")
    if(missing(border)) border <- par("fg")
    .Internal(persp(x, y, z, xlim, ylim, zlim,
		    theta, phi, r, d, scale, expand, col, border, ...))
}
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)) {
	    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)) {
	    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, ...)
}
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("fg"), bg=NA, pch=par("pch"),
			 cex=par("cex"), lty=par("lty"), lwd=par("lwd"),
			 asp=NA, ...)
{
    xlabel <- if (!missing(x)) deparse(substitute(x))	else NULL
    ylabel <- if (!missing(y)) deparse(substitute(y))	else NULL
    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, finite=TRUE) else xlim
    ylim <- if (is.null(ylim)) range(xy$y, finite=TRUE) 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))
	barplot(table(x), ...)
    else if (is.factor(y)) 
        barplot(table(y, x), legend.text=legend.text, ...)
    else if (is.numeric(y))
	boxplot(y ~ x, ...)
    else NextMethod("plot")
}
plot.formula <- function(formula, data = NULL, subset, na.action,
			 ..., ask = TRUE)
{
    if (missing(na.action)) na.action <- options()$na.action
    m <- match.call(expand.dots = FALSE)
    if (is.matrix(eval(m$data, sys.parent())))
	m$data <- as.data.frame(data)
    m$... <- NULL
    m[[1]] <- as.name("model.frame")
    mf <- eval(m, sys.parent())
    response <- attr(attr(mf, "terms"), "response")
    if (response) {
	varnames <- names(mf)
	y <- mf[[response]]
	ylab <- varnames[response]
	if (length(varnames) > 2) {
	    opar <- par(ask = ask)
	    on.exit(par(opar))
	}
	for (i in varnames[-response])
	    plot(mf[[i]], y, xlab = i, ylab = ylab, ...)
    }
    else plot.data.frame(mf)
}
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=bg, cex=cex, ...))
plot.new <- function(ask=NA) .Internal(plot.new(ask))
frame <- .Alias(plot.new)
pmax <- function (..., na.rm = FALSE)
{
    elts <- list(...)
    maxmm <- as.vector(elts[[1]])
    for (each in elts[-1]) {
	work <- cbind(maxmm, as.vector(each))
	nas <- is.na(work)
	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 (!na.rm) work[,1][nas[,1]+nas[,2] > 0] <- NA
	maxmm <- work[,1]
    }
    attributes(maxmm) <- attributes(elts[[1]])
    maxmm
}
pmin <- function (..., na.rm = FALSE)
{
    elts <- list(...)
    minmm <- as.vector(elts[[1]])
    for (each in elts[-1]) {
	work <- cbind(minmm, as.vector(each))
	nas <- is.na(work)
	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 (!na.rm) work[,1][nas[,1]+nas[,2] > 0] <- NA
	minmm <- work[,1]
    }
    attributes(minmm) <- attributes(elts[[1]])
    minmm
}
points <- function(x, ...) UseMethod("points")
points.default <-
    function(x, y=NULL, type="p", pch=1, col="black", 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, density = -1, angle = 45, border=par("fg"), ...)
{
    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, border=border, ...))
}
.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)
check.options <-
    function(new, name.opt, reset = FALSE, assign.opt = FALSE,
	     envir=.GlobalEnv, check.attributes = c("mode", "length"),
	     override.check= FALSE)
{
    ## Purpose: Utility function for setting options
    lnew <- length(new)
    if(lnew != length(newnames <- names(new)))
	stop(paste("invalid arguments in \"",
		   deparse(sys.call(sys.parent())),
		   "\" (need NAMED args)", sep=""))
    if(reset && exists(name.opt, envir=envir, inherits=FALSE)) {
	if(length(find(name.opt)) <= 1)
	    stop(paste("Cannot reset '", name.opt,
		       "'  since it exists only once in search()!\n", sep=""))
	else rm(list=name.opt, envir=envir)
    }
    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 names in \"",
		       deparse(sys.call(sys.parent())),"\"",sep=""))
	else if(any(matches==0))
	    stop(paste("ambiguous argument names 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))
}
##--> source in ../../../main/devices.c	 and ../../../unix/devPS.c
##	cpars <- old[c("paper", "family", "bg", "fg")]
##	npars <- old[c("width", "height", "horizontal", "pointsize")]
##	cpars <- c(file, as.character(unlist(lapply(cpars, "[", 1))))
##	npars <- as.numeric(unlist(lapply(npars, "[", 1)))
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
predict.glm <-
    function(object, newdata = NULL, type = c("link", "response"),
	     se.fit = FALSE, dispersion = 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)
	else {
	    pred <- predict.lm(object, newdata, se.fit, scale = 1)
	    switch(type,
		   response = {pred <- family(object)$linkinv(pred)},
		   link = )
	}
    } else {
	## summary.survreg has no ... argument.
	if(inherits(object, "survreg")) dispersion <- 1.
	if(is.null(dispersion) || dispersion == 0)
	    dispersion <- summary(object, dispersion=dispersion)$dispersion
	residual.scale <- as.vector(sqrt(dispersion))
	pred <- predict.lm(object, newdata, se.fit, scale = residual.scale)
	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 = )
	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("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)
    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, .Options$digits - 2),
	     signif.stars= .Options$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 && .Options$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(.Options$digits - 2, 3),
			signif.stars= .Options$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)
}
#### 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")
## Later, we may want  a data.frame method ..
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 ... ~~}")
	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,
		  "\\description{",
		  " ~~ A concise (1-5 lines) description of what the function does. ~~",
		  "}",
		  "\\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 <- getenv("RHOME")
    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)
}
prop.test <- function(x, n, p = NULL, alternative = "two.sided",
		      conf.level = 0.95, correct = TRUE)
{
    DNAME <- deparse(substitute(x))
    if (is.matrix(x)) {
	if (ncol(x) != 2)
	    stop("x must have 2 columns")
	l <- nrow(x)
	n <- apply(x, 1, sum)
	x <- x[, 1]
    }
    else {
	DNAME <- paste(DNAME, "out of", deparse(substitute(n)))
	if ((l <- length(x)) != length(n))
	    stop("x and n must have the same length")
    }
    OK <- complete.cases(x, n)
    x <- x[OK]
    n <- n[OK]
    if ((k <- length(x)) < 1)
	stop("Not enough data")
    if (any(n <= 0))
	stop("Elements of n must be positive")
    if (any(x < 0))
	stop("Elements of x must be nonnegative")
    if (any(x > n))
	stop("Elements of x must not be greater than those of n")
    if (is.null(p) && (k == 1))
	p <- .5
    if (!is.null(p)) {
	DNAME <- paste(DNAME, ", null ",
		       ifelse(k == 1, "probability ", "probabilities "),
		       deparse(substitute(p)), sep = "")
	if (length(p) != l)
	    stop("p must have the same length as x and n")
	p <- p[OK]
	if (any((p <= 0) | (p >= 1)))
	    stop("Elements of p must be in (0,1)")
    }
    CHOICES <- c("two.sided", "less", "greater")
    alternative <- CHOICES[pmatch(alternative, CHOICES)]
    if (length(alternative) > 1 || is.na(alternative))
	stop("alternative must be \"two.sided\", \"less\" or \"greater\"")
    if ((k > 2) || (k == 2) && !is.null(p))
	alternative <- "two.sided"
    if ((length(conf.level) != 1) || is.na(conf.level) ||
	(conf.level <= 0) || (conf.level >= 1))
	stop("conf.level must be a single number between 0 and 1")
    correct <- as.logical(correct)
    ESTIMATE <- x/n
    names(ESTIMATE) <- if (k == 1) "p" else paste("prop", 1:l)[OK]
    NVAL <- p
    CINT <- NULL
    YATES <- ifelse(correct && (k <= 2), .5, 0)
    if (k == 1) {
	z <- ifelse(alternative == "two.sided",
		    qnorm((1 + conf.level) / 2),
		    qnorm(conf.level))
	YATES <- min(YATES, abs(x - n * p))
	p.c <- ESTIMATE + YATES / n
	p.u <- ((p.c + z^2 / (2 * n)
		 + z * sqrt(p.c * (1 - p.c) / n + z^2 / (4 * n^2)))
		/ (1 + z^2 / n))
	p.c <- ESTIMATE - YATES / n
	p.l <- ((p.c + z^2 / (2 * n)
		 - z * sqrt(p.c * (1 - p.c) / n + z^2 / (4 * n^2)))
		/ (1 + z^2 / n))
	CINT <- switch(alternative,
		       "two.sided" = c(max(p.l, 0), min(p.u, 1)),
		       "greater" = c(max(p.l, 0), 1),
		       "less" = c(0, min(p.u, 1)))
    }
    else if ((k == 2) & is.null(p)) {
	DELTA <- ESTIMATE[1] - ESTIMATE[2]
	YATES <- min(YATES, abs(DELTA) / sum(1/n))
	WIDTH <- (switch(alternative,
			 "two.sided" = qnorm((1 + conf.level) / 2),
			 qnorm(conf.level))
		  * sqrt(sum(ESTIMATE * (1 - ESTIMATE) / n))
		  + YATES * sum(1/n))
	CINT <- switch(alternative,
		       "two.sided" = c(max(DELTA - WIDTH, -1),
		       min(DELTA + WIDTH, 1)),
		       "greater" = c(max(DELTA - WIDTH, -1), 1),
		       "less" = c(-1, min(DELTA + WIDTH, 1)))
    }
    if (!is.null(CINT))
	attr(CINT, "conf.level") <- conf.level
    METHOD <- paste(ifelse(k == 1,
			   "1-sample proportions test",
			   paste(k, "-sample test for ",
				 ifelse(is.null(p), "equality of", "given"),
				 " proportions", sep = "")),
		    ifelse(YATES, "with", "without"),
		    "continuity correction")
    if (is.null(p)) {
	p <- sum(x)/sum(n)
	PARAMETER <- k - 1
    }
    else {
	PARAMETER <- k
	names(NVAL) <- names(ESTIMATE)
    }
    names(PARAMETER) <- "df"
    x <- cbind(x, n - x)
    E <- cbind(n * p, n * (1 - p))
    if (any(E < 5))
	warning("Chi-square approximation may be incorrect")
    STATISTIC <- sum((abs(x - E) - YATES)^2 / E)
    names(STATISTIC) <- "X-squared"
    if (alternative == "two.sided")
	PVAL <- 1 - pchisq(STATISTIC, PARAMETER)
    else {
	if (k == 1)
	    z <- sign(ESTIMATE - p) * sqrt(STATISTIC)
	else
	    z <- sign(DELTA) * sqrt(STATISTIC)
	if (alternative == "greater")
	    PVAL <- 1 - pnorm(z)
	else
	    PVAL <- pnorm(z)
    }
    RVAL <- list(statistic = STATISTIC,
		 parameter = PARAMETER,
		 p.value = PVAL,
		 estimate = ESTIMATE,
		 null.value = NVAL,
		 conf.int = CINT,
		 alternative = alternative,
		 method = METHOD,
		 data.name = DNAME)
    class(RVAL) <- "htest"
    return(RVAL)
}
### returns value, extra protection.  BDR 29/5/98.
qqnorm <-
    function(y, ylim, main="Normal Q-Q Plot",
	     xlab="Theoretical Quantiles", ylab="Sample Quantiles",
	     plot.it=TRUE, ...)
{
    y <- y[!is.na(y)]
    if(!length(y)) stop("y is empty")
    if (missing(ylim)) ylim <- range(y)
    x <- qnorm((1:length(y) - 0.5)/length(y))
    if(plot.it) plot(x, sort(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))[c(1,6,7,8)]
}
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)
    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")
    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)[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(ncol(y) == 1)
	dim(coef) <- NULL
    return(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)
    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("dqrqy",
	     as.double(qr$qr),
	     n, k,
	     as.double(qr$qraux),
	     y,
	     ny,
	     qy=mat.or.vec(n,ny))$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)
    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("dqrqty",
	     as.double(qr$qr),
	     n, k,
	     as.double(qr$qraux),
	     y,
	     ny,
	     qty=mat.or.vec(n,ny))$qty
}
qr.resid <- 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)
    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))$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))$xb
}
## qr.solve is defined in 'solve'
##---- 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 (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, .Options$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)
    as.vector(diff(quantile(as.numeric(x), c(0.25, 0.75), na.rm=na.rm)))
quit <- function(save = "ask").Internal(quit(save))
q <- .Alias(quit)
range <- function(..., na.rm=FALSE, finite=FALSE) {
    x <- c(..., recursive=TRUE)
    if(finite) x <- x[is.finite(x)]
    else if(na.rm) x <- x[!is.na(x)]
    if(length(x)) c(min(x), max(x)) else NA
}
read.fwf <- function(file, widths, sep = "", as.is = FALSE,
		     skip = 0, row.names, col.names) {
    FILE <- tempfile("R.")
    on.exit(unlink(FILE))
    system(paste("${RHOME}/bin/fwf2table -f",
		 deparse(paste("A", widths, sep = "", collapse = " ")),
		 "-s", deparse(sep), file, ">", FILE))
    read.table(file = FILE, header = FALSE, sep = sep, as.is = as.is,
	       skip = skip, row.names = row.names, col.names = col.names)
}
count.fields <- function(file, sep = "", skip = 0)
    .Internal(count.fields(file, sep, skip))
read.table <-
    function (file, header=FALSE, sep="", row.names, col.names, as.is=FALSE,
	      na.strings="NA", skip=0)
{
    type.convert <-	function(x, na.strings="NA", as.is=FALSE)
	.Internal(type.convert(x, na.strings, as.is))
    ##	basic column counting and header determination;
    ##	rlabp (logical) := it looks like we have column names
    row.lens <- count.fields(file, sep, 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, 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, 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)
	if (!as.is[i])
	    data[[i]] <- type.convert(data[[i]])
    ##	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
}
rect <-
    function(xleft, ybottom, xright, ytop,
	     col=NULL, border=par("fg"), lty=NULL, xpd=FALSE) {
	.Internal(rect(
		       as.double(xleft),
		       as.double(ybottom),
		       as.double(xright),
		       as.double(ytop),
		       col=col,
		       border=border,
		       lty=lty,
		       xpd=xpd))
    }
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) x[length(x):1]
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(diff(x) != 0), 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=T) {
    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("rowsum", dd= as.integer(dd),
			 as.double(na.indicator),
			 x = x,
			 as.double(group))
    new.n <- temp$dd[1]
    ugroup <- unique(group)
    if (is.matrix(x)){
	new.x <- temp$x[1:new.n,]
	dimnames(new.x) <- list(ugroup, dimnames(x)[[2]])
	if (reorder) new.x <- new.x[order(ugroup), ]
	}
    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)
    on.exit(par(oldtick))
    oldtick <- par(tck = ticksize)
    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)
{
    if(is.character(FUN))
	FUN <- get(FUN, mode = "function")
    else if(mode(FUN) != "function") {
	farg <- substitute(FUN)
	if(mode(farg) == "name")
	    FUN <- get(farg, mode = "function")
	else stop(paste("\"", farg, "\" is not a function", sep = ""))
    }
    answer <- lapply(as.list(X), FUN, ...)
    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="", skip=0, nlines=0,
	     na.strings="NA", flush=FALSE, strip.white=FALSE, quiet=FALSE) {
	if(!missing(sep))
	    na.strings<-c(na.strings,"")
	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, 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) {
	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) sqrt(var(x, na.rm=na.rm))
segments <-
    function(x0, y0, x1, y1, col=par("fg"), lty=par("lty"), lwd=par("lwd"), xpd = FALSE)
    .Internal(segments(x0, y0, x1, y1, col=col, lty=lty, lwd=lwd, xpd=xpd))
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(nargs() == 1 && !missing(from))
	return(if(mode(from) == "numeric" && length(from) == 1)
               1:from else seq(along.with = from))
    if(!missing(along.with))
	length.out <- length(along.with)
    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)
{
    sequence <- NULL
    for(i in nvec)
	sequence <- c(sequence, seq(1:i))
    return(sequence)
}
.First.lib <- function(lib, pkg) library.dynam("sockets", pkg, lib)
print.socket<-function(socket){
  cat("Socket connection #",socket$socket,"to",socket$host,"on port",socket$port,"\n")
}
make.socket<-function(host="localhost",port,fail=T,server=F){
  if (!server){
    tmp2<-.C("Rsockconnect",port=as.integer(port),host=host)
  }
  else{
    if (host!="localhost")
      stop("Can only receive calls on local machine")
    tmp<-.C("Rsockopen",port=as.integer(port))
    buffer<-paste(rep("#",256),collapse="")
    tmp2<-.C("Rsocklisten",port=as.integer(tmp[[1]]),buffer=buffer,len=as.integer(256))
    host<-substr(tmp2$buffer,1,tmp2$len)
    .C("Rsockclose",as.integer(tmp$port))
  }
  if (tmp2$port<=0){
    if (fail)
      stop("Socket not established")
    else
      warning("Socket not established")
  }
  rval<-list(socket=tmp2$port,host=host,port=port) 
  class(rval)<-"socket"
  rval
}
close.socket<-function(socket){
  as.logical(.C("Rsockclose",as.integer(socket$socket))[[1]])
}
read.socket<-function(socket, maxlen=256, loop=F){
  buffer<-paste(rep("#",maxlen),collapse="")
  repeat{
    tmp<-.C("Rsockread",as.integer(socket$socket),buffer=buffer,len=as.integer(maxlen))
    rval<-substr(tmp$buffer,1,tmp$len)
    if ((rval>0) | !loop) break
  }
  rval
}
write.socket<-function(socket,string){
  strlen<-length(strsplit(string,NULL)[[1]])
  invisible(.C("Rsockwrite",as.integer(socket$socket),string,as.integer(0),as.integer(strlen),as.integer(strlen))[[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)
    }
    b<-as.matrix(b)
    return(qr.coef(a,b))
}
solve <- function(a, b, ...) UseMethod("solve")
solve.default <- qr.solve
solve.qr <- 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
}
source <-
    function(file, local=FALSE, echo = verbose, print.eval=echo,
	     verbose= .Options$verbose, prompt.echo = .Options$prompt,
	     max.deparse.length=150)
{
    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())
    ass1 <- expression(y <- x)[[1]][[1]] #-- ass1 :  the  '<-' symbol/name
    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) {
	    dep <- substr(paste(deparse(ei), collapse="\n"),
			  12, 1e6)# drop "expression("
	    nd <- nchar(dep) -1 # -1: drop ")"
	    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(ei, envir)
	i.symbol <- mode(ei[[1]]) == "name"
	if(!i.symbol) {
	    curr.fun <- ei[[1]][[1]]## ei[[1]] : the function "<-" or other
	    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 &&
	   (i.symbol|| (length(pf <- paste(curr.fun))==1 &&
			all(paste(curr.fun) != c("<-","cat", "str", "print")))))
	    print(yy)
	if(verbose) cat(" .. after `", deparse(ei), "'\n", sep="")
    }
    invisible(yy)
}
sys.source <- function (file)
{
    exprs <- parse(n = -1, file = file)
    if (length(exprs) == 0) return(invisible())
    for (i in exprs) {
	yy <- eval(i, NULL)
    }
    invisible(yy)
}
demo <- function(topic, device = x11, directory.sep = "/")
{
    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(paste(getenv("RHOME"),
		     "demos",
		     Topics["dir",  i.top],
		     Topics["file", i.top], sep= directory.sep),
	       echo = TRUE, max.deparse.length=250)
    }
}
example <- function(topic, package= .packages(), lib.loc = .lib.loc,
		    echo = TRUE, verbose = .Options$verbose,
		    prompt.echo = paste(abbreviate(topic, 6),"> ", sep=""),
		    directory.sep = "/")
{
    topic <- substitute(topic)
    if(!is.character(topic)) topic <- deparse(topic)[1]
    file <- ""
    for(lib in lib.loc)
        for(pkg in package) {
            AnIndexF <- system.file(paste("help","AnIndex",sep=directory.sep),
                                    pkg, lib)
            if(AnIndexF != "") {
                AnIndex <- scan(AnIndexF,what=c("c","c"),quiet=TRUE)
                i <- match(topic,AnIndex[seq(1,length(AnIndex),2)],-1)
                if(i != -1)	 
                    file <- system.file(paste("R-ex",directory.sep,AnIndex[2*i],
                                              ".R", sep=""),
                                        pkg = pkg, lib = lib)
            } 
            if(file != "") break
        }
    if(file == "") stop(paste("Couldn't find '", topic, "' example", sep=""))
    if(pkg != "base") library(pkg, lib = lib, character.only = TRUE)
    source(file, 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))
    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)[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))
    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)$y
    }
}
split <-
    function( x, f )
    UseMethod( "split" )
split.default <-
    function( x, f )
    .Internal( split( x, as.factor( f ) ) )
split.data.frame <-
    function( x, f )
{
    lapply( split( 1:nrow( x ), f ), function( ind ) x[ ind, , drop = FALSE ] )
}
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))
    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.9 1999/01/06 15:37:49 pd 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 ",
	length(object), "variables:\n")
    ## 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 = .Options$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.9 1999/01/06 15:37:49 pd 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 ""
    std.attr <- "names"			  #-- Default NON interesting attributes
    has.class <- !is.null(cl <- class(object))
    mod <- ""
    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 "num"
		else if(mod == "char") mod <- "chr"
		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)) {
	    str1 <- " Factor class"
	    object <- unclass(object)
	    nl <- length(lev.att <- levels(object))
	    str1 <- paste(str1, " ", le.str, "; ", nl, " levels: ",
			  paste(lev.att[1:min(2,nl)], collapse =","),
			  ":", sep="")
	    std.attr <- "levels"      #- "names"
	} 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); mod <- 'chr' #-- 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) ||
	       (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(mod == 'chr') {
	    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, finite=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(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)
	    y <- y + (unlist(xo) - 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(!is.null(attrib)) {
	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)
	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, .Options$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
}
print.table <-
    function(x, digits= .Options$digits, quote = FALSE, na.print='', ...)
{
    print.default(unclass(x), digits=digits, quote=quote, na.print=na.print, ...)
}
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(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)[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 = "-", ...)
{
    if(is.character(FUN))
	FUN <- get(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"),
		   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 -----------------------------
  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)," !")
  has.na <- any(nax <- is.na(x))
  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)
  symbols <- as.character(symbols)
  if(any(duplicated(symbols)))
    stop(paste("'symbols' must be unique, but are =",
	       paste(symbols, collapse="|")))
  ns <- length(symbols)
  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]
  }
  if(has.na) {
    Scor <- character(length(iS))
    has.na <- is.character(na)# if TRUE, add to legend
    if(has.na) Scor[nax] <- na
    Scor[!nax] <- symbols[iS[!nax]]
  } else Scor <- symbols[iS]
  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)){
    coln <- if(is.null(dimnames(Scor))) {
      dimnames(Scor) <- list(NULL,NULL); NULL } else dimnames(Scor)[[2]]
    dimnames(Scor)[[2]] <-
      if(length(coln)) {
	      ch <- abbreviate(coln, minlength=1)
	      if(sum(1+nchar(ch)) + max(nchar(coln)) + 1 > .Options[["width"]])
					#-- would not fit on one line
		abbreviate(ch, minlength=2, use.classes=FALSE)
	      else ch
      }
      else rep("", dim(Scor)[2])
  }
  formatI <- function(x) { #- format individually
    n<-length(x); r<-character(n); for(i in 1:n) r[i]<-format(x[i]); r
  }
  legend <- c(rbind(formatI(cutpoints), 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)) {
    args <- list(...)
    if (length(args) == 0)
	stop("nothing to tabulate")
    if (length(args) == 1 && is.list(args[[1]]))
	args <- args[[1]]
    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
    }
    bin <- bin[!is.na(bin)]
    array(tabulate(bin + 1, pd), dims, dimnames = dn)
}
tabulate <- function(bin, nbins = max(bin))
{
    if(!is.numeric(bin) && !is.factor(bin))
	stop("tabulate: bin must be numeric or a factor")
    bin <- as.integer(if((n <- length(bin)) == 0) 1 else bin)
    .C("tabulate",
       bin,
       n,
       ans = integer(nbins))$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, ...)
    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
    index <- as.numeric(names(ans))
    names(ans) <- NULL
    ansmat[index] <- ans
    ansmat
}
as.char.or.expr <- function(x) {
    if (is.expression(x)) x else unlist(strsplit(as.character(x), "\n"))
}
text <- function(x, ...) UseMethod("text")
text.default <- function(x, y = NULL, labels = seq(along = x), adj =
			 NULL, ...) {
    if (!missing(y) && (is.character(y) || is.expression(y))) {
	labels <- y; y <- NULL
    }
    .Internal(text(xy.coords(x,y, recycle=TRUE),
		   as.char.or.expr(labels), adj, ...))
}
system.time <- function(expr) {
    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)
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)
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")
## The first 2 as requested by	<la-jassine@aix.pacwan.net>
start.default	<- function (x) start(ts(x))
end.default	<- function (x)	end(ts(x))
frequency.default<-function (x) frequency(ts(x))
time.default	<- function (x)	time(ts(x))
window.default	<- function (x)	window(ts(x))
options(ts.eps = 1e-5)#- default as S
ts <- function(data=NA, start=1, end=numeric(0), frequency=1, deltat=1,
	       ts.eps = .Options$ts.eps)
{
    if(is.matrix(data)) {
	nseries <- ncol(data)
	ndata <- nrow(data)
    } else {
	nseries <- 1
	ndata <- length(data)
    }
    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
    nobs <- floor((end - start) * frequency + 1.01)
    if(nobs != ndata)
	data <-
	    if(nseries == 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 fix !
    attr(data, "class") <- "ts"
    data
}
tsp <- function(x) attr(x, "tsp")
"tsp<-" <- function(x, value)
{
    cl <- class(x)
    attr(x,"tsp") <- value
    class(x) <-
	if (is.null(value) && inherits(x,"ts")) cl["ts" != cl] else c("ts",cl)
    x
}
is.ts <-function (x) inherits(x, "ts")
as.ts <-function (x) if (is.ts(x)) x else ts(x)
start.ts <- function(x)
{
    ts.eps <- .Options$ts.eps
    ##if(is.null(ts.eps)) ts.eps <- 1.e-5
    tsp <- attr(as.ts(x), "tsp")
    is <- tsp[1]*tsp[3]
    if(abs(is-round(is)) < ts.eps) {
	is <- floor(tsp[1])
	fs <- floor(tsp[3]*(tsp[1] - is)+0.001)
	c(is,fs+1)
    }
    else tsp[1]
}
end.ts <- function(x)
{
    ts.eps <- .Options$ts.eps
    ##if(is.null(ts.eps)) ts.eps <- 1.e-5
    tsp <- attr(as.ts(x), "tsp")
    is <- tsp[2]*tsp[3]
    if(abs(is-round(is)) < ts.eps) {
	is <- floor(tsp[2])
	fs <- floor(tsp[3]*(tsp[2] - is)+0.001)
	c(is, fs+1)
    }
    else tsp[2]
}
frequency.ts <- function(x) { attr(as.ts(x), "tsp")[3] }
time.ts <- function (x)
{
    x <- as.ts(x)
    n <- if(is.matrix(x)) nrow(x) else length(x)
    xtsp <- attr(x, "tsp")
    ts(seq(xtsp[1], xtsp[2], length=n),
       start=start(x), end=end(x), frequency=frequency(x))
}
print.ts <- function(x, calendar, ...)
{
    x <- as.ts(x)
    fr.x <- frequency(x)
    if(missing(calendar))
	calendar <- any(fr.x==c(4,12))
    if(!is.matrix(x) && calendar) {
	if(fr.x > 1) {
	    start.pad <- start(x)[2] - 1
	    end.pad <- fr.x - end(x)[2]
	    dn1 <- start(x)[1]:end(x)[1]
	    dn2 <-
		if(fr.x == 12)	month.abb
		else if(fr.x == 4) {
		    dn1 <- paste(dn1, ":" , sep="")
		    c("Qtr1", "Qtr2", "Qtr3", "Qtr4")
		} else paste("p", 1:fr.x, sep="")
	    x <- matrix(c(rep(NA, start.pad), x,
			  rep(NA, 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' --
	cat("Time-Series:\nStart =", deparse(start(x)),
	    "\nEnd =", deparse(end(x)),
	    "\nFrequency =", deparse(fr.x), "\n")
	tx <- time(x)
	attr(x, "tsp") <- NULL
	attr(x, "class") <- NULL
	##>> something like this is needed here
	##---  if(is.matrix(x)) rownames(data) <- tx
    }
    NextMethod("print", ...)
    invisible(x)
}
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, ...)
{
    xlabel <- if (!missing(x)) deparse(substitute(x))	else NULL
    ylabel <- if (!missing(y)) deparse(substitute(y))	else NULL
    x <- as.ts(x)
    if(!is.null(y)) {
	## want ("scatter") plot of y ~ x
	y <- as.ts(y)
	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, finite=TRUE) else xlim
	ylim <- if (is.null(ylim)) range(xy$y, finite=TRUE) 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, finite=TRUE)
    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(...)
}
window.ts <- function(x, start, end)
{
    x <- as.ts(x)
    xtsp <- tsp(x)
    freq <- xtsp[3]
    xtime <- time(x)
    ts.eps <- .Options$ts.eps
    start <- if(missing(start))
	xtsp[1]
    else switch(length(start),
		start,
		start[1] + (start[2] - 1)/freq,
		stop("Bad value for start"))
    if(start < xtsp[1]) {
	start <- xtsp[1]
	warning("start value not changed")
    }
    end <- if(missing(end))
	xtsp[2]
    else switch(length(end),
		end,
		end[1] + (end[2] - 1)/freq,
		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/freq) > xtime)]
    }
    if(all(abs(end - xtime) > abs(end) * ts.eps)) {
	end <- xtime[(xtime < end) & ((end - 1/freq) < xtime)]
    }
    i <- trunc((start - xtsp[1]) * freq + 1.5):
	trunc(( end  - xtsp[1]) * freq + 1.5)
    x <- if(is.matrix(x)) x[i, , drop = FALSE] else x[i]
    tsp(x) <- c(start, end, freq)
    x
}
"[.ts" <- function (x, i, j, drop = TRUE)
{
    y <- NextMethod("[")
    if (missing(i))
	ts(y, start = start(x), freq = frequency(x))
    else {
	n <- if (is.matrix(x)) nrow(x) else length(x)
	li <- length(ind <- (1:n)[i])
	if(li > 1) delta <- unique(ind[-1] - ind[-li])
	if (li <= 1 || length(delta) != 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]))
	}
	y
    }
}
t.test <- function(x, y=NULL, alternative="two.sided",mu=0, paired = FALSE, var.equal = FALSE,	conf.level = 0.95) {
    choices<-c("two.sided","greater","less")
    alt<- pmatch(alternative,choices)
    alternative<-choices[alt]
    if( length(alternative)>1 || is.na(alternative) )
	stop("alternative must be one \"greater\", \"less\", \"two.sided\"")
    if( !missing(mu) )
	if( length(mu) != 1  || is.na(mu) )
	    stop("mu must be a single number")
    if( !missing(conf.level) )
	if( length(conf.level) !=1 || is.na(conf.level) || conf.level<0 || conf.level > 1)
	    stop("conf.level must be a number between 0 and 1")
    if( !is.null(y) ) {
	dname<-paste(deparse(substitute(x)),"and",paste(deparse(substitute(y))))
	if(paired)
	    xok<-yok<-complete.cases(x,y)
	else {
	    yok<-!is.na(y)
	    xok<-!is.na(x)
	}
	y<-y[yok]
    }
    else {
	dname<-deparse(substitute(x))
	if( paired ) stop("y is missing for paired test")
	xok<-!is.na(x)
	yok<-NULL
    }
    x<-x[xok]
    if( paired ) {
	x<- x-y
	y<- NULL
    }
    nx <- length(x)
    if(nx <= 2) stop("not enough x observations")
    mx <- mean(x)
    vx <- var(x)
    estimate<-mx
    if(is.null(y)) {
	df <- length(x)-1
	stderr<-sqrt(vx/nx)
	tstat <- (mx-mu)/stderr
	method<-ifelse(paired,"Paired t-test","One Sample t-test")
	names(estimate)<-ifelse(paired,"mean of the differences","mean of x")
    } else {
	ny <- length(y)
	if(ny <= 2) stop("not enough y observations")
	my <- mean(y)
	vy <- var(y)
	method<-ifelse(var.equal,"Two Sample t-test","Welch Two Sample t-test")
	estimate<-c(mx,my)
	names(estimate)<-c("mean of x","mean of y")
	if(var.equal) {
	    df <- nx+ny-2
	    v <- ((nx-1)*vx + (ny-1)*vy)/df
	    stderr <- sqrt(v*(1/nx+1/ny))
	    tstat <- (mx-my-mu)/stderr
	} else {
	    stderrx <-sqrt(vx/nx)
	    stderry <-sqrt(vy/ny)
	    stderr <- sqrt(stderrx^2 + stderry^2)
	    df <- stderr^4/(stderrx^4/(nx-1) + stderry^4/(ny-1))
	    tstat <- (mx - my - mu)/stderr
	}
    }
    if (alternative == "less") {
	pval <- pt(tstat, df)
	cint <- c(NA, tstat * stderr + qt(conf.level, df) * stderr)
    }
    else if (alternative == "greater") {
	pval <- 1 - pt(tstat, df)
	cint <- c(tstat * stderr - qt(conf.level, df) * stderr, NA)
    }
    else {
	pval <- 2 * pt(-abs(tstat), df)
	alpha <- 1 - conf.level
	cint <- c(tstat * stderr - qt((1 - alpha/2), df) * stderr,
		  tstat * stderr + qt((1 - alpha/2), df) * stderr)
    }
    cint<-cint+mu
    names(tstat)<-"t"
    names(df)<-"df"
    if(paired || !is.null(y) )
	names(mu)<-"difference in means"
    else
	names(mu)<- "mean"
    attr(cint,"conf.level")<-conf.level
    rval<-list(statistic = tstat, parameter = df, p.value = pval,
	       conf.int=cint, estimate=estimate, null.value = mu, alternative=alternative,
	       method=method, data.name=dname)
    attr(rval,"class")<-"htest"
    return(rval)
}
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))
## 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)
is.R <-
    function() exists("version") && !is.null(vl <- version$language) && vl == "R"
var <- function(x, y=x, na.rm = FALSE, use) {
    if(missing(use)) {
	if(na.rm) use <- "complete.obs"
	else use <- "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))
    }
}
which <- function(logic, arr.ind = FALSE)
{
    if(!is.logical(logic))
	stop("argument to \"which\" is not logical")
    if(0 == (n <- length(logic)))
	return(integer(0))
    wh <- (1:n)[logic & !is.na(logic)]
    if ((m <- length(wh)) > 0) {
	dl <- dim(logic)
	if (is.null(dl) || !arr.ind) {
	    names(wh) <- names(logic)[logic]
	}
	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
}
windows<- function(width = 7, height = 7, pointsize = 12)
    .Internal(Windows(width,height,pointsize))
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)
}
X11 <- function(display="", width=7, height=7, pointsize=12)
    .Internal(X11(display, width, height, pointsize))
x11 <- X11
xor <- function(x, y) { (x | y) & !(x & y) }
zapsmall <- function(x, digits = .Options$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)
}
.Platform <-
    list(OS.type = "Unix",
	 file.sep = "/",
	 dynlib.ext = ".so",
	 show.file = function(file) system(paste(options("pager")[[1]], file)),
	 append.file = function(f1,f2) {# append to 'f1' the file 'f2':
	     system(paste("cat", f2, ">>", f1), trash.errors= TRUE)
	 },
	 show.data = function(package,lib.loc,fsep) {
	 ## give `index' of all possible data sets
	     for (lib in lib.loc)
	     for (pkg in package) {
	      INDEX <- system.file(paste("data", "index.doc", sep = fsep),
			      pkg, lib)
	      if (INDEX != "") {
	       cat(paste("\n\nData sets in package `", pkg, "':\n\n",
			 sep = fsep))
	       .Platform$ show.file(INDEX)
	      }}},	 
	 )
bug.report <- function(send=TRUE, method=.Options$mailer)
{
    methods <- c("mailx", "gnudoit")
    method <-
	if(is.null(method)) "mailx"
	else methods[pmatch(method, methods)]
    body <- paste("\\n\\n",
		  "--please do not edit the information below--\\n\\n",
		  "Version:\\n ",
		  paste(names(version), version, sep=" = ", collapse="\\n "),
		  "\\n\\n",
		  "Search Path:\\n ",
		  paste(search(), collapse=", "),
		  "\\n", sep="", collapse="")
    if(method == "mailx") {
	file <- tempfile()
	cat("Subject: ")
	subject <- readline()
	body <- gsub("\\\\n", "\n", body)
	cat(body, file=file)
	system(paste(.Options$editor, file))
	cmd <- paste("mailx", "-s '", subject,
		     "' r-bugs@biostat.ku.dk < ", file)
	if(send){
	    cat("Submit the bug report? ")
	    answer <- readline()
	    answer <- grep("y", answer, ignore.case=TRUE)
	    if(length(answer)>0){
		cat("Sending email ...\n")
		system(cmd)
	    }
	    else
		cat("OK, not sending email, deleting report ...\n")
	    unlink(file)
	}
	else
	    cat("The unsent bug report can be found in file",
		file, "\n")
    }
    else if(method == "gnudoit") {
	cmd <- paste("gnudoit -q '",
		     "(mail nil \"r-bugs@biostat.ku.dk\")",
		     "(insert \"", body, "\")",
		     "(search-backward \"Subject:\")",
		     "(end-of-line)'",
		     sep="")
	system(cmd)
    }
}
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)
    }
}
help <- function(topic, offline = FALSE, package = c(.packages(), .Autoloaded),
		 lib.loc = .lib.loc, verbose = .Options$verbose,
		 htmlhelp = .Options$htmlhelp) {
    if (!missing(package))
	if (is.name(y <- substitute(package)))# && !is.character(package))
	    package <- as.character(y)
    fsep <- .Platform$file.sep
    if (!missing(topic)) {
	topic <- substitute(topic)
	if (is.name(topic))
	    topic <- as.character(topic)
	else if (!is.character(topic))
	    stop("Unimplemented help feature")
	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"
	topic <- gsub("\\[","\\\\[", topic)# for cmd/help ..
	INDICES <- paste(t(outer(lib.loc, package, paste, sep = fsep)),
			 "help", "AnIndex", sep = fsep, collapse = " ")
	file <- system(paste("${RHOME}/bin/help INDEX '", topic, "' ",
			     INDICES, sep=""),
		       intern = TRUE)
	if (file == "") {		# try data .doc -- this is OUTDATED
	    file <- system.file(paste("data", fsep, topic, ".doc", sep = ""),
				package, lib.loc)
	}
	if (length(file) && file != "") {
	    if (verbose)
		cat ("\t\t\t\t\t\tHelp file name `", sub(".*/", "", file),
		     ".Rd'\n", sep = "")
	    if (!offline) {
		if(!is.null(htmlhelp) && htmlhelp){
                    ## replace the last occurence of /help/ in the
                    ## path with /html/, then append .html
		    file <- gsub("/help/([^/]*)$", "/html/\\1", file)
		    file <- paste("file:", file, ".html", sep="")
		    if(is.null(.Options$browser))
			stop("options(\"browser\") not set")
		    browser <- .Options$browser
		    system(paste(browser, " -remote \"openURL(", file,
				 ")\" 2>/dev/null || ",
				 browser, " ", file, " &", sep = ""))
		    cat("help() for", topic, " is shown in browser",
			browser, "...\n")
		}
		else
		    .Platform$ show.file(file)
	    }
	    else {
		FILE <- tempfile()
		## on.exit(unlink(paste(FILE, "*", sep = "")))
		cat("\\documentclass[", .Options$papersize, "paper]{article}\n",
		    file = FILE, sep = "")
		.Platform$ append.file(FILE, "${RHOME}/doc/manual/Rd.sty")
		cat("\\InputIfFileExists{Rhelp.cfg}{}{}\n\\begin{document}\n",
		    file = FILE, append = TRUE)
		.Platform$ append.file(FILE,
				       paste(sub("help/","latex/",file),".tex",
					     sep = ""))
		cat("\\end{document}\n", file = FILE, append = TRUE)
		system(paste("${RHOME}/bin/help PRINT", FILE, topic))
		return()
	    }
	} 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 = .Options$browser,
			remote = NULL) {
    if(is.null(browser))
	stop("Invalid browser name, check options(\"browser\").")
    url <- paste(if (is.null(remote)) "$HOME/.R" else remote,
		 "/doc/html/index.html", sep = "")
    cat("If", browser, " is already running,\tit is *not* restarted,\n",
	"and you must switch to its window.\nOtherwise, be patient..\n")
    system(paste("${RHOME}/bin/help.links",
		 paste(.lib.loc[length(.lib.loc):1], sep=" ", collapse=" "),
		 sep =" "))
    system(paste(browser, " -remote \"openURL(", url, ")\" 2>/dev/null || ",
		 browser, " ", url, " &", sep = ""))
    options(htmlhelp=TRUE)
}
system <- function(call, intern = FALSE, trash.errors = FALSE)
    .Internal(system(if(trash.errors) paste(call, "2>/dev/null") else call,
		     intern))
unix <- function(call, intern = FALSE) {
    .Deprecated("system"); system(call,intern)
}
system.file <- function(file = "", pkg = .packages(), lib = .lib.loc) {
    FILES <- paste(t(outer(lib, pkg, paste, sep = .Platform$file.sep)),
		   file, sep = .Platform$file.sep, collapse = " ")
    system(paste("${RHOME}/bin/filename", FILES), intern = TRUE)
}
##--- All the following should really be done in C [platform !] :
##---> For the first 3, look at Guido's win32 code!
date <- function() { system("date", intern = TRUE) }
tempfile <- function(pattern = "file") {
    system(paste("for p in", paste(pattern, collapse = " "), ";",
		 "do echo /tmp/$p$$; done"),
	   intern = TRUE)
}
unlink <- function(x) { system(paste("rm -rf ", paste(x, collapse = " "))) }
## Unfortunately, the following fails for "-e" on Solaris [/bin/sh-builtin test]
system.test <- function(...) { system(paste("test", ...)) == 0 }
## Martin would like these;  Kurt thinks they're unnecessary:
## file.exists <-function(file){ sapply(file, function(f)system.test("-e", f))} 
## dir.exists  <-function(dir) { sapply(dir,  function(d)system.test("-d", d))} 
## Yet another misuse of  is.xxx naming [S-plus compatibility]:
## is.dir <- .Alias(dir.exists)
