.Defunct <- function() {
  stop(paste("`", as.character(sys.call(sys.parent())[[1]]), "' ",
             "is defunct.\n",
             "See ?Defunct.",
             sep = ""))
}
.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)
}
##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(...))
}
check.bounds <- function(on=TRUE).Internal(check.bounds(on)) ### NO DOC
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().Internal(gc())
gcinfo <- function(verbose).Internal(gcinfo(verbose))
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) .Internal(sink(file))
##-- 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))
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()
}
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))
print.anova <- function(x, digits = max(.Options$digits - 2, 3),
                        signif.stars= .Options$show.signif.stars, ...)
{
  heading <- attr(x, "heading")
  if (!is.null(heading)) cat(heading, sep = "\n")
  attr(x, "heading") <- NULL
  nn <- names(x)
###-- we should be able to do withOUT for()
###-- and use new   print.coefmat(.), instead ! -- MM.
  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)
}
## which (invisibly) returns the newly changed, instead of the original x !
#### copyright (C) 1998 W. N. Venables and B. D. Ripley
aov <-
  function(formula, data = sys.parent(), projections = FALSE, contrasts =
        NULL, ...)
{
  if(projections) stop("projections are not implemented")
  lmcall <- Call <- match.call()
  lmcall[[1]] <- as.name("lm")
  lmcall$singular.ok <- TRUE
  lmcall$projections <- NULL
  fit <- eval(lmcall, sys.frame(sys.parent()))
  class(fit) <- c("aov", "lm")
  fit$call <- Call
  fit
}
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]] # changed
  effects <- x$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(x$terms, "term.labels"))
  nterms <- max(asgn)+1
  df <- ss <- numeric(nterms)
  if(nterms) {
    for(i in seq(nterms)) {
      ai <- asgn==(i-1) # delete line
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
    }
    keep <- df > 0
    if(!intercept) keep[1] <- FALSE
    nmeffect <- nmeffect[keep]
    df <- df[keep]
    ss <- ss[keep]
    nterms <- length(df)
  }
  cat("\nTerms:\n")
  if(nterms == 0) {
    # empty model
    print(matrix(0, 1, 2, dimnames=list("<empty>",
                            c("Sum of Squares", "Deg. of Freedom"))))
    return(invisible(x))
  }
  df.res <- x$df.resid
  if(is.null(df.res))
    df.res <- length(x$resid) - length(asgn)
  if(df.res > 0) {
    resid <- x$resid
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmeffect[nterms] <- "Residuals"
  }
  print(matrix(c(format(ss), format(df)), 2, nterms, byrow=TRUE,
               dimnames=list(c("Sum of Squares", "Deg. of Freedom"),
               nmeffect)),
        quote = FALSE, right = TRUE)
  rank <- x$rank
  int <- attr(x$terms, "int")
  nobs <- length(x$residuals) - !(is.null(int) || int == 0)
  rdf <- x$df.resid
  if(is.null(rdf)) rdf <- nobs - rank
  cat("\n")
  if(rdf > 0)
    cat("Residual standard error:", format(sqrt(sum(x$residuals^2)/
                                                rdf)), "\n")
  coef <- x$coef
  R <- x$qr$qr
  R <- R[1:ncol(R), ]
  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]
    }
  dm <- dim(R)
  d <- seq(1, length = min(dm), by = dm[1] + 1)
  R <- abs(R)
  if(sum(R[ - d])/sum(R[d]) > 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]] # changed
  nterms <- max(asgn)+1
  effects <- object$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(object$terms, "term.labels"))
  resid <- object$residuals
  wt <- object$weights
  if(!is.null(wt)) resid <- resid * wt^0.5
  if(is.null(effects)) {
    df <- nterms  <- 0
    ss <- ms <- numeric(0)
    nmrows <- character(0)
  }
  else {
    nobs <- length(resid)
    nterms <- max(asgn)+1
    df <- ss <- numeric(nterms)
    nmrows <- character(nterms)
    for(i in 1:nterms) {
      ai <- asgn == (i-1) # changed
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
      nmrows[i] <- nmeffect[i]
    }
  }
  df.res <- object$df.resid
  if(df.res > 0) {
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmrows[nterms] <- "Residuals"
  }
  ok <- df > 0
  if(all(ok)) ms <- ss/df
  else {
    ms <- rep(NA, nterms)
    ms[ok] <- ss[ok]/df[ok]
  }
  x <- list(Df = df, "Sum of Sq" = ss, "Mean Sq" = ms)
  if(df.res > 0) {
    TT <- ms/ms[nterms]
    TP <- 1 - pf(TT, df, df.res)
    TT[nterms] <- TP[nterms] <- NA
    x$"F Value" <- TT
    x$"Pr(F)" <- TP
  }
  class(x) <- c("anova", "data.frame")
  row.names(x) <- format(nmrows)
  if(!keep.zero.df) x <- x[df > 0, ]
  if(!intercept) x <- x[-1,]
  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, ...)
{
  pattern <- function(x, ...) {
    x[abs(x) < 1e-6] <- 0
    if(exists("fractions", mode="function")) fractions(x) else x
  }
  Model <- object$terms
  attributes(Model) <- NULL
  value <- list(Model = Model)
  R <- object$qr$qr
  R <- R[1:ncol(R), ]
  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 <- dimnames(R)[[2]]
        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])
        pattern(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
    value$Partial <- beta11
  }
  class(value) <- "listof"
  value
}
print.listof <- function(x, ...)
{
  nn <- names(x)
  ll <- length(x)
  if(length(nn) != ll) nn <- paste("Component", seq(ll))
  for(i in seq(ll)) {
    cat(nn[i], ":\n"); print(x[[i]], ...); cat("\n")
  }
}
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)
	ds <- 1:dl
	if(dl == 0)
		stop("dim(X) must have a positive length")
	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)
	if(!ans.list)
		ans <- unlist(ans, recursive = FALSE)
	if(length(MARGIN) == 1 && length(ans) == d2) {
		if(length(dn.ans[[1]]) > 0)
			names(ans) <- dn.ans[[1]]
		else names(ans) <- NULL
		return(ans)
	}
	else if(length(ans) == d2)
		return(array(ans, d.ans, dn.ans))
	else if(length(ans) > 0 && length(ans) %% d2 == 0) {
		if(is.null(dn.ans))
			return(array(ans, c(length(ans)/d2, d[MARGIN])))
		else return(array(ans, c(length(ans)/d2, d.ans),
				c(list(ans.names), dn.ans)))
	}
	else 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 ]
 if(check.mode && any(ind)) {
          ii <- which(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]
 } else {
          if(numeric.) structure(which(ind), names=sp[ind]) else sp[ind]
 }
}
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]
	}
	dim(data) <- dim
	if(is.list(dimnames))
		dimnames(data) <- dimnames
	data
}
arrows <-
function(x0, y0, x1, y1, length=0.25, angle=30, code=2,
	col=par("fg"), lty=NULL, xpd=FALSE) {
 .Internal(arrows(
	x0,
	y0,
	x1,
	y1,
	length=length,
	angle=angle,
	code=code,
	col=col,
	lty=lty,
	xpd=xpd))
}
as.logical <- function(x) .Internal(as.vector(x,"logical"))
as.integer <- function(x) .Internal(as.vector(x,"integer"))
as.double <- function(x) .Internal(as.vector(x,"double"))
as.real <- .Alias(as.double)
as.complex <- function(x) .Internal(as.vector(x, "complex"))
as.single <- function(x) {
  warning("type single is not supported in R")
  .Internal(as.vector(x,"double"))
}
as.character <- function(x) .Internal(as.vector(x,"character"))
as.expression <- function(x) .Internal(as.vector(x,"expression"))
"as.list" <-
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"))
}
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) NULL
as.function <- function(x,...) UseMethod("as.function")
"as.function.default" <-
function (l, envir = sys.frame(sys.parent())) 
{
  if (!is.list(l)) 
    stop("Can't coerce object to function")
  ln <- length(l)
  alist <- l[-ln]
  body <- l[[ln]]
  if (is.expression(body)) 
    body <- body[[1]]
  if (ln < 2) 
    e <- substitute(function() body)
  else {
    e <- substitute(function(x) body)
    e[[2]] <- alist
  }
  eval(e, 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 tercol=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()
}
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))
print.anova <- function(x, digits = max(.Options$digits - 2, 3),
                        signif.stars= .Options$show.signif.stars, ...)
{
  heading <- attr(x, "heading")
  if (!is.null(heading)) cat(heading, sep = "\n")
  attr(x, "heading") <- NULL
  nn <- names(x)
###-- we should be able to do withOUT for()
###-- and use new   print.coefmat(.), instead ! -- MM.
  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)
}
## which (invisibly) returns the newly changed, instead of the original x !
#### copyright (C) 1998 W. N. Venables and B. D. Ripley
aov <-
  function(formula, data = sys.parent(), projections = FALSE, contrasts =
        NULL, ...)
{
  if(projections) stop("projections are not implemented")
  lmcall <- Call <- match.call()
  lmcall[[1]] <- as.name("lm")
  lmcall$singular.ok <- TRUE
  lmcall$projections <- NULL
  fit <- eval(lmcall, sys.frame(sys.parent()))
  class(fit) <- c("aov", "lm")
  fit$call <- Call
  fit
}
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]] # changed
  effects <- x$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(x$terms, "term.labels"))
  nterms <- max(asgn)+1
  df <- ss <- numeric(nterms)
  if(nterms) {
    for(i in seq(nterms)) {
      ai <- asgn==(i-1) # delete line
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
    }
    keep <- df > 0
    if(!intercept) keep[1] <- FALSE
    nmeffect <- nmeffect[keep]
    df <- df[keep]
    ss <- ss[keep]
    nterms <- length(df)
  }
  cat("\nTerms:\n")
  if(nterms == 0) {
    # empty model
    print(matrix(0, 1, 2, dimnames=list("<empty>",
                            c("Sum of Squares", "Deg. of Freedom"))))
    return(invisible(x))
  }
  df.res <- x$df.resid
  if(is.null(df.res))
    df.res <- length(x$resid) - length(asgn)
  if(df.res > 0) {
    resid <- x$resid
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmeffect[nterms] <- "Residuals"
  }
  print(matrix(c(format(ss), format(df)), 2, nterms, byrow=TRUE,
               dimnames=list(c("Sum of Squares", "Deg. of Freedom"),
               nmeffect)),
        quote = FALSE, right = TRUE)
  rank <- x$rank
  int <- attr(x$terms, "int")
  nobs <- length(x$residuals) - !(is.null(int) || int == 0)
  rdf <- x$df.resid
  if(is.null(rdf)) rdf <- nobs - rank
  cat("\n")
  if(rdf > 0)
    cat("Residual standard error:", format(sqrt(sum(x$residuals^2)/
                                                rdf)), "\n")
  coef <- x$coef
  R <- x$qr$qr
  R <- R[1:ncol(R), ]
  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]
    }
  dm <- dim(R)
  d <- seq(1, length = min(dm), by = dm[1] + 1)
  R <- abs(R)
  if(sum(R[ - d])/sum(R[d]) > 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]] # changed
  nterms <- max(asgn)+1
  effects <- object$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(object$terms, "term.labels"))
  resid <- object$residuals
  wt <- object$weights
  if(!is.null(wt)) resid <- resid * wt^0.5
  if(is.null(effects)) {
    df <- nterms  <- 0
    ss <- ms <- numeric(0)
    nmrows <- character(0)
  }
  else {
    nobs <- length(resid)
    nterms <- max(asgn)+1
    df <- ss <- numeric(nterms)
    nmrows <- character(nterms)
    for(i in 1:nterms) {
      ai <- asgn == (i-1) # changed
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
      nmrows[i] <- nmeffect[i]
    }
  }
  df.res <- object$df.resid
  if(df.res > 0) {
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmrows[nterms] <- "Residuals"
  }
  ok <- df > 0
  if(all(ok)) ms <- ss/df
  else {
    ms <- rep(NA, nterms)
    ms[ok] <- ss[ok]/df[ok]
  }
  x <- list(Df = df, "Sum of Sq" = ss, "Mean Sq" = ms)
  if(df.res > 0) {
    TT <- ms/ms[nterms]
    TP <- 1 - pf(TT, df, df.res)
    TT[nterms] <- TP[nterms] <- NA
    x$"F Value" <- TT
    x$"Pr(F)" <- TP
  }
  class(x) <- c("anova", "data.frame")
  row.names(x) <- format(nmrows)
  if(!keep.zero.df) x <- x[df > 0, ]
  if(!intercept) x <- x[-1,]
  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, ...)
{
  pattern <- function(x, ...) {
    x[abs(x) < 1e-6] <- 0
    if(exists("fractions", mode="function")) fractions(x) else x
  }
  Model <- object$terms
  attributes(Model) <- NULL
  value <- list(Model = Model)
  R <- object$qr$qr
  R <- R[1:ncol(R), ]
  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 <- dimnames(R)[[2]]
        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])
        pattern(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
    value$Partial <- beta11
  }
  class(value) <- "listof"
  value
}
print.listof <- function(x, ...)
{
  nn <- names(x)
  ll <- length(x)
  if(length(nn) != ll) nn <- paste("Component", seq(ll))
  for(i in seq(ll)) {
    cat(nn[i], ":\n"); print(x[[i]], ...); cat("\n")
  }
}
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)
	ds <- 1:dl
	if(dl == 0)
		stop("dim(X) must have a positive length")
	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)
	if(!ans.list)
		ans <- unlist(ans, recursive = FALSE)
	if(length(MARGIN) == 1 && length(ans) == d2) {
		if(length(dn.ans[[1]]) > 0)
			names(ans) <- dn.ans[[1]]
		else names(ans) <- NULL
		return(ans)
	}
	else if(length(ans) == d2)
		return(array(ans, d.ans, dn.ans))
	else if(length(ans) > 0 && length(ans) %% d2 == 0) {
		if(is.null(dn.ans))
			return(array(ans, c(length(ans)/d2, d[MARGIN])))
		else return(array(ans, c(length(ans)/d2, d.ans),
				c(list(ans.names), dn.ans)))
	}
	else 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 ]
 if(check.mode && any(ind)) {
          ii <- which(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]
 } else {
          if(numeric.) structure(which(ind), names=sp[ind]) else sp[ind]
 }
}
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]
	}
	dim(data) <- dim
	if(is.list(dimnames))
		dimnames(data) <- dimnames
	data
}
arrows <-
function(x0, y0, x1, y1, length=0.25, angle=30, code=2,
	col=par("fg"), lty=NULL, xpd=FALSE) {
 .Internal(arrows(
	x0,
	y0,
	x1,
	y1,
	length=length,
	angle=angle,
	code=code,
	col=col,
	lty=lty,
	xpd=xpd))
}
as.logical <- function(x) .Internal(as.vector(x,"logical"))
as.integer <- function(x) .Internal(as.vector(x,"integer"))
as.double <- function(x) .Internal(as.vector(x,"double"))
as.real <- .Alias(as.double)
as.complex <- function(x) .Internal(as.vector(x, "complex"))
as.single <- function(x) {
  warning("type single is not supported in R")
  .Internal(as.vector(x,"double"))
}
as.character <- function(x) .Internal(as.vector(x,"character"))
as.expression <- function(x) .Internal(as.vector(x,"expression"))
"as.list" <-
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"))
}
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) NULL
as.function <- function(x,...) UseMethod("as.function")
"as.function.default" <-
function (l, envir = sys.frame(sys.parent())) 
{
  if (!is.list(l)) 
    stop("Can't coerce object to function")
  ln <- length(l)
  alist <- l[-ln]
  body <- l[[ln]]
  if (is.expression(body)) 
    body <- body[[1]]
  if (ln < 2) 
    e <- substitute(function() body)
  else {
    e <- substitute(function(x) body)
    e[[2]] <- alist
  }
  eval(e, 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 tercol=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()
}
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))
print.anova <- function(x, digits = max(.Options$digits - 2, 3),
                        signif.stars= .Options$show.signif.stars, ...)
{
  heading <- attr(x, "heading")
  if (!is.null(heading)) cat(heading, sep = "\n")
  attr(x, "heading") <- NULL
  nn <- names(x)
###-- we should be able to do withOUT for()
###-- and use new   print.coefmat(.), instead ! -- MM.
  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)
}
## which (invisibly) returns the newly changed, instead of the original x !
#### copyright (C) 1998 W. N. Venables and B. D. Ripley
aov <-
  function(formula, data = sys.parent(), projections = FALSE, contrasts =
        NULL, ...)
{
  if(projections) stop("projections are not implemented")
  lmcall <- Call <- match.call()
  lmcall[[1]] <- as.name("lm")
  lmcall$singular.ok <- TRUE
  lmcall$projections <- NULL
  fit <- eval(lmcall, sys.frame(sys.parent()))
  class(fit) <- c("aov", "lm")
  fit$call <- Call
  fit
}
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]] # changed
  effects <- x$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(x$terms, "term.labels"))
  nterms <- max(asgn)+1
  df <- ss <- numeric(nterms)
  if(nterms) {
    for(i in seq(nterms)) {
      ai <- asgn==(i-1) # delete line
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
    }
    keep <- df > 0
    if(!intercept) keep[1] <- FALSE
    nmeffect <- nmeffect[keep]
    df <- df[keep]
    ss <- ss[keep]
    nterms <- length(df)
  }
  cat("\nTerms:\n")
  if(nterms == 0) {
    # empty model
    print(matrix(0, 1, 2, dimnames=list("<empty>",
                            c("Sum of Squares", "Deg. of Freedom"))))
    return(invisible(x))
  }
  df.res <- x$df.resid
  if(is.null(df.res))
    df.res <- length(x$resid) - length(asgn)
  if(df.res > 0) {
    resid <- x$resid
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmeffect[nterms] <- "Residuals"
  }
  print(matrix(c(format(ss), format(df)), 2, nterms, byrow=TRUE,
               dimnames=list(c("Sum of Squares", "Deg. of Freedom"),
               nmeffect)),
        quote = FALSE, right = TRUE)
  rank <- x$rank
  int <- attr(x$terms, "int")
  nobs <- length(x$residuals) - !(is.null(int) || int == 0)
  rdf <- x$df.resid
  if(is.null(rdf)) rdf <- nobs - rank
  cat("\n")
  if(rdf > 0)
    cat("Residual standard error:", format(sqrt(sum(x$residuals^2)/
                                                rdf)), "\n")
  coef <- x$coef
  R <- x$qr$qr
  R <- R[1:ncol(R), ]
  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]
    }
  dm <- dim(R)
  d <- seq(1, length = min(dm), by = dm[1] + 1)
  R <- abs(R)
  if(sum(R[ - d])/sum(R[d]) > 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]] # changed
  nterms <- max(asgn)+1
  effects <- object$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(object$terms, "term.labels"))
  resid <- object$residuals
  wt <- object$weights
  if(!is.null(wt)) resid <- resid * wt^0.5
  if(is.null(effects)) {
    df <- nterms  <- 0
    ss <- ms <- numeric(0)
    nmrows <- character(0)
  }
  else {
    nobs <- length(resid)
    nterms <- max(asgn)+1
    df <- ss <- numeric(nterms)
    nmrows <- character(nterms)
    for(i in 1:nterms) {
      ai <- asgn == (i-1) # changed
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
      nmrows[i] <- nmeffect[i]
    }
  }
  df.res <- object$df.resid
  if(df.res > 0) {
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmrows[nterms] <- "Residuals"
  }
  ok <- df > 0
  if(all(ok)) ms <- ss/df
  else {
    ms <- rep(NA, nterms)
    ms[ok] <- ss[ok]/df[ok]
  }
  x <- list(Df = df, "Sum of Sq" = ss, "Mean Sq" = ms)
  if(df.res > 0) {
    TT <- ms/ms[nterms]
    TP <- 1 - pf(TT, df, df.res)
    TT[nterms] <- TP[nterms] <- NA
    x$"F Value" <- TT
    x$"Pr(F)" <- TP
  }
  class(x) <- c("anova", "data.frame")
  row.names(x) <- format(nmrows)
  if(!keep.zero.df) x <- x[df > 0, ]
  if(!intercept) x <- x[-1,]
  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, ...)
{
  pattern <- function(x, ...) {
    x[abs(x) < 1e-6] <- 0
    if(exists("fractions", mode="function")) fractions(x) else x
  }
  Model <- object$terms
  attributes(Model) <- NULL
  value <- list(Model = Model)
  R <- object$qr$qr
  R <- R[1:ncol(R), ]
  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 <- dimnames(R)[[2]]
        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])
        pattern(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
    value$Partial <- beta11
  }
  class(value) <- "listof"
  value
}
print.listof <- function(x, ...)
{
  nn <- names(x)
  ll <- length(x)
  if(length(nn) != ll) nn <- paste("Component", seq(ll))
  for(i in seq(ll)) {
    cat(nn[i], ":\n"); print(x[[i]], ...); cat("\n")
  }
}
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)
	ds <- 1:dl
	if(dl == 0)
		stop("dim(X) must have a positive length")
	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)
	if(!ans.list)
		ans <- unlist(ans, recursive = FALSE)
	if(length(MARGIN) == 1 && length(ans) == d2) {
		if(length(dn.ans[[1]]) > 0)
			names(ans) <- dn.ans[[1]]
		else names(ans) <- NULL
		return(ans)
	}
	else if(length(ans) == d2)
		return(array(ans, d.ans, dn.ans))
	else if(length(ans) > 0 && length(ans) %% d2 == 0) {
		if(is.null(dn.ans))
			return(array(ans, c(length(ans)/d2, d[MARGIN])))
		else return(array(ans, c(length(ans)/d2, d.ans),
				c(list(ans.names), dn.ans)))
	}
	else 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 ]
 if(check.mode && any(ind)) {
          ii <- which(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]
 } else {
          if(numeric.) structure(which(ind), names=sp[ind]) else sp[ind]
 }
}
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]
	}
	dim(data) <- dim
	if(is.list(dimnames))
		dimnames(data) <- dimnames
	data
}
arrows <-
function(x0, y0, x1, y1, length=0.25, angle=30, code=2,
	col=par("fg"), lty=NULL, xpd=FALSE) {
 .Internal(arrows(
	x0,
	y0,
	x1,
	y1,
	length=length,
	angle=angle,
	code=code,
	col=col,
	lty=lty,
	xpd=xpd))
}
as.logical <- function(x) .Internal(as.vector(x,"logical"))
as.integer <- function(x) .Internal(as.vector(x,"integer"))
as.double <- function(x) .Internal(as.vector(x,"double"))
as.real <- .Alias(as.double)
as.complex <- function(x) .Internal(as.vector(x, "complex"))
as.single <- function(x) {
  warning("type single is not supported in R")
  .Internal(as.vector(x,"double"))
}
as.character <- function(x) .Internal(as.vector(x,"character"))
as.expression <- function(x) .Internal(as.vector(x,"expression"))
"as.list" <-
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"))
}
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) NULL
as.function <- function(x,...) UseMethod("as.function")
"as.function.default" <-
function (l, envir = sys.frame(sys.parent())) 
{
  if (!is.list(l)) 
    stop("Can't coerce object to function")
  ln <- length(l)
  alist <- l[-ln]
  body <- l[[ln]]
  if (is.expression(body)) 
    body <- body[[1]]
  if (ln < 2) 
    e <- substitute(function() body)
  else {
    e <- substitute(function(x) body)
    e[[2]] <- alist
  }
  eval(e, 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 tercol=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()
}
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))
print.anova <- function(x, digits = max(.Options$digits - 2, 3),
                        signif.stars= .Options$show.signif.stars, ...)
{
  heading <- attr(x, "heading")
  if (!is.null(heading)) cat(heading, sep = "\n")
  attr(x, "heading") <- NULL
  nn <- names(x)
###-- we should be able to do withOUT for()
###-- and use new   print.coefmat(.), instead ! -- MM.
  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)
}
## which (invisibly) returns the newly changed, instead of the original x !
#### copyright (C) 1998 W. N. Venables and B. D. Ripley
aov <-
  function(formula, data = sys.parent(), projections = FALSE, contrasts =
        NULL, ...)
{
  if(projections) stop("projections are not implemented")
  lmcall <- Call <- match.call()
  lmcall[[1]] <- as.name("lm")
  lmcall$singular.ok <- TRUE
  lmcall$projections <- NULL
  fit <- eval(lmcall, sys.frame(sys.parent()))
  class(fit) <- c("aov", "lm")
  fit$call <- Call
  fit
}
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]] # changed
  effects <- x$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(x$terms, "term.labels"))
  nterms <- max(asgn)+1
  df <- ss <- numeric(nterms)
  if(nterms) {
    for(i in seq(nterms)) {
      ai <- asgn==(i-1) # delete line
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
    }
    keep <- df > 0
    if(!intercept) keep[1] <- FALSE
    nmeffect <- nmeffect[keep]
    df <- df[keep]
    ss <- ss[keep]
    nterms <- length(df)
  }
  cat("\nTerms:\n")
  if(nterms == 0) {
    # empty model
    print(matrix(0, 1, 2, dimnames=list("<empty>",
                            c("Sum of Squares", "Deg. of Freedom"))))
    return(invisible(x))
  }
  df.res <- x$df.resid
  if(is.null(df.res))
    df.res <- length(x$resid) - length(asgn)
  if(df.res > 0) {
    resid <- x$resid
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmeffect[nterms] <- "Residuals"
  }
  print(matrix(c(format(ss), format(df)), 2, nterms, byrow=TRUE,
               dimnames=list(c("Sum of Squares", "Deg. of Freedom"),
               nmeffect)),
        quote = FALSE, right = TRUE)
  rank <- x$rank
  int <- attr(x$terms, "int")
  nobs <- length(x$residuals) - !(is.null(int) || int == 0)
  rdf <- x$df.resid
  if(is.null(rdf)) rdf <- nobs - rank
  cat("\n")
  if(rdf > 0)
    cat("Residual standard error:", format(sqrt(sum(x$residuals^2)/
                                                rdf)), "\n")
  coef <- x$coef
  R <- x$qr$qr
  R <- R[1:ncol(R), ]
  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]
    }
  dm <- dim(R)
  d <- seq(1, length = min(dm), by = dm[1] + 1)
  R <- abs(R)
  if(sum(R[ - d])/sum(R[d]) > 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]] # changed
  nterms <- max(asgn)+1
  effects <- object$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(object$terms, "term.labels"))
  resid <- object$residuals
  wt <- object$weights
  if(!is.null(wt)) resid <- resid * wt^0.5
  if(is.null(effects)) {
    df <- nterms  <- 0
    ss <- ms <- numeric(0)
    nmrows <- character(0)
  }
  else {
    nobs <- length(resid)
    nterms <- max(asgn)+1
    df <- ss <- numeric(nterms)
    nmrows <- character(nterms)
    for(i in 1:nterms) {
      ai <- asgn == (i-1) # changed
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
      nmrows[i] <- nmeffect[i]
    }
  }
  df.res <- object$df.resid
  if(df.res > 0) {
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmrows[nterms] <- "Residuals"
  }
  ok <- df > 0
  if(all(ok)) ms <- ss/df
  else {
    ms <- rep(NA, nterms)
    ms[ok] <- ss[ok]/df[ok]
  }
  x <- list(Df = df, "Sum of Sq" = ss, "Mean Sq" = ms)
  if(df.res > 0) {
    TT <- ms/ms[nterms]
    TP <- 1 - pf(TT, df, df.res)
    TT[nterms] <- TP[nterms] <- NA
    x$"F Value" <- TT
    x$"Pr(F)" <- TP
  }
  class(x) <- c("anova", "data.frame")
  row.names(x) <- format(nmrows)
  if(!keep.zero.df) x <- x[df > 0, ]
  if(!intercept) x <- x[-1,]
  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, ...)
{
  pattern <- function(x, ...) {
    x[abs(x) < 1e-6] <- 0
    if(exists("fractions", mode="function")) fractions(x) else x
  }
  Model <- object$terms
  attributes(Model) <- NULL
  value <- list(Model = Model)
  R <- object$qr$qr
  R <- R[1:ncol(R), ]
  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 <- dimnames(R)[[2]]
        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])
        pattern(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
    value$Partial <- beta11
  }
  class(value) <- "listof"
  value
}
print.listof <- function(x, ...)
{
  nn <- names(x)
  ll <- length(x)
  if(length(nn) != ll) nn <- paste("Component", seq(ll))
  for(i in seq(ll)) {
    cat(nn[i], ":\n"); print(x[[i]], ...); cat("\n")
  }
}
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)
	ds <- 1:dl
	if(dl == 0)
		stop("dim(X) must have a positive length")
	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)
	if(!ans.list)
		ans <- unlist(ans, recursive = FALSE)
	if(length(MARGIN) == 1 && length(ans) == d2) {
		if(length(dn.ans[[1]]) > 0)
			names(ans) <- dn.ans[[1]]
		else names(ans) <- NULL
		return(ans)
	}
	else if(length(ans) == d2)
		return(array(ans, d.ans, dn.ans))
	else if(length(ans) > 0 && length(ans) %% d2 == 0) {
		if(is.null(dn.ans))
			return(array(ans, c(length(ans)/d2, d[MARGIN])))
		else return(array(ans, c(length(ans)/d2, d.ans),
				c(list(ans.names), dn.ans)))
	}
	else 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 ]
 if(check.mode && any(ind)) {
          ii <- which(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]
 } else {
          if(numeric.) structure(which(ind), names=sp[ind]) else sp[ind]
 }
}
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]
	}
	dim(data) <- dim
	if(is.list(dimnames))
		dimnames(data) <- dimnames
	data
}
arrows <-
function(x0, y0, x1, y1, length=0.25, angle=30, code=2,
	col=par("fg"), lty=NULL, xpd=FALSE) {
 .Internal(arrows(
	x0,
	y0,
	x1,
	y1,
	length=length,
	angle=angle,
	code=code,
	col=col,
	lty=lty,
	xpd=xpd))
}
as.logical <- function(x) .Internal(as.vector(x,"logical"))
as.integer <- function(x) .Internal(as.vector(x,"integer"))
as.double <- function(x) .Internal(as.vector(x,"double"))
as.real <- .Alias(as.double)
as.complex <- function(x) .Internal(as.vector(x, "complex"))
as.single <- function(x) {
  warning("type single is not supported in R")
  .Internal(as.vector(x,"double"))
}
as.character <- function(x) .Internal(as.vector(x,"character"))
as.expression <- function(x) .Internal(as.vector(x,"expression"))
"as.list" <-
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"))
}
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) NULL
as.function <- function(x,...) UseMethod("as.function")
"as.function.default" <-
function (l, envir = sys.frame(sys.parent())) 
{
  if (!is.list(l)) 
    stop("Can't coerce object to function")
  ln <- length(l)
  alist <- l[-ln]
  body <- l[[ln]]
  if (is.expression(body)) 
    body <- body[[1]]
  if (ln < 2) 
    e <- substitute(function() body)
  else {
    e <- substitute(function(x) body)
    e[[2]] <- alist
  }
  eval(e, 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 tercol=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()
}
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))
print.anova <- function(x, digits = max(.Options$digits - 2, 3),
                        signif.stars= .Options$show.signif.stars, ...)
{
  heading <- attr(x, "heading")
  if (!is.null(heading)) cat(heading, sep = "\n")
  attr(x, "heading") <- NULL
  nn <- names(x)
###-- we should be able to do withOUT for()
###-- and use new   print.coefmat(.), instead ! -- MM.
  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)
}
## which (invisibly) returns the newly changed, instead of the original x !
#### copyright (C) 1998 W. N. Venables and B. D. Ripley
aov <-
  function(formula, data = sys.parent(), projections = FALSE, contrasts =
        NULL, ...)
{
  if(projections) stop("projections are not implemented")
  lmcall <- Call <- match.call()
  lmcall[[1]] <- as.name("lm")
  lmcall$singular.ok <- TRUE
  lmcall$projections <- NULL
  fit <- eval(lmcall, sys.frame(sys.parent()))
  class(fit) <- c("aov", "lm")
  fit$call <- Call
  fit
}
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]] # changed
  effects <- x$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(x$terms, "term.labels"))
  nterms <- max(asgn)+1
  df <- ss <- numeric(nterms)
  if(nterms) {
    for(i in seq(nterms)) {
      ai <- asgn==(i-1) # delete line
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
    }
    keep <- df > 0
    if(!intercept) keep[1] <- FALSE
    nmeffect <- nmeffect[keep]
    df <- df[keep]
    ss <- ss[keep]
    nterms <- length(df)
  }
  cat("\nTerms:\n")
  if(nterms == 0) {
    # empty model
    print(matrix(0, 1, 2, dimnames=list("<empty>",
                            c("Sum of Squares", "Deg. of Freedom"))))
    return(invisible(x))
  }
  df.res <- x$df.resid
  if(is.null(df.res))
    df.res <- length(x$resid) - length(asgn)
  if(df.res > 0) {
    resid <- x$resid
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmeffect[nterms] <- "Residuals"
  }
  print(matrix(c(format(ss), format(df)), 2, nterms, byrow=TRUE,
               dimnames=list(c("Sum of Squares", "Deg. of Freedom"),
               nmeffect)),
        quote = FALSE, right = TRUE)
  rank <- x$rank
  int <- attr(x$terms, "int")
  nobs <- length(x$residuals) - !(is.null(int) || int == 0)
  rdf <- x$df.resid
  if(is.null(rdf)) rdf <- nobs - rank
  cat("\n")
  if(rdf > 0)
    cat("Residual standard error:", format(sqrt(sum(x$residuals^2)/
                                                rdf)), "\n")
  coef <- x$coef
  R <- x$qr$qr
  R <- R[1:ncol(R), ]
  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]
    }
  dm <- dim(R)
  d <- seq(1, length = min(dm), by = dm[1] + 1)
  R <- abs(R)
  if(sum(R[ - d])/sum(R[d]) > 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]] # changed
  nterms <- max(asgn)+1
  effects <- object$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(object$terms, "term.labels"))
  resid <- object$residuals
  wt <- object$weights
  if(!is.null(wt)) resid <- resid * wt^0.5
  if(is.null(effects)) {
    df <- nterms  <- 0
    ss <- ms <- numeric(0)
    nmrows <- character(0)
  }
  else {
    nobs <- length(resid)
    nterms <- max(asgn)+1
    df <- ss <- numeric(nterms)
    nmrows <- character(nterms)
    for(i in 1:nterms) {
      ai <- asgn == (i-1) # changed
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
      nmrows[i] <- nmeffect[i]
    }
  }
  df.res <- object$df.resid
  if(df.res > 0) {
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmrows[nterms] <- "Residuals"
  }
  ok <- df > 0
  if(all(ok)) ms <- ss/df
  else {
    ms <- rep(NA, nterms)
    ms[ok] <- ss[ok]/df[ok]
  }
  x <- list(Df = df, "Sum of Sq" = ss, "Mean Sq" = ms)
  if(df.res > 0) {
    TT <- ms/ms[nterms]
    TP <- 1 - pf(TT, df, df.res)
    TT[nterms] <- TP[nterms] <- NA
    x$"F Value" <- TT
    x$"Pr(F)" <- TP
  }
  class(x) <- c("anova", "data.frame")
  row.names(x) <- format(nmrows)
  if(!keep.zero.df) x <- x[df > 0, ]
  if(!intercept) x <- x[-1,]
  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, ...)
{
  pattern <- function(x, ...) {
    x[abs(x) < 1e-6] <- 0
    if(exists("fractions", mode="function")) fractions(x) else x
  }
  Model <- object$terms
  attributes(Model) <- NULL
  value <- list(Model = Model)
  R <- object$qr$qr
  R <- R[1:ncol(R), ]
  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 <- dimnames(R)[[2]]
        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])
        pattern(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
    value$Partial <- beta11
  }
  class(value) <- "listof"
  value
}
print.listof <- function(x, ...)
{
  nn <- names(x)
  ll <- length(x)
  if(length(nn) != ll) nn <- paste("Component", seq(ll))
  for(i in seq(ll)) {
    cat(nn[i], ":\n"); print(x[[i]], ...); cat("\n")
  }
}
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)
	ds <- 1:dl
	if(dl == 0)
		stop("dim(X) must have a positive length")
	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)
	if(!ans.list)
		ans <- unlist(ans, recursive = FALSE)
	if(length(MARGIN) == 1 && length(ans) == d2) {
		if(length(dn.ans[[1]]) > 0)
			names(ans) <- dn.ans[[1]]
		else names(ans) <- NULL
		return(ans)
	}
	else if(length(ans) == d2)
		return(array(ans, d.ans, dn.ans))
	else if(length(ans) > 0 && length(ans) %% d2 == 0) {
		if(is.null(dn.ans))
			return(array(ans, c(length(ans)/d2, d[MARGIN])))
		else return(array(ans, c(length(ans)/d2, d.ans),
				c(list(ans.names), dn.ans)))
	}
	else 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 ]
 if(check.mode && any(ind)) {
          ii <- which(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]
 } else {
          if(numeric.) structure(which(ind), names=sp[ind]) else sp[ind]
 }
}
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]
	}
	dim(data) <- dim
	if(is.list(dimnames))
		dimnames(data) <- dimnames
	data
}
arrows <-
function(x0, y0, x1, y1, length=0.25, angle=30, code=2,
	col=par("fg"), lty=NULL, xpd=FALSE) {
 .Internal(arrows(
	x0,
	y0,
	x1,
	y1,
	length=length,
	angle=angle,
	code=code,
	col=col,
	lty=lty,
	xpd=xpd))
}
as.logical <- function(x) .Internal(as.vector(x,"logical"))
as.integer <- function(x) .Internal(as.vector(x,"integer"))
as.double <- function(x) .Internal(as.vector(x,"double"))
as.real <- .Alias(as.double)
as.complex <- function(x) .Internal(as.vector(x, "complex"))
as.single <- function(x) {
  warning("type single is not supported in R")
  .Internal(as.vector(x,"double"))
}
as.character <- function(x) .Internal(as.vector(x,"character"))
as.expression <- function(x) .Internal(as.vector(x,"expression"))
"as.list" <-
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"))
}
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) NULL
as.function <- function(x,...) UseMethod("as.function")
"as.function.default" <-
function (l, envir = sys.frame(sys.parent())) 
{
  if (!is.list(l)) 
    stop("Can't coerce object to function")
  ln <- length(l)
  alist <- l[-ln]
  body <- l[[ln]]
  if (is.expression(body)) 
    body <- body[[1]]
  if (ln < 2) 
    e <- substitute(function() body)
  else {
    e <- substitute(function(x) body)
    e[[2]] <- alist
  }
  eval(e, 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 tercol=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()
}
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))
print.anova <- function(x, digits = max(.Options$digits - 2, 3),
                        signif.stars= .Options$show.signif.stars, ...)
{
  heading <- attr(x, "heading")
  if (!is.null(heading)) cat(heading, sep = "\n")
  attr(x, "heading") <- NULL
  nn <- names(x)
###-- we should be able to do withOUT for()
###-- and use new   print.coefmat(.), instead ! -- MM.
  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)
}
## which (invisibly) returns the newly changed, instead of the original x !
#### copyright (C) 1998 W. N. Venables and B. D. Ripley
aov <-
  function(formula, data = sys.parent(), projections = FALSE, contrasts =
        NULL, ...)
{
  if(projections) stop("projections are not implemented")
  lmcall <- Call <- match.call()
  lmcall[[1]] <- as.name("lm")
  lmcall$singular.ok <- TRUE
  lmcall$projections <- NULL
  fit <- eval(lmcall, sys.frame(sys.parent()))
  class(fit) <- c("aov", "lm")
  fit$call <- Call
  fit
}
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]] # changed
  effects <- x$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(x$terms, "term.labels"))
  nterms <- max(asgn)+1
  df <- ss <- numeric(nterms)
  if(nterms) {
    for(i in seq(nterms)) {
      ai <- asgn==(i-1) # delete line
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
    }
    keep <- df > 0
    if(!intercept) keep[1] <- FALSE
    nmeffect <- nmeffect[keep]
    df <- df[keep]
    ss <- ss[keep]
    nterms <- length(df)
  }
  cat("\nTerms:\n")
  if(nterms == 0) {
    # empty model
    print(matrix(0, 1, 2, dimnames=list("<empty>",
                            c("Sum of Squares", "Deg. of Freedom"))))
    return(invisible(x))
  }
  df.res <- x$df.resid
  if(is.null(df.res))
    df.res <- length(x$resid) - length(asgn)
  if(df.res > 0) {
    resid <- x$resid
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmeffect[nterms] <- "Residuals"
  }
  print(matrix(c(format(ss), format(df)), 2, nterms, byrow=TRUE,
               dimnames=list(c("Sum of Squares", "Deg. of Freedom"),
               nmeffect)),
        quote = FALSE, right = TRUE)
  rank <- x$rank
  int <- attr(x$terms, "int")
  nobs <- length(x$residuals) - !(is.null(int) || int == 0)
  rdf <- x$df.resid
  if(is.null(rdf)) rdf <- nobs - rank
  cat("\n")
  if(rdf > 0)
    cat("Residual standard error:", format(sqrt(sum(x$residuals^2)/
                                                rdf)), "\n")
  coef <- x$coef
  R <- x$qr$qr
  R <- R[1:ncol(R), ]
  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]
    }
  dm <- dim(R)
  d <- seq(1, length = min(dm), by = dm[1] + 1)
  R <- abs(R)
  if(sum(R[ - d])/sum(R[d]) > 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]] # changed
  nterms <- max(asgn)+1
  effects <- object$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(object$terms, "term.labels"))
  resid <- object$residuals
  wt <- object$weights
  if(!is.null(wt)) resid <- resid * wt^0.5
  if(is.null(effects)) {
    df <- nterms  <- 0
    ss <- ms <- numeric(0)
    nmrows <- character(0)
  }
  else {
    nobs <- length(resid)
    nterms <- max(asgn)+1
    df <- ss <- numeric(nterms)
    nmrows <- character(nterms)
    for(i in 1:nterms) {
      ai <- asgn == (i-1) # changed
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
      nmrows[i] <- nmeffect[i]
    }
  }
  df.res <- object$df.resid
  if(df.res > 0) {
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmrows[nterms] <- "Residuals"
  }
  ok <- df > 0
  if(all(ok)) ms <- ss/df
  else {
    ms <- rep(NA, nterms)
    ms[ok] <- ss[ok]/df[ok]
  }
  x <- list(Df = df, "Sum of Sq" = ss, "Mean Sq" = ms)
  if(df.res > 0) {
    TT <- ms/ms[nterms]
    TP <- 1 - pf(TT, df, df.res)
    TT[nterms] <- TP[nterms] <- NA
    x$"F Value" <- TT
    x$"Pr(F)" <- TP
  }
  class(x) <- c("anova", "data.frame")
  row.names(x) <- format(nmrows)
  if(!keep.zero.df) x <- x[df > 0, ]
  if(!intercept) x <- x[-1,]
  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, ...)
{
  pattern <- function(x, ...) {
    x[abs(x) < 1e-6] <- 0
    if(exists("fractions", mode="function")) fractions(x) else x
  }
  Model <- object$terms
  attributes(Model) <- NULL
  value <- list(Model = Model)
  R <- object$qr$qr
  R <- R[1:ncol(R), ]
  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 <- dimnames(R)[[2]]
        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])
        pattern(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
    value$Partial <- beta11
  }
  class(value) <- "listof"
  value
}
print.listof <- function(x, ...)
{
  nn <- names(x)
  ll <- length(x)
  if(length(nn) != ll) nn <- paste("Component", seq(ll))
  for(i in seq(ll)) {
    cat(nn[i], ":\n"); print(x[[i]], ...); cat("\n")
  }
}
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)
	ds <- 1:dl
	if(dl == 0)
		stop("dim(X) must have a positive length")
	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)
	if(!ans.list)
		ans <- unlist(ans, recursive = FALSE)
	if(length(MARGIN) == 1 && length(ans) == d2) {
		if(length(dn.ans[[1]]) > 0)
			names(ans) <- dn.ans[[1]]
		else names(ans) <- NULL
		return(ans)
	}
	else if(length(ans) == d2)
		return(array(ans, d.ans, dn.ans))
	else if(length(ans) > 0 && length(ans) %% d2 == 0) {
		if(is.null(dn.ans))
			return(array(ans, c(length(ans)/d2, d[MARGIN])))
		else return(array(ans, c(length(ans)/d2, d.ans),
				c(list(ans.names), dn.ans)))
	}
	else 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 ]
 if(check.mode && any(ind)) {
          ii <- which(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]
 } else {
          if(numeric.) structure(which(ind), names=sp[ind]) else sp[ind]
 }
}
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]
	}
	dim(data) <- dim
	if(is.list(dimnames))
		dimnames(data) <- dimnames
	data
}
arrows <-
function(x0, y0, x1, y1, length=0.25, angle=30, code=2,
	col=par("fg"), lty=NULL, xpd=FALSE) {
 .Internal(arrows(
	x0,
	y0,
	x1,
	y1,
	length=length,
	angle=angle,
	code=code,
	col=col,
	lty=lty,
	xpd=xpd))
}
as.logical <- function(x) .Internal(as.vector(x,"logical"))
as.integer <- function(x) .Internal(as.vector(x,"integer"))
as.double <- function(x) .Internal(as.vector(x,"double"))
as.real <- .Alias(as.double)
as.complex <- function(x) .Internal(as.vector(x, "complex"))
as.single <- function(x) {
  warning("type single is not supported in R")
  .Internal(as.vector(x,"double"))
}
as.character <- function(x) .Internal(as.vector(x,"character"))
as.expression <- function(x) .Internal(as.vector(x,"expression"))
"as.list" <-
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"))
}
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) NULL
as.function <- function(x,...) UseMethod("as.function")
"as.function.default" <-
function (l, envir = sys.frame(sys.parent())) 
{
  if (!is.list(l)) 
    stop("Can't coerce object to function")
  ln <- length(l)
  alist <- l[-ln]
  body <- l[[ln]]
  if (is.expression(body)) 
    body <- body[[1]]
  if (ln < 2) 
    e <- substitute(function() body)
  else {
    e <- substitute(function(x) body)
    e[[2]] <- alist
  }
  eval(e, 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 tercol=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()
}
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))
print.anova <- function(x, digits = max(.Options$digits - 2, 3),
                        signif.stars= .Options$show.signif.stars, ...)
{
  heading <- attr(x, "heading")
  if (!is.null(heading)) cat(heading, sep = "\n")
  attr(x, "heading") <- NULL
  nn <- names(x)
###-- we should be able to do withOUT for()
###-- and use new   print.coefmat(.), instead ! -- MM.
  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)
}
## which (invisibly) returns the newly changed, instead of the original x !
#### copyright (C) 1998 W. N. Venables and B. D. Ripley
aov <-
  function(formula, data = sys.parent(), projections = FALSE, contrasts =
        NULL, ...)
{
  if(projections) stop("projections are not implemented")
  lmcall <- Call <- match.call()
  lmcall[[1]] <- as.name("lm")
  lmcall$singular.ok <- TRUE
  lmcall$projections <- NULL
  fit <- eval(lmcall, sys.frame(sys.parent()))
  class(fit) <- c("aov", "lm")
  fit$call <- Call
  fit
}
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]] # changed
  effects <- x$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(x$terms, "term.labels"))
  nterms <- max(asgn)+1
  df <- ss <- numeric(nterms)
  if(nterms) {
    for(i in seq(nterms)) {
      ai <- asgn==(i-1) # delete line
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
    }
    keep <- df > 0
    if(!intercept) keep[1] <- FALSE
    nmeffect <- nmeffect[keep]
    df <- df[keep]
    ss <- ss[keep]
    nterms <- length(df)
  }
  cat("\nTerms:\n")
  if(nterms == 0) {
    # empty model
    print(matrix(0, 1, 2, dimnames=list("<empty>",
                            c("Sum of Squares", "Deg. of Freedom"))))
    return(invisible(x))
  }
  df.res <- x$df.resid
  if(is.null(df.res))
    df.res <- length(x$resid) - length(asgn)
  if(df.res > 0) {
    resid <- x$resid
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmeffect[nterms] <- "Residuals"
  }
  print(matrix(c(format(ss), format(df)), 2, nterms, byrow=TRUE,
               dimnames=list(c("Sum of Squares", "Deg. of Freedom"),
               nmeffect)),
        quote = FALSE, right = TRUE)
  rank <- x$rank
  int <- attr(x$terms, "int")
  nobs <- length(x$residuals) - !(is.null(int) || int == 0)
  rdf <- x$df.resid
  if(is.null(rdf)) rdf <- nobs - rank
  cat("\n")
  if(rdf > 0)
    cat("Residual standard error:", format(sqrt(sum(x$residuals^2)/
                                                rdf)), "\n")
  coef <- x$coef
  R <- x$qr$qr
  R <- R[1:ncol(R), ]
  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]
    }
  dm <- dim(R)
  d <- seq(1, length = min(dm), by = dm[1] + 1)
  R <- abs(R)
  if(sum(R[ - d])/sum(R[d]) > 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]] # changed
  nterms <- max(asgn)+1
  effects <- object$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(object$terms, "term.labels"))
  resid <- object$residuals
  wt <- object$weights
  if(!is.null(wt)) resid <- resid * wt^0.5
  if(is.null(effects)) {
    df <- nterms  <- 0
    ss <- ms <- numeric(0)
    nmrows <- character(0)
  }
  else {
    nobs <- length(resid)
    nterms <- max(asgn)+1
    df <- ss <- numeric(nterms)
    nmrows <- character(nterms)
    for(i in 1:nterms) {
      ai <- asgn == (i-1) # changed
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
      nmrows[i] <- nmeffect[i]
    }
  }
  df.res <- object$df.resid
  if(df.res > 0) {
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmrows[nterms] <- "Residuals"
  }
  ok <- df > 0
  if(all(ok)) ms <- ss/df
  else {
    ms <- rep(NA, nterms)
    ms[ok] <- ss[ok]/df[ok]
  }
  x <- list(Df = df, "Sum of Sq" = ss, "Mean Sq" = ms)
  if(df.res > 0) {
    TT <- ms/ms[nterms]
    TP <- 1 - pf(TT, df, df.res)
    TT[nterms] <- TP[nterms] <- NA
    x$"F Value" <- TT
    x$"Pr(F)" <- TP
  }
  class(x) <- c("anova", "data.frame")
  row.names(x) <- format(nmrows)
  if(!keep.zero.df) x <- x[df > 0, ]
  if(!intercept) x <- x[-1,]
  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, ...)
{
  pattern <- function(x, ...) {
    x[abs(x) < 1e-6] <- 0
    if(exists("fractions", mode="function")) fractions(x) else x
  }
  Model <- object$terms
  attributes(Model) <- NULL
  value <- list(Model = Model)
  R <- object$qr$qr
  R <- R[1:ncol(R), ]
  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 <- dimnames(R)[[2]]
        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])
        pattern(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
    value$Partial <- beta11
  }
  class(value) <- "listof"
  value
}
print.listof <- function(x, ...)
{
  nn <- names(x)
  ll <- length(x)
  if(length(nn) != ll) nn <- paste("Component", seq(ll))
  for(i in seq(ll)) {
    cat(nn[i], ":\n"); print(x[[i]], ...); cat("\n")
  }
}
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)
	ds <- 1:dl
	if(dl == 0)
		stop("dim(X) must have a positive length")
	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)
	if(!ans.list)
		ans <- unlist(ans, recursive = FALSE)
	if(length(MARGIN) == 1 && length(ans) == d2) {
		if(length(dn.ans[[1]]) > 0)
			names(ans) <- dn.ans[[1]]
		else names(ans) <- NULL
		return(ans)
	}
	else if(length(ans) == d2)
		return(array(ans, d.ans, dn.ans))
	else if(length(ans) > 0 && length(ans) %% d2 == 0) {
		if(is.null(dn.ans))
			return(array(ans, c(length(ans)/d2, d[MARGIN])))
		else return(array(ans, c(length(ans)/d2, d.ans),
				c(list(ans.names), dn.ans)))
	}
	else 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 ]
 if(check.mode && any(ind)) {
          ii <- which(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]
 } else {
          if(numeric.) structure(which(ind), names=sp[ind]) else sp[ind]
 }
}
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]
	}
	dim(data) <- dim
	if(is.list(dimnames))
		dimnames(data) <- dimnames
	data
}
arrows <-
function(x0, y0, x1, y1, length=0.25, angle=30, code=2,
	col=par("fg"), lty=NULL, xpd=FALSE) {
 .Internal(arrows(
	x0,
	y0,
	x1,
	y1,
	length=length,
	angle=angle,
	code=code,
	col=col,
	lty=lty,
	xpd=xpd))
}
as.logical <- function(x) .Internal(as.vector(x,"logical"))
as.integer <- function(x) .Internal(as.vector(x,"integer"))
as.double <- function(x) .Internal(as.vector(x,"double"))
as.real <- .Alias(as.double)
as.complex <- function(x) .Internal(as.vector(x, "complex"))
as.single <- function(x) {
  warning("type single is not supported in R")
  .Internal(as.vector(x,"double"))
}
as.character <- function(x) .Internal(as.vector(x,"character"))
as.expression <- function(x) .Internal(as.vector(x,"expression"))
"as.list" <-
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"))
}
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) NULL
as.function <- function(x,...) UseMethod("as.function")
"as.function.default" <-
function (l, envir = sys.frame(sys.parent())) 
{
  if (!is.list(l)) 
    stop("Can't coerce object to function")
  ln <- length(l)
  alist <- l[-ln]
  body <- l[[ln]]
  if (is.expression(body)) 
    body <- body[[1]]
  if (ln < 2) 
    e <- substitute(function() body)
  else {
    e <- substitute(function(x) body)
    e[[2]] <- alist
  }
  eval(e, 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 tercol=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()
}
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))
print.anova <- function(x, digits = max(.Options$digits - 2, 3),
                        signif.stars= .Options$show.signif.stars, ...)
{
  heading <- attr(x, "heading")
  if (!is.null(heading)) cat(heading, sep = "\n")
  attr(x, "heading") <- NULL
  nn <- names(x)
###-- we should be able to do withOUT for()
###-- and use new   print.coefmat(.), instead ! -- MM.
  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)
}
## which (invisibly) returns the newly changed, instead of the original x !
#### copyright (C) 1998 W. N. Venables and B. D. Ripley
aov <-
  function(formula, data = sys.parent(), projections = FALSE, contrasts =
        NULL, ...)
{
  if(projections) stop("projections are not implemented")
  lmcall <- Call <- match.call()
  lmcall[[1]] <- as.name("lm")
  lmcall$singular.ok <- TRUE
  lmcall$projections <- NULL
  fit <- eval(lmcall, sys.frame(sys.parent()))
  class(fit) <- c("aov", "lm")
  fit$call <- Call
  fit
}
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]] # changed
  effects <- x$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(x$terms, "term.labels"))
  nterms <- max(asgn)+1
  df <- ss <- numeric(nterms)
  if(nterms) {
    for(i in seq(nterms)) {
      ai <- asgn==(i-1) # delete line
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
    }
    keep <- df > 0
    if(!intercept) keep[1] <- FALSE
    nmeffect <- nmeffect[keep]
    df <- df[keep]
    ss <- ss[keep]
    nterms <- length(df)
  }
  cat("\nTerms:\n")
  if(nterms == 0) {
    # empty model
    print(matrix(0, 1, 2, dimnames=list("<empty>",
                            c("Sum of Squares", "Deg. of Freedom"))))
    return(invisible(x))
  }
  df.res <- x$df.resid
  if(is.null(df.res))
    df.res <- length(x$resid) - length(asgn)
  if(df.res > 0) {
    resid <- x$resid
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmeffect[nterms] <- "Residuals"
  }
  print(matrix(c(format(ss), format(df)), 2, nterms, byrow=TRUE,
               dimnames=list(c("Sum of Squares", "Deg. of Freedom"),
               nmeffect)),
        quote = FALSE, right = TRUE)
  rank <- x$rank
  int <- attr(x$terms, "int")
  nobs <- length(x$residuals) - !(is.null(int) || int == 0)
  rdf <- x$df.resid
  if(is.null(rdf)) rdf <- nobs - rank
  cat("\n")
  if(rdf > 0)
    cat("Residual standard error:", format(sqrt(sum(x$residuals^2)/
                                                rdf)), "\n")
  coef <- x$coef
  R <- x$qr$qr
  R <- R[1:ncol(R), ]
  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]
    }
  dm <- dim(R)
  d <- seq(1, length = min(dm), by = dm[1] + 1)
  R <- abs(R)
  if(sum(R[ - d])/sum(R[d]) > 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]] # changed
  nterms <- max(asgn)+1
  effects <- object$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(object$terms, "term.labels"))
  resid <- object$residuals
  wt <- object$weights
  if(!is.null(wt)) resid <- resid * wt^0.5
  if(is.null(effects)) {
    df <- nterms  <- 0
    ss <- ms <- numeric(0)
    nmrows <- character(0)
  }
  else {
    nobs <- length(resid)
    nterms <- max(asgn)+1
    df <- ss <- numeric(nterms)
    nmrows <- character(nterms)
    for(i in 1:nterms) {
      ai <- asgn == (i-1) # changed
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
      nmrows[i] <- nmeffect[i]
    }
  }
  df.res <- object$df.resid
  if(df.res > 0) {
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmrows[nterms] <- "Residuals"
  }
  ok <- df > 0
  if(all(ok)) ms <- ss/df
  else {
    ms <- rep(NA, nterms)
    ms[ok] <- ss[ok]/df[ok]
  }
  x <- list(Df = df, "Sum of Sq" = ss, "Mean Sq" = ms)
  if(df.res > 0) {
    TT <- ms/ms[nterms]
    TP <- 1 - pf(TT, df, df.res)
    TT[nterms] <- TP[nterms] <- NA
    x$"F Value" <- TT
    x$"Pr(F)" <- TP
  }
  class(x) <- c("anova", "data.frame")
  row.names(x) <- format(nmrows)
  if(!keep.zero.df) x <- x[df > 0, ]
  if(!intercept) x <- x[-1,]
  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, ...)
{
  pattern <- function(x, ...) {
    x[abs(x) < 1e-6] <- 0
    if(exists("fractions", mode="function")) fractions(x) else x
  }
  Model <- object$terms
  attributes(Model) <- NULL
  value <- list(Model = Model)
  R <- object$qr$qr
  R <- R[1:ncol(R), ]
  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 <- dimnames(R)[[2]]
        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])
        pattern(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
    value$Partial <- beta11
  }
  class(value) <- "listof"
  value
}
print.listof <- function(x, ...)
{
  nn <- names(x)
  ll <- length(x)
  if(length(nn) != ll) nn <- paste("Component", seq(ll))
  for(i in seq(ll)) {
    cat(nn[i], ":\n"); print(x[[i]], ...); cat("\n")
  }
}
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)
	ds <- 1:dl
	if(dl == 0)
		stop("dim(X) must have a positive length")
	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)
	if(!ans.list)
		ans <- unlist(ans, recursive = FALSE)
	if(length(MARGIN) == 1 && length(ans) == d2) {
		if(length(dn.ans[[1]]) > 0)
			names(ans) <- dn.ans[[1]]
		else names(ans) <- NULL
		return(ans)
	}
	else if(length(ans) == d2)
		return(array(ans, d.ans, dn.ans))
	else if(length(ans) > 0 && length(ans) %% d2 == 0) {
		if(is.null(dn.ans))
			return(array(ans, c(length(ans)/d2, d[MARGIN])))
		else return(array(ans, c(length(ans)/d2, d.ans),
				c(list(ans.names), dn.ans)))
	}
	else 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 ]
 if(check.mode && any(ind)) {
          ii <- which(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]
 } else {
          if(numeric.) structure(which(ind), names=sp[ind]) else sp[ind]
 }
}
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]
	}
	dim(data) <- dim
	if(is.list(dimnames))
		dimnames(data) <- dimnames
	data
}
arrows <-
function(x0, y0, x1, y1, length=0.25, angle=30, code=2,
	col=par("fg"), lty=NULL, xpd=FALSE) {
 .Internal(arrows(
	x0,
	y0,
	x1,
	y1,
	length=length,
	angle=angle,
	code=code,
	col=col,
	lty=lty,
	xpd=xpd))
}
as.logical <- function(x) .Internal(as.vector(x,"logical"))
as.integer <- function(x) .Internal(as.vector(x,"integer"))
as.double <- function(x) .Internal(as.vector(x,"double"))
as.real <- .Alias(as.double)
as.complex <- function(x) .Internal(as.vector(x, "complex"))
as.single <- function(x) {
  warning("type single is not supported in R")
  .Internal(as.vector(x,"double"))
}
as.character <- function(x) .Internal(as.vector(x,"character"))
as.expression <- function(x) .Internal(as.vector(x,"expression"))
"as.list" <-
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"))
}
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) NULL
as.function <- function(x,...) UseMethod("as.function")
"as.function.default" <-
function (l, envir = sys.frame(sys.parent())) 
{
  if (!is.list(l)) 
    stop("Can't coerce object to function")
  ln <- length(l)
  alist <- l[-ln]
  body <- l[[ln]]
  if (is.expression(body)) 
    body <- body[[1]]
  if (ln < 2) 
    e <- substitute(function() body)
  else {
    e <- substitute(function(x) body)
    e[[2]] <- alist
  }
  eval(e, 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 tercol=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()
}
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))
print.anova <- function(x, digits = max(.Options$digits - 2, 3),
                        signif.stars= .Options$show.signif.stars, ...)
{
  heading <- attr(x, "heading")
  if (!is.null(heading)) cat(heading, sep = "\n")
  attr(x, "heading") <- NULL
  nn <- names(x)
###-- we should be able to do withOUT for()
###-- and use new   print.coefmat(.), instead ! -- MM.
  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)
}
## which (invisibly) returns the newly changed, instead of the original x !
#### copyright (C) 1998 W. N. Venables and B. D. Ripley
aov <-
  function(formula, data = sys.parent(), projections = FALSE, contrasts =
        NULL, ...)
{
  if(projections) stop("projections are not implemented")
  lmcall <- Call <- match.call()
  lmcall[[1]] <- as.name("lm")
  lmcall$singular.ok <- TRUE
  lmcall$projections <- NULL
  fit <- eval(lmcall, sys.frame(sys.parent()))
  class(fit) <- c("aov", "lm")
  fit$call <- Call
  fit
}
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]] # changed
  effects <- x$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(x$terms, "term.labels"))
  nterms <- max(asgn)+1
  df <- ss <- numeric(nterms)
  if(nterms) {
    for(i in seq(nterms)) {
      ai <- asgn==(i-1) # delete line
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
    }
    keep <- df > 0
    if(!intercept) keep[1] <- FALSE
    nmeffect <- nmeffect[keep]
    df <- df[keep]
    ss <- ss[keep]
    nterms <- length(df)
  }
  cat("\nTerms:\n")
  if(nterms == 0) {
    # empty model
    print(matrix(0, 1, 2, dimnames=list("<empty>",
                            c("Sum of Squares", "Deg. of Freedom"))))
    return(invisible(x))
  }
  df.res <- x$df.resid
  if(is.null(df.res))
    df.res <- length(x$resid) - length(asgn)
  if(df.res > 0) {
    resid <- x$resid
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmeffect[nterms] <- "Residuals"
  }
  print(matrix(c(format(ss), format(df)), 2, nterms, byrow=TRUE,
               dimnames=list(c("Sum of Squares", "Deg. of Freedom"),
               nmeffect)),
        quote = FALSE, right = TRUE)
  rank <- x$rank
  int <- attr(x$terms, "int")
  nobs <- length(x$residuals) - !(is.null(int) || int == 0)
  rdf <- x$df.resid
  if(is.null(rdf)) rdf <- nobs - rank
  cat("\n")
  if(rdf > 0)
    cat("Residual standard error:", format(sqrt(sum(x$residuals^2)/
                                                rdf)), "\n")
  coef <- x$coef
  R <- x$qr$qr
  R <- R[1:ncol(R), ]
  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]
    }
  dm <- dim(R)
  d <- seq(1, length = min(dm), by = dm[1] + 1)
  R <- abs(R)
  if(sum(R[ - d])/sum(R[d]) > 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]] # changed
  nterms <- max(asgn)+1
  effects <- object$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(object$terms, "term.labels"))
  resid <- object$residuals
  wt <- object$weights
  if(!is.null(wt)) resid <- resid * wt^0.5
  if(is.null(effects)) {
    df <- nterms  <- 0
    ss <- ms <- numeric(0)
    nmrows <- character(0)
  }
  else {
    nobs <- length(resid)
    nterms <- max(asgn)+1
    df <- ss <- numeric(nterms)
    nmrows <- character(nterms)
    for(i in 1:nterms) {
      ai <- asgn == (i-1) # changed
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
      nmrows[i] <- nmeffect[i]
    }
  }
  df.res <- object$df.resid
  if(df.res > 0) {
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmrows[nterms] <- "Residuals"
  }
  ok <- df > 0
  if(all(ok)) ms <- ss/df
  else {
    ms <- rep(NA, nterms)
    ms[ok] <- ss[ok]/df[ok]
  }
  x <- list(Df = df, "Sum of Sq" = ss, "Mean Sq" = ms)
  if(df.res > 0) {
    TT <- ms/ms[nterms]
    TP <- 1 - pf(TT, df, df.res)
    TT[nterms] <- TP[nterms] <- NA
    x$"F Value" <- TT
    x$"Pr(F)" <- TP
  }
  class(x) <- c("anova", "data.frame")
  row.names(x) <- format(nmrows)
  if(!keep.zero.df) x <- x[df > 0, ]
  if(!intercept) x <- x[-1,]
  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, ...)
{
  pattern <- function(x, ...) {
    x[abs(x) < 1e-6] <- 0
    if(exists("fractions", mode="function")) fractions(x) else x
  }
  Model <- object$terms
  attributes(Model) <- NULL
  value <- list(Model = Model)
  R <- object$qr$qr
  R <- R[1:ncol(R), ]
  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 <- dimnames(R)[[2]]
        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])
        pattern(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
    value$Partial <- beta11
  }
  class(value) <- "listof"
  value
}
print.listof <- function(x, ...)
{
  nn <- names(x)
  ll <- length(x)
  if(length(nn) != ll) nn <- paste("Component", seq(ll))
  for(i in seq(ll)) {
    cat(nn[i], ":\n"); print(x[[i]], ...); cat("\n")
  }
}
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)
	ds <- 1:dl
	if(dl == 0)
		stop("dim(X) must have a positive length")
	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)
	if(!ans.list)
		ans <- unlist(ans, recursive = FALSE)
	if(length(MARGIN) == 1 && length(ans) == d2) {
		if(length(dn.ans[[1]]) > 0)
			names(ans) <- dn.ans[[1]]
		else names(ans) <- NULL
		return(ans)
	}
	else if(length(ans) == d2)
		return(array(ans, d.ans, dn.ans))
	else if(length(ans) > 0 && length(ans) %% d2 == 0) {
		if(is.null(dn.ans))
			return(array(ans, c(length(ans)/d2, d[MARGIN])))
		else return(array(ans, c(length(ans)/d2, d.ans),
				c(list(ans.names), dn.ans)))
	}
	else 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 ]
 if(check.mode && any(ind)) {
          ii <- which(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]
 } else {
          if(numeric.) structure(which(ind), names=sp[ind]) else sp[ind]
 }
}
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]
	}
	dim(data) <- dim
	if(is.list(dimnames))
		dimnames(data) <- dimnames
	data
}
arrows <-
function(x0, y0, x1, y1, length=0.25, angle=30, code=2,
	col=par("fg"), lty=NULL, xpd=FALSE) {
 .Internal(arrows(
	x0,
	y0,
	x1,
	y1,
	length=length,
	angle=angle,
	code=code,
	col=col,
	lty=lty,
	xpd=xpd))
}
as.logical <- function(x) .Internal(as.vector(x,"logical"))
as.integer <- function(x) .Internal(as.vector(x,"integer"))
as.double <- function(x) .Internal(as.vector(x,"double"))
as.real <- .Alias(as.double)
as.complex <- function(x) .Internal(as.vector(x, "complex"))
as.single <- function(x) {
  warning("type single is not supported in R")
  .Internal(as.vector(x,"double"))
}
as.character <- function(x) .Internal(as.vector(x,"character"))
as.expression <- function(x) .Internal(as.vector(x,"expression"))
"as.list" <-
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"))
}
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) NULL
as.function <- function(x,...) UseMethod("as.function")
"as.function.default" <-
function (l, envir = sys.frame(sys.parent())) 
{
  if (!is.list(l)) 
    stop("Can't coerce object to function")
  ln <- length(l)
  alist <- l[-ln]
  body <- l[[ln]]
  if (is.expression(body)) 
    body <- body[[1]]
  if (ln < 2) 
    e <- substitute(function() body)
  else {
    e <- substitute(function(x) body)
    e[[2]] <- alist
  }
  eval(e, 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 tercol=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()
}
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))
print.anova <- function(x, digits = max(.Options$digits - 2, 3),
                        signif.stars= .Options$show.signif.stars, ...)
{
  heading <- attr(x, "heading")
  if (!is.null(heading)) cat(heading, sep = "\n")
  attr(x, "heading") <- NULL
  nn <- names(x)
###-- we should be able to do withOUT for()
###-- and use new   print.coefmat(.), instead ! -- MM.
  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)
}
## which (invisibly) returns the newly changed, instead of the original x !
#### copyright (C) 1998 W. N. Venables and B. D. Ripley
aov <-
  function(formula, data = sys.parent(), projections = FALSE, contrasts =
        NULL, ...)
{
  if(projections) stop("projections are not implemented")
  lmcall <- Call <- match.call()
  lmcall[[1]] <- as.name("lm")
  lmcall$singular.ok <- TRUE
  lmcall$projections <- NULL
  fit <- eval(lmcall, sys.frame(sys.parent()))
  class(fit) <- c("aov", "lm")
  fit$call <- Call
  fit
}
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]] # changed
  effects <- x$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(x$terms, "term.labels"))
  nterms <- max(asgn)+1
  df <- ss <- numeric(nterms)
  if(nterms) {
    for(i in seq(nterms)) {
      ai <- asgn==(i-1) # delete line
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
    }
    keep <- df > 0
    if(!intercept) keep[1] <- FALSE
    nmeffect <- nmeffect[keep]
    df <- df[keep]
    ss <- ss[keep]
    nterms <- length(df)
  }
  cat("\nTerms:\n")
  if(nterms == 0) {
    # empty model
    print(matrix(0, 1, 2, dimnames=list("<empty>",
                            c("Sum of Squares", "Deg. of Freedom"))))
    return(invisible(x))
  }
  df.res <- x$df.resid
  if(is.null(df.res))
    df.res <- length(x$resid) - length(asgn)
  if(df.res > 0) {
    resid <- x$resid
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmeffect[nterms] <- "Residuals"
  }
  print(matrix(c(format(ss), format(df)), 2, nterms, byrow=TRUE,
               dimnames=list(c("Sum of Squares", "Deg. of Freedom"),
               nmeffect)),
        quote = FALSE, right = TRUE)
  rank <- x$rank
  int <- attr(x$terms, "int")
  nobs <- length(x$residuals) - !(is.null(int) || int == 0)
  rdf <- x$df.resid
  if(is.null(rdf)) rdf <- nobs - rank
  cat("\n")
  if(rdf > 0)
    cat("Residual standard error:", format(sqrt(sum(x$residuals^2)/
                                                rdf)), "\n")
  coef <- x$coef
  R <- x$qr$qr
  R <- R[1:ncol(R), ]
  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]
    }
  dm <- dim(R)
  d <- seq(1, length = min(dm), by = dm[1] + 1)
  R <- abs(R)
  if(sum(R[ - d])/sum(R[d]) > 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]] # changed
  nterms <- max(asgn)+1
  effects <- object$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(object$terms, "term.labels"))
  resid <- object$residuals
  wt <- object$weights
  if(!is.null(wt)) resid <- resid * wt^0.5
  if(is.null(effects)) {
    df <- nterms  <- 0
    ss <- ms <- numeric(0)
    nmrows <- character(0)
  }
  else {
    nobs <- length(resid)
    nterms <- max(asgn)+1
    df <- ss <- numeric(nterms)
    nmrows <- character(nterms)
    for(i in 1:nterms) {
      ai <- asgn == (i-1) # changed
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
      nmrows[i] <- nmeffect[i]
    }
  }
  df.res <- object$df.resid
  if(df.res > 0) {
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmrows[nterms] <- "Residuals"
  }
  ok <- df > 0
  if(all(ok)) ms <- ss/df
  else {
    ms <- rep(NA, nterms)
    ms[ok] <- ss[ok]/df[ok]
  }
  x <- list(Df = df, "Sum of Sq" = ss, "Mean Sq" = ms)
  if(df.res > 0) {
    TT <- ms/ms[nterms]
    TP <- 1 - pf(TT, df, df.res)
    TT[nterms] <- TP[nterms] <- NA
    x$"F Value" <- TT
    x$"Pr(F)" <- TP
  }
  class(x) <- c("anova", "data.frame")
  row.names(x) <- format(nmrows)
  if(!keep.zero.df) x <- x[df > 0, ]
  if(!intercept) x <- x[-1,]
  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, ...)
{
  pattern <- function(x, ...) {
    x[abs(x) < 1e-6] <- 0
    if(exists("fractions", mode="function")) fractions(x) else x
  }
  Model <- object$terms
  attributes(Model) <- NULL
  value <- list(Model = Model)
  R <- object$qr$qr
  R <- R[1:ncol(R), ]
  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 <- dimnames(R)[[2]]
        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])
        pattern(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
    value$Partial <- beta11
  }
  class(value) <- "listof"
  value
}
print.listof <- function(x, ...)
{
  nn <- names(x)
  ll <- length(x)
  if(length(nn) != ll) nn <- paste("Component", seq(ll))
  for(i in seq(ll)) {
    cat(nn[i], ":\n"); print(x[[i]], ...); cat("\n")
  }
}
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)
	ds <- 1:dl
	if(dl == 0)
		stop("dim(X) must have a positive length")
	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)
	if(!ans.list)
		ans <- unlist(ans, recursive = FALSE)
	if(length(MARGIN) == 1 && length(ans) == d2) {
		if(length(dn.ans[[1]]) > 0)
			names(ans) <- dn.ans[[1]]
		else names(ans) <- NULL
		return(ans)
	}
	else if(length(ans) == d2)
		return(array(ans, d.ans, dn.ans))
	else if(length(ans) > 0 && length(ans) %% d2 == 0) {
		if(is.null(dn.ans))
			return(array(ans, c(length(ans)/d2, d[MARGIN])))
		else return(array(ans, c(length(ans)/d2, d.ans),
				c(list(ans.names), dn.ans)))
	}
	else 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 ]
 if(check.mode && any(ind)) {
          ii <- which(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]
 } else {
          if(numeric.) structure(which(ind), names=sp[ind]) else sp[ind]
 }
}
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]
	}
	dim(data) <- dim
	if(is.list(dimnames))
		dimnames(data) <- dimnames
	data
}
arrows <-
function(x0, y0, x1, y1, length=0.25, angle=30, code=2,
	col=par("fg"), lty=NULL, xpd=FALSE) {
 .Internal(arrows(
	x0,
	y0,
	x1,
	y1,
	length=length,
	angle=angle,
	code=code,
	col=col,
	lty=lty,
	xpd=xpd))
}
as.logical <- function(x) .Internal(as.vector(x,"logical"))
as.integer <- function(x) .Internal(as.vector(x,"integer"))
as.double <- function(x) .Internal(as.vector(x,"double"))
as.real <- .Alias(as.double)
as.complex <- function(x) .Internal(as.vector(x, "complex"))
as.single <- function(x) {
  warning("type single is not supported in R")
  .Internal(as.vector(x,"double"))
}
as.character <- function(x) .Internal(as.vector(x,"character"))
as.expression <- function(x) .Internal(as.vector(x,"expression"))
"as.list" <-
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"))
}
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) NULL
as.function <- function(x,...) UseMethod("as.function")
"as.function.default" <-
function (l, envir = sys.frame(sys.parent())) 
{
  if (!is.list(l)) 
    stop("Can't coerce object to function")
  ln <- length(l)
  alist <- l[-ln]
  body <- l[[ln]]
  if (is.expression(body)) 
    body <- body[[1]]
  if (ln < 2) 
    e <- substitute(function() body)
  else {
    e <- substitute(function(x) body)
    e[[2]] <- alist
  }
  eval(e, 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 tercol=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()
}
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))
print.anova <- function(x, digits = max(.Options$digits - 2, 3),
                        signif.stars= .Options$show.signif.stars, ...)
{
  heading <- attr(x, "heading")
  if (!is.null(heading)) cat(heading, sep = "\n")
  attr(x, "heading") <- NULL
  nn <- names(x)
###-- we should be able to do withOUT for()
###-- and use new   print.coefmat(.), instead ! -- MM.
  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)
}
## which (invisibly) returns the newly changed, instead of the original x !
#### copyright (C) 1998 W. N. Venables and B. D. Ripley
aov <-
  function(formula, data = sys.parent(), projections = FALSE, contrasts =
        NULL, ...)
{
  if(projections) stop("projections are not implemented")
  lmcall <- Call <- match.call()
  lmcall[[1]] <- as.name("lm")
  lmcall$singular.ok <- TRUE
  lmcall$projections <- NULL
  fit <- eval(lmcall, sys.frame(sys.parent()))
  class(fit) <- c("aov", "lm")
  fit$call <- Call
  fit
}
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]] # changed
  effects <- x$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(x$terms, "term.labels"))
  nterms <- max(asgn)+1
  df <- ss <- numeric(nterms)
  if(nterms) {
    for(i in seq(nterms)) {
      ai <- asgn==(i-1) # delete line
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
    }
    keep <- df > 0
    if(!intercept) keep[1] <- FALSE
    nmeffect <- nmeffect[keep]
    df <- df[keep]
    ss <- ss[keep]
    nterms <- length(df)
  }
  cat("\nTerms:\n")
  if(nterms == 0) {
    # empty model
    print(matrix(0, 1, 2, dimnames=list("<empty>",
                            c("Sum of Squares", "Deg. of Freedom"))))
    return(invisible(x))
  }
  df.res <- x$df.resid
  if(is.null(df.res))
    df.res <- length(x$resid) - length(asgn)
  if(df.res > 0) {
    resid <- x$resid
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmeffect[nterms] <- "Residuals"
  }
  print(matrix(c(format(ss), format(df)), 2, nterms, byrow=TRUE,
               dimnames=list(c("Sum of Squares", "Deg. of Freedom"),
               nmeffect)),
        quote = FALSE, right = TRUE)
  rank <- x$rank
  int <- attr(x$terms, "int")
  nobs <- length(x$residuals) - !(is.null(int) || int == 0)
  rdf <- x$df.resid
  if(is.null(rdf)) rdf <- nobs - rank
  cat("\n")
  if(rdf > 0)
    cat("Residual standard error:", format(sqrt(sum(x$residuals^2)/
                                                rdf)), "\n")
  coef <- x$coef
  R <- x$qr$qr
  R <- R[1:ncol(R), ]
  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]
    }
  dm <- dim(R)
  d <- seq(1, length = min(dm), by = dm[1] + 1)
  R <- abs(R)
  if(sum(R[ - d])/sum(R[d]) > 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]] # changed
  nterms <- max(asgn)+1
  effects <- object$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(object$terms, "term.labels"))
  resid <- object$residuals
  wt <- object$weights
  if(!is.null(wt)) resid <- resid * wt^0.5
  if(is.null(effects)) {
    df <- nterms  <- 0
    ss <- ms <- numeric(0)
    nmrows <- character(0)
  }
  else {
    nobs <- length(resid)
    nterms <- max(asgn)+1
    df <- ss <- numeric(nterms)
    nmrows <- character(nterms)
    for(i in 1:nterms) {
      ai <- asgn == (i-1) # changed
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
      nmrows[i] <- nmeffect[i]
    }
  }
  df.res <- object$df.resid
  if(df.res > 0) {
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmrows[nterms] <- "Residuals"
  }
  ok <- df > 0
  if(all(ok)) ms <- ss/df
  else {
    ms <- rep(NA, nterms)
    ms[ok] <- ss[ok]/df[ok]
  }
  x <- list(Df = df, "Sum of Sq" = ss, "Mean Sq" = ms)
  if(df.res > 0) {
    TT <- ms/ms[nterms]
    TP <- 1 - pf(TT, df, df.res)
    TT[nterms] <- TP[nterms] <- NA
    x$"F Value" <- TT
    x$"Pr(F)" <- TP
  }
  class(x) <- c("anova", "data.frame")
  row.names(x) <- format(nmrows)
  if(!keep.zero.df) x <- x[df > 0, ]
  if(!intercept) x <- x[-1,]
  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, ...)
{
  pattern <- function(x, ...) {
    x[abs(x) < 1e-6] <- 0
    if(exists("fractions", mode="function")) fractions(x) else x
  }
  Model <- object$terms
  attributes(Model) <- NULL
  value <- list(Model = Model)
  R <- object$qr$qr
  R <- R[1:ncol(R), ]
  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 <- dimnames(R)[[2]]
        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])
        pattern(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
    value$Partial <- beta11
  }
  class(value) <- "listof"
  value
}
print.listof <- function(x, ...)
{
  nn <- names(x)
  ll <- length(x)
  if(length(nn) != ll) nn <- paste("Component", seq(ll))
  for(i in seq(ll)) {
    cat(nn[i], ":\n"); print(x[[i]], ...); cat("\n")
  }
}
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)
	ds <- 1:dl
	if(dl == 0)
		stop("dim(X) must have a positive length")
	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)
	if(!ans.list)
		ans <- unlist(ans, recursive = FALSE)
	if(length(MARGIN) == 1 && length(ans) == d2) {
		if(length(dn.ans[[1]]) > 0)
			names(ans) <- dn.ans[[1]]
		else names(ans) <- NULL
		return(ans)
	}
	else if(length(ans) == d2)
		return(array(ans, d.ans, dn.ans))
	else if(length(ans) > 0 && length(ans) %% d2 == 0) {
		if(is.null(dn.ans))
			return(array(ans, c(length(ans)/d2, d[MARGIN])))
		else return(array(ans, c(length(ans)/d2, d.ans),
				c(list(ans.names), dn.ans)))
	}
	else 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 ]
 if(check.mode && any(ind)) {
          ii <- which(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]
 } else {
          if(numeric.) structure(which(ind), names=sp[ind]) else sp[ind]
 }
}
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]
	}
	dim(data) <- dim
	if(is.list(dimnames))
		dimnames(data) <- dimnames
	data
}
arrows <-
function(x0, y0, x1, y1, length=0.25, angle=30, code=2,
	col=par("fg"), lty=NULL, xpd=FALSE) {
 .Internal(arrows(
	x0,
	y0,
	x1,
	y1,
	length=length,
	angle=angle,
	code=code,
	col=col,
	lty=lty,
	xpd=xpd))
}
as.logical <- function(x) .Internal(as.vector(x,"logical"))
as.integer <- function(x) .Internal(as.vector(x,"integer"))
as.double <- function(x) .Internal(as.vector(x,"double"))
as.real <- .Alias(as.double)
as.complex <- function(x) .Internal(as.vector(x, "complex"))
as.single <- function(x) {
  warning("type single is not supported in R")
  .Internal(as.vector(x,"double"))
}
as.character <- function(x) .Internal(as.vector(x,"character"))
as.expression <- function(x) .Internal(as.vector(x,"expression"))
"as.list" <-
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"))
}
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) NULL
as.function <- function(x,...) UseMethod("as.function")
"as.function.default" <-
function (l, envir = sys.frame(sys.parent())) 
{
  if (!is.list(l)) 
    stop("Can't coerce object to function")
  ln <- length(l)
  alist <- l[-ln]
  body <- l[[ln]]
  if (is.expression(body)) 
    body <- body[[1]]
  if (ln < 2) 
    e <- substitute(function() body)
  else {
    e <- substitute(function(x) body)
    e[[2]] <- alist
  }
  eval(e, 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 tercol=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()
}
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))
print.anova <- function(x, digits = max(.Options$digits - 2, 3),
                        signif.stars= .Options$show.signif.stars, ...)
{
  heading <- attr(x, "heading")
  if (!is.null(heading)) cat(heading, sep = "\n")
  attr(x, "heading") <- NULL
  nn <- names(x)
###-- we should be able to do withOUT for()
###-- and use new   print.coefmat(.), instead ! -- MM.
  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)
}
## which (invisibly) returns the newly changed, instead of the original x !
#### copyright (C) 1998 W. N. Venables and B. D. Ripley
aov <-
  function(formula, data = sys.parent(), projections = FALSE, contrasts =
        NULL, ...)
{
  if(projections) stop("projections are not implemented")
  lmcall <- Call <- match.call()
  lmcall[[1]] <- as.name("lm")
  lmcall$singular.ok <- TRUE
  lmcall$projections <- NULL
  fit <- eval(lmcall, sys.frame(sys.parent()))
  class(fit) <- c("aov", "lm")
  fit$call <- Call
  fit
}
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]] # changed
  effects <- x$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(x$terms, "term.labels"))
  nterms <- max(asgn)+1
  df <- ss <- numeric(nterms)
  if(nterms) {
    for(i in seq(nterms)) {
      ai <- asgn==(i-1) # delete line
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
    }
    keep <- df > 0
    if(!intercept) keep[1] <- FALSE
    nmeffect <- nmeffect[keep]
    df <- df[keep]
    ss <- ss[keep]
    nterms <- length(df)
  }
  cat("\nTerms:\n")
  if(nterms == 0) {
    # empty model
    print(matrix(0, 1, 2, dimnames=list("<empty>",
                            c("Sum of Squares", "Deg. of Freedom"))))
    return(invisible(x))
  }
  df.res <- x$df.resid
  if(is.null(df.res))
    df.res <- length(x$resid) - length(asgn)
  if(df.res > 0) {
    resid <- x$resid
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmeffect[nterms] <- "Residuals"
  }
  print(matrix(c(format(ss), format(df)), 2, nterms, byrow=TRUE,
               dimnames=list(c("Sum of Squares", "Deg. of Freedom"),
               nmeffect)),
        quote = FALSE, right = TRUE)
  rank <- x$rank
  int <- attr(x$terms, "int")
  nobs <- length(x$residuals) - !(is.null(int) || int == 0)
  rdf <- x$df.resid
  if(is.null(rdf)) rdf <- nobs - rank
  cat("\n")
  if(rdf > 0)
    cat("Residual standard error:", format(sqrt(sum(x$residuals^2)/
                                                rdf)), "\n")
  coef <- x$coef
  R <- x$qr$qr
  R <- R[1:ncol(R), ]
  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]
    }
  dm <- dim(R)
  d <- seq(1, length = min(dm), by = dm[1] + 1)
  R <- abs(R)
  if(sum(R[ - d])/sum(R[d]) > 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]] # changed
  nterms <- max(asgn)+1
  effects <- object$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(object$terms, "term.labels"))
  resid <- object$residuals
  wt <- object$weights
  if(!is.null(wt)) resid <- resid * wt^0.5
  if(is.null(effects)) {
    df <- nterms  <- 0
    ss <- ms <- numeric(0)
    nmrows <- character(0)
  }
  else {
    nobs <- length(resid)
    nterms <- max(asgn)+1
    df <- ss <- numeric(nterms)
    nmrows <- character(nterms)
    for(i in 1:nterms) {
      ai <- asgn == (i-1) # changed
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
      nmrows[i] <- nmeffect[i]
    }
  }
  df.res <- object$df.resid
  if(df.res > 0) {
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmrows[nterms] <- "Residuals"
  }
  ok <- df > 0
  if(all(ok)) ms <- ss/df
  else {
    ms <- rep(NA, nterms)
    ms[ok] <- ss[ok]/df[ok]
  }
  x <- list(Df = df, "Sum of Sq" = ss, "Mean Sq" = ms)
  if(df.res > 0) {
    TT <- ms/ms[nterms]
    TP <- 1 - pf(TT, df, df.res)
    TT[nterms] <- TP[nterms] <- NA
    x$"F Value" <- TT
    x$"Pr(F)" <- TP
  }
  class(x) <- c("anova", "data.frame")
  row.names(x) <- format(nmrows)
  if(!keep.zero.df) x <- x[df > 0, ]
  if(!intercept) x <- x[-1,]
  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, ...)
{
  pattern <- function(x, ...) {
    x[abs(x) < 1e-6] <- 0
    if(exists("fractions", mode="function")) fractions(x) else x
  }
  Model <- object$terms
  attributes(Model) <- NULL
  value <- list(Model = Model)
  R <- object$qr$qr
  R <- R[1:ncol(R), ]
  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 <- dimnames(R)[[2]]
        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])
        pattern(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
    value$Partial <- beta11
  }
  class(value) <- "listof"
  value
}
print.listof <- function(x, ...)
{
  nn <- names(x)
  ll <- length(x)
  if(length(nn) != ll) nn <- paste("Component", seq(ll))
  for(i in seq(ll)) {
    cat(nn[i], ":\n"); print(x[[i]], ...); cat("\n")
  }
}
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)
	ds <- 1:dl
	if(dl == 0)
		stop("dim(X) must have a positive length")
	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)
	if(!ans.list)
		ans <- unlist(ans, recursive = FALSE)
	if(length(MARGIN) == 1 && length(ans) == d2) {
		if(length(dn.ans[[1]]) > 0)
			names(ans) <- dn.ans[[1]]
		else names(ans) <- NULL
		return(ans)
	}
	else if(length(ans) == d2)
		return(array(ans, d.ans, dn.ans))
	else if(length(ans) > 0 && length(ans) %% d2 == 0) {
		if(is.null(dn.ans))
			return(array(ans, c(length(ans)/d2, d[MARGIN])))
		else return(array(ans, c(length(ans)/d2, d.ans),
				c(list(ans.names), dn.ans)))
	}
	else 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 ]
 if(check.mode && any(ind)) {
          ii <- which(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]
 } else {
          if(numeric.) structure(which(ind), names=sp[ind]) else sp[ind]
 }
}
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]
	}
	dim(data) <- dim
	if(is.list(dimnames))
		dimnames(data) <- dimnames
	data
}
arrows <-
function(x0, y0, x1, y1, length=0.25, angle=30, code=2,
	col=par("fg"), lty=NULL, xpd=FALSE) {
 .Internal(arrows(
	x0,
	y0,
	x1,
	y1,
	length=length,
	angle=angle,
	code=code,
	col=col,
	lty=lty,
	xpd=xpd))
}
as.logical <- function(x) .Internal(as.vector(x,"logical"))
as.integer <- function(x) .Internal(as.vector(x,"integer"))
as.double <- function(x) .Internal(as.vector(x,"double"))
as.real <- .Alias(as.double)
as.complex <- function(x) .Internal(as.vector(x, "complex"))
as.single <- function(x) {
  warning("type single is not supported in R")
  .Internal(as.vector(x,"double"))
}
as.character <- function(x) .Internal(as.vector(x,"character"))
as.expression <- function(x) .Internal(as.vector(x,"expression"))
"as.list" <-
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"))
}
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) NULL
as.function <- function(x,...) UseMethod("as.function")
"as.function.default" <-
function (l, envir = sys.frame(sys.parent())) 
{
  if (!is.list(l)) 
    stop("Can't coerce object to function")
  ln <- length(l)
  alist <- l[-ln]
  body <- l[[ln]]
  if (is.expression(body)) 
    body <- body[[1]]
  if (ln < 2) 
    e <- substitute(function() body)
  else {
    e <- substitute(function(x) body)
    e[[2]] <- alist
  }
  eval(e, 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 tercol=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()
}
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))
print.anova <- function(x, digits = max(.Options$digits - 2, 3),
                        signif.stars= .Options$show.signif.stars, ...)
{
  heading <- attr(x, "heading")
  if (!is.null(heading)) cat(heading, sep = "\n")
  attr(x, "heading") <- NULL
  nn <- names(x)
###-- we should be able to do withOUT for()
###-- and use new   print.coefmat(.), instead ! -- MM.
  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)
}
## which (invisibly) returns the newly changed, instead of the original x !
#### copyright (C) 1998 W. N. Venables and B. D. Ripley
aov <-
  function(formula, data = sys.parent(), projections = FALSE, contrasts =
        NULL, ...)
{
  if(projections) stop("projections are not implemented")
  lmcall <- Call <- match.call()
  lmcall[[1]] <- as.name("lm")
  lmcall$singular.ok <- TRUE
  lmcall$projections <- NULL
  fit <- eval(lmcall, sys.frame(sys.parent()))
  class(fit) <- c("aov", "lm")
  fit$call <- Call
  fit
}
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]] # changed
  effects <- x$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(x$terms, "term.labels"))
  nterms <- max(asgn)+1
  df <- ss <- numeric(nterms)
  if(nterms) {
    for(i in seq(nterms)) {
      ai <- asgn==(i-1) # delete line
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
    }
    keep <- df > 0
    if(!intercept) keep[1] <- FALSE
    nmeffect <- nmeffect[keep]
    df <- df[keep]
    ss <- ss[keep]
    nterms <- length(df)
  }
  cat("\nTerms:\n")
  if(nterms == 0) {
    # empty model
    print(matrix(0, 1, 2, dimnames=list("<empty>",
                            c("Sum of Squares", "Deg. of Freedom"))))
    return(invisible(x))
  }
  df.res <- x$df.resid
  if(is.null(df.res))
    df.res <- length(x$resid) - length(asgn)
  if(df.res > 0) {
    resid <- x$resid
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmeffect[nterms] <- "Residuals"
  }
  print(matrix(c(format(ss), format(df)), 2, nterms, byrow=TRUE,
               dimnames=list(c("Sum of Squares", "Deg. of Freedom"),
               nmeffect)),
        quote = FALSE, right = TRUE)
  rank <- x$rank
  int <- attr(x$terms, "int")
  nobs <- length(x$residuals) - !(is.null(int) || int == 0)
  rdf <- x$df.resid
  if(is.null(rdf)) rdf <- nobs - rank
  cat("\n")
  if(rdf > 0)
    cat("Residual standard error:", format(sqrt(sum(x$residuals^2)/
                                                rdf)), "\n")
  coef <- x$coef
  R <- x$qr$qr
  R <- R[1:ncol(R), ]
  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]
    }
  dm <- dim(R)
  d <- seq(1, length = min(dm), by = dm[1] + 1)
  R <- abs(R)
  if(sum(R[ - d])/sum(R[d]) > 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]] # changed
  nterms <- max(asgn)+1
  effects <- object$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(object$terms, "term.labels"))
  resid <- object$residuals
  wt <- object$weights
  if(!is.null(wt)) resid <- resid * wt^0.5
  if(is.null(effects)) {
    df <- nterms  <- 0
    ss <- ms <- numeric(0)
    nmrows <- character(0)
  }
  else {
    nobs <- length(resid)
    nterms <- max(asgn)+1
    df <- ss <- numeric(nterms)
    nmrows <- character(nterms)
    for(i in 1:nterms) {
      ai <- asgn == (i-1) # changed
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
      nmrows[i] <- nmeffect[i]
    }
  }
  df.res <- object$df.resid
  if(df.res > 0) {
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmrows[nterms] <- "Residuals"
  }
  ok <- df > 0
  if(all(ok)) ms <- ss/df
  else {
    ms <- rep(NA, nterms)
    ms[ok] <- ss[ok]/df[ok]
  }
  x <- list(Df = df, "Sum of Sq" = ss, "Mean Sq" = ms)
  if(df.res > 0) {
    TT <- ms/ms[nterms]
    TP <- 1 - pf(TT, df, df.res)
    TT[nterms] <- TP[nterms] <- NA
    x$"F Value" <- TT
    x$"Pr(F)" <- TP
  }
  class(x) <- c("anova", "data.frame")
  row.names(x) <- format(nmrows)
  if(!keep.zero.df) x <- x[df > 0, ]
  if(!intercept) x <- x[-1,]
  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, ...)
{
  pattern <- function(x, ...) {
    x[abs(x) < 1e-6] <- 0
    if(exists("fractions", mode="function")) fractions(x) else x
  }
  Model <- object$terms
  attributes(Model) <- NULL
  value <- list(Model = Model)
  R <- object$qr$qr
  R <- R[1:ncol(R), ]
  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 <- dimnames(R)[[2]]
        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])
        pattern(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
    value$Partial <- beta11
  }
  class(value) <- "listof"
  value
}
print.listof <- function(x, ...)
{
  nn <- names(x)
  ll <- length(x)
  if(length(nn) != ll) nn <- paste("Component", seq(ll))
  for(i in seq(ll)) {
    cat(nn[i], ":\n"); print(x[[i]], ...); cat("\n")
  }
}
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)
	ds <- 1:dl
	if(dl == 0)
		stop("dim(X) must have a positive length")
	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)
	if(!ans.list)
		ans <- unlist(ans, recursive = FALSE)
	if(length(MARGIN) == 1 && length(ans) == d2) {
		if(length(dn.ans[[1]]) > 0)
			names(ans) <- dn.ans[[1]]
		else names(ans) <- NULL
		return(ans)
	}
	else if(length(ans) == d2)
		return(array(ans, d.ans, dn.ans))
	else if(length(ans) > 0 && length(ans) %% d2 == 0) {
		if(is.null(dn.ans))
			return(array(ans, c(length(ans)/d2, d[MARGIN])))
		else return(array(ans, c(length(ans)/d2, d.ans),
				c(list(ans.names), dn.ans)))
	}
	else 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 ]
 if(check.mode && any(ind)) {
          ii <- which(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]
 } else {
          if(numeric.) structure(which(ind), names=sp[ind]) else sp[ind]
 }
}
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]
	}
	dim(data) <- dim
	if(is.list(dimnames))
		dimnames(data) <- dimnames
	data
}
arrows <-
function(x0, y0, x1, y1, length=0.25, angle=30, code=2,
	col=par("fg"), lty=NULL, xpd=FALSE) {
 .Internal(arrows(
	x0,
	y0,
	x1,
	y1,
	length=length,
	angle=angle,
	code=code,
	col=col,
	lty=lty,
	xpd=xpd))
}
as.logical <- function(x) .Internal(as.vector(x,"logical"))
as.integer <- function(x) .Internal(as.vector(x,"integer"))
as.double <- function(x) .Internal(as.vector(x,"double"))
as.real <- .Alias(as.double)
as.complex <- function(x) .Internal(as.vector(x, "complex"))
as.single <- function(x) {
  warning("type single is not supported in R")
  .Internal(as.vector(x,"double"))
}
as.character <- function(x) .Internal(as.vector(x,"character"))
as.expression <- function(x) .Internal(as.vector(x,"expression"))
"as.list" <-
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"))
}
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) NULL
as.function <- function(x,...) UseMethod("as.function")
"as.function.default" <-
function (l, envir = sys.frame(sys.parent())) 
{
  if (!is.list(l)) 
    stop("Can't coerce object to function")
  ln <- length(l)
  alist <- l[-ln]
  body <- l[[ln]]
  if (is.expression(body)) 
    body <- body[[1]]
  if (ln < 2) 
    e <- substitute(function() body)
  else {
    e <- substitute(function(x) body)
    e[[2]] <- alist
  }
  eval(e, 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 tercol=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()
}
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))
print.anova <- function(x, digits = max(.Options$digits - 2, 3),
                        signif.stars= .Options$show.signif.stars, ...)
{
  heading <- attr(x, "heading")
  if (!is.null(heading)) cat(heading, sep = "\n")
  attr(x, "heading") <- NULL
  nn <- names(x)
###-- we should be able to do withOUT for()
###-- and use new   print.coefmat(.), instead ! -- MM.
  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)
}
## which (invisibly) returns the newly changed, instead of the original x !
#### copyright (C) 1998 W. N. Venables and B. D. Ripley
aov <-
  function(formula, data = sys.parent(), projections = FALSE, contrasts =
        NULL, ...)
{
  if(projections) stop("projections are not implemented")
  lmcall <- Call <- match.call()
  lmcall[[1]] <- as.name("lm")
  lmcall$singular.ok <- TRUE
  lmcall$projections <- NULL
  fit <- eval(lmcall, sys.frame(sys.parent()))
  class(fit) <- c("aov", "lm")
  fit$call <- Call
  fit
}
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]] # changed
  effects <- x$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(x$terms, "term.labels"))
  nterms <- max(asgn)+1
  df <- ss <- numeric(nterms)
  if(nterms) {
    for(i in seq(nterms)) {
      ai <- asgn==(i-1) # delete line
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
    }
    keep <- df > 0
    if(!intercept) keep[1] <- FALSE
    nmeffect <- nmeffect[keep]
    df <- df[keep]
    ss <- ss[keep]
    nterms <- length(df)
  }
  cat("\nTerms:\n")
  if(nterms == 0) {
    # empty model
    print(matrix(0, 1, 2, dimnames=list("<empty>",
                            c("Sum of Squares", "Deg. of Freedom"))))
    return(invisible(x))
  }
  df.res <- x$df.resid
  if(is.null(df.res))
    df.res <- length(x$resid) - length(asgn)
  if(df.res > 0) {
    resid <- x$resid
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmeffect[nterms] <- "Residuals"
  }
  print(matrix(c(format(ss), format(df)), 2, nterms, byrow=TRUE,
               dimnames=list(c("Sum of Squares", "Deg. of Freedom"),
               nmeffect)),
        quote = FALSE, right = TRUE)
  rank <- x$rank
  int <- attr(x$terms, "int")
  nobs <- length(x$residuals) - !(is.null(int) || int == 0)
  rdf <- x$df.resid
  if(is.null(rdf)) rdf <- nobs - rank
  cat("\n")
  if(rdf > 0)
    cat("Residual standard error:", format(sqrt(sum(x$residuals^2)/
                                                rdf)), "\n")
  coef <- x$coef
  R <- x$qr$qr
  R <- R[1:ncol(R), ]
  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]
    }
  dm <- dim(R)
  d <- seq(1, length = min(dm), by = dm[1] + 1)
  R <- abs(R)
  if(sum(R[ - d])/sum(R[d]) > 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]] # changed
  nterms <- max(asgn)+1
  effects <- object$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(object$terms, "term.labels"))
  resid <- object$residuals
  wt <- object$weights
  if(!is.null(wt)) resid <- resid * wt^0.5
  if(is.null(effects)) {
    df <- nterms  <- 0
    ss <- ms <- numeric(0)
    nmrows <- character(0)
  }
  else {
    nobs <- length(resid)
    nterms <- max(asgn)+1
    df <- ss <- numeric(nterms)
    nmrows <- character(nterms)
    for(i in 1:nterms) {
      ai <- asgn == (i-1) # changed
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
      nmrows[i] <- nmeffect[i]
    }
  }
  df.res <- object$df.resid
  if(df.res > 0) {
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmrows[nterms] <- "Residuals"
  }
  ok <- df > 0
  if(all(ok)) ms <- ss/df
  else {
    ms <- rep(NA, nterms)
    ms[ok] <- ss[ok]/df[ok]
  }
  x <- list(Df = df, "Sum of Sq" = ss, "Mean Sq" = ms)
  if(df.res > 0) {
    TT <- ms/ms[nterms]
    TP <- 1 - pf(TT, df, df.res)
    TT[nterms] <- TP[nterms] <- NA
    x$"F Value" <- TT
    x$"Pr(F)" <- TP
  }
  class(x) <- c("anova", "data.frame")
  row.names(x) <- format(nmrows)
  if(!keep.zero.df) x <- x[df > 0, ]
  if(!intercept) x <- x[-1,]
  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, ...)
{
  pattern <- function(x, ...) {
    x[abs(x) < 1e-6] <- 0
    if(exists("fractions", mode="function")) fractions(x) else x
  }
  Model <- object$terms
  attributes(Model) <- NULL
  value <- list(Model = Model)
  R <- object$qr$qr
  R <- R[1:ncol(R), ]
  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 <- dimnames(R)[[2]]
        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])
        pattern(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
    value$Partial <- beta11
  }
  class(value) <- "listof"
  value
}
print.listof <- function(x, ...)
{
  nn <- names(x)
  ll <- length(x)
  if(length(nn) != ll) nn <- paste("Component", seq(ll))
  for(i in seq(ll)) {
    cat(nn[i], ":\n"); print(x[[i]], ...); cat("\n")
  }
}
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)
	ds <- 1:dl
	if(dl == 0)
		stop("dim(X) must have a positive length")
	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)
	if(!ans.list)
		ans <- unlist(ans, recursive = FALSE)
	if(length(MARGIN) == 1 && length(ans) == d2) {
		if(length(dn.ans[[1]]) > 0)
			names(ans) <- dn.ans[[1]]
		else names(ans) <- NULL
		return(ans)
	}
	else if(length(ans) == d2)
		return(array(ans, d.ans, dn.ans))
	else if(length(ans) > 0 && length(ans) %% d2 == 0) {
		if(is.null(dn.ans))
			return(array(ans, c(length(ans)/d2, d[MARGIN])))
		else return(array(ans, c(length(ans)/d2, d.ans),
				c(list(ans.names), dn.ans)))
	}
	else 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 ]
 if(check.mode && any(ind)) {
          ii <- which(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]
 } else {
          if(numeric.) structure(which(ind), names=sp[ind]) else sp[ind]
 }
}
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]
	}
	dim(data) <- dim
	if(is.list(dimnames))
		dimnames(data) <- dimnames
	data
}
arrows <-
function(x0, y0, x1, y1, length=0.25, angle=30, code=2,
	col=par("fg"), lty=NULL, xpd=FALSE) {
 .Internal(arrows(
	x0,
	y0,
	x1,
	y1,
	length=length,
	angle=angle,
	code=code,
	col=col,
	lty=lty,
	xpd=xpd))
}
as.logical <- function(x) .Internal(as.vector(x,"logical"))
as.integer <- function(x) .Internal(as.vector(x,"integer"))
as.double <- function(x) .Internal(as.vector(x,"double"))
as.real <- .Alias(as.double)
as.complex <- function(x) .Internal(as.vector(x, "complex"))
as.single <- function(x) {
  warning("type single is not supported in R")
  .Internal(as.vector(x,"double"))
}
as.character <- function(x) .Internal(as.vector(x,"character"))
as.expression <- function(x) .Internal(as.vector(x,"expression"))
"as.list" <-
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"))
}
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) NULL
as.function <- function(x,...) UseMethod("as.function")
"as.function.default" <-
function (l, envir = sys.frame(sys.parent())) 
{
  if (!is.list(l)) 
    stop("Can't coerce object to function")
  ln <- length(l)
  alist <- l[-ln]
  body <- l[[ln]]
  if (is.expression(body)) 
    body <- body[[1]]
  if (ln < 2) 
    e <- substitute(function() body)
  else {
    e <- substitute(function(x) body)
    e[[2]] <- alist
  }
  eval(e, 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 tercol=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()
}
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))
print.anova <- function(x, digits = max(.Options$digits - 2, 3),
                        signif.stars= .Options$show.signif.stars, ...)
{
  heading <- attr(x, "heading")
  if (!is.null(heading)) cat(heading, sep = "\n")
  attr(x, "heading") <- NULL
  nn <- names(x)
###-- we should be able to do withOUT for()
###-- and use new   print.coefmat(.), instead ! -- MM.
  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)
}
## which (invisibly) returns the newly changed, instead of the original x !
#### copyright (C) 1998 W. N. Venables and B. D. Ripley
aov <-
  function(formula, data = sys.parent(), projections = FALSE, contrasts =
        NULL, ...)
{
  if(projections) stop("projections are not implemented")
  lmcall <- Call <- match.call()
  lmcall[[1]] <- as.name("lm")
  lmcall$singular.ok <- TRUE
  lmcall$projections <- NULL
  fit <- eval(lmcall, sys.frame(sys.parent()))
  class(fit) <- c("aov", "lm")
  fit$call <- Call
  fit
}
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]] # changed
  effects <- x$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(x$terms, "term.labels"))
  nterms <- max(asgn)+1
  df <- ss <- numeric(nterms)
  if(nterms) {
    for(i in seq(nterms)) {
      ai <- asgn==(i-1) # delete line
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
    }
    keep <- df > 0
    if(!intercept) keep[1] <- FALSE
    nmeffect <- nmeffect[keep]
    df <- df[keep]
    ss <- ss[keep]
    nterms <- length(df)
  }
  cat("\nTerms:\n")
  if(nterms == 0) {
    # empty model
    print(matrix(0, 1, 2, dimnames=list("<empty>",
                            c("Sum of Squares", "Deg. of Freedom"))))
    return(invisible(x))
  }
  df.res <- x$df.resid
  if(is.null(df.res))
    df.res <- length(x$resid) - length(asgn)
  if(df.res > 0) {
    resid <- x$resid
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmeffect[nterms] <- "Residuals"
  }
  print(matrix(c(format(ss), format(df)), 2, nterms, byrow=TRUE,
               dimnames=list(c("Sum of Squares", "Deg. of Freedom"),
               nmeffect)),
        quote = FALSE, right = TRUE)
  rank <- x$rank
  int <- attr(x$terms, "int")
  nobs <- length(x$residuals) - !(is.null(int) || int == 0)
  rdf <- x$df.resid
  if(is.null(rdf)) rdf <- nobs - rank
  cat("\n")
  if(rdf > 0)
    cat("Residual standard error:", format(sqrt(sum(x$residuals^2)/
                                                rdf)), "\n")
  coef <- x$coef
  R <- x$qr$qr
  R <- R[1:ncol(R), ]
  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]
    }
  dm <- dim(R)
  d <- seq(1, length = min(dm), by = dm[1] + 1)
  R <- abs(R)
  if(sum(R[ - d])/sum(R[d]) > 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]] # changed
  nterms <- max(asgn)+1
  effects <- object$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(object$terms, "term.labels"))
  resid <- object$residuals
  wt <- object$weights
  if(!is.null(wt)) resid <- resid * wt^0.5
  if(is.null(effects)) {
    df <- nterms  <- 0
    ss <- ms <- numeric(0)
    nmrows <- character(0)
  }
  else {
    nobs <- length(resid)
    nterms <- max(asgn)+1
    df <- ss <- numeric(nterms)
    nmrows <- character(nterms)
    for(i in 1:nterms) {
      ai <- asgn == (i-1) # changed
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
      nmrows[i] <- nmeffect[i]
    }
  }
  df.res <- object$df.resid
  if(df.res > 0) {
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmrows[nterms] <- "Residuals"
  }
  ok <- df > 0
  if(all(ok)) ms <- ss/df
  else {
    ms <- rep(NA, nterms)
    ms[ok] <- ss[ok]/df[ok]
  }
  x <- list(Df = df, "Sum of Sq" = ss, "Mean Sq" = ms)
  if(df.res > 0) {
    TT <- ms/ms[nterms]
    TP <- 1 - pf(TT, df, df.res)
    TT[nterms] <- TP[nterms] <- NA
    x$"F Value" <- TT
    x$"Pr(F)" <- TP
  }
  class(x) <- c("anova", "data.frame")
  row.names(x) <- format(nmrows)
  if(!keep.zero.df) x <- x[df > 0, ]
  if(!intercept) x <- x[-1,]
  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, ...)
{
  pattern <- function(x, ...) {
    x[abs(x) < 1e-6] <- 0
    if(exists("fractions", mode="function")) fractions(x) else x
  }
  Model <- object$terms
  attributes(Model) <- NULL
  value <- list(Model = Model)
  R <- object$qr$qr
  R <- R[1:ncol(R), ]
  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 <- dimnames(R)[[2]]
        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])
        pattern(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
    value$Partial <- beta11
  }
  class(value) <- "listof"
  value
}
print.listof <- function(x, ...)
{
  nn <- names(x)
  ll <- length(x)
  if(length(nn) != ll) nn <- paste("Component", seq(ll))
  for(i in seq(ll)) {
    cat(nn[i], ":\n"); print(x[[i]], ...); cat("\n")
  }
}
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)
	ds <- 1:dl
	if(dl == 0)
		stop("dim(X) must have a positive length")
	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)
	if(!ans.list)
		ans <- unlist(ans, recursive = FALSE)
	if(length(MARGIN) == 1 && length(ans) == d2) {
		if(length(dn.ans[[1]]) > 0)
			names(ans) <- dn.ans[[1]]
		else names(ans) <- NULL
		return(ans)
	}
	else if(length(ans) == d2)
		return(array(ans, d.ans, dn.ans))
	else if(length(ans) > 0 && length(ans) %% d2 == 0) {
		if(is.null(dn.ans))
			return(array(ans, c(length(ans)/d2, d[MARGIN])))
		else return(array(ans, c(length(ans)/d2, d.ans),
				c(list(ans.names), dn.ans)))
	}
	else 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 ]
 if(check.mode && any(ind)) {
          ii <- which(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]
 } else {
          if(numeric.) structure(which(ind), names=sp[ind]) else sp[ind]
 }
}
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]
	}
	dim(data) <- dim
	if(is.list(dimnames))
		dimnames(data) <- dimnames
	data
}
arrows <-
function(x0, y0, x1, y1, length=0.25, angle=30, code=2,
	col=par("fg"), lty=NULL, xpd=FALSE) {
 .Internal(arrows(
	x0,
	y0,
	x1,
	y1,
	length=length,
	angle=angle,
	code=code,
	col=col,
	lty=lty,
	xpd=xpd))
}
as.logical <- function(x) .Internal(as.vector(x,"logical"))
as.integer <- function(x) .Internal(as.vector(x,"integer"))
as.double <- function(x) .Internal(as.vector(x,"double"))
as.real <- .Alias(as.double)
as.complex <- function(x) .Internal(as.vector(x, "complex"))
as.single <- function(x) {
  warning("type single is not supported in R")
  .Internal(as.vector(x,"double"))
}
as.character <- function(x) .Internal(as.vector(x,"character"))
as.expression <- function(x) .Internal(as.vector(x,"expression"))
"as.list" <-
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"))
}
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) NULL
as.function <- function(x,...) UseMethod("as.function")
"as.function.default" <-
function (l, envir = sys.frame(sys.parent())) 
{
  if (!is.list(l)) 
    stop("Can't coerce object to function")
  ln <- length(l)
  alist <- l[-ln]
  body <- l[[ln]]
  if (is.expression(body)) 
    body <- body[[1]]
  if (ln < 2) 
    e <- substitute(function() body)
  else {
    e <- substitute(function(x) body)
    e[[2]] <- alist
  }
  eval(e, 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 tercol=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()
}
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))
print.anova <- function(x, digits = max(.Options$digits - 2, 3),
                        signif.stars= .Options$show.signif.stars, ...)
{
  heading <- attr(x, "heading")
  if (!is.null(heading)) cat(heading, sep = "\n")
  attr(x, "heading") <- NULL
  nn <- names(x)
###-- we should be able to do withOUT for()
###-- and use new   print.coefmat(.), instead ! -- MM.
  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)
}
## which (invisibly) returns the newly changed, instead of the original x !
#### copyright (C) 1998 W. N. Venables and B. D. Ripley
aov <-
  function(formula, data = sys.parent(), projections = FALSE, contrasts =
        NULL, ...)
{
  if(projections) stop("projections are not implemented")
  lmcall <- Call <- match.call()
  lmcall[[1]] <- as.name("lm")
  lmcall$singular.ok <- TRUE
  lmcall$projections <- NULL
  fit <- eval(lmcall, sys.frame(sys.parent()))
  class(fit) <- c("aov", "lm")
  fit$call <- Call
  fit
}
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]] # changed
  effects <- x$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(x$terms, "term.labels"))
  nterms <- max(asgn)+1
  df <- ss <- numeric(nterms)
  if(nterms) {
    for(i in seq(nterms)) {
      ai <- asgn==(i-1) # delete line
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
    }
    keep <- df > 0
    if(!intercept) keep[1] <- FALSE
    nmeffect <- nmeffect[keep]
    df <- df[keep]
    ss <- ss[keep]
    nterms <- length(df)
  }
  cat("\nTerms:\n")
  if(nterms == 0) {
    # empty model
    print(matrix(0, 1, 2, dimnames=list("<empty>",
                            c("Sum of Squares", "Deg. of Freedom"))))
    return(invisible(x))
  }
  df.res <- x$df.resid
  if(is.null(df.res))
    df.res <- length(x$resid) - length(asgn)
  if(df.res > 0) {
    resid <- x$resid
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmeffect[nterms] <- "Residuals"
  }
  print(matrix(c(format(ss), format(df)), 2, nterms, byrow=TRUE,
               dimnames=list(c("Sum of Squares", "Deg. of Freedom"),
               nmeffect)),
        quote = FALSE, right = TRUE)
  rank <- x$rank
  int <- attr(x$terms, "int")
  nobs <- length(x$residuals) - !(is.null(int) || int == 0)
  rdf <- x$df.resid
  if(is.null(rdf)) rdf <- nobs - rank
  cat("\n")
  if(rdf > 0)
    cat("Residual standard error:", format(sqrt(sum(x$residuals^2)/
                                                rdf)), "\n")
  coef <- x$coef
  R <- x$qr$qr
  R <- R[1:ncol(R), ]
  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]
    }
  dm <- dim(R)
  d <- seq(1, length = min(dm), by = dm[1] + 1)
  R <- abs(R)
  if(sum(R[ - d])/sum(R[d]) > 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]] # changed
  nterms <- max(asgn)+1
  effects <- object$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(object$terms, "term.labels"))
  resid <- object$residuals
  wt <- object$weights
  if(!is.null(wt)) resid <- resid * wt^0.5
  if(is.null(effects)) {
    df <- nterms  <- 0
    ss <- ms <- numeric(0)
    nmrows <- character(0)
  }
  else {
    nobs <- length(resid)
    nterms <- max(asgn)+1
    df <- ss <- numeric(nterms)
    nmrows <- character(nterms)
    for(i in 1:nterms) {
      ai <- asgn == (i-1) # changed
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
      nmrows[i] <- nmeffect[i]
    }
  }
  df.res <- object$df.resid
  if(df.res > 0) {
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmrows[nterms] <- "Residuals"
  }
  ok <- df > 0
  if(all(ok)) ms <- ss/df
  else {
    ms <- rep(NA, nterms)
    ms[ok] <- ss[ok]/df[ok]
  }
  x <- list(Df = df, "Sum of Sq" = ss, "Mean Sq" = ms)
  if(df.res > 0) {
    TT <- ms/ms[nterms]
    TP <- 1 - pf(TT, df, df.res)
    TT[nterms] <- TP[nterms] <- NA
    x$"F Value" <- TT
    x$"Pr(F)" <- TP
  }
  class(x) <- c("anova", "data.frame")
  row.names(x) <- format(nmrows)
  if(!keep.zero.df) x <- x[df > 0, ]
  if(!intercept) x <- x[-1,]
  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, ...)
{
  pattern <- function(x, ...) {
    x[abs(x) < 1e-6] <- 0
    if(exists("fractions", mode="function")) fractions(x) else x
  }
  Model <- object$terms
  attributes(Model) <- NULL
  value <- list(Model = Model)
  R <- object$qr$qr
  R <- R[1:ncol(R), ]
  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 <- dimnames(R)[[2]]
        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])
        pattern(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
    value$Partial <- beta11
  }
  class(value) <- "listof"
  value
}
print.listof <- function(x, ...)
{
  nn <- names(x)
  ll <- length(x)
  if(length(nn) != ll) nn <- paste("Component", seq(ll))
  for(i in seq(ll)) {
    cat(nn[i], ":\n"); print(x[[i]], ...); cat("\n")
  }
}
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)
	ds <- 1:dl
	if(dl == 0)
		stop("dim(X) must have a positive length")
	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)
	if(!ans.list)
		ans <- unlist(ans, recursive = FALSE)
	if(length(MARGIN) == 1 && length(ans) == d2) {
		if(length(dn.ans[[1]]) > 0)
			names(ans) <- dn.ans[[1]]
		else names(ans) <- NULL
		return(ans)
	}
	else if(length(ans) == d2)
		return(array(ans, d.ans, dn.ans))
	else if(length(ans) > 0 && length(ans) %% d2 == 0) {
		if(is.null(dn.ans))
			return(array(ans, c(length(ans)/d2, d[MARGIN])))
		else return(array(ans, c(length(ans)/d2, d.ans),
				c(list(ans.names), dn.ans)))
	}
	else 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 ]
 if(check.mode && any(ind)) {
          ii <- which(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]
 } else {
          if(numeric.) structure(which(ind), names=sp[ind]) else sp[ind]
 }
}
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]
	}
	dim(data) <- dim
	if(is.list(dimnames))
		dimnames(data) <- dimnames
	data
}
arrows <-
function(x0, y0, x1, y1, length=0.25, angle=30, code=2,
	col=par("fg"), lty=NULL, xpd=FALSE) {
 .Internal(arrows(
	x0,
	y0,
	x1,
	y1,
	length=length,
	angle=angle,
	code=code,
	col=col,
	lty=lty,
	xpd=xpd))
}
as.logical <- function(x) .Internal(as.vector(x,"logical"))
as.integer <- function(x) .Internal(as.vector(x,"integer"))
as.double <- function(x) .Internal(as.vector(x,"double"))
as.real <- .Alias(as.double)
as.complex <- function(x) .Internal(as.vector(x, "complex"))
as.single <- function(x) {
  warning("type single is not supported in R")
  .Internal(as.vector(x,"double"))
}
as.character <- function(x) .Internal(as.vector(x,"character"))
as.expression <- function(x) .Internal(as.vector(x,"expression"))
"as.list" <-
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"))
}
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) NULL
as.function <- function(x,...) UseMethod("as.function")
"as.function.default" <-
function (l, envir = sys.frame(sys.parent())) 
{
  if (!is.list(l)) 
    stop("Can't coerce object to function")
  ln <- length(l)
  alist <- l[-ln]
  body <- l[[ln]]
  if (is.expression(body)) 
    body <- body[[1]]
  if (ln < 2) 
    e <- substitute(function() body)
  else {
    e <- substitute(function(x) body)
    e[[2]] <- alist
  }
  eval(e, 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 tercol=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()
}
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))
print.anova <- function(x, digits = max(.Options$digits - 2, 3),
                        signif.stars= .Options$show.signif.stars, ...)
{
  heading <- attr(x, "heading")
  if (!is.null(heading)) cat(heading, sep = "\n")
  attr(x, "heading") <- NULL
  nn <- names(x)
###-- we should be able to do withOUT for()
###-- and use new   print.coefmat(.), instead ! -- MM.
  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)
}
## which (invisibly) returns the newly changed, instead of the original x !
#### copyright (C) 1998 W. N. Venables and B. D. Ripley
aov <-
  function(formula, data = sys.parent(), projections = FALSE, contrasts =
        NULL, ...)
{
  if(projections) stop("projections are not implemented")
  lmcall <- Call <- match.call()
  lmcall[[1]] <- as.name("lm")
  lmcall$singular.ok <- TRUE
  lmcall$projections <- NULL
  fit <- eval(lmcall, sys.frame(sys.parent()))
  class(fit) <- c("aov", "lm")
  fit$call <- Call
  fit
}
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]] # changed
  effects <- x$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(x$terms, "term.labels"))
  nterms <- max(asgn)+1
  df <- ss <- numeric(nterms)
  if(nterms) {
    for(i in seq(nterms)) {
      ai <- asgn==(i-1) # delete line
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
    }
    keep <- df > 0
    if(!intercept) keep[1] <- FALSE
    nmeffect <- nmeffect[keep]
    df <- df[keep]
    ss <- ss[keep]
    nterms <- length(df)
  }
  cat("\nTerms:\n")
  if(nterms == 0) {
    # empty model
    print(matrix(0, 1, 2, dimnames=list("<empty>",
                            c("Sum of Squares", "Deg. of Freedom"))))
    return(invisible(x))
  }
  df.res <- x$df.resid
  if(is.null(df.res))
    df.res <- length(x$resid) - length(asgn)
  if(df.res > 0) {
    resid <- x$resid
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmeffect[nterms] <- "Residuals"
  }
  print(matrix(c(format(ss), format(df)), 2, nterms, byrow=TRUE,
               dimnames=list(c("Sum of Squares", "Deg. of Freedom"),
               nmeffect)),
        quote = FALSE, right = TRUE)
  rank <- x$rank
  int <- attr(x$terms, "int")
  nobs <- length(x$residuals) - !(is.null(int) || int == 0)
  rdf <- x$df.resid
  if(is.null(rdf)) rdf <- nobs - rank
  cat("\n")
  if(rdf > 0)
    cat("Residual standard error:", format(sqrt(sum(x$residuals^2)/
                                                rdf)), "\n")
  coef <- x$coef
  R <- x$qr$qr
  R <- R[1:ncol(R), ]
  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]
    }
  dm <- dim(R)
  d <- seq(1, length = min(dm), by = dm[1] + 1)
  R <- abs(R)
  if(sum(R[ - d])/sum(R[d]) > 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]] # changed
  nterms <- max(asgn)+1
  effects <- object$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(object$terms, "term.labels"))
  resid <- object$residuals
  wt <- object$weights
  if(!is.null(wt)) resid <- resid * wt^0.5
  if(is.null(effects)) {
    df <- nterms  <- 0
    ss <- ms <- numeric(0)
    nmrows <- character(0)
  }
  else {
    nobs <- length(resid)
    nterms <- max(asgn)+1
    df <- ss <- numeric(nterms)
    nmrows <- character(nterms)
    for(i in 1:nterms) {
      ai <- asgn == (i-1) # changed
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
      nmrows[i] <- nmeffect[i]
    }
  }
  df.res <- object$df.resid
  if(df.res > 0) {
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmrows[nterms] <- "Residuals"
  }
  ok <- df > 0
  if(all(ok)) ms <- ss/df
  else {
    ms <- rep(NA, nterms)
    ms[ok] <- ss[ok]/df[ok]
  }
  x <- list(Df = df, "Sum of Sq" = ss, "Mean Sq" = ms)
  if(df.res > 0) {
    TT <- ms/ms[nterms]
    TP <- 1 - pf(TT, df, df.res)
    TT[nterms] <- TP[nterms] <- NA
    x$"F Value" <- TT
    x$"Pr(F)" <- TP
  }
  class(x) <- c("anova", "data.frame")
  row.names(x) <- format(nmrows)
  if(!keep.zero.df) x <- x[df > 0, ]
  if(!intercept) x <- x[-1,]
  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, ...)
{
  pattern <- function(x, ...) {
    x[abs(x) < 1e-6] <- 0
    if(exists("fractions", mode="function")) fractions(x) else x
  }
  Model <- object$terms
  attributes(Model) <- NULL
  value <- list(Model = Model)
  R <- object$qr$qr
  R <- R[1:ncol(R), ]
  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 <- dimnames(R)[[2]]
        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])
        pattern(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
    value$Partial <- beta11
  }
  class(value) <- "listof"
  value
}
print.listof <- function(x, ...)
{
  nn <- names(x)
  ll <- length(x)
  if(length(nn) != ll) nn <- paste("Component", seq(ll))
  for(i in seq(ll)) {
    cat(nn[i], ":\n"); print(x[[i]], ...); cat("\n")
  }
}
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)
	ds <- 1:dl
	if(dl == 0)
		stop("dim(X) must have a positive length")
	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)
	if(!ans.list)
		ans <- unlist(ans, recursive = FALSE)
	if(length(MARGIN) == 1 && length(ans) == d2) {
		if(length(dn.ans[[1]]) > 0)
			names(ans) <- dn.ans[[1]]
		else names(ans) <- NULL
		return(ans)
	}
	else if(length(ans) == d2)
		return(array(ans, d.ans, dn.ans))
	else if(length(ans) > 0 && length(ans) %% d2 == 0) {
		if(is.null(dn.ans))
			return(array(ans, c(length(ans)/d2, d[MARGIN])))
		else return(array(ans, c(length(ans)/d2, d.ans),
				c(list(ans.names), dn.ans)))
	}
	else 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 ]
 if(check.mode && any(ind)) {
          ii <- which(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]
 } else {
          if(numeric.) structure(which(ind), names=sp[ind]) else sp[ind]
 }
}
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]
	}
	dim(data) <- dim
	if(is.list(dimnames))
		dimnames(data) <- dimnames
	data
}
arrows <-
function(x0, y0, x1, y1, length=0.25, angle=30, code=2,
	col=par("fg"), lty=NULL, xpd=FALSE) {
 .Internal(arrows(
	x0,
	y0,
	x1,
	y1,
	length=length,
	angle=angle,
	code=code,
	col=col,
	lty=lty,
	xpd=xpd))
}
as.logical <- function(x) .Internal(as.vector(x,"logical"))
as.integer <- function(x) .Internal(as.vector(x,"integer"))
as.double <- function(x) .Internal(as.vector(x,"double"))
as.real <- .Alias(as.double)
as.complex <- function(x) .Internal(as.vector(x, "complex"))
as.single <- function(x) {
  warning("type single is not supported in R")
  .Internal(as.vector(x,"double"))
}
as.character <- function(x) .Internal(as.vector(x,"character"))
as.expression <- function(x) .Internal(as.vector(x,"expression"))
"as.list" <-
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"))
}
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) NULL
as.function <- function(x,...) UseMethod("as.function")
"as.function.default" <-
function (l, envir = sys.frame(sys.parent())) 
{
  if (!is.list(l)) 
    stop("Can't coerce object to function")
  ln <- length(l)
  alist <- l[-ln]
  body <- l[[ln]]
  if (is.expression(body)) 
    body <- body[[1]]
  if (ln < 2) 
    e <- substitute(function() body)
  else {
    e <- substitute(function(x) body)
    e[[2]] <- alist
  }
  eval(e, 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 tercol=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()
}
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))
print.anova <- function(x, digits = max(.Options$digits - 2, 3),
                        signif.stars= .Options$show.signif.stars, ...)
{
  heading <- attr(x, "heading")
  if (!is.null(heading)) cat(heading, sep = "\n")
  attr(x, "heading") <- NULL
  nn <- names(x)
###-- we should be able to do withOUT for()
###-- and use new   print.coefmat(.), instead ! -- MM.
  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)
}
## which (invisibly) returns the newly changed, instead of the original x !
#### copyright (C) 1998 W. N. Venables and B. D. Ripley
aov <-
  function(formula, data = sys.parent(), projections = FALSE, contrasts =
        NULL, ...)
{
  if(projections) stop("projections are not implemented")
  lmcall <- Call <- match.call()
  lmcall[[1]] <- as.name("lm")
  lmcall$singular.ok <- TRUE
  lmcall$projections <- NULL
  fit <- eval(lmcall, sys.frame(sys.parent()))
  class(fit) <- c("aov", "lm")
  fit$call <- Call
  fit
}
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]] # changed
  effects <- x$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(x$terms, "term.labels"))
  nterms <- max(asgn)+1
  df <- ss <- numeric(nterms)
  if(nterms) {
    for(i in seq(nterms)) {
      ai <- asgn==(i-1) # delete line
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
    }
    keep <- df > 0
    if(!intercept) keep[1] <- FALSE
    nmeffect <- nmeffect[keep]
    df <- df[keep]
    ss <- ss[keep]
    nterms <- length(df)
  }
  cat("\nTerms:\n")
  if(nterms == 0) {
    # empty model
    print(matrix(0, 1, 2, dimnames=list("<empty>",
                            c("Sum of Squares", "Deg. of Freedom"))))
    return(invisible(x))
  }
  df.res <- x$df.resid
  if(is.null(df.res))
    df.res <- length(x$resid) - length(asgn)
  if(df.res > 0) {
    resid <- x$resid
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmeffect[nterms] <- "Residuals"
  }
  print(matrix(c(format(ss), format(df)), 2, nterms, byrow=TRUE,
               dimnames=list(c("Sum of Squares", "Deg. of Freedom"),
               nmeffect)),
        quote = FALSE, right = TRUE)
  rank <- x$rank
  int <- attr(x$terms, "int")
  nobs <- length(x$residuals) - !(is.null(int) || int == 0)
  rdf <- x$df.resid
  if(is.null(rdf)) rdf <- nobs - rank
  cat("\n")
  if(rdf > 0)
    cat("Residual standard error:", format(sqrt(sum(x$residuals^2)/
                                                rdf)), "\n")
  coef <- x$coef
  R <- x$qr$qr
  R <- R[1:ncol(R), ]
  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]
    }
  dm <- dim(R)
  d <- seq(1, length = min(dm), by = dm[1] + 1)
  R <- abs(R)
  if(sum(R[ - d])/sum(R[d]) > 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]] # changed
  nterms <- max(asgn)+1
  effects <- object$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(object$terms, "term.labels"))
  resid <- object$residuals
  wt <- object$weights
  if(!is.null(wt)) resid <- resid * wt^0.5
  if(is.null(effects)) {
    df <- nterms  <- 0
    ss <- ms <- numeric(0)
    nmrows <- character(0)
  }
  else {
    nobs <- length(resid)
    nterms <- max(asgn)+1
    df <- ss <- numeric(nterms)
    nmrows <- character(nterms)
    for(i in 1:nterms) {
      ai <- asgn == (i-1) # changed
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
      nmrows[i] <- nmeffect[i]
    }
  }
  df.res <- object$df.resid
  if(df.res > 0) {
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmrows[nterms] <- "Residuals"
  }
  ok <- df > 0
  if(all(ok)) ms <- ss/df
  else {
    ms <- rep(NA, nterms)
    ms[ok] <- ss[ok]/df[ok]
  }
  x <- list(Df = df, "Sum of Sq" = ss, "Mean Sq" = ms)
  if(df.res > 0) {
    TT <- ms/ms[nterms]
    TP <- 1 - pf(TT, df, df.res)
    TT[nterms] <- TP[nterms] <- NA
    x$"F Value" <- TT
    x$"Pr(F)" <- TP
  }
  class(x) <- c("anova", "data.frame")
  row.names(x) <- format(nmrows)
  if(!keep.zero.df) x <- x[df > 0, ]
  if(!intercept) x <- x[-1,]
  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, ...)
{
  pattern <- function(x, ...) {
    x[abs(x) < 1e-6] <- 0
    if(exists("fractions", mode="function")) fractions(x) else x
  }
  Model <- object$terms
  attributes(Model) <- NULL
  value <- list(Model = Model)
  R <- object$qr$qr
  R <- R[1:ncol(R), ]
  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 <- dimnames(R)[[2]]
        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])
        pattern(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
    value$Partial <- beta11
  }
  class(value) <- "listof"
  value
}
print.listof <- function(x, ...)
{
  nn <- names(x)
  ll <- length(x)
  if(length(nn) != ll) nn <- paste("Component", seq(ll))
  for(i in seq(ll)) {
    cat(nn[i], ":\n"); print(x[[i]], ...); cat("\n")
  }
}
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)
	ds <- 1:dl
	if(dl == 0)
		stop("dim(X) must have a positive length")
	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)
	if(!ans.list)
		ans <- unlist(ans, recursive = FALSE)
	if(length(MARGIN) == 1 && length(ans) == d2) {
		if(length(dn.ans[[1]]) > 0)
			names(ans) <- dn.ans[[1]]
		else names(ans) <- NULL
		return(ans)
	}
	else if(length(ans) == d2)
		return(array(ans, d.ans, dn.ans))
	else if(length(ans) > 0 && length(ans) %% d2 == 0) {
		if(is.null(dn.ans))
			return(array(ans, c(length(ans)/d2, d[MARGIN])))
		else return(array(ans, c(length(ans)/d2, d.ans),
				c(list(ans.names), dn.ans)))
	}
	else 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 ]
 if(check.mode && any(ind)) {
          ii <- which(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]
 } else {
          if(numeric.) structure(which(ind), names=sp[ind]) else sp[ind]
 }
}
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]
	}
	dim(data) <- dim
	if(is.list(dimnames))
		dimnames(data) <- dimnames
	data
}
arrows <-
function(x0, y0, x1, y1, length=0.25, angle=30, code=2,
	col=par("fg"), lty=NULL, xpd=FALSE) {
 .Internal(arrows(
	x0,
	y0,
	x1,
	y1,
	length=length,
	angle=angle,
	code=code,
	col=col,
	lty=lty,
	xpd=xpd))
}
as.logical <- function(x) .Internal(as.vector(x,"logical"))
as.integer <- function(x) .Internal(as.vector(x,"integer"))
as.double <- function(x) .Internal(as.vector(x,"double"))
as.real <- .Alias(as.double)
as.complex <- function(x) .Internal(as.vector(x, "complex"))
as.single <- function(x) {
  warning("type single is not supported in R")
  .Internal(as.vector(x,"double"))
}
as.character <- function(x) .Internal(as.vector(x,"character"))
as.expression <- function(x) .Internal(as.vector(x,"expression"))
"as.list" <-
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"))
}
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) NULL
as.function <- function(x,...) UseMethod("as.function")
"as.function.default" <-
function (l, envir = sys.frame(sys.parent())) 
{
  if (!is.list(l)) 
    stop("Can't coerce object to function")
  ln <- length(l)
  alist <- l[-ln]
  body <- l[[ln]]
  if (is.expression(body)) 
    body <- body[[1]]
  if (ln < 2) 
    e <- substitute(function() body)
  else {
    e <- substitute(function(x) body)
    e[[2]] <- alist
  }
  eval(e, 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 tercol=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()
}
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))
print.anova <- function(x, digits = max(.Options$digits - 2, 3),
                        signif.stars= .Options$show.signif.stars, ...)
{
  heading <- attr(x, "heading")
  if (!is.null(heading)) cat(heading, sep = "\n")
  attr(x, "heading") <- NULL
  nn <- names(x)
###-- we should be able to do withOUT for()
###-- and use new   print.coefmat(.), instead ! -- MM.
  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)
}
## which (invisibly) returns the newly changed, instead of the original x !
#### copyright (C) 1998 W. N. Venables and B. D. Ripley
aov <-
  function(formula, data = sys.parent(), projections = FALSE, contrasts =
        NULL, ...)
{
  if(projections) stop("projections are not implemented")
  lmcall <- Call <- match.call()
  lmcall[[1]] <- as.name("lm")
  lmcall$singular.ok <- TRUE
  lmcall$projections <- NULL
  fit <- eval(lmcall, sys.frame(sys.parent()))
  class(fit) <- c("aov", "lm")
  fit$call <- Call
  fit
}
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]] # changed
  effects <- x$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(x$terms, "term.labels"))
  nterms <- max(asgn)+1
  df <- ss <- numeric(nterms)
  if(nterms) {
    for(i in seq(nterms)) {
      ai <- asgn==(i-1) # delete line
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
    }
    keep <- df > 0
    if(!intercept) keep[1] <- FALSE
    nmeffect <- nmeffect[keep]
    df <- df[keep]
    ss <- ss[keep]
    nterms <- length(df)
  }
  cat("\nTerms:\n")
  if(nterms == 0) {
    # empty model
    print(matrix(0, 1, 2, dimnames=list("<empty>",
                            c("Sum of Squares", "Deg. of Freedom"))))
    return(invisible(x))
  }
  df.res <- x$df.resid
  if(is.null(df.res))
    df.res <- length(x$resid) - length(asgn)
  if(df.res > 0) {
    resid <- x$resid
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmeffect[nterms] <- "Residuals"
  }
  print(matrix(c(format(ss), format(df)), 2, nterms, byrow=TRUE,
               dimnames=list(c("Sum of Squares", "Deg. of Freedom"),
               nmeffect)),
        quote = FALSE, right = TRUE)
  rank <- x$rank
  int <- attr(x$terms, "int")
  nobs <- length(x$residuals) - !(is.null(int) || int == 0)
  rdf <- x$df.resid
  if(is.null(rdf)) rdf <- nobs - rank
  cat("\n")
  if(rdf > 0)
    cat("Residual standard error:", format(sqrt(sum(x$residuals^2)/
                                                rdf)), "\n")
  coef <- x$coef
  R <- x$qr$qr
  R <- R[1:ncol(R), ]
  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]
    }
  dm <- dim(R)
  d <- seq(1, length = min(dm), by = dm[1] + 1)
  R <- abs(R)
  if(sum(R[ - d])/sum(R[d]) > 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]] # changed
  nterms <- max(asgn)+1
  effects <- object$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(object$terms, "term.labels"))
  resid <- object$residuals
  wt <- object$weights
  if(!is.null(wt)) resid <- resid * wt^0.5
  if(is.null(effects)) {
    df <- nterms  <- 0
    ss <- ms <- numeric(0)
    nmrows <- character(0)
  }
  else {
    nobs <- length(resid)
    nterms <- max(asgn)+1
    df <- ss <- numeric(nterms)
    nmrows <- character(nterms)
    for(i in 1:nterms) {
      ai <- asgn == (i-1) # changed
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
      nmrows[i] <- nmeffect[i]
    }
  }
  df.res <- object$df.resid
  if(df.res > 0) {
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmrows[nterms] <- "Residuals"
  }
  ok <- df > 0
  if(all(ok)) ms <- ss/df
  else {
    ms <- rep(NA, nterms)
    ms[ok] <- ss[ok]/df[ok]
  }
  x <- list(Df = df, "Sum of Sq" = ss, "Mean Sq" = ms)
  if(df.res > 0) {
    TT <- ms/ms[nterms]
    TP <- 1 - pf(TT, df, df.res)
    TT[nterms] <- TP[nterms] <- NA
    x$"F Value" <- TT
    x$"Pr(F)" <- TP
  }
  class(x) <- c("anova", "data.frame")
  row.names(x) <- format(nmrows)
  if(!keep.zero.df) x <- x[df > 0, ]
  if(!intercept) x <- x[-1,]
  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, ...)
{
  pattern <- function(x, ...) {
    x[abs(x) < 1e-6] <- 0
    if(exists("fractions", mode="function")) fractions(x) else x
  }
  Model <- object$terms
  attributes(Model) <- NULL
  value <- list(Model = Model)
  R <- object$qr$qr
  R <- R[1:ncol(R), ]
  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 <- dimnames(R)[[2]]
        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])
        pattern(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
    value$Partial <- beta11
  }
  class(value) <- "listof"
  value
}
print.listof <- function(x, ...)
{
  nn <- names(x)
  ll <- length(x)
  if(length(nn) != ll) nn <- paste("Component", seq(ll))
  for(i in seq(ll)) {
    cat(nn[i], ":\n"); print(x[[i]], ...); cat("\n")
  }
}
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)
	ds <- 1:dl
	if(dl == 0)
		stop("dim(X) must have a positive length")
	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)
	if(!ans.list)
		ans <- unlist(ans, recursive = FALSE)
	if(length(MARGIN) == 1 && length(ans) == d2) {
		if(length(dn.ans[[1]]) > 0)
			names(ans) <- dn.ans[[1]]
		else names(ans) <- NULL
		return(ans)
	}
	else if(length(ans) == d2)
		return(array(ans, d.ans, dn.ans))
	else if(length(ans) > 0 && length(ans) %% d2 == 0) {
		if(is.null(dn.ans))
			return(array(ans, c(length(ans)/d2, d[MARGIN])))
		else return(array(ans, c(length(ans)/d2, d.ans),
				c(list(ans.names), dn.ans)))
	}
	else 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 ]
 if(check.mode && any(ind)) {
          ii <- which(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]
 } else {
          if(numeric.) structure(which(ind), names=sp[ind]) else sp[ind]
 }
}
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]
	}
	dim(data) <- dim
	if(is.list(dimnames))
		dimnames(data) <- dimnames
	data
}
arrows <-
function(x0, y0, x1, y1, length=0.25, angle=30, code=2,
	col=par("fg"), lty=NULL, xpd=FALSE) {
 .Internal(arrows(
	x0,
	y0,
	x1,
	y1,
	length=length,
	angle=angle,
	code=code,
	col=col,
	lty=lty,
	xpd=xpd))
}
as.logical <- function(x) .Internal(as.vector(x,"logical"))
as.integer <- function(x) .Internal(as.vector(x,"integer"))
as.double <- function(x) .Internal(as.vector(x,"double"))
as.real <- .Alias(as.double)
as.complex <- function(x) .Internal(as.vector(x, "complex"))
as.single <- function(x) {
  warning("type single is not supported in R")
  .Internal(as.vector(x,"double"))
}
as.character <- function(x) .Internal(as.vector(x,"character"))
as.expression <- function(x) .Internal(as.vector(x,"expression"))
"as.list" <-
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"))
}
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) NULL
as.function <- function(x,...) UseMethod("as.function")
"as.function.default" <-
function (l, envir = sys.frame(sys.parent())) 
{
  if (!is.list(l)) 
    stop("Can't coerce object to function")
  ln <- length(l)
  alist <- l[-ln]
  body <- l[[ln]]
  if (is.expression(body)) 
    body <- body[[1]]
  if (ln < 2) 
    e <- substitute(function() body)
  else {
    e <- substitute(function(x) body)
    e[[2]] <- alist
  }
  eval(e, 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 tercol=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()
}
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))
print.anova <- function(x, digits = max(.Options$digits - 2, 3),
                        signif.stars= .Options$show.signif.stars, ...)
{
  heading <- attr(x, "heading")
  if (!is.null(heading)) cat(heading, sep = "\n")
  attr(x, "heading") <- NULL
  nn <- names(x)
###-- we should be able to do withOUT for()
###-- and use new   print.coefmat(.), instead ! -- MM.
  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)
}
## which (invisibly) returns the newly changed, instead of the original x !
#### copyright (C) 1998 W. N. Venables and B. D. Ripley
aov <-
  function(formula, data = sys.parent(), projections = FALSE, contrasts =
        NULL, ...)
{
  if(projections) stop("projections are not implemented")
  lmcall <- Call <- match.call()
  lmcall[[1]] <- as.name("lm")
  lmcall$singular.ok <- TRUE
  lmcall$projections <- NULL
  fit <- eval(lmcall, sys.frame(sys.parent()))
  class(fit) <- c("aov", "lm")
  fit$call <- Call
  fit
}
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]] # changed
  effects <- x$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(x$terms, "term.labels"))
  nterms <- max(asgn)+1
  df <- ss <- numeric(nterms)
  if(nterms) {
    for(i in seq(nterms)) {
      ai <- asgn==(i-1) # delete line
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
    }
    keep <- df > 0
    if(!intercept) keep[1] <- FALSE
    nmeffect <- nmeffect[keep]
    df <- df[keep]
    ss <- ss[keep]
    nterms <- length(df)
  }
  cat("\nTerms:\n")
  if(nterms == 0) {
    # empty model
    print(matrix(0, 1, 2, dimnames=list("<empty>",
                            c("Sum of Squares", "Deg. of Freedom"))))
    return(invisible(x))
  }
  df.res <- x$df.resid
  if(is.null(df.res))
    df.res <- length(x$resid) - length(asgn)
  if(df.res > 0) {
    resid <- x$resid
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmeffect[nterms] <- "Residuals"
  }
  print(matrix(c(format(ss), format(df)), 2, nterms, byrow=TRUE,
               dimnames=list(c("Sum of Squares", "Deg. of Freedom"),
               nmeffect)),
        quote = FALSE, right = TRUE)
  rank <- x$rank
  int <- attr(x$terms, "int")
  nobs <- length(x$residuals) - !(is.null(int) || int == 0)
  rdf <- x$df.resid
  if(is.null(rdf)) rdf <- nobs - rank
  cat("\n")
  if(rdf > 0)
    cat("Residual standard error:", format(sqrt(sum(x$residuals^2)/
                                                rdf)), "\n")
  coef <- x$coef
  R <- x$qr$qr
  R <- R[1:ncol(R), ]
  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]
    }
  dm <- dim(R)
  d <- seq(1, length = min(dm), by = dm[1] + 1)
  R <- abs(R)
  if(sum(R[ - d])/sum(R[d]) > 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]] # changed
  nterms <- max(asgn)+1
  effects <- object$effects[seq(along=asgn)]
  nmeffect <- c("(Intercept)", attr(object$terms, "term.labels"))
  resid <- object$residuals
  wt <- object$weights
  if(!is.null(wt)) resid <- resid * wt^0.5
  if(is.null(effects)) {
    df <- nterms  <- 0
    ss <- ms <- numeric(0)
    nmrows <- character(0)
  }
  else {
    nobs <- length(resid)
    nterms <- max(asgn)+1
    df <- ss <- numeric(nterms)
    nmrows <- character(nterms)
    for(i in 1:nterms) {
      ai <- asgn == (i-1) # changed
      df[i] <- sum(ai)
      ss[i] <- sum(effects[ai]^2)
      nmrows[i] <- nmeffect[i]
    }
  }
  df.res <- object$df.resid
  if(df.res > 0) {
    nterms <- nterms + 1
    df[nterms] <- df.res
    ss[nterms] <- sum(resid^2)
    nmrows[nterms] <- "Residuals"
  }
  ok <- df > 0
  if(all(ok)) ms <- ss/df
  else {
    ms <- rep(NA, nterms)
    ms[ok] <- ss[ok]/df[ok]
  }
  x <- list(Df = df, "Sum of Sq" = ss, "Mean Sq" = ms)
  if(df.res > 0) {
    TT <- ms/ms[nterms]
    TP <- 1 - pf(TT, df, df.res)
    TT[nterms] <- TP[nterms] <- NA
    x$"F Value" <- TT
    x$"Pr(F)" <- TP
  }
  class(x) <- c("anova", "data.frame")
  row.names(x) <- format(nmrows)
  if(!keep.zero.df) x <- x[df > 0, ]
  if(!intercept) x <- x[-1,]
  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, ...)
{
  pattern <- function(x, ...) {
    x[abs(x) < 1e-6] <- 0
    if(exists("fractions", mode="function")) fractions(x) else x
  }
  Model <- object$terms
  attributes(Model) <- NULL
  value <- list(Model = Model)
  R <- object$qr$qr
  R <- R[1:ncol(R), ]
  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 <- dimnames(R)[[2]]
        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])
        pattern(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
    value$Partial <- beta11
  }
  class(value) <- "listof"
  value
}
print.listof <- function(x, ...)
{
  nn <- names(x)
  ll <- length(x)
  if(length(nn) != ll) nn <- paste("Component", seq(ll))
  for(i in seq(ll)) {
    cat(nn[i], ":\n"); print(x[[i]], ...); cat("\n")
  }
}
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(