.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 "\\" for simple cases:
     if(pattern == "[") {
       pattern <- "\\["
       warning("replaced regular expression pattern `[' by `\\\\['")
     } else if(length(grep("[^\\\\]\\[<-",pattern)>0)) {
       pattern <- sub("\\[<-","\\\\\\[<-",pattern)
       warning("replaced `[<-' by `\\\\[<-' in regular expression pattern")
     }
   }
   grep(pattern, all.names, value = TRUE)
 } else all.names
}
ls <- .Alias(objects)
attr <- function(x, which) {
    if (!is.character(which))
        stop("attribute name must be of mode character")
    if (length(which) != 1)
        stop("exactly one attribute name must be given")
    attributes(x)[[which]]
}
autoload <- function (name, file)
{
	if (exists(name,envir=.GlobalEnv,inherits=FALSE))
        	stop("Object already exists")
        newcall <- paste("delay(autoloader(\"", name, "\",\"", file, "\"))",
                sep = "")
	if (is.na(match(file,.Autoloaded)))
  	        assign(".Autoloaded",c(file,.Autoloaded),env=.AutoloadEnv)
        assign(name, parse(text = newcall), env = .AutoloadEnv)
}
autoloader <- function (name, file)
{
	name<-paste(name,"",sep="")
	rm(list=name,envir=.AutoloadEnv,inherits=FALSE)
        where <- length(search)
        eval(parse(text = paste("library(\"", file, "\")", sep = "")),
                .GlobalEnv)
	autoload(name,file)
        where <- length(search) - where + 2
 	if (exists(name,where=where,inherits=FALSE))
           eval(as.name(name), pos.to.env(where))
	else
	   stop(paste("autoloader didn't find `",name,"' in `",file,"'.",sep=""))
}
ave <- function (x, ..., FUN = mean)
{
        l <- list(...)
        if (is.null(l)) {
                x[] <- FUN(x)
        }
        else {
                g <- 1
                nlv <- 1
                for (i in 1:length(l)) {
                        l[[i]] <- li <- as.factor(l[[i]])
                        g <- g + nlv * (as.numeric(li) - 1)
                        nlv <- nlv * length(levels(li))
                }
                x[] <- unlist(lapply(split(x, g), FUN))[g]
        }
        x
}
axis <- function(side, at=NULL, labels=NULL, ...)
.Internal(axis(side, at, labels,...))
backsolve <- function(r, x, k=ncol(r))
{
	r <- as.matrix(r)# nr  x  k
	x <- as.matrix(x)#  k  x  nb
	if(k <= 0 || nrow(x) != k) stop("invalid parameters in backsolve")
        nb <- ncol(x)
	z <- .C("bakslv",
                t  = as.double(r),
                ldt= nrow(r),
                n  = k,
                b  = as.double(x),
                ldb= k,
                nb = nb,
                x  = matrix(0, k, nb),
                job= as.integer(1),
                info= integer(1),
                DUP= FALSE)
	if(z$info != 0) stop("singular matrix in backsolve")
	z$x
}
barplot <-
function(height, width = 1, space = NULL, names.arg = NULL,
	 legend.text = NULL, beside = FALSE, horiz = FALSE,
	 col = heat.colors(NR), border = par("fg"), main = NULL,
	 xlab = NULL, ylab = NULL, xlim = NULL, ylim = NULL,
	 axes = TRUE, inside = TRUE, ...)
{
 if (!missing(inside))
   .NotYetUsed("inside")
 opar <- if (horiz)	par(xaxs = "i", xpd = TRUE)
		else	par(yaxs = "i", xpd = TRUE)
 on.exit(par(opar))
 if (missing(space))
	space <- if (is.matrix(height) && beside) c(0, 1) else 0.2
 space <- space * mean(width)
 if (is.vector(height)) {
	height <- cbind(height)
	beside <- TRUE
 } else if (is.array(height) && (length(dim(height)) == 1)) {
   height <- rbind(height)
   beside <- TRUE
 } else if (!is.matrix(height))
	stop("`height' must be a vector or a matrix")
 NR <- nrow(height)
 NC <- ncol(height)
 if (missing(names.arg))
	names.arg <- if(is.matrix(height)) colnames(height) else names(height)
 if (beside) {
	if (length(space) == 2)
		space <- rep(c(space[2], rep(space[1], NR - 1)), NC)
	width <- rep(width, length = NR * NC)
 } else {
	width <- rep(width, length = NC)
	height <- rbind(0, apply(height, 2, cumsum))
 }
 delta <- width / 2
 w.r <- cumsum(space + width)
 w.m <- w.r - delta
 w.l <- w.m - delta
 if (horiz) {
	if (missing(xlim)) xlim <- range(-0.01, height)
	if (missing(ylim)) ylim <- c(min(w.l), max(w.r))
 } else {
	if (missing(xlim)) xlim <- c(min(w.l), max(w.r))
	if (missing(ylim)) ylim <- range(-0.01, height)
 }
 ## -------- Plotting :
 plot.new()
 plot.window(xlim, ylim, log = "")
 if (beside) {
	if (horiz)
	  rect(0, w.l, c(height), w.r, col = col)
	else
	  rect(w.l, 0, w.r, c(height), col = col)
 } else {
	for (i in 1:NC) {
	 if (horiz)
	   rect(height[1:NR, i], w.l[i], height[-1, i], w.r[i], col = col)
	 else
	   rect(w.l[i], height[1:NR, i], w.r[i], height[-1, i], col = col)
	}
 }
 if (!is.null(names.arg)) {
    if (length(names.arg) != length(w.m)) {
	if (length(names.arg) == NC)
		w.m <- apply(matrix(w.m, nc = NC), 2, mean)
	else
		stop("incorrect number of names")
    }
    axis(if(horiz) 2 else 1, at = w.m, labels = names.arg, lty = 0)
 }
 if (!missing(legend.text)) {
	xy <- par("usr")
	legend(xy[2] - xinch(0.1), xy[4] - yinch(0.1),
		legend = rev(legend.text), fill = rev(col),
		xjust = 1, yjust = 1)
 }
 title(main = main, xlab = xlab, ylab = ylab, ...)
 if (axes) axis(if(horiz) 1 else 2)
 invisible(w.m)
}
box <-
function(which="plot", lty="solid", ...)
{
	which <- pmatch(which[1], c("plot", "figure", "inner", "outer"))
	.Internal(box(which=which, lty=lty, ...))
}
boxplot <- function(x, ..., range=1.5, width=NULL, varwidth=FALSE,
	notch=FALSE, names.x, data=sys.frame(sys.parent()),
	plot=TRUE, border=par("fg"), col=NULL, log="", pars=NULL)
{
	args <- list(x,...)
	namedargs <- if(!is.null(attributes(args)$names))
		attributes(args)$names != ""
	else
		rep(FALSE, length=length(args))
	pars <- c(args[namedargs], pars)
	groups <- if(is.language(x)) {
		if(length(x) == 3 && deparse(x[[1]]) == '~') {
			groups <- eval(x[[3]], data)
			x <- eval(x[[2]], data)
			split(x, groups)
		}
		else stop("invalid first argument")
	 }
	 else {
		groups <- args[!namedargs]
		if (length(groups) == 1 && is.list(x)) x else groups
	 }
	n <- length(groups)
	if(!missing(names.x)) attr(groups, "names") <- names.x
	else if(is.null(attr(groups, "names"))) attr(groups, "names") <- 1:n
	for(i in 1:n)
		groups[i] <- list(boxplot.stats(groups[[i]], range))
	if(plot) {
		bxp(groups, width, varwidth=varwidth, notch=notch,
			border=border, col=col, log=log, pars=pars)
		invisible(groups)
	}
	else groups
}
boxplot.stats <- function(x, coef = 1.5)
{
	nna <- !is.na(x)
	n <- length(nna)# including +/- Inf
	stats <- fivenum(x, na.rm=TRUE)
	iqr <- diff(stats[c(2, 4)])
	out <- x < (stats[2]-coef*iqr) | x > (stats[4]+coef*iqr)
	if(coef > 0) stats[c(1, 5)] <- range(x[!out], na.rm=TRUE)
	conf <- stats[3]+c(-1.58, 1.58)*diff(stats[c(2, 4)])/sqrt(n)
	list(stats=stats, n=n, conf=conf, out=x[out&nna])
}
bxp <- function(z, notch=FALSE, width=NULL, varwidth=FALSE,
		notch.frac = 0.5,
		border=par("fg"), col=NULL, log="", pars=NULL, ...)
{
 bplt <- function(x, wid, stats, out, conf, notch, border, col)
 {
	## Draw single box plot.
	pars <- c(pars, list(...))# from bxp(...).
	if(!any(is.na(stats))) {
		## stats = +/- Inf:  polygon & segments should handle
		wid <- wid/2
		if(notch) {
			xx <- x+wid*c(-1,1, 1, notch.frac, 1,
				      1,-1,-1,-notch.frac,-1)
			yy <- c(stats[c(2,2)],conf[1],stats[3],conf[2],
				stats[c(4,4)],conf[2],stats[3],conf[1])
			polygon(xx, yy, col=col, border=border)
			segments(x-wid/2,stats[3], x+wid/2,stats[3], col=border)
		}
		else {
			xx <- x+wid*c(-1,1,1,-1)
			yy <- stats[c(2,2,4,4)]
			polygon(xx, yy, col=col, border=border)
			segments(x-wid,stats[3],x+wid,stats[3],col=border)
		}
		segments(rep(x,2),stats[c(1,5)], rep(x,2),
			 stats[c(2,4)], lty="dashed",col=border)
		segments(rep(x-wid/2,2),stats[c(1,5)],rep(x+wid/2,2),
			 stats[c(1,5)],col=border)
		points(rep(x,length(out)), out, col=border)
		if(any(inf <- !is.finite(out))) {
			## FIXME: should MARK on plot !! (S-plus doesn't either)
			warning(paste("Outlier (",
				 paste(unique(out[inf]),collapse=", "),
				      ") in ", paste(x,c("st","nd","rd","th")
						   [pmin(4,x)], sep=""),
				      " boxplot are NOT drawn", sep=""))
		}
	}
 }## bplt
 n <- length(z)
 limits <- numeric(0)
 nmax <- 0
 for(i in 1:n) {
	nmax <- max(nmax,z[[i]]$n)
	limits <- range(limits, z[[i]]$stats, z[[i]]$out, finite=TRUE)
 }
 width <- if (!is.null(width)) {
		if (length(width) != n | any(is.na(width)) | any(width <= 0))
			stop("invalid boxplot widths")
		0.8 * width/max(width)
	}
	else if (varwidth) 0.8 * sqrt(unlist(lapply(z, "[[", "n"))/nmax)
	else if (n == 1) 0.4
	else rep(0.8, n)
 ylim <- if(is.null(pars$ylim)) limits else pars$ylim
 if(missing(border) || length(border)==0)
	border <- par("fg")
 plot.new()
 plot.window(xlim=c(0.5,n+0.5), ylim=ylim, log=log)
 for(i in 1:n)
	 bplt(i, wid=width[i],
	      stats= z[[i]]$stats,
	      out  = z[[i]]$out,
	      conf = z[[i]]$conf,
	      notch= notch,
	      border=border[(i-1)%%length(border)+1],
	      col=if(is.null(col)) col else col[(i-1)%%length(col)+1])
 if(is.null(pars$axes) || pars$axes) {
         if(n > 1) axis(1, at=1:n, labels=names(z))
         axis(2)
 }
 do.call("title", pars)
 box()
 invisible(1:n)
}
builtins <- function(internal=FALSE)
.Internal(builtins(internal))
cat <- function(...,file="",sep=" ", fill=FALSE, labels=NULL,append=FALSE)
	.Internal(cat(list(...),file,sep,fill,labels,append))
#nchar <- function(x) {
#	x<-as.character(x)
#	.Internal(nchar(x))
#}
substr <- function(x,start,stop) {
	x <- as.character(x)
	.Internal(substr(x,as.integer(start),as.integer(stop)))
}
strsplit <- function(x,split) {
	x <- as.character(x)
	split <- as.character(split)
	.Internal(strsplit(x,split))
}
substring <- function(text,first,last=1000000)
{
	storage.mode(text) <- "character"
	n <- max(length(text), length(first), length(last))
	text <- rep(text, length = n)
	first <- rep(first, length = n)
	last <- rep(last, length = n)
	substr(text, first, last)
}
abbreviate <-
function(names.arg, minlength = 4, use.classes = TRUE, dot = FALSE)
{
	## we just ignore use.classes
	if(minlength<=0)
		return(rep("",length(names.arg)))
	names.arg <- as.character(names.arg)
	dups <- duplicated(names.arg)
	old <- names.arg
	if(any(dups))
		names.arg <- names.arg[!dups]
	dup2 <- rep(TRUE, length(names.arg))
	x <- these <- names.arg
	repeat {
		ans <- .Internal(abbreviate(these,minlength,use.classes))
		x[dup2] <- ans
		dup2 <- duplicated(x)
		if(!any(dup2))
			break
		minlength <- minlength+1
		dup2 <- dup2 | match(x, x[duplicated(x)], 0)
		these <- names.arg[dup2]
	}
	if(any(dups))
		x <- x[match(old,names.arg)]
	if(dot)
		x <- paste(x,".",sep="")
	names(x) <- old
	x
}
make.names <- function(names, unique=FALSE)
{
	names <- .Internal(make.names(as.character(names)))
	if(unique) {
		while(any(dups <- duplicated(names))) {
			names[dups] <- paste(names[dups],
					     seq(length = sum(dups)), sep = "")
		}
	}
	names
}
chisq.test <- function(x, y = NULL, correct = TRUE,
		       p = rep(1 / length(x), length(x)))
{
  DNAME <- deparse(substitute(x))
  if (is.matrix(x)) {
    if (min(dim(x)) == 1)
      x <- as.vector(x)
  }
  if (!is.matrix(x) && !is.null(y)) {
    if (length(x) != length(y))
      stop("x and y must have the same length")
    DNAME <- paste(DNAME, "and", deparse(substitute(y)))
    OK <- complete.cases(x, y)
    x <- as.factor(x[OK])
    y <- as.factor(y[OK])
    if ((nlevels(x) < 2) || (nlevels(y) < 2))
      stop("x and y must have at least 2 levels")
    x <- table(x, y)
  }
  if (any(x < 0) || any(is.na(x)))
    stop("all entries of x must be nonnegative and finite")
  if (is.matrix(x)) {
    METHOD <- "Pearson's Chi-square test"    
    E <- outer(apply(x, 1, sum), apply(x, 2, sum), "*") / sum(x)  
    if (correct && nrow(x) == 2 && ncol(x) == 2) {
      YATES <- .5
      METHOD <- paste(METHOD, "with Yates' continuity correction")
    }
    else
      YATES <- 0
    dimnames(E) <- dimnames(x)
    STATISTIC <- sum((abs(x - E) - YATES)^2 / E)
    PARAMETER <- (nrow(x) - 1) * (ncol(x) - 1)
  }
  else {
    if (length(x) == 1)
      stop("x must at least have 2 elements")
    if (length(x) != length(p))
      stop("x and p must have the same number of elements")
    METHOD <- "Chi-square test for given probabilities"
    E <- sum(x) * p
    names(E) <- names(x)
    STATISTIC <- sum((x - E) ^ 2 / E)
    PARAMETER <- length(x) - 1
  }
  names(STATISTIC) <- "X-squared"
  names(PARAMETER) <- "df"
  if (any(E < 5))
    warning("Chi-square approximation may be incorrect") 
  PVAL <- 1 - pchisq(STATISTIC, PARAMETER)
  structure(list(statistic = STATISTIC,
		 parameter = PARAMETER,
		 p.value = PVAL,
		 method = METHOD,
		 data.name = DNAME,
		 observed = x,
		 expected = E),
	    class = "htest")
}
chol <- function(x)
{
	if(!is.numeric(x))
		stop("non-numeric argument to chol")
	if(is.matrix(x)) {
		if(nrow(x) != ncol(x))
			stop("non-square matrix in chol")
		n <- nrow(x)
	}
	else {
		if(length(x) != 1)
			stop("non-matrix argument to chol")
		n <- as.integer(1)
	}
	if(!is.double(x)) storage.mode(x) <- "double"
	z <- .Fortran("chol",
		x=x,
		n,
		n,
		v=matrix(0, nr=n, nc=n),
		info=integer(1),
		DUP=FALSE)
	if(z$info)
		stop("singular matrix in chol")
	z$v
}
chol2inv <- function(x, size=ncol(x))
{
	if(!is.numeric(x))
		stop("non-numeric argument to chol2inv")
	if(is.matrix(x)) {
		nr <- nrow(x)
		nc <- ncol(x)
	}
	else {
		nr <- length(x)
		nc <- as.integer(1)
	}
	size <- as.integer(size)
	if(size <= 0 || size > nr || size > nc)
		stop("invalid size argument in chol2inv")
	if(!is.double(x)) storage.mode(x) <- "double"
	z <- .Fortran("ch2inv",
		x=x,
		nr,
		size,
		v=matrix(0, nr=size, nc=size),
		info=integer(1),
		DUP=FALSE)
	if(z$info)
		stop("singular matrix in chol2inv")
	z$v
}
colnames <- function(x) {
	dn <- dimnames(x)
	if(is.null(dn)) dn else dn[[2]]
}
"colnames<-" <- function(x, value) {
	dn <- dimnames(x)
	if(is.null(dn)) dimnames(x) <- list(dn, value)
	else dimnames(x) <- list(dn[[1]], value)
	x
}
rgb <- function(red, green, blue, names=NULL)
.Internal(rgb(red, green, blue, names))
hsv <- function(h=1,s=1,v=1,gamma=1)
.Internal(hsv(h,s,v,gamma))
palette <- function(value)
{
	if(missing(value)) .Internal(palette(character()))
	else invisible(.Internal(palette(value)))
}
## A quick little ``rainbow'' function -- improved by MM
					# doc in	../man/palettes.Rd
rainbow <-
function (n, s = 1, v = 1, start = 0, end = max(1,n - 1)/n, gamma = 1)
{
 if ((n <- as.integer(n[1])) > 0) {
	if(start == end || any(c(start,end) < 0)|| any(c(start,end) > 1))
		stop("`start' and `end' must be distinct and in [0,1].")
	hsv(h = seq(start, ifelse(start > end, 1, 0) + end, length= n) %% 1,
	    s, v, gamma)
 } else character(0)
}
topo.colors <- function (n)
{
 if ((n <- as.integer(n[1])) > 0) {
	j <- n %/% 3
	k <- n %/% 3
	i <- n - j - k
	c(if(i > 0) hsv(h= seq(from = 43/60, to = 31/60, length = i)),
	  if(j > 0) hsv(h= seq(from = 23/60, to = 11/60, length = j)),
	  if(k > 0) hsv(h= seq(from = 10/60, to =  6/60, length = k),
			s= seq(from = 1,     to = 0.3,	 length = k), v = 1))
 } else character(0)
}
terrain.colors <- function (n)
{
 if ((n <- as.integer(n[1])) > 0) {
	j <- n %/% 3
	k <- n %/% 3
	i <- n - j - k
	c(hsv(23/60, 1, v = seq(0.6, 0.85, length = i)),
	  if(j > 0)
		hsv(h = seq(22/60, 10/60, length = j), s = 1,
		    v = seq(0.85 ,     1, length = j)),
	  if(k > 0)
		hsv(h = seq(from = 9/60, to = 6/60, length = k),
		    s = seq(from =    1, to = 0.3,  length = k), v = 1))
 } else character(0)
}
heat.colors <- function (n)
{
 if ((n <- as.integer(n[1])) > 0) {
	j <- n %/% 4
	i <- n - j
	c(rainbow(i, start = 0, end = 1/6),
	  if (j > 0)
		hsv(h = 1/6, s = seq(from= 1-1/(2*j), to= 1/(2*j), length = j),
		    v = 1))
 } else character(0)
}
complete.cases <- function(...) .Internal(complete.cases(...))
pi <- 4*atan(1)
letters <- c(
"a","b","c","d","e","f","g","h","i","j","k","l", "m",
"n","o","p","q","r","s","t","u","v","w","x","y","z")
LETTERS <- c(
"A","B","C","D","E","F","G","H","I","J","K","L", "M",
"N","O","P","Q","R","S","T","U","V","W","X","Y","Z")
month.name <- c(
"January", "February", "March", "April", "May", "June",
"July", "August", "September", "October", "November", "December")
month.abb <- c(
"Jan", "Feb", "Mar", "Apr", "May", "Jun",
"Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
contour <-
function (x = seq(0, 1, len = nrow(z)), y = seq(0, 1, len = ncol(z)), 
            z, nlevels = 10, levels = pretty(range(z, finite = TRUE), 
                    nlevels), labcex = 0, xlim = range(x, finite = TRUE), 
            ylim = range(y, finite = TRUE), col = par("fg"), lty = par("lty"), 
            add = FALSE, ...) 
{
  ## labcex is disregarded since we do NOT yet put  ANY labels...
  if (missing(z)) {
    if (!missing(x)) {
      if (is.list(x)) {
        z <- x$z; y <- x$y; x <- x$x
      } else {
        z <- x
        x <- seq(0, 1, len = nrow(z))
      }
    } else stop("no `z' matrix specified")
  } else if (is.list(x)) {
    y <- x$y
    x <- x$x
  }
  if (any(diff(x) <= 0) || any(diff(y) <= 0)) 
    stop("increasing x and y values expected")
  if (!add) {
    plot.new()
    plot.window(xlim, ylim, "")
    title(...)
  }
  if (!is.matrix(z) || nrow(z) <= 1 || ncol(z) <= 1) 
    stop("no proper `z' matrix specified")
  #- don't lose  dim(.)
  if (!is.double(z)) storage.mode(z) <- "double"
  .Internal(contour(as.double(x), as.double(y), z, as.double(levels), 
                    col = col, lty = lty))
  if (!add) {
    axis(1)
    axis(2)
    box()
  }
  invisible()
}
#### copyright (C) 1998 W. N. Venables and B. D. Ripley
####
#### copyright (C) 1998 The R Development Core Team.
contr.poly <- function (n, contrasts = TRUE)
{
  make.poly <- function(n)
    {
      y <- seq(length=n) - n %/% 2 - 1
      X <- outer(y, seq(length=n) - 1, "^")
      QR <- qr(X)
      z <- QR$qr
      z <- z *(row(z) == col(z))
      raw <- qr.qy(QR, z)
      Z <- sweep(raw, 2, apply(raw, 2, function(x) sqrt(sum(x^2))), "/")
      dimnames(Z)[[2]] <- paste("^", 1:n - 1, sep="")
      Z
    }
  if (is.numeric(n) && length(n) == 1) levs <- 1:n
  else {
    levs <- n
    n <- length(levs)
  }
  if (n < 2)
    stop(paste("Contrasts not defined for", n - 1, "degrees of freedom"))
  contr <- make.poly(n)
  if (contrasts) {
    dn <- dimnames(contr)[[2]]
    dn[2:min(4,n)] <- c(".L", ".Q", ".C")[1:min(3, n-1)]
    dimnames(contr)[[2]] <- dn
    contr[, -1, drop = FALSE]
  }
  else {
    contr[, 1] <- 1
    contr
  }
}
## implemented by BDR 29 May 1998
poly <- function(x, degree=1)
{
  if(is.matrix(x)) stop("poly is only implemented for vectors")
  n <- degree + 1
  X <- outer(x, seq(length=n) - 1, "^")
  QR <- qr(X)
  z <- QR$qr
  z <- z *(row(z) == col(z))
  raw <- qr.qy(QR, z)
  s <- apply(raw, 2, function(x) sqrt(sum(x^2)))
  Z <- sweep(raw, 2, s, "/")
  dimnames(Z)[[2]] <- 1:n - 1
  Z <- Z[, -1]
  attr(Z, "degree") <- 1:degree
  Z
}
contrasts <-
function (x, contrasts = TRUE)
{
  if (!is.factor(x))
    stop("contrasts apply only to factors")
  ctr <- attr(x, "contrasts")
  if (is.null(ctr)) {
    ctr <- get(options("contrasts")[[1]] [[if (is.ordered(x)) 2 else 1]])(levels(x), contrasts = contrasts)
    dimnames(ctr) <- list(levels(x), dimnames(ctr)[[2]])
  }
  else if (is.character(ctr))
    ctr <- get(ctr)(levels(x), contrasts = contrasts)
  if(ncol(ctr)==1) dimnames(ctr) <- list(dimnames(ctr)[[1]], "")
  ctr
}
"contrasts<-" <-
function(x, how.many, value)
{
 if(!is.factor(x))
	stop("contrasts apply only to factors")
 if(is.function(value)) value <- value(nlevels(x))
 if(is.numeric(value)) {
   value <- as.matrix(value)
   nlevs <- nlevels(x)
   if(nrow(value) != nlevs)
     stop("wrong number of contrast matrix rows")
   n1 <- if(missing(how.many)) nlevs - 1 else how.many
   nc <- ncol(value)
   rownames(value) <- levels(x)
   if(nc  < n1) {
     cm <- qr(cbind(1,value))
     if(cm$rank != nc+1) stop("singular contrast matrix")
     cm <- qr.qy(cm, diag(nlevs))[,2:nlevs]
     cm[,1:nc] <- value
     dimnames(cm) <- list(levels(x),NULL)
     if(!is.null(nmcol <- dimnames(value)[[2]]))
       dimnames(cm)[[2]] <- c(nmcol, rep("", n1-nc))
   } else cm <- value[, 1:n1, drop=FALSE]
 }
 else if(is.character(value)) cm <- value
 else if(is.null(value)) cm <- NULL
 else stop("numeric contrasts or contrast name expected")
 attr(x, "contrasts") <- cm
 x
}
contr.helmert <-
function (n, contrasts=TRUE)
{
	if (length(n) <= 1) {
		if(is.numeric(n) && length(n) == 1 && n > 1) levels <- 1:n
		else stop("contrasts are not defined for 0 degrees of freedom")
	} else levels <- n
	lenglev <- length(levels)
	if (contrasts) {
		cont <- array(-1, c(lenglev, lenglev-1), list(levels, NULL))
		cont[col(cont) <= row(cont) - 2] <- 0
		cont[col(cont) == row(cont) - 1] <- 1:(lenglev-1)
	} else {
		cont <- array(0, c(lenglev, lenglev), list(levels, levels))
		cont[col(cont) == row(cont)] <- 1
	}
	cont
}
contr.treatment <-
function(n, contrasts = TRUE)
{
	if(is.numeric(n) && length(n) == 1)
		levs <- 1:n
	else {
		levs <- n
		n <- length(n)
	}
	contr <- array(0, c(n, n), list(levs, levs))
	contr[seq(1, n^2, n + 1)] <- 1
	if(contrasts) {
		if(n < 2)
			stop(paste("Contrasts not defined for", n - 1,
				"degrees of freedom"))
		contr <- contr[, -1, drop = FALSE]
	}
	contr
}
contr.sum <-
function (n, contrasts=TRUE)
{
	if (length(n) <= 1) {
		if (is.numeric(n) && length(n) == 1 && n > 1)
			levels <- 1:n
		else stop("Not enough degrees of freedom to define contrasts")
	} else levels <- n
	lenglev <- length(levels)
	if (contrasts) {
		cont <- array(0, c(lenglev, lenglev - 1), list(levels, NULL))
		cont[col(cont) == row(cont)] <- 1
		cont[lenglev, ] <- -1
	} else {
		cont <- array(0, c(lenglev, lenglev), list(levels, levels))
		cont[col(cont) == row(cont)] <- 1
	}
	cont
}
"co.intervals" <-
function (x, number = 6, overlap = 0.5)
{
	x <- sort(x[!is.na(x)])
	n <- length(x)
	## "from the record"
	r <- n/(number * (1 - overlap) + overlap)
	l <- round(1 + 0:(number - 1) * (1 - overlap) * r)
	u <- round(r + 0:(number - 1) * (1 - overlap) * r)
	cbind(x[l], x[u])
}
panel.smooth <-
function(x, y, col = par("col"), pch = par("pch"), col.smooth = "red",
         f=2/3, iter=3, ...)
{
	points(x, y, pch=pch, col=col)
	lines(lowess(x, y, f=f, iter=iter), col = col.smooth, ...)
}
coplot <-
function (formula, data, given.values, panel=points, rows, columns,
	show.given = TRUE, col = par("fg"), pch=par("pch"), ...)
{
 deparen <- function(expr) {
	while (is.language(expr) && !is.name(expr) && deparse(expr[[1]]) == "(")
	  expr <- expr[[2]]
	expr
 }
 bad.formula <- function() stop("invalid conditioning formula")
 bad.lengths <- function() stop("incompatible variable lengths")
 ## parse and check the formula
 formula <- deparen(formula)
 if (deparse(formula[[1]]) != "~")
	bad.formula()
 y <- deparen(formula[[2]])
 rhs <- deparen(formula[[3]])
 if (deparse(rhs[[1]]) != "|")
	bad.formula()
 x <- deparen(rhs[[2]])
 rhs <- deparen(rhs[[3]])
 if (is.language(rhs) && !is.name(rhs)
     && (deparse(rhs[[1]]) == "*" || deparse(rhs[[1]]) == "+")) {
	have.b <- TRUE
	a <- deparen(rhs[[2]])
	b <- deparen(rhs[[3]])
 } else {
	have.b <- FALSE
	a <- rhs
 }
 ## evaluate the formulae components to get the data values
 if (missing(data))
	data <- sys.frame(sys.parent())
 x.name <- deparse(x)
 x <- eval(x, data)
 nobs <- length(x)
 y.name <- deparse(y)
 y <- eval(y, data)
 if(length(y) != nobs) bad.lengths()
 a.name <- deparse(a)
 a <- eval(a, data)
 if(length(a) != nobs) bad.lengths()
 if (have.b) {
	b.name <- deparse(b)
	b <- eval(b, data)
	if(length(b) != nobs) bad.lengths()
 }
 else b <- NULL
 ## generate the given value intervals
 bad.givens <- function() stop("invalid given.values")
 if(missing(given.values)) {
	if(is.factor(a)) {
		a.intervals <- cbind(1:nlevels(a), 1:nlevels(a))
		a <- as.numeric(a)
	}
	else a.intervals <- co.intervals(a)
	b.intervals <- NULL
	if (have.b)  {
		if(is.factor(b)) {
			b.intervals <- cbind(1:nlevels(b), 1:nlevels(b))
			b <- as.numeric(b)
		}
		else b.intervals <- co.intervals(b)
	}
 } else {
	 if(!is.list(given.values))
		given.values <- list(given.values)
	 if(length(given.values) != (if(have.b) 2 else 1))
		bad.givens()
	 a.intervals <- given.values[[1]]
	 if(is.factor(a)) {
		if(is.character(a.intervals))
			a.levels <- match(a.levels, levels(a))
		else a.levels <- cbind(a.levels, a.levels)
		a <- as.numeric(a)
	 } else if(is.numeric(a)) {
		if(!is.numeric(a)) bad.givens()
		if(!is.matrix(a.intervals) || ncol(a.intervals) != 2)
			a.intervals <- cbind(a.intervals, a.intervals)
	 }
	 if(have.b) {
		b.intervals <- given.values[[2]]
		if(is.factor(b)) {
			if(is.character(b.intervals))
				b.levels <- match(b.levels, levels(b))
			else b.levels <- cbind(b.levels, b.levels)
			b <- as.numeric(b)
		} else if(is.numeric(b)) {
			if(!is.numeric(b)) bad.givens()
			if(!is.matrix(b.intervals) || ncol(b.intervals) != 2)
				b.intervals <- cbind(b.intervals, b.intervals)
		}
	}
 }
 if(any(is.na(a.intervals))) bad.givens()
 if(have.b)
	if(any(is.na(b.intervals))) bad.givens()
 ## compute the page layout
 if (have.b) {
	rows <- nrow(b.intervals)
	columns <- nrow(b.intervals)
	nplots <- rows * columns
	total.rows <- rows + if (show.given) 1 else 0
	total.columns <- columns + if (show.given) 1 else 0
 } else {
	nplots <- nrow(a.intervals)
	if (missing(rows)) {
		if (missing(columns)) {
			rows <- ceiling(round(sqrt(nplots)))
			columns <- ceiling(nplots/rows)
		}
		else rows <- ceiling(nplots/columns)
	}
	else if (missing(columns))
		columns <- ceiling(nplots/rows)
	if (rows * columns < nplots)
		stop("rows * columns too small")
	total.rows <- rows + if (show.given) 1 else 0
	total.columns <- columns
 }
 ## Start Plotting only now
 opar <- par(mfrow = c(total.rows, total.columns),
	     oma = if(have.b) rep(5, 4) else c(5, 6, 5, 4),
	     mar = if(have.b) rep(0, 4) else c(0.5, 0, 0.5, 0),
	     new = FALSE)
 on.exit(par(opar))
 plot.new()
 xlim <- range(x, finite = TRUE)
 ylim <- range(y, finite = TRUE)
 pch <- rep(pch, length=nobs)
 col <- rep(col, length=nobs)
 do.panel <- function(index) {
	istart <- (total.rows - rows) + 1
	i <- total.rows - ((index - 1)%/%columns)
	j <- (index - 1)%%columns + 1
	par(mfg = c(i, j, total.rows, total.columns))
	plot.new()
	plot.window(xlim, ylim, log = "")
	if(any(id)) {
		grid(lty="solid")
		panel(x[id], y[id], col = col[id], pch=pch[id], ...)
	}
	if ((i == total.rows) && (j%%2 == 0))
		axis(1)
	if ((i == istart || index + columns > nplots) && (j%%2 == 1))
		axis(3)
	if ((j == 1) && ((total.rows - i)%%2 == 0))
		axis(2)
	if ((j == columns || index == nplots) && ((total.rows - i)%%2 == 1))
		axis(4)
	## if (i == total.rows)
	##	axis(1, labels = (j%%2 == 0))
	## if (i == istart || index + columns > nplots)
	##	axis(3, labels = (j%%2 == 1))
	## if (j == 1)
	##	axis(2, labels = ((total.rows - i)%%2 == 0))
	## if (j == columns || index == nplots)
	##	axis(4, labels = ((total.rows - i)%%2 == 1))
	box()
 }## do.panel
 if(have.b) {
	count <- 1
	for(i in 1:rows) {
		for(j in 1:columns) {
		 id <- ((a.intervals[j,1] <= a) & (a <= a.intervals[j,2]) &
			(b.intervals[i,1] <= b) & (b <= b.intervals[i,2]))
		 do.panel(count)
		 count <- count + 1
		}
	}
 } else {
	for (i in 1:nplots) {
		id <- ((a.intervals[i,1] <= a) & (a <= a.intervals[i,2]))
		do.panel(i)
	}
 }
 mtext(x.name, side=1, at=0.5*(columns/total.columns),
	outer=TRUE, line=3.5, xpd=TRUE)
 mtext(y.name, side=2, at=0.5*(rows/total.rows),
	outer=TRUE, line=3.5, xpd=TRUE)
 if(show.given) {
	mar <- par("mar")
	nmar <- mar + c(4,0,0,0)
	par(fig = c(0, columns/total.columns, rows/total.rows, 1),
	    mar = nmar, new=TRUE)
	plot.new()
	nint <- nrow(a.intervals)
	plot.window(range(a.intervals, finite=TRUE), .5+c(0, nint), log="")
	rect(a.intervals[,1], 1:nint-0.3,
	     a.intervals[,2], 1:nint+0.3, col=gray(0.9))
	axis(3)
	axis(1, labels=FALSE)
	box()
	mtext(paste("Given :", a.name),
	      side=3, at=mean(par("usr")[1:2]), line=3, xpd=TRUE)
	if(have.b) {
		nmar <- mar + c(0, 4, 0, 0)
		par(fig = c(columns/total.columns, 1, 0, rows/total.rows),
		    mar = nmar, new=TRUE)
		plot.new()
		nint <- nrow(b.intervals)
		plot.window(.5+c(0, nint),
			    range(b.intervals, finite=TRUE), log="")
		rect(1:nint-0.3, b.intervals[,1],
		     1:nint+0.3, b.intervals[,2], col=gray(0.9))
		axis(4)
		axis(2, labels=FALSE)
		box()
		mtext(paste("Given :", b.name),
			side=4, at=mean(par("usr")[3:4]), line=3, xpd=TRUE)
	}
 }
}
cor <- function (x, y=NULL, use="all.obs")
{
	na.method <- pmatch(use, c("all.obs", "complete.obs", "pairwise.complete.obs"))
	if(is.data.frame(x)) x <- as.matrix(x)
	if(is.data.frame(y)) y <- as.matrix(y)
	.Internal(cor(x, y, na.method))
}
cov <- function (x, y=NULL, use="all.obs") 
{
	na.method <- pmatch(use, c("all.obs", "complete.obs",
			"pairwise.complete.obs"))
	if(is.data.frame(x)) x <- as.matrix(x)
	if(is.data.frame(y)) y <- as.matrix(y)
	.Internal(cov(x, y, na.method))
}
cov.wt <- function(x, wt = rep(1/nrow(x), nrow(x)), cor = FALSE,
                   center = TRUE)
{
  if (is.data.frame(x))
    x <- as.matrix(x)
  else if (!is.matrix(x))
    stop("x must be a matrix or a data frame")
  if (!all(is.finite(x)))
    stop("x must contain finite values only")
  n <- nrow(x)
  if (with.wt <- !missing(wt)) {
    if (length(wt) != n)
      stop("length of wt must equal the number of rows in x")
    if (any(wt < 0) || (s <- sum(wt)) == 0)
      stop("weights must be non-negative and not all zero")
    wt <- wt / s
  }
  if (is.logical(center)) {
    center <- if (center)
      apply(wt * x, 2, sum)
    else 0
  } else {
    if (length(center) != ncol(x))
      stop("length of center must equal the number of columns in x")
  }
  x <- sqrt(wt) * sweep(x, 2, center)
  cov <- (t(x) %*% x) / (1 - sum(wt^2))
  y <- list(cov = cov, center = center, n.obs = n)
  if (with.wt)
    y <- c(y, wt = wt)
  if (cor) {
    sdinv <- diag(1 / sqrt(diag(cov)))
    y <- c(y, cor = sdinv %*% cov %*% sdinv)
  }
  y
}
curve <- function(expr, from, to, n=101, add=FALSE, type="l", ...) {
	expr <- substitute(expr)
	lims <- par("usr")
	if(missing(from)) from <- lims[1]
	if(missing(to)) to <- lims[2]
	x <- seq(from,to,length=n)
	y <- eval(expr)
	if(add)
		lines(x, y, ...)
	else
		plot(x, y, type="l", ...)
}
cut <- function(x, ...) UseMethod("cut")
cut.default <- function (x, breaks, labels=NULL, include.lowest = FALSE,
                         right=TRUE, dig.lab=3)
{
	if (!is.numeric(x)) stop("cut: x must be numeric")
	if (length(breaks) == 1) {
		if (is.na(breaks) | breaks < 2)
		  stop("invalid number of intervals")
		nb <- as.integer(breaks + 1)# one more than #{intervals}
		dx <- diff(rx <- range(x,na.rm=TRUE))
		if(dx==0) dx <- rx[1]
		breaks <- seq(rx[1] - dx/1000,
			      rx[2] + dx/1000, len=nb)
	} else nb <- length(breaks <- sort(breaks))
	if (any(duplicated(breaks))) stop("cut: breaks are not unique")
	if (is.null(labels)) {#- try to construct nice ones ..
		for(dig in dig.lab:12) {
			ch.br <- formatC(breaks, dig=dig, wid=1)
			if(ok <- all(ch.br[-1]!=ch.br[-nb])) break
		}
		labels <-
		  if(ok) paste(if(right)"(" else "[",
			       ch.br[-nb], ",", ch.br[-1],
			       if(right)"]" else ")", sep='')
		  else paste("Range", 1:(nb - 1),sep="_")
	} else if (length(labels) != nb-1)
		stop("labels/breaks length conflict")
	code <- .C(if(right) "bincode2" else "bincode",
		   as.double(x),
		   length(x),
		   as.double(breaks),
		   nb,
		   code= integer(length(x)),
                   include= as.logical(include.lowest),
		   NAOK= TRUE) $code
	factor(code, seq(labels), labels)
}
data.matrix <-
function(frame)
{
	if(!is.data.frame(frame))
		return(as.matrix(frame))
	log <- unlist(lapply(frame, is.logical))
	num <- unlist(lapply(frame, is.numeric))
	fac <- unlist(lapply(frame, is.factor))
	if(!all(log|fac|num))
		stop("non-numeric data type in frame")
	d <- dim(frame)
	x <- matrix(nr=d[1],nc=d[2],dimnames=dimnames(frame))
	for(i in 1:length(frame)) {
		xi <- frame[[i]]
		if(is.logical(xi)) x[,i] <- as.numeric(xi)
		else if(is.numeric(xi)) x[,i] <- xi
		else x[,i] <- codes(xi)
	}
	x
}
### Useful Generics
"row.names<-" <- function(x, value) UseMethod("row.names<-")
"row.names"   <- function(x)  UseMethod("row.names")
### Dataframe specific code
row.names.default <- function(x) attr(x,"row.names")
"row.names<-.data.frame" <- function(x, value)
{
  if( !is.data.frame(x) )
    return(data.frame(x, row.names=value))
  else {
    old <- attr(x,"row.names")
    if(!is.null(old) && length(value) != length(old))
      stop("invalid row.names length")
    attr(x,"row.names") <- as.character(value)
  }
  x
}
"row.names<-.default" <- function(x, value)
    "row.names<-.data.frame"(as.data.frame(x),value)
"is.na.data.frame" <- function (x)
{
  y <- do.call("cbind", lapply(x, "is.na"))
  rownames(y) <- row.names(x)
  y
}
is.data.frame <- function(x) inherits(x, "data.frame")
I <- function(x) { structure(x, class = unique(c("AsIs", class(x)))) }
plot.data.frame <- function (x, ...)
{
  if(!is.data.frame(x))
    stop("plot.data.frame applied to non data frame")
  x <- data.matrix(x)
  if(ncol(x) == 1) {
    stripplot(x, ...)
  }
  else if(ncol(x) == 2) {
    plot(x, ...)
  }
  else {
    pairs(x, ...)
  }
}
t.data.frame <- function(x)
{
  x <- as.matrix(x)
  NextMethod("t")
}
dim.data.frame <- function(x) c(length(attr(x,"row.names")), length(x))
dimnames.data.frame <- function(x) list(attr(x,"row.names"), names(x))
"dimnames<-.data.frame" <- function(x, value)
{
  d <- dim(x)
  if(!is.list(value) || length(value) != 2
      || d[[1]] != length(value[[1]])
      || d[[2]] != length(value[[2]]))
    stop("invalid dimnames given for data frame")
  attr(x, "row.names") <- as.character(value[[1]])
  attr(x, "names") <- as.character(value[[2]])
  x
}
as.data.frame <- function(x, row.names = NULL, optional = FALSE)
    UseMethod("as.data.frame")
as.data.frame.default <- function(x, row.names = NULL, optional = FALSE)
{
  dcmethod <- paste("as.data.frame", data.class(x), sep=".")
  if(exists(dcmethod, mode="function"))
    (get(dcmethod, mode="function"))(x, row.names, optional)
  else stop(paste("can't coerce",data.class(x), "into a data.frame"))
}
###  Here are methods ensuring that the arguments to "data.frame"
###  are in a form suitable for combining into a data frame.
as.data.frame.data.frame <- function(x, row.names = NULL, optional = FALSE)
{
  cl <- class(x)
  i <- match("data.frame", cl)
  if(i > 1)
    class(x) <- cl[ - seq(length = i - 1)]
  if(is.character(row.names)){
    if(length(row.names) == length(attr(x, "row.names")))
      attr(x, "row.names") <- row.names
    else stop(paste("invalid row.names, length", length(row.names),
		    "for a data frame with", length(attr(x, "row.names")),
		    "rows"))
  }
  x
}
as.data.frame.list <- function(x, row.names = NULL, optional = FALSE)
{
  x <- eval(as.call(c(expression(data.frame), x)))
  if(!is.null(row.names)) {
    row.names <- as.character(row.names)
    if(length(row.names) != dim(x)[[1]]) stop(paste(
	       "supplied", length(row.names), "row names for",
	       dim(x)[[1]], "rows"))
    attr(x, "row.names") <- row.names
  }
  x
}
as.data.frame.vector <- function(x, row.names = NULL, optional = FALSE)
{
  nrows <- length(x)
  if(is.null(row.names)) {
    if(length(row.names <- names(x)) == nrows &&
       !any(duplicated(row.names))) {}
    else if(optional) row.names <- character(nrows)
    else row.names <- as.character(1:nrows)
  }
  value <- list(x)
  if(!optional) names(value) <- deparse(substitute(x))[[1]]
  attr(value, "row.names") <- row.names
  class(value) <- "data.frame"
  value
}
as.data.frame.ts <-
function(x, row.names=NULL, optional=FALSE)
{
  if(is.matrix(x)) as.data.frame.matrix(x, row.names, optional)
  else as.data.frame.vector(x, row.names, optional)
}
as.data.frame.numeric <- .Alias(as.data.frame.vector)
as.data.frame.complex <- .Alias(as.data.frame.vector)
as.data.frame.integer <- .Alias(as.data.frame.vector)
as.data.frame.factor <- .Alias(as.data.frame.vector)
as.data.frame.ordered <- .Alias(as.data.frame.vector)
as.data.frame.character <- function(x, row.names = NULL, optional = FALSE)
	as.data.frame.vector(factor(x), row.names, optional)
as.data.frame.logical <- .Alias(as.data.frame.character)
as.data.frame.matrix <- function(x, row.names = NULL, optional = FALSE)
{
  d <- dim(x)
  nrows <- d[[1]]
  ncols <- d[[2]]
  dn <- dimnames(x)
  row.names <- dn[[1]]
  collabs <- dn[[2]]
  value <- vector("list", ncols)
  for(i in seq(length=ncols))
    value[[i]] <- x[,i]
  if(length(row.names)==nrows) {}
  else if(optional) row.names <- character(nrows)
  else row.names <- as.character(seq(length=nrows))
  if(length(collabs) == ncols) names(value) <- collabs
  else if(!optional) names(value) <- paste("V", seq(length=ncols), sep="")
  attr(value, "row.names") <- row.names
  class(value) <- "data.frame"
  value
}
as.data.frame.model.matrix <- function(x, row.names = NULL, optional = FALSE)
{
  d <- dim(x)
  nrows <- d[[1]]
  dn <- dimnames(x)
  row.names <- dn[[1]]
  value <- list(x)
  if(!is.null(row.names)) {
    row.names <- as.character(row.names)
    if(length(row.names) != nrows) stop(paste("supplied",
	       length(row.names), "names for a data frame with",
	       nrows, "rows"))
  }
  else if(optional) row.names <- character(nrows)
  else row.names <- as.character(seq(length=nrows))
  if(!optional) names(value) <- deparse(substitute(x))[[1]]
  attr(value, "row.names") <- row.names
  class(value) <- "data.frame"
  value
}
as.data.frame.AsIs <- function(x, row.names = NULL, optional = FALSE)
{
  if(length(dim(x))==2) as.data.frame.model.matrix(x, row.names, optional)
  else as.data.frame.vector(x, row.names, optional)
}
###  This is the real "data.frame".
###  It does everything by calling the methods presented above.
data.frame <- function(..., row.names = NULL, check.rows = FALSE, check.names = TRUE)
{
  data.row.names <-
    if(check.rows && missing(row.names))
      function(current, new, i) {
	new <- as.character(new)
	if(any(duplicated(new)))
	  return(current)
	if(is.null(current))
	  return(new)
	if(all(current == new) || all(current == ""))
	  return(new)
	stop(paste("mismatch of row names in elements of \"data.frame\", item",
		   i))
      }
    else function(current, new, i) {
      if(is.null(current) && !any(duplicated(new <- as.character(new))))
	new
      else current
    }
  object <- as.list(substitute(list(...)))[-1]
  x <- list(...)
  n <- length(x)
  if(n < 1)
    return(structure(list(), class = "data.frame"))
  vnames <- names(x)
  if(length(vnames) != n)
    vnames <- character(n)
  no.vn <- nchar(vnames) == 0
  value <- vnames <- as.list(vnames)
  nrows <- numeric(n)
  for(i in 1:n) {
    xi <- as.data.frame(x[[i]], optional=TRUE)
    rowsi <- attr(xi, "row.names")
    nnew <- length(xi)
    namesi <- names(xi)
    if(nnew>1) {
      if(length(namesi) == 0) namesi <- seq(length=nnew)
      if(no.vn[i]) vnames[[i]] <- namesi
      else vnames[[i]] <- paste(vnames[[i]], namesi, sep=".")
    }
    else if(length(namesi) > 0) vnames[[i]] <- namesi
    else if(no.vn[[i]]) vnames[[i]] <- deparse(object[[i]])
    nrows[[i]] <- length(rowsi)
    if(missing(row.names) && rowsi[[1]]!="")
      row.names <- data.row.names(row.names, rowsi, i)
    value[[i]] <- xi
  }
  nr <- max(nrows)
  for(i in seq(length=n)[nrows < nr]) {
    xi <- value[[i]]
    if(length(xi)==1 && nr%%nrows[[i]]==0 && is.vector(xi[[1]]))
      value[[i]] <- list(rep(xi[[1]], length=nr))
    else stop(paste("arguments imply differing number of rows:",
		    paste(unique(nrows), collapse = ", ")))
  }
  value <- unlist(value, recursive=FALSE, use.names=FALSE)
  vnames <- unlist(vnames)
  noname <- nchar(vnames) == 0
  if(any(noname))
    vnames[noname] <- paste("Var", 1:length(vnames), sep = ".")[noname]
  if(check.names)
    vnames <- make.names(vnames)
  names(value) <- vnames
  if(length(row.names) == 0)
    row.names <- 1:nr
  else if(length(row.names) != nr) {
    if(is.character(row.names))
      row.names <- match(row.names, vnames, 0)
    if(length(row.names)!=1 ||
       row.names < 1 || row.names > length(vnames))
      stop("row.names should specify one of the variables")
    i <- row.names
    row.names <- value[[i]]
    value <- value[ - i]
  }
  row.names <- as.character(row.names)
  if(any(duplicated(row.names)))
    stop(paste("duplicate row.names:",
	       paste(unique(row.names[duplicated(row.names)]),
		     collapse = ", ")))
  attr(value, "row.names") <- row.names
  attr(value, "class") <- "data.frame"
  value
}
###  Subsetting and mutation methods
###  These are a little less general than S
"[.data.frame" <-
  function(x, i, j, drop = if(missing(i)) TRUE else length(cols) == 1)
  {
    if(nargs() < 3) {
      if(missing(i))
	return(x)
      if(is.matrix(i))
	return(as.matrix(x)[i])
      return(structure(NextMethod("["), class = class(x),
		       row.names = row.names(x)))
    }
    ## preserve the attributes for later use ...
    rows <- attr(x, "row.names")
    cols <- names(x)
    cl <- class(x)
    class(x) <- attr(x, "row.names") <- NULL
    ## handle the column only subsetting ...
    if(missing(i)) {
      x <- x[j]
      cols <- names(x)
      if(is.null(cols) || any(nchar(cols) == 0))
	stop("undefined columns selected")
    }
    else {
      if(is.character(i))
	i <- pmatch(i, rows, duplicates.ok = TRUE)
      rows <- rows[i]
      if(!missing(j)) {
	x <- x[j]
	cols <- names(x)
	if(is.null(cols) || any(nchar(cols) == 0))
	  stop("undefined columns selected")
      }
      n <- length(x)
      jj <- seq(length = n)
      for(j in jj) {
	xj <- x[[j]]
	if(length(dim(xj)) != 2)
	  x[[j]] <- xj[i]
	else x[[j]] <- xj[i, , drop = drop]
      }
    }
    if(drop) {
      drop <- FALSE
      n <- length(x)
      if(n == 1) {
	x <- x[[1]]
	drop <- TRUE
      }
      else if(n > 1) {
	xj <- x[[1]]
	if(length(dim(xj)) == 2)
	  nrow <- dim(xj)[1]
	else nrow <- length(xj)
	if(nrow == 1) {
	  drop <- TRUE
	  names(x) <- cols
	  attr(x, "row.names") <- NULL
	}
      }
    }
    if(!drop) {
      names(x) <- cols
      if(any(duplicated(rows)))
	rows <- make.names(rows, unique = TRUE)
      attr(x, "row.names") <- rows
      class(x) <- cl
    }
    x
  }
"[[.data.frame"<-
  function(x, ...)
  {
    ## use in-line functions to refer to the 1st and 2nd ... arguments
    ## explicitly. Also will check for wrong number or empty args
    if(nargs() < 3)
      (function(x, i)
       if(is.matrix(i))
       as.matrix(x)[[i]]
       else unclass(x)[[i]])(x, ...)
    else (function(x, i, j)
	  x[[j]][[i]])(unclass(x), ...)
  }
"[<-.data.frame" <- function(x, i, j, value)
{
  if((nA <- nargs()) == 4) {
    has.i <- !missing(i)
    has.j <- !missing(j)
  }
  else if(nA == 3) {
    ## really ambiguous, but follow common use as if list
    if(is.matrix(i))
      stop("Matrix-subscripts not allowed in replacement")
    j <- i
    i <- NULL
    has.i <- FALSE
    has.j <- TRUE
  }
  else if(nA == 2) {
    value <- i
    i <- j <- NULL
    has.i <- has.j <- FALSE
  }
  else {
    stop("Need 0, 1, or 2 subscripts")
  }
  cl <- class(x)
  ## delete class: Version 3 idiom
  ## to avoid any special methods for [[, etc
  class(x) <- NULL
  rows <- attr(x, "row.names")
  new.cols <- NULL
  nvars <- length(x)
  nrows <- length(rows)
  if(has.i) {
    if(char.i <- is.character(i)) {
      ii <- match(i, rows)
      nextra <- sum(new.rows <- is.na(ii))
      if(nextra > 0) {
	ii[new.rows] <- seq(from = nrows + 1, length =
			    nextra)
	new.rows <- i[new.rows]
      }
      i <- ii
    }
    if(all(i >= 0) && (nn <- max(i)) > nrows) {
      ## expand
      if(!char.i) {
	nrr <- as.character((nrows + 1):nn)
	if(inherits(value, "data.frame") &&
	   (nrv <- dim(value)[1]) >= length(nrr)) {
	  new.rows <- attr(value, "row.names")[1:length(nrr)]
	  repl <- duplicated(new.rows) | match(new.rows, rows, 0)
	  if(any(repl))
	    new.rows[repl] <- nrr[repl]
	}
	else new.rows <- nrr
      }
      x <- xpdrows.data.frame(x, nrows, nn, rows, new.rows)
      rows <- attr(x, "row.names")
      nrows <- length(rows)
    }
    iseq <- seq(along = rows)[i]
    if(any(is.na(iseq)))
      stop("non-existent rows not allowed")
  }
  else iseq <- NULL
  if(has.j) {
    if(is.character(j)) {
      jj <- match(j, names(x))
      nnew <- sum(is.na(jj))
      if(nnew > 0) {
	n <- is.na(jj)
	jj[n] <- nvars + 1:nnew
	new.cols <- c(names(x), j[n])
      }
      jseq <- jj
    }
    else if(is.logical(j) || min(j) < 0)
      jseq <- seq(along = x)[j]
    else {
      jseq <- j
      if(max(jseq) > nvars) {
	new.cols <- c(names(x),
		      paste("V", seq(from = nvars + 1, to = max(jseq)),
			    sep = ""))
	if(length(new.cols) - nvars != sum(jseq > nvars))
	  stop("new columns would leave holes after existing columns")
      }
    }
  }
  else jseq <- seq(along = x)
  n <- length(iseq)
  if(n == 0)
    n <- nrows
  p <- length(jseq)
  m <- length(value)
  value <- as.data.frame(value)
  dimv <- dim(value)
  nrowv <- dimv[[1]]
  if(nrowv < n) {
    if(n %% nrowv == 0) value <- value[rep(1:nrowv, length=n),]
    else stop(paste(nrowv, "rows in value to replace", n, "rows"))
  }
  else if(nrowv > n) warning(paste("replacement data has", nrowv,
				   "rows to replace", n, "rows"))
  vseq <- 1:n
  ncolv <- dimv[[2]]
  jvseq <- 1:p
  if(ncolv < p) jvseq <- rep(1:ncolv, length=p)
  else if(ncolv > p) warning(paste("provided", ncolv,
				   "variables to replace", p, "variables"))
  if(has.i)
    for(jjj in 1:p) {
      jj <- jseq[jjj]
      vjj <- value[[jvseq[[jjj]] ]]
      xj <- x[[jj]]
      if(length(dim(xj)) != 2)
	xj[iseq] <- vjj
      else xj[iseq,  ] <- vjj
      x[[jj]] <- xj
    }
  else for(jjj in 1:p) {
    jj <- jseq[jjj]
    x[[jj]] <- value[[jvseq[[jjj]] ]]
  }
  if(length(new.cols) > 0)
    names(x) <- new.cols
  class(x) <- cl
  x
}
"[[<-.data.frame"<- function(x, i, j, value)
{
  cl <- class(x)
  ## delete class: Version 3 idiom
  ## to avoid any special methods for [[, etc
  class(x) <- NULL
  rows <- attr(x, "row.names")
  nrows <- length(rows)
  if(nargs() < 4) {
    ## really ambiguous, but follow common use as if list
    ## el(x,i) <- value is the preferred approach
    if(is.null(value)) {}
    else {
      if(!inherits(value, "data.frame"))
	value <- as.data.frame(value)
      if(length(value) != 1)
	stop(paste("trying to replace one column with", length(value)))
      if(length(row.names(value)) != nrows)
	stop(paste("replacement has", length(value),
		   "rows, data has", nrows))
      class(value) <- NULL
      value <- value[[1]]
    }
    x[[i]] <- value
    class(x) <- cl
    return(x)
  }
  if(missing(i) || missing(j))
    stop("only valid calls are x[[j]] <- value or x[[i,j]] <- value")
  nvars <- length(x)
  if(n <- is.character(i)) {
    ii <- match(i, rows)
    n <- sum(new.rows <- is.na(ii))
    if(any(n > 0)) {# drop any(.)?
      ii[new.rows] <- seq(from = nrows + 1, length = n)
      new.rows <- i[new.rows]
    }
    i <- ii
  }
  if(all(i >= 0) && (nn <- max(i)) > nrows) {
    ## expand
    if(n==0) {
      nrr <- as.character((nrows + 1):nn)
      if(inherits(value, "data.frame") &&
	 (nrv <- dim(value)[1]) >= length(nrr)) {
	new.rows <- attr(value, "row.names")[1:length(nrr)]
	repl <- duplicated(new.rows) | match(new.rows, rows, 0)
	if(any(repl))
	  new.rows[repl] <- nrr[repl]
      }
      else new.rows <- nrr
    }
    x <- xpdrows.data.frame(x, nrows, nn, rows, new.rows)
    rows <- attr(x, "row.names")
    nrows <- length(rows)
  }
  iseq <- seq(along = rows)[i]
  if(any(is.na(iseq)))
    stop("non-existent rows not allowed")
  if(is.character(j)) {
    jseq <- match(j, names(x))
    if(any(is.na(jseq)))
      stop(paste("replacing element in non-existent column:", j[is.na(jseq)]))
  }
  else if(is.logical(j) || min(j) < 0)
    jseq <- seq(along = x)[j]
  else {
    jseq <- j
    if(max(jseq) > nvars)
      stop(paste("replacing element in non-existent column:", jseq[jseq>nvars]))
  }
  if(length(iseq) > 1 || length(jseq) > 1)
    stop("only a single element should be replaced")
  x[[jseq]][[iseq]] <- value
  class(x) <- cl
  x
}
### Here are the methods for rbind and cbind.
cbind.data.frame <- function(..., deparse.level = 1)
  data.frame(..., check.names = FALSE)
rbind.data.frame <- function(..., deparse.level = 1)
{
  match.names <- function(clabs, nmi)
    {
      if(all(clabs == nmi))
	NULL
      else if(all(nii <- match(nmi, clabs, 0)))
	nii
      else stop(paste("names don't match previous names:\n\t",
		      paste(nmi[nii == 0], collapse = ", ")))
    }
  Make.row.names <- function(nmi, ri, ni, nrow)
    {
      if(nchar(nmi) > 0) {
	if(ni > 1)
	  paste(nmi, ri, sep = ".")
	else nmi
      }
      else if(nrow > 0 && all(ri == seq(length = ni)))
	seq(from = nrow + 1, length = ni)
      else ri
    }
  n <- nargs()
  if(n == 0)
    return(structure(list(), class = "data.frame", row.names = character()))
  all <- list(...)
  nms <- names(all)
  if(is.null(nms))
    nms <- character(length(all))
  cl <- NULL
  perm <- rows <- rlabs <- vector("list", n)
  nrow <- 0
  value <- clabs <- NULL
  all.levs <- list()
  for(i in 1:n) {
    ## check the arguments, develop row and column labels
    xi <- all[[i]]
    nmi <- nms[i]
    if(inherits(xi, "data.frame")) {
      if(is.null(cl))
	cl <- class(xi)
      ri <- row.names(xi)
      ni <- length(ri)
      if(is.null(clabs))
	clabs <- names(xi)
      else perm[[i]] <- pi <- match.names(clabs, names(xi))
      rows[[i]] <- nii <- seq(from = nrow + 1, length = ni)
      rlabs[[i]] <- Make.row.names(nmi, ri, ni, nrow)
      nrow <- nrow + ni
      if(is.null(value)) {
	value <- unclass(xi)
	nvar <- length(value)
	all.levs <- vector("list", nvar)
	has.dim <- logical(nvar)
	for(j in 1:nvar) {
	  xj <- value[[j]]
	  all.levs[[j]] <- levels(xj)
	  has.dim[j] <- length(dim(xj)) == 2
	}
      }
      else for(j in 1:nvar)
	if(length(lij <- levels(xi[[j]])) > 0) {
	  if(is.null(pi) || is.na(jj <- pi[[j]]))
	    jj <- j
	  all.levs[[jj]] <- unique(c(all.levs[[jj]],
				     lij))
	}
    }
    else if(is.list(xi)) {
      ni <- range(sapply(xi, length))
      if(ni[1] == ni[2])
	ni <- ni[1]
      else stop("invalid list argument: all variables should have the same length")
      rows[[i]] <- ri <- seq(from = nrow + 1, length = ni)
      nrow <- nrow + ni
      rlabs[[i]] <- Make.row.names(nmi, ri, ni, nrow)
      if(length(nmi <- names(xi)) > 0) {
	if(is.null(clabs))
	  clabs <- nmi
	else perm[[i]] <- match.names(clabs, nmi)
      }
    }
    else if(length(xi) > 0) {
      rows[[i]] <- nrow <- nrow + 1
      rlabs[[i]] <- if(nchar(nmi) > 0) nmi else nrow
    }
  }
  nvar <- length(clabs)
  if(nvar == 0)
    nvar <- max(sapply(all, length))	# only vector args
  if(nvar == 0)
    return(structure(list(), class = "data.frame",
		     row.names = character()))
  pseq <- 1:nvar
  if(is.null(value)) {
    value <- list()
    value[pseq] <- list(logical(nrow))
  }
  names(value) <- clabs
  for(j in 1:nvar)
    if(length(lij <- all.levs[[j]]) > 0)
      value[[j]] <- factor(as.vector(value[[j]]), lij)
  if(any(has.dim)) {
    rmax <- max(unlist(rows))
    for(i in (1:nvar)[has.dim])
      if(!inherits(xi <- value[[i]], "data.frame")) {
	dn <- dimnames(xi)
	row.names <- dn[[1]]
	if(length(row.names) > 0)
	  length(row.names) <- rmax
	pi <- dim(xi)[2]
	length(xi) <- rmax * pi
	value[[i]] <- array(xi, c(rmax, pi), list(row.names, dn[[2]]))
      }
  }
  for(i in 1:n) {
    xi <- unclass(all[[i]])
    if(!is.list(xi))
      if(length(xi) != nvar)
	xi <- rep(xi, length = nvar)
    ri <- rows[[i]]
    pi <- perm[[i]]
    if(is.null(pi))
      pi <- pseq
    for(j in 1:nvar) {
      jj <- pi[j]
      if(has.dim[jj])
	value[[jj]][ri,	 ] <- xi[[j]]
      else value[[jj]][ri] <- xi[[j]]
    }
  }
  for(j in 1:nvar) {
    xj <- value[[j]]
    if(!has.dim[j] && (is.character(xj) || is.logical(xj)))
      value[[j]] <- factor(xj)
  }
  rlabs <- unlist(rlabs)
  while(any(xj <- duplicated(rlabs)))
    rlabs[xj] <- paste(rlabs[xj], seq(length = sum(xj)), sep = "")
  if(is.null(cl)) {
    as.data.frame(value, row.names = rlabs)
  }
  else {
    class(value) <- cl
    ## ensure that row names are ok.  Similar to row.names<-
    rlabs <- as.character(rlabs)
    if(any(duplicated(rlabs)))
      rlabs <- make.names(rlabs, uniq = TRUE)
    attr(value, "row.names") <- rlabs
    value
  }
}
### coercion and print methods
print.data.frame <-
  function(x, ..., digits = NULL, quote = FALSE, right = TRUE)
{
  if(length(x) == 0) {
    cat("NULL data frame with", length(row.names(x)), "rows\n")
  } else if(length(row.names(x)) == 0) {
    print.default(names(x), quote = FALSE)
    cat("<0 rows> (or 0-length row.names)\n")
  } else {
    if(!is.null(digits)) {
      ## if 'x' has factors & numeric, as.matrix(x) will use
      ## format(.) on the numbers -- set options(.) for the following print(.):
      op <- options(digits = digits)
      on.exit(options(op))
    }
    print.matrix(as.matrix(x), ..., quote = quote, right = right)
  }
  invisible(x)
}
as.matrix.data.frame <- function (x)
{
  X <- x
  dm <- dim(X)
  p <- dm[2]
  n <- dm[1]
  dn <- dimnames(X)
  collabs <- as.list(dn[[2]])
  class(X) <- NULL
  non.numeric <- non.atomic <- FALSE
  for (j in 1:p) {
    xj <- X[[j]]
    if(length(dj <- dim(xj)) == 2 && dj[2] > 1) {
      if(inherits(xj, "data.frame"))
	xj <- X[[j]] <- as.matrix(X[[j]])
      dnj <- dimnames(xj)[[2]]
      collabs[[j]] <- paste(collabs[[j]],
			    if(length(dnj) > 0) dnj else seq(1:dj[2]),
			    sep = ".")
    }
    if(length(levels(xj)) > 0 || !(is.numeric(xj) || is.complex(xj)))
      non.numeric <- TRUE
    if(!is.atomic(xj))
      non.atomic <- TRUE
  }
  if(non.atomic) {
    for (j in 1:p) {
      xj <- X[[j]]
      if(is.recursive(xj)) {
      }
      else X[[j]] <- as.list(as.vector(xj))
    }
  } else if(non.numeric) {
    for (j in 1:p) {
      xj <- X[[j]]
      if(length(levels(xj)) > 0) {
	X[[j]] <- as.vector(xj)
      }
      else X[[j]] <- format(xj)
    }
  }
  X <- unlist(X, recursive = FALSE, use.names = FALSE)
  dim(X) <- c(n, length(X)/n)
  dimnames(X) <- list(dn[[1]], unlist(collabs, use.names = FALSE))
  ##NO! don't copy buggy S-plus!  either all matrices have class or none!!
  ##NO class(X) <- "matrix"
  X
}
Math.data.frame <- function(x, ...)
{
  X <- x
  class(X) <- NULL
  f <- get(.Generic, mode = "function")
  call <- match.call(f, sys.call())
  call[[1]] <- as.name(.Generic)
  arg <- names(formals(f))[[1]]
  call[[arg]] <- as.name("xx")
  for(j in names(X)) {
    xx <- X[[j]]
    if(!is.numeric(xx) && mode(xx) != "complex")
      stop(paste("Non-numeric variable:", j))
    X[[j]] <- eval(call)
  }
  attr(X, "class") <- class(x)
  X
}
Ops.data.frame <- function(e1, e2 = NULL)
{
  isList <- function(x) !is.null(x) && is.list(x)
  unary <- nargs() == 1
  lclass <- nchar(.Method[1]) > 0
  rclass <- !unary && (nchar(.Method[2]) > 0)
  value <- list()
  ## set up call as op(left, right)
  FUN <- get(.Generic, envir = sys.frame(sys.parent()),mode="function")
  f <- if (unary) 
    quote(FUN(left))
  else quote(FUN(left, right))
  lscalar <- rscalar <- FALSE
  if(lclass && rclass) {
    rn <- row.names(e1)
    cn <- names(e1)
    if(any(dim(e2) != dim(e1)))
      stop(paste(.Generic, "only defined for equally-sized data frames"))
  } else if(lclass) {
    ## e2 is not a data frame, but e1 is.
    rn <- row.names(e1)
    cn <- names(e1)
    rscalar <- length(e2) <= 1 # e2 might be null
    if(isList(e2)) {
      if(scalar) e2 <- e2[[1]]
      else if(length(e2) != ncol(e1))
        stop(paste("list of length", length(e2), "not meaningful"))
    } else {
      if(!rscalar)
        e2 <- split(rep(as.vector(e2), length = prod(dim(e1))),
                    rep(1:ncol(e1), rep(nrow(e1), ncol(e1))))
    }
  } else {
    ## e1 is not a data frame, but e2 is.
    rn <- row.names(e2)
    cn <- names(e2)
    lscalar <- length(e1) <= 1
    if(isList(e1)) {
      if(lscalar) e1 <- e1[[1]]
      else if(length(e1) != ncol(e2))
        stop(paste("list of length", length(e1), "not meaningful"))
    } else {
      if(!lscalar)
        e1 <- split(rep(as.vector(e1), length = prod(dim(e2))),
                    rep(1:ncol(e2), rep(nrow(e2), ncol(e2))))
    }
  }
  for(j in seq(along=cn)) {
    left <- if(!lscalar) e1[[j]] else e1
    right <-if(!rscalar) e2[[j]] else e2
    value[[j]] <- eval(f)
  }
  names(value) <- cn
  data.frame(value, row.names=rn)
}
Summary.data.frame <- function(x, ...)
{
  x <- as.matrix(x)
  if(!is.numeric(x) && mode(x) != "complex")
    stop("only defined on a data frame with all numeric or complex variables")
  NextMethod(.Generic)
}
de.ncols <- function(inlist)
{
	ncols <- matrix(0, nrow=length(inlist), ncol=2)
	i <- 1
	for( telt in inlist ) {
		if( is.matrix(telt) ) {
				ncols[i, 1] <- ncol(telt)
				ncols[i, 2] <- 2
		}
		else if( is.list(telt) ) {
			for( telt2 in telt )
				if( !is.vector(telt2) ) stop("wrong argument to dataentry")
			ncols[i, 1] <- length(telt)
			ncols[i, 2] <- 3
		}
		else if( is.vector(telt) ) {
			ncols[i, 1] <- 1
			ncols[i, 2] <- 1
		}
		else stop("wrong argument to dataentry")
		i <- i+1
	}
	return(ncols)
}
de.setup <- function(ilist, list.names, incols)
{
	ilen <- sum(incols)
	ivec <- vector("list", ilen)
	inames <- vector("list", ilen)
	i <- 1
	k <- 0
	for( telt in ilist ) {
		k <- k+1
		if( is.list(telt) ) {
			y <- names(telt)
			for( j in 1:length(telt) ) {
				ivec[[i]] <- telt[[j]]
				if( is.null(y) || y[j]=="" )
					inames[[i]] <- paste("var", i, sep="")
				else inames[[i]] <- y[j]
				i <- i+1
			}
		}
		else if( is.vector(telt) ) {
			ivec[[i]] <- telt
			inames[[i]] <- list.names[[k]]
			i <- i+1
		}
		else if( is.matrix(telt) ) {
			y <- dimnames(telt)[[2]]
			for( j in 1:ncol(telt) ) {
				ivec[[i]] <- telt[, j]
				if( is.null(y) || y[j]=="" )
					inames[[i]] <- paste("var", i, sep="")
				else inames[[i]] <- y[j]
				i <- i+1
			}
		}
		else stop("wrong argument to dataentry")
	}
	names(ivec) <- inames
	return(ivec)
}
# take the data in inlist and restore it to the format described by ncols and coltypes
de.restore <- function(inlist, ncols, coltypes, argnames, args)
{
	rlist <- vector("list", length=length(ncols))
	rnames <- vector("character", length=length(ncols))
	j <- 1
	lnames <- names(inlist)
	for( i in 1:length(ncols) ) {
		if(coltypes[i]==2) {
			tlen <- length(inlist[[j]])
			x <- matrix(0, nrow=tlen, ncol=ncols[i])
			cnames <- vector("character", ncol(x))
			for( ind1 in 1:ncols[i]) {
				if(tlen != length(inlist[[j]]) ) {
					warning("could not restore type information")
					return(inlist)
				}
				x[, ind1] <- inlist[[j]]
				cnames[ind1] <- lnames[j]
				j <- j+1
			}
			if( dim(x) == dim(args[[i]]) )
				rn <- dimnames(args[[i]])[[1]]
			else rn <- NULL
			if( any(cnames!="") )
				dimnames(x) <- list(rn, cnames)
			rlist[[i]] <- x
			rnames[i] <- argnames[i]
		}
		else if(coltypes[i]==3) {
			x <- vector("list", length=ncols[i])
			cnames <- vector("character", ncols[i])
			for( ind1 in 1:ncols[i]) {
				x[[ind1]] <- inlist[[j]]
				cnames[ind1] <- lnames[j]
				j <- j+1
			}
			if( any(cnames!="") )
				names(x) <- cnames
			rlist[[i]] <- x
			rnames[i] <- argnames[i]
		}
		else {
			rlist[[i]] <- inlist[[j]]
			j <- j+1
			rnames[i] <- argnames[i]
		}
	}
	names(rlist) <- rnames
	return(rlist)
}
de <- function(..., Modes=NULL, Names=NULL)
{
	sdata <- list(...)
	snames <- as.character(substitute(list(...))[-1])
	if( is.null(sdata) ) {
		if( is.null(Names) ) {
			if( !is.null(Modes) ) {
				odata <- vector("list", length=length(Modes))
			}
			else odata <- vector("list", length=1)
		}
		else {
			if( (length(Names) != length(Modes)) && !is.null(Modes) ) {
				warning("modes argument ignored")
				Modes <- NULL
			}
			odata <- vector("list", length=length(Names))
			names(odata) <- Names
		}
		ncols <- rep(1, length(odata))
		coltypes <- rep(1, length(odata))
	}
	else {
		ncols <- de.ncols(sdata)
		coltypes <- ncols[, 2]
		ncols <- ncols[, 1]
		odata <- de.setup(sdata, snames, ncols)
		if( !is.null(Names) ) 
			if( length(Names) != length(odata) )
				warning("names argument ignored")
			else names(odata) <- Names
		if( !is.null(Modes) )
			if( length(Modes) != length(odata) ) {
				warning("modes argument ignored")
				Modes <- NULL
			}
	}
	rdata <- dataentry(odata, Modes)
	t1 <- length(rdata)==sum(ncols)
	if( t1 && any(coltypes!=1) )
		rdata <- de.restore(rdata, ncols, coltypes, snames, sdata)
	else if( any(coltypes!=1) ) warning("could not restore data types properly")
	return(rdata)
}
data.entry <- function(..., Modes=NULL, Names=NULL)
{
	tmp1 <- de(..., Modes=Modes, Names=Names)
	j <- 1
	for(i in names(tmp1) ) {
		assign(i, tmp1[[j]], env=.GlobalEnv)
		j <- j+1
	}
	invisible(NULL)
}
delay <- function(x, env=.GlobalEnv)
.Internal(delay(substitute(x), env))
density <-
function(x, bw, adjust = 1, kernel="gaussian", window = kernel,
	 n = 512, width, from, to, cut = 3, na.rm = FALSE)
{
	if (!is.numeric(x))
		stop("argument must be numeric")
	name <- deparse(substitute(x))
        x.na <- is.na(x)
	if(na.rm) x <- x[!x.na]
        has.na <- !na.rm && any(x.na)
	N <- length(x)
	k.list <- c("gaussian", "rectangular", "triangular", "cosine")
	method <- pmatch(kernel, k.list)
	if(is.na(method))
		stop(paste("kernel must be a 'pmatch' of",
                           paste(k.list,collapse=', ')))
	##if(! method %in% 1:4) stop("unknown density estimation kernel")
        n.user <- n
        n <- max(n, 512)
	if(n > 512) n <- 2^ceiling(log2(n)) #- to be fast with FFT
	if (missing(bw))
	 bw <-
	  if(missing(width))
		adjust * 0.9 * min(sd (x, na.rm=has.na),
                                   IQR(x, na.rm=has.na)/1.34) * N^-0.2
	  else 0.25 * width
	if (missing(from))
		from <- min(x, na.rm = has.na) - cut * bw
	if (missing(to))
		to   <- max(x, na.rm = has.na) + cut * bw
        lo <- from - 4 * bw
        up <- to + 4 * bw
	y <- .C("massdist",
		x = as.double(x),
		nx= N,
		xlo = as.double(lo),
		xhi = as.double(up),
		y = double(2 * n),
		ny= as.integer(n),
                NAOK = has.na) $ y
	xords <- seq(lo, up + (up-lo), length = 2 * n)
	kords <- xords - lo
	kords[(n + 2):(2 * n)] <- -kords[n:2]
	kords <- switch(method,
                        dnorm(kords, sd = bw),# 1
                        { a <- bw/0.2886751
                          ifelse(abs(kords) < 0.5 * a, 1/a, 0) },# 2
                        { a <- bw/0.4082483
                          ifelse(abs(kords) < a, (1 - abs(kords)/a)/a, 0) },# 3
                        { a <- bw/1.135724
                          ifelse(abs(kords) < a*pi,
                                 (1+cos(kords/a))/(2*pi*a), 0)}# 4
                        )
	kords <- convolve(y, kords)[1:n]
	xords <- seq(lo, up, length = n)
        keep <- (xords >= from) & (xords <= to)
        x <- seq(from, to, length = n.user)
	structure(list(x = x, y = approx(xords, kords, x)$y, bw = bw, n = N,
                       call=match.call(), data.name=name, has.na = has.na),
                  class="density")
}
plot.density <-
function(s, main=NULL, xlab=NULL, ylab="Density", type="l", ...)
{
	if(is.null(xlab)) xlab <- paste("Bandwidth =", format(s$bw))
	if(is.null(main)) main <- deparse(s$call)
	plot.default(s, main=main, xlab=xlab, ylab=ylab, type=type, ...)
}
print.density <-
function(x, digits=NULL, ...)
{
	cat("\nCall:\n\t",deparse(x$call),
	    "\n\nData: ",x$data.name," (",x$n," obs.);",
	    "\tBandwidth 'bw' =",formatC(x$bw,digits=digits), "\n\n",sep="")
	print(summary(as.data.frame(x[c("x","y")])), digits=digits, ...)
	invisible(x)
}
dev.list <- 
function()
{
        if(exists(".Devices")) {
                n <- get(".Devices")
        }
        else {
                n <- list("null device")
        }
        n <- unlist(n)
        i <- seq(along = n)[n != ""]
        names(i) <- n[i]
        i <- i[-1]
        if(length(i) == 0)
                return(NULL)
        else i
}
dev.cur <-
function()
{
        if(!exists(".Devices")) {
                .Devices <- list("null device")
        }
        num.device <- .Internal(dev.cur())
        names(num.device) <- .Devices[[num.device]]
        num.device
}
dev.set <-
function(which = dev.next())
{
        which <- .Internal(dev.set(as.integer(which)))
        if(exists(".Devices")) {
                assign(".Device", get(".Devices")[[which]])
        }
        else {
                .Devices <- list("null device")
        }
        names(which) <- .Devices[[which]]
        which
}
dev.next <-
function(which = dev.cur())
{
        if(!exists(".Devices"))
                .Devices <- list("null.device")
        num.device <- .Internal(dev.next(as.integer(which)))
        names(num.device) <- .Devices[[num.device]]
        num.device
}
dev.prev <-
function(which = dev.cur())
{
        if(!exists(".Devices"))
                .Devices <- list("null device")
        num.device <- .Internal(dev.prev(as.integer(which)))
        names(num.device) <- .Devices[[num.device]]
        num.device
}
dev.off <-
function(which = dev.cur())
{
        if(which == 1)
                stop("Cannot shut down device 1 (the null device)")
        if(exists(".Devices")) {
                .Devices <- get(".Devices")
        }
        else {
                .Devices <- list("null device")
        }
        .Devices[[which]] <- ""
        assign(".Devices", .Devices)
	.Internal(dev.off(as.integer(which)))
        assign(".Device", .Devices[[dev.cur()]])
        dev.cur()
}
dev.copy <- function(device, ..., which = dev.next())
{
        if(!missing(which) & !missing(device))
                stop("Cannot supply which and device at the same time.")
	old.device <- dev.cur()
        if(old.device == 1)
                stop("Cannot copy the null device.")
        if(missing(device)) {
                if(which == 1)
                        stop("Cannot copy to the null device.")
                else if(which == dev.cur())
                        stop("Cannot copy device to itself")
                dev.set(which)
        }
        else {
                if(!is.function(device))
                        stop("Argument 'device' should be a function")
                else device(...)
        }
	.Internal(dev.copy(old.device))
        dev.cur()
}
dev.print <- function(device = postscript, ...)
{
        current.device <- dev.cur()
        dev.off(dev.copy(device = device, ...)) # user must still print this
        dev.set(current.device)
}
dev.control <- function(displaylist)
{
        if(!missing(displaylist)) {
                if(displaylist == "inhibit")
			.Internal(dev.control())
                else stop(paste("displaylist should be inhibit"))
        }
        invisible()
}
graphics.off <- function () 
{
        while ((which <- dev.cur()) != 1)
		dev.off(which)
}
diag <-
function(x = 1, nrow, ncol = n)
{
	if(is.matrix(x) && nargs() == 1)
		return(c(x)[1 + 0:(min(dim(x)) - 1) * (dim(x)[1] + 1)])
	if(missing(x))
		n <- nrow
	else if(length(x) == 1 && missing(nrow) && missing(ncol)) {
		n <- as.integer(x)
		x <- 1
	}
	else n <- length(x)
	if(!missing(nrow))
		n <- nrow
	p <- ncol
	y <- array(0, c(n, p))
	y[1 + 0:(min(n, p) - 1) * (n + 1)] <- x
	y
}
"diag<-" <-
function(x, value)
{
	dx <- dim(x)
	if(length(dx) != 2 || prod(dx) != length(x))
		stop("only matrix diagonals can be replaced")
	i <- 1:min(dx)
	if(length(value) != 1 && length(value) != length(i))
		stop("replacement diagonal has wrong length")
	x[cbind(i, i)] <- value
	x
}
"diff" <- function(x, ...) UseMethod("diff")
"diff.default" <- function (x, lag = 1, differences = 1) 
{
	ismat <- is.matrix(x)
	if (ismat) 
		xlen <- dim(x)[1]
	else xlen <- length(x)
	if (lag < 1 | differences < 1) 
		stop("Bad value for lag or differences")
	if (lag * differences >= xlen) 
		return(x[0])
	r <- x
	s <- 1:lag
	if (is.matrix(r)) {
		for (i in 1:differences) {
			rlen <- dim(r)[1]
			r <- r[-s, , drop = FALSE] - r[-(rlen + 1 - s), , drop = FALSE]
		}
	}
	else for (i in 1:differences) {
		r <- r[-s] - r[-(length(r) + 1 - s)]
	}
	xtsp <- attr(x, "tsp")
	if (is.null(xtsp)) r
	else ts(r, end = xtsp[2], freq = xtsp[3])
}
dexp <- function(x, rate=1) .Internal(dexp(x, 1/rate))
pexp <- function(q, rate=1) .Internal(pexp(q, 1/rate))
qexp <- function(p, rate=1) .Internal(qexp(p, 1/rate))
rexp <- function(n, rate=1) .Internal(rexp(n, 1/rate))
dunif <- function(x, min=0, max=1) .Internal(dunif(x, min, max))
punif <- function(q, min=0, max=1) .Internal(punif(q, min, max))
qunif <- function(p, min=0, max=1) .Internal(qunif(p, min, max))
runif <- function(n, min=0, max=1) .Internal(runif(n, min, max))
dnorm <- function(x, mean=0, sd=1) .Internal(dnorm(x, mean, sd))
pnorm <- function(q, mean=0, sd=1) .Internal(pnorm(q, mean, sd))
qnorm <- function(p, mean=0, sd=1) .Internal(qnorm(p, mean, sd))
rnorm <- function(n, mean=0, sd=1) .Internal(rnorm(n, mean, sd))
dcauchy <-
function(x, location=0, scale=1) .Internal(dcauchy(x, location, scale))
pcauchy <-
function(q, location=0, scale=1) .Internal(pcauchy(q, location, scale))
qcauchy <-
function(p, location=0, scale=1) .Internal(qcauchy(p, location, scale))
rcauchy <-
function(n, location=0, scale=1) .Internal(rcauchy(n, location, scale))
dgamma <- function(x, shape, scale=1) .Internal(dgamma(x, shape, scale))
pgamma <- function(q, shape, scale=1) .Internal(pgamma(q, shape, scale))
qgamma <- function(p, shape, scale=1) .Internal(qgamma(p, shape, scale))
rgamma <- function(n, shape, scale=1) .Internal(rgamma(n, shape, scale))
dlnorm <- function(x, meanlog=0, sdlog=1) .Internal(dlnorm(x, meanlog, sdlog))
plnorm <- function(q, meanlog=0, sdlog=1) .Internal(plnorm(q, meanlog, sdlog))
qlnorm <- function(p, meanlog=0, sdlog=1) .Internal(qlnorm(p, meanlog, sdlog))
rlnorm <- function(n, meanlog=0, sdlog=1) .Internal(rlnorm(n, meanlog, sdlog))
dlogis <- function(x, location=0, scale=1) .Internal(dlogis(x, location, scale))
plogis <- function(q, location=0, scale=1) .Internal(plogis(q, location, scale))
qlogis <- function(p, location=0, scale=1) .Internal(qlogis(p, location, scale))
rlogis <- function(n, location=0, scale=1) .Internal(rlogis(n, location, scale))
dweibull <- function(x, shape, scale=1) .Internal(dweibull(x, shape, scale))
pweibull <- function(q, shape, scale=1) .Internal(pweibull(q, shape, scale))
qweibull <- function(p, shape, scale=1) .Internal(qweibull(p, shape, scale))
rweibull <- function(n, shape, scale=1) .Internal(rweibull(n, shape, scale))
dbeta <- function(x, shape1, shape2, ncp=0) {
	if(missing(ncp)) .Internal(dbeta(x, shape1, shape2))
	else .Internal(dnbeta(x, shape1, shape2, ncp))
}
pbeta <- function(q, shape1, shape2, ncp=0) {
	if(missing(ncp)) .Internal(pbeta(q, shape1, shape2))
	else .Internal(pnbeta(q, shape1, shape2, ncp))
}
qbeta <- function(p, shape1, shape2) .Internal(qbeta(p, shape1, shape2))
rbeta <- function(n, shape1, shape2) .Internal(rbeta(n, shape1, shape2))
dbinom <- function(x, size, prob) .Internal(dbinom(x, size, prob))
pbinom <- function(q, size, prob) .Internal(pbinom(q, size, prob))
qbinom <- function(p, size, prob) .Internal(qbinom(p, size, prob))
rbinom <- function(n, size, prob) .Internal(rbinom(n, size, prob))
dchisq <- function(x, df, ncp=0) {
	if(missing(ncp)) .Internal(dchisq(x, df))
	else .Internal(dnchisq(x, df, ncp))
}
pchisq <- function(q, df, ncp=0) {
	if(missing(ncp)) .Internal(pchisq(q, df))
	else .Internal(pnchisq(q, df, ncp))
}
qchisq <- function(p, df, ncp=0) {
	if(missing(ncp)) .Internal(qchisq(p, df))
	else .Internal(qnchisq(p, df, ncp))
}
rchisq <- function(n, df, ncp=0) {
	if(missing(ncp)) .Internal(rchisq(n, df))
        else .not.yet.implemented()
}
df <- function(x, df1, df2) .Internal(df(x, df1, df2))
pf <- function(q, df1, df2, ncp=0) {
	if(missing(ncp)) .Internal(pf(q, df1, df2))
	else .Internal(pnf(q, df1, df2, ncp))
}
qf <- function(p, df1, df2) .Internal(qf(p, df1, df2))
rf <- function(n, df1, df2) .Internal(rf(n, df1, df2))
dgeom <- function(x, prob) .Internal(dgeom(x, prob))
pgeom <- function(q, prob) .Internal(pgeom(q, prob))
qgeom <- function(p, prob) .Internal(qgeom(p, prob))
rgeom <- function(n, prob) .Internal(rgeom(n, prob))
dhyper <- function(x, m, n, k) .Internal(dhyper(x, m, n, k))
phyper <- function(q, m, n, k) .Internal(phyper(q, m, n, k))
qhyper <- function(p, m, n, k) .Internal(qhyper(p, m, n, k))
rhyper <- function(nn, m, n, k) .Internal(rhyper(nn, m, n, k))
dnbinom <- function(x, size, prob) .Internal(dnbinom(x, size, prob))
pnbinom <- function(q, size, prob) .Internal(pnbinom(q, size, prob))
qnbinom <- function(p, size, prob) .Internal(qnbinom(p, size, prob))
rnbinom <- function(n, size, prob) .Internal(rnbinom(n, size, prob))
dpois <- function(x, lambda) .Internal(dpois(x, lambda))
ppois <- function(q, lambda) .Internal(ppois(q, lambda))
qpois <- function(p, lambda) .Internal(qpois(p, lambda))
rpois <- function(n, lambda) .Internal(rpois(n, lambda))
dt <- function(x, df) .Internal(dt(x, df))
pt <- function(q, df, ncp) {
  if(missing(ncp))
    .Internal(pt(q, df))
  else
    .Internal(pnt(q, df, ncp))
}
qt <- function(p, df) .Internal(qt(p, df))
rt <- function(n, df) .Internal(rt(n, df))
ptukey <- function(q, nmeans, df, nranges=1)
  .Internal(ptukey(q, nranges, nmeans, df))
qtukey <- function(p, nmeans, df, nranges=1)
  .Internal(qtukey(p, nranges, nmeans, df))
dwilcox <- function(x, m, n) .Internal(dwilcox(x, m, n))
pwilcox <- function(q, m, n) .Internal(pwilcox(q, m, n))
qwilcox <- function(p, m, n) .Internal(qwilcox(p, m, n))
rwilcox <- function(nn, m, n) .Internal(rwilcox(nn, m, n))
"dotplot" <-
  function (x, labels = NULL, groups = NULL, gdata = NULL, cex = par("cex"), 
            pch = 21, gpch = 21, bg = par("bg"), color = par("fg"), 
            gcolor = par("fg"), lcolor = "gray", main = NULL, 
	    xlab = NULL, ylab = NULL, ...) 
{
  opar <- par("mar", "cex", "yaxs")
  on.exit(par(opar))
  par(cex = cex, yaxs = "i")
  n <- length(x)
  if (is.matrix(x)) {
    if (is.null(labels)) 
      labels <- rownames(x)
    if (is.null(labels)) 
      labels <- as.character(1:nrow(x))
    labels <- rep(labels, length = n)
    if (is.null(groups)) 
      groups <- col(x, as.factor = TRUE)
    glabels <- levels(groups)
  }
  else {
    if (is.null(labels)) 
      labels <- names(x)
    if (!is.null(groups)) 
      glabels <- levels(groups)
    else glabels <- NULL
  }
  linch <- 0
  ginch <- 0
  if (!is.null(labels)) 
    linch <- max(strwidth(labels, "inch"), na.rm = TRUE)
    goffset <- 0
  if (!is.null(glabels)) {
    ginch <- max(strwidth(glabels, "inch"), na.rm = TRUE)
    goffset <- 0.4
  }
  lheight <- strheight("M", "inch")
  if (!(is.null(labels) && is.null(glabels))) {
    nmar <- mar <- par("mar")
    nmar[2] <- nmar[4] + (max(linch + goffset, ginch) +
	0.1)/lheight
    par(mar = nmar)
  }
  if (is.null(groups)) {
    o <- 1:n
    y <- o
    ylim <- c(0, n + 1)
  }
  else {
    o <- rev(order(as.numeric(groups)))
    x <- x[o]
    groups <- groups[o]
    offset <- cumsum(c(0, diff(as.numeric(groups)[o]) != 0))
    y <- 1:n + 2 * offset
    ylim <- range(0, y + 2)
  }
  plot.new()
  plot.window(xlim = range(x, finite = TRUE), ylim = ylim, log = "")
  xmin <- par("usr")[1]
  if (!is.null(labels)) {
    linch <- max(strwidth(labels, "inch"), na.rm = TRUE)
    loffset <- (linch + 0.1)/lheight
    labs <- labels[o]
    for(i in 1:n)
      mtext(labs[i], side=2, line=loffset, at=y[i], adj = 0,
	col = color, las=2, ...)
  }
  abline(h = y, lty = "dotted", col = lcolor)
  points(x, y, pch = pch, col = color, bg = bg)
  if (!is.null(groups)) {
    gpos <- rev(cumsum(tapply(groups, groups, length) + 2) - 1)
    ginch <- max(strwidth(glabels, "inch"), na.rm = TRUE)
    goffset <- (max(linch+0.2, ginch, na.rm = TRUE) + 0.1)/lheight
    for(i in 1:nlevels(groups))
      mtext(glabels[i], side=2, line=goffset, at=gpos[i], 
         adj = 0, col = gcolor, las=2, ...)
    if (!is.null(gdata)) {
      abline(h = gpos, lty = "dotted")
      points(gdata, gpos, pch = gpch, col = gcolor, 
             bg = bg, ...)
    }
  }
  axis(1)
  box()
  title(main=main, xlab=xlab, ylab=ylab, ...)
  invisible()
}
dput <- function(x, file = "")
  .Internal(dput(x, file))
dget <- function(file)
  eval(parse(file = file))
dump <- function(list, fileout="dumpdata")
.Internal(dump(list, fileout))
#dyn.load <- function(x)
#{
#	x <- as.character(x)
#	y <- substr(x, 1, 1)
#	if (y == "/") {
#		.Internal(dyn.load(x))
#	}
#	else {
#		.Internal(dyn.load(
#		paste(system("pwd", intern = TRUE), x, sep = "/", collapse="")))
#	}
#}
dyn.load <- function(x)
	.Internal(dyn.load(x))
edit <- function(name=NULL, file="", editor=options()$editor) 
	.Internal(edit(name,file, editor))
vi <- function(name=NULL, file="") edit(name, file, editor="vi")
emacs <- function(name=NULL, file="") edit(name, file, editor="emacs")
xemacs <- function(name=NULL, file="") edit(name, file, editor="xemacs")
xedit <- function(name=NULL, file="") edit(name, file, editor="xedit")
pico <- function(name=NULL, file="") edit(name, file, editor="pico")
eigen <- function (x, symmetric, only.values=FALSE)
{
	x <- as.matrix(x)
	n <- nrow(x)
	if (n != ncol(x))
		stop("non-square matrix in eigen")
	complex.x <- is.complex(x)
	if(complex.x) {
		if(missing(symmetric))
			symmetric <- all(x == Conj(t(x)))
	}
	else if(is.numeric(x)) {
		storage.mode(x) <- "double"
		if(missing(symmetric))
			symmetric <- all(x == t(x))
	}
	else stop("numeric or complex values required in eigen")
	dbl.n <- double(n)
	if(symmetric) {##--> real values
		if(complex.x) {
			xr <- Re(x)
			xi <- Im(x)
			z <- .Fortran(
				"ch",
				n,
				n,
				xr,
				xi,
				values = dbl.n,
				!only.values,
				vectors = xr,
				ivectors = xi,
				dbl.n,
				dbl.n,
				double(2*n),
				ierr = integer(1))
			if (z$ierr)
				stop(paste("ch returned code ", z$ierr, " in eigen"))
			if(!only.values)
				z$vectors <- matrix(complex(re=z$vectors,
						im=z$ivectors), nc=n)
		}
		else {
			z <- .Fortran(
				"rs",
				n,
				n,
				x,
				values = dbl.n,
				!only.values,
				vectors = x,
				dbl.n,
				dbl.n,
				ierr = integer(1))
			if (z$ierr)
				stop(paste("rs returned code ", z$ierr, " in eigen"))
		}
		ord <- rev(order(z$values))
	}
	else {##- Asymmetric :
		if(complex.x) {
			xr <- Re(x)
			xi <- Im(x)
			z <- .Fortran(
				"cg",
				n,
				n,
				xr,
				xi,
				values = dbl.n,
				ivalues = dbl.n,
				!only.values,
				vectors = xr,
				ivectors = xi,
				dbl.n,
				dbl.n,
				dbl.n,
				ierr = integer(1))
			if (z$ierr)
				stop(paste("cg returned code ", z$ierr, " in eigen"))
			z$values <- complex(re=z$values,im=z$ivalues)
			if(!only.values)
				z$vectors <- matrix(complex(re=z$vectors,
						im=z$ivectors), nc=n)
		}
		else {
			z <- .Fortran(
				"rg",
				n,
				n,
				x,
				values = dbl.n,
				ivalues = dbl.n,
				!only.values,
				vectors = x,
				integer(n),
				dbl.n,
				ierr = integer(1))
			if (z$ierr)
				stop(paste("rg returned code ", z$ierr, " in eigen"))
			ind <- z$ivalues > 0
			if(any(ind)) {#- have complex (conjugated) values
				ind <- seq(n)[ind]
				z$values <- complex(re=z$values,im=z$ivalues)
				if(!only.values) {
					z$vectors[, ind] <- complex(re=z$vectors[,ind],
								im=z$vectors[,ind+1])
					z$vectors[, ind+1] <- Conj(z$vectors[,ind])
				}
			}
		}
		ord <- rev(order(Mod(z$values)))
	}
	z$values <- z$values[ord]
	if(!only.values) {
		z$vectors <- z$vectors[,ord]
		z[c("values", "vectors")]
	}
	else z["values"]
}
environment <- function(fun=NULL) .Internal(environment(fun))
.GlobalEnv <- environment()
eval <-
function(expr, envir=sys.frame(sys.parent()))
.Internal(eval(expr, envir))
quote <- function(x) substitute(x)
Recall <- function(...) .Internal(Recall(...))
exists <-
function(x, where=-1, envir=pos.to.env(where), frame,
	mode="any", inherits=TRUE)
{
	if(!missing(frame))
		envir <- sys.frame(frame)
	.Internal(exists(x, envir, mode, inherits))
}
# file expand.grid.R
# copyright (C) 1998 W. N. Venables and B. D. Ripley
#
expand.grid <- function(...) {
  # x should either be a list or a set of vectors or factors
  args <- list(...)
  if(!length(args)) return(NULL)
  a1 <- args[[1]]
  if(length(args) == 1 && is.list(a1)) args <- a1
  nargs <- length(args)
  if(nargs == 1) return (args[[1]])
  cargs <- args
  nmc <- paste("Var", 1:nargs, sep="")
  nm <- names(args)
  if(is.null(nm)) nm <- nmc
  nmc[nchar(nm)>0] <- nm[nchar(nm)>0]
  names(cargs) <- nmc
  rep.fac <- 1
  orep <- final.len <- prod(sapply(args, length))
  for(i in 1:nargs) {
    x <- args[[i]]
    # avoid sorting the levels of character variates
    nx <- length(x)
    orep <- orep/nx
    x <- rep(rep(x, rep(rep.fac, nx)), orep)
    # avoid sorting the levels of character variates
    if(!is.factor(x) && is.character(x)) x <- factor(x, levels = unique(x))
    cargs[[i]] <- x
    rep.fac <- rep.fac * nx
  }
  do.call("cbind.data.frame", cargs)
}
"factor" <- function (x, levels = sort(unique(x), na.last = TRUE),
	labels=levels, exclude = NA, ordered = is.ordered(x))
{
  if (length(x) == 0)
    return(character(0))
  exclude <- as.vector(exclude, typeof(x))
  levels <- levels[is.na(match(levels, exclude))]
  f <- match(x, levels)
  names(f) <- names(x)
  attr(f, "levels") <- if (length(labels) == length(levels))
    as.character(labels)
  else if(length(labels) == 1)
    paste(labels, seq(along = levels), sep = "")
  else
    stop("invalid labels argument in \"factor\"")
  attr(f, "class") <- c(if(ordered)"ordered", "factor")
  f
}
"is.factor" <- function(x) inherits(x, "factor")
levels <- function(x) attr(x, "levels")
nlevels <- function(x) length(levels(x))
"levels<-" <- function(x, value) {
  x <- as.factor(x)
  if (length(value) != nlevels(x))
    stop("Length mismatch in levels<-")
  value <- as.character(value)
  uvalue <- unique(value)
  factor(match(value, uvalue), labels = uvalue)[x]
}
codes <- function(x, ...) UseMethod("codes")
codes.factor <- function(x)
{
  ## This is the S-plus semantics.
  ## The deeper meaning? Search me...
  rank(levels(x))[x]
}
codes.ordered <- .Alias(as.integer)
"codes<-" <- function(x, value)
{
  if ( length(value) == 1 )
    value <- rep(value, length(x))
  else if ( length(x) != length(value) )
    stop("Length mismatch in \"codes<-\"")
  ## S-plus again...
  if ( !is.ordered(x) ) value <- order(levels(x))[value]
  attributes(value) <- attributes(x)
  value
}
"as.factor" <- function (x) if (is.factor(x)) x else factor(x)
"as.vector.factor" <- function(x, type="any")
{
  if (type== "any" || type== "character" || type == "logical" || type == "list")
    as.vector(levels(x)[x], type)
  else
    as.vector(unclass(x), type)
}
print.factor <- function (x, quote=FALSE)
{
  if(length(x) <= 0)
    cat("factor(0)\n")
  else
    print(levels(x)[x], quote=quote)
  cat("Levels: ",paste(levels(x), collapse=" "), "\n")
}
Math.factor <- function(x, ...)
 	stop(paste('"',.Generic,'"', " not meaningful for factors", sep=""))
Summary.factor <- function(x, ...)
        stop(paste('"',.Generic,'"', " not meaningful for factors", sep=""))
Ops.factor <- function(e1, e2)
{
  ok <- switch(.Generic, "=="=, "!="=TRUE, FALSE)
  if (!ok) stop(paste('"',.Generic,'"', " not meaningful for factors", sep=""))
  nas <- is.na(e1) | is.na(e2)
  if (nchar(.Method[1])) {
    l1 <- levels(e1)
    e1 <- l1[e1]
  }
  if (nchar(.Method[2])) {
    l2 <- levels(e2)
    e2 <- l2[e2]
  }
  if (all(nchar(.Method)) && (length(l1) != length(l2) ||
			      !all(sort(l2) == sort(l1))))
    stop("Level sets of factors are different")
  value <- NextMethod(.Generic)
  value[nas] <- NA
  value
}
"[.factor" <- function(x, i, drop=FALSE)
{
  y <- NextMethod("[")
  class(y)<-class(x)
  attr(y,"levels")<-attr(x,"levels")
  if ( drop ) factor(y) else y
}
"[<-.factor" <- function(x, i, value)
{
  lx <- levels(x)
  cx <- class(x)
  nas <- is.na(x)
  if (is.factor(value))
    value <- levels(value)[value]
  m <- match(value, lx)
  if (any(is.na(m) && !is.na(value)))
    warning("invalid factor level, NAs generated")
  class(x) <- NULL
  x[i] <- m
  attr(x,"levels") <- lx
  class(x) <- cx
  x
}
## ordered factors ...
ordered <-
function (x, levels = sort(unique(x), na.last = TRUE), labels = levels,
          exclude = NA, ordered = TRUE)
{
  if (length(x) == 0)
    return(character(0))
  exclude <- as.vector(exclude, typeof(x))
  levels <- levels[is.na(match(levels, exclude))]
  f <- match(as.character(x), levels)
  names(f) <- names(x)
  attr(f, "levels") <-
    if (length(labels) == length(levels))
      as.character(labels)
    else if (length(labels) == 1)
      paste(labels, seq(along = levels), sep = "")
    else
      stop("invalid labels argument in \"ordered\"")
  attr(f, "class") <- c(if (ordered) "ordered", "factor")
  f
}
"is.ordered" <- function(x) inherits(x, "ordered")
"as.ordered" <- function(x) if (is.ordered(x)) x else ordered(x)
"print.ordered" <-
  function (x, quote=FALSE) {
    if(length(x) <= 0)
      cat("ordered(0)\n")
    else
      print(levels(x)[x], quote=quote)
  cat("Levels: ",paste(levels(x), collapse=" < "), "\n")
}
"Ops.ordered" <- function(e1, e2)
{
  nas <- is.na(e1) | is.na(e2)
  if (nchar(.Method[1])) {
    l1 <- levels(e1)
    e1 <- l1[e1]
  }
  if (nchar(.Method[2])) {
    l2 <- levels(e2)
    e2 <- l2[e2]
  }
  if (all(nchar(.Method)) && (length(l1) != length(l2) ||
			      !all(sort(l2) == sort(l1))))
    stop("Level sets of factors are different")
  value <- get(.Generic, mode="function")(e1,e2)
  value[nas] <- NA
  value
}
family <- function(object, ...) UseMethod("family")
print.family <- function(x, ...)
{
	cat("\nFamily:", x$family, "\n")
	cat("Link function:", x$link, "\n\n")
}
power <- function(lambda = 1)
{
	if(lambda <= 0)
		return("log")
	return(lambda)
}
## Written by Simon Davies Dec 1995
## Modified by Thomas Lumley 26 Apr 97
## added valideta(eta) function returning TRUE if all of eta
## is in the domain of linkinv
make.link <- function (link)
{
 ## This function is used with  glm().
 ## Given a link, it returns a link function, an inverse link
 ## function and the derivative dmu/deta.
 switch (link,
	 "logit" = {
		linkfun <- function(mu) log(mu/(1 - mu))
		linkinv <- function(eta) exp(eta)/(1 + exp(eta))
		mu.eta <- function(eta) exp(eta)/(1 + exp(eta))^2
		valideta <- function(eta) TRUE
	      },
	 "probit" = {
		linkfun <- function(mu) qnorm(mu)
		linkinv <- pnorm
		mu.eta <- function(eta) 0.3989422 * exp(-0.5 * eta^2)
		valideta <- function(eta) TRUE
	      },
	 "cloglog" = {
		linkfun <- function(mu) log(-log(1 - mu))
		linkinv <- function(eta) 1 - exp(-exp(eta))
		mu.eta <- function(eta) exp(eta) * exp(-exp(eta))
		valideta <- function(eta) TRUE
	      },
	 "identity" = {
		linkfun <- function(mu) mu
		linkinv <- function(eta) eta
		mu.eta <- function(eta) rep(1, length(eta))
		valideta <- function(eta) TRUE
	      },
	 "log" = {
		linkfun <- function(mu) log(mu)
		linkinv <- function(eta) exp(eta)
		mu.eta <- function(eta) exp(eta)
		valideta <- function(eta) TRUE
	      },
	 "sqrt" = {
		linkfun <- function(mu) mu^0.5
		linkinv <- function(eta) eta^2
		mu.eta <- function(eta) 2 * eta
		valideta <- function(eta) all(eta>0)
	      },
	 "1/mu^2" = {
		linkfun <- function(mu) 1/mu^2
		linkinv <- function(eta) 1/eta^0.5
		mu.eta <- function(eta) -1/(2 * eta^1.5)
		valideta <- function(eta) all(eta>0)
	      },
	 "inverse" = {
		linkfun <- function(mu) 1/mu
		linkinv <- function(eta) 1/eta
		mu.eta <- function(eta) -1/(eta^2)
		valideta <- function(eta) all(eta!=0)
	      },
	 ## else :
	 {
	   if (!is.na(as.numeric(link))) {
		lambda <- as.numeric(link)
		linkfun <- function(mu) mu^lambda
		linkinv <- function(eta) eta^(1/lambda)
		mu.eta <- function(eta) (1/lambda) * eta^(1/lambda - 1)
		valideta <- function(eta) all(eta>0)
	   } else
		stop(paste(link, "link not recognised"))
	 }
	 )# end switch(.)
 list(linkfun = linkfun, linkinv = linkinv,
      mu.eta = mu.eta, valideta = valideta)
}
poisson <- function (link = "log")
{
	linktemp <- substitute(link)
	## this is a function used in  glm().
	## It holds everything personal to the family,
	## converts link into character string
	if (!is.character(linktemp)) {
		linktemp <- deparse(linktemp)
		if (linktemp == "link")
			linktemp <- eval(link)
	}
	if (any(linktemp == c("log", "identity", "sqrt")))
		stats <- make.link(linktemp)
	else stop(paste(linktemp, "link not available for poisson",
			"family; available links are",
			'"identity", "log" and "sqrt"'))
	variance <- function(mu) mu
	validmu <- function(mu) all(mu>0)
	dev.resids <- function(y, mu, wt)
		2 * wt * (y * log(ifelse(y == 0, 1, y/mu)) - (y - mu))
	aic <- function(y, n, mu, wt, dev)
		2*sum((mu-y*log(mu)+lgamma(y+1))*wt)
	initialize <- expression({
		if (any(y < 0))
			stop(paste("Negative values not allowed for",
				"the Poisson family"))
		n <- rep(1, nobs)
		mustart <- y + 0.1
	})
	structure(list(family = "poisson",
			link = linktemp,
			linkfun = stats$linkfun,
			linkinv = stats$linkinv,
			variance = variance,
			dev.resids = dev.resids,
			aic = aic,
			mu.eta = stats$mu.eta,
			initialize = initialize,
			validmu = validmu,
			valideta = stats$valideta),
		  class = "family")
}
gaussian <- function (link = "identity")
{
	linktemp <- substitute(link)
	## This is a function used in  glm();
	## it holds everything personal to the family
	## converts link into character string
	if (!is.character(linktemp)) {
		linktemp <- deparse(linktemp)
		if (linktemp == "link")
			linktemp <- eval(link)
	}
	if (any(linktemp == c("inverse", "log", "identity")))
		stats <- make.link(linktemp)
	else stop(paste(linktemp, "link not available for gaussian",
		"family, available links are \"inverse\", ",
		"\"log\" and \"identity\""))
 structure(list(family = "gaussian",
                  link = linktemp,
		  linkfun = stats$linkfun,
		  linkinv = stats$linkinv,
                  variance = function(mu) rep(1, length(mu)),
                  dev.resids = function(y, mu, wt) wt * ((y - mu)^2),
                  aic =	function(y, n, mu, wt, dev)
	                        sum(wt)*(log(dev/sum(wt)*2*pi)+1)+2,
		  mu.eta = stats$mu.eta,
                  initialize = expression({
                  		n <- rep(1, nobs)
				mustart <- y }),
                  validmu = function(mu) TRUE
                  ),
           class = "family")
}
binomial <- function (link = "logit")
{
	linktemp <- substitute(link)
	## this is a function used in  glm();
	## it holds everything personal to the family
	## converts link into character string
	if (!is.character(linktemp)) {
		linktemp <- deparse(linktemp)
		if (linktemp == "link")
			linktemp <- eval(link)
	}
	if (any(linktemp == c("logit", "probit", "cloglog", "log")))
		stats <- make.link(linktemp)
	else stop(paste(linktemp, "link not available for binomial",
		"family, available links are \"logit\", ",
		"\"probit\" and \"cloglog\""))
	variance <- function(mu) mu * (1 - mu)
	validmu <- function(mu) all(mu>0) && all(mu<1)
	dev.resids <- function(y, mu, wt)
		2 * wt * (y * log(ifelse(y == 0, 1, y/mu)) +
		(1 - y) * log(ifelse(y == 1, 1, (1 - y)/(1 - mu))))
	aic <- function(y, n, mu, wt, dev)
		-2*sum((lchoose(n,n*y)+n*(y*log(mu)+(1-y)*log(1-mu)))*wt/n)
	initialize <- expression({
		if (NCOL(y) == 1) {
                  # allow factors as responses
                  # added BDR 29/5/98
                  if (is.factor(y)) y <- y != levels(y)[1]
                  n <- rep(1, nobs)
			if (any(y < 0 | y > 1))
				stop("y values must be 0 <= y <= 1")
		}
		else if (NCOL(y) == 2) {
			n <- y[, 1] + y[, 2]
			y <- ifelse(n == 0, 0, y[, 1]/n)
			weights <- weights * n
		}
		else stop(paste("For the binomial family, y must be",
			"a vector of 0 and 1\'s or a 2 column",
			"matrix where col 1 is no. successes",
			"and col 2 is no. failures"))
		mustart <- (n * y + 0.5)/(n + 1)
	})
	structure(list(family = "binomial",
			link = linktemp,
			linkfun = stats$linkfun,
			linkinv = stats$linkinv,
			variance = variance,
			dev.resids = dev.resids,
			aic = aic,
			mu.eta = stats$mu.eta,
			initialize = initialize,
			validmu = validmu,
			valideta = stats$valideta),
		  class = "family")
}
Gamma <- function (link = "inverse")
{
	linktemp <- substitute(link)
	## This is a function used in  glm();
	## it holds everything personal to the family
	## converts link into character string
	if (!is.character(linktemp)) {
		linktemp <- deparse(linktemp)
		if (linktemp == "link")
			linktemp <- eval(link)
	}
	if (any(linktemp == c("inverse", "log", "identity")))
		stats <- make.link(linktemp)
	else stop(paste(linktemp, "link not available for gamma",
		"family, available links are \"inverse\", ",
		"\"log\" and \"identity\""))
	variance <- function(mu) mu^2
	validmu <- function(mu) all(mu>0)
	dev.resids <- function(y, mu, wt)
		-2 * wt * (log(ifelse(y == 0, 1, y/mu)) - (y - mu)/mu)
	aic <- function(y, n, mu, wt, dev){
		n <- sum(wt)
		disp <- dev/n
		2*((sum(wt*(y/mu+log(mu)-log(y)))+n*log(disp))/disp+
			n*lgamma(1/disp)+sum(log(y)*wt)+1)}
	initialize <- expression({
		if (any(y <= 0))
			stop(paste("Non-positive values not",
				"allowed for the gamma family"))
		n <- rep(1, nobs)
		mustart <- y
	})
	structure(list(family = "Gamma",
			link = linktemp,
			linkfun = stats$linkfun,
			linkinv = stats$linkinv,
			variance = variance,
			dev.resids = dev.resids,
			aic = aic,
			mu.eta = stats$mu.eta,
			initialize = initialize,
			validmu = validmu,
			valideta = stats$valideta),
		  class = "family")
}
inverse.gaussian <- function(link = "1/mu^2")
{
	linktemp <- substitute(link)
	## This is a function used in  glm();
	## it holds everything personal to the family
	## converts link into character string
	if (!is.character(linktemp)) {
		linktemp <- deparse(linktemp)
		if (linktemp == "link")
			linktemp <- eval(link)
	}
	if (any(linktemp == c("inverse", "log", "identity", "1/mu^2")))
		stats <- make.link(linktemp)
	else stop(paste(linktemp, "link not available for inverse gauss",
		"family, available links are \"inverse\", ",
		"\"1/mu^2\" \"log\" and \"identity\""))
#	stats <- make.link("1/mu^2")
	variance <- function(mu) mu^3
	dev.resids <- function(y, mu, wt)  wt*((y - mu)^2)/(y*mu^2)
	aic <- function(y, n, mu, wt, dev)
		sum(wt)*(log(dev/sum(wt)*2*pi)+1)+3*sum(log(y)*wt)+2
	initialize <- expression({
			if(any(y <= 0))
				stop(paste("Positive values only allowed for",
					"the inverse.gaussian family"))
			n <- rep(1, nobs)
			mustart <- y
			})
	validmu <- function(mu) TRUE
	structure(list(family = "inverse.gaussian",
			link = "1/mu^2",
			linkfun = stats$linkfun,
			linkinv = stats$linkinv,
			variance = variance,
			dev.resids = dev.resids,
			aic = aic,
			mu.eta = stats$mu.eta,
			initialize = initialize,
			validmu = validmu,
			valideta = stats$valideta),
	class = "family")
}
quasi <- function (link = "identity", variance = "constant")
{
	linktemp <- substitute(link)
	#this is a function used in  glm()
	#it holds everything personal to the family
	#converts link into character string
	if (is.expression(linktemp))
		linktemp <- eval(linktemp)
	if (!is.character(linktemp)) {
		linktemp <- deparse(linktemp)
		if (linktemp == "link")
			linktemp <- eval(link)
	}
	stats <- make.link(linktemp)
	#converts variance into character string
	variancetemp <- substitute(variance)
	if (!is.character(variancetemp)) {
		variancetemp <- deparse(variancetemp)
		if (linktemp == "variance")
			variancetemp <- eval(variance)
	}
	switch(variancetemp,
	       "constant" = {
			variance <- function(mu) rep(1, length(mu))
			dev.resids <- function(y, mu, wt) wt * ((y - mu)^2)
			validmu <-function(mu) TRUE
		      },
	       "mu(1-mu)" = {
			variance <- function(mu) mu * (1 - mu)
			validmu <-function(mu) all(mu>0) && all(mu<1)
			dev.resids <- function(y, mu, wt)
				2 * wt * (y * log(ifelse(y == 0, 1, y/mu)) +
			 (1 - y) * log(ifelse(y == 1, 1, (1 - y)/(1 - mu))))
		      },
	       "mu" = {
			variance <- function(mu) mu
			validmu<-function(mu) all(mu>0)
			dev.resids <- function(y, mu, wt)
			  2 * wt * (y * log(ifelse(y == 0, 1, y/mu)) - (y - mu))
		      },
	       "mu^2" = {
			variance <- function(mu) mu^2
			validmu<-function(mu) all(mu!=0)
			dev.resids <- function(y, mu, wt)
				pmax(-2 * wt * (log(y/mu) - (y - mu)/mu), 0)
		      },
	       "mu^3" = {
			variance <- function(mu) mu^3
			validmu <-function(mu) all(mu>0)
			dev.resids <- function(y, mu, wt)
				wt * ((y - mu)^2)/(y * mu^2)
		      },
	       stop(paste(variancetemp, "not recognised, possible variances",
			'are "mu(1-mu)", "mu", "mu^2", "mu^3" and "constant"'))
	       )# end switch(.)
	initialize <- expression({ n <- rep(1, nobs); mustart <- y })
            aic <- function(y, n, mu, wt, dev) NA
	structure(list(family = "quasi",
                       link = linktemp,
                       linkfun = stats$linkfun,
                       linkinv = stats$linkinv,
                       variance = variance,
                       dev.resids = dev.resids,
                       aic = aic,
                       mu.eta = stats$mu.eta,
                       initialize = initialize,
                       validmu = validmu,
                       valideta = stats$valideta),
		  class = "family")
}
fft <- function(z, inverse=FALSE)
.Internal(fft(z, inverse))
mvfft <- function(z, inverse=FALSE)
.Internal(mvfft(z, inverse))
nextn <- function(n, factors=c(2,3,5))
.Internal(nextn(n, factors))
convolve <- function(x, y, conj=TRUE) {
	n <- length(x)
	if(length(y) != n)
		stop("length mismatch in convolution")
        Re(fft(fft(x)* (if(conj)Conj(fft(y)) else fft(y)), inv=TRUE))/n
}
fivenum <- function(x, na.rm=TRUE)
{
	xna <- is.na(x)
	if(na.rm) x <- x[!xna]
	else if(any(xna)) return(rep(NA,5))
	x <- sort(x)
	n <- length(x)
	if(n == 0) rep(NA,5)
	else {
		d <- c(1, 0.5*floor(0.5*(n+3)), 0.5*(n+1),
			n+1-0.5*floor(0.5*(n+3)), n)
		0.5*(x[floor(d)]+x[ceiling(d)])
	}
}
fix <- function(x) {
	subx <- substitute(x)
	if( is.name(subx) )
		subx<-deparse(subx)
	if (!is.character(subx) || length(subx) != 1)
		stop("fix requires a name")
	if(exists(subx, inherits=TRUE))
		x <- edit(get(subx))
	else
		stop(paste("no object named \"", subx, "\" to edit",sep=""))
	assign(subx, x, env=.GlobalEnv)
}
formals <- function(fun=sys.function(sys.parent())) {
	if(is.character(fun))
		fun <- get(fun, mode = "function")
	.Internal(formals(fun))
}
body <- function(fun=sys.function(sys.parent())) {
	if(is.character(fun))
		fun <- get(fun, mode = "function")
	.Internal(body(fun))
}
alist <- function (...) as.list(sys.call())[-1]
"body<-" <- function (f, value, envir = sys.frame(sys.parent())) {
	value <- substitute(value)
	if (is.expression(value)) 
		value <- value[[1]]
	f <- as.function(c(formals(f), value), envir)
}
"formals<-" <- function (f, value, envir = sys.frame(sys.parent())) {
	value <- substitute(value)
	if (is.expression(value)) 
		value <- value[[1]]
	f <- as.function(c(value, body(f)), envir)
}
format <- function(x, ...) UseMethod("format")
###	 -----
###----- FIXME ----- the digits handling should rather happen in
###	 -----       in .Internal(format(...))   in  ../../main/paste.c !
###--- also the 'names' should be kept INTERNALLY !
format.default <- function(x, trim=FALSE, digits=NULL)
{
        if(!is.null(digits)) {
                op <- options(digits=digits)
                on.exit(options(op))
        }
        switch(mode(x),
               NULL = "NULL",
               list = sapply(
                 lapply(x, function(x)
                        .Internal(format(unlist(x),trim=trim))),
                 paste, collapse=", "),
               ##else: numeric, complex, character, ??? :
               structure(.Internal(format(x, trim = trim)), names=names(x)))
}
##-- this should also happen in	C(.) :
##	.Internal(format(..) should work  with  'width =' and 'flag=.."
##		at least for the case of character arguments.
format.char <- function(x, width = NULL, flag = "-")
{
	## Purpose: Character formatting
	## --------------------------------------------------------------------
	## Arguments: x: character,  width: of field, flag: if "-" LEFT-justify
	## --------------------------------------------------------------------
	## Author: Martin Maechler <maechler@stat.math.ethz.ch>
	if (is.null(x)) return("")
	if(!is.character(x)) {
		warning("format.char: coercing 'x' to 'character'")
		x <- as.character(x)
	}
	if(is.null(width) && flag == "-")
	  return(format(x))		# Left justified; width= max.width
	## else
	at <- attributes(x)
	nc <- nchar(x)			#-- string lengths
	if(is.null(width)) width <- max(nc)
	else if(width<0) { flag <- "-"; width <- -width }
	pad <- sapply(pmax(0,width - nc),
		      function(no) paste(character(no+1), collapse =" "))
	r <- if(flag=="-") paste(x, pad, sep="")#-- LEFT  justified
		else	   paste(pad, x, sep="")#-- RIGHT justified
	if(!is.null(at)) attributes(r) <- at
	r
}
format.pval <- function(pv, digits = max(1, .Options$digits-2),
			eps = .Machine$double.eps, na.form = "NA")
{
	## Format  P values; auxiliary for print.summary.[g]lm(.)
	if((has.na <- any(ina <- is.na(pv)))) pv <- pv[!ina]
	## Better than '0.0' for very small values `is0':
	r <- character(length(is0 <- pv < eps))
	if(any(!is0)) {
		rr <- pv <- pv[!is0]
		## be smart -- differ for fixp. and expon. display:
		expo <- floor(log10(pv))
		fixp <- expo >= -3 | (expo == -4 & digits>1)
		if(any( fixp)) rr[ fixp] <- format(pv[ fixp], dig=digits)
		if(any(!fixp)) rr[!fixp] <- format(pv[!fixp], dig=digits)
		r[!is0]<- rr
	}
	if(any(is0)) {
		digits <- max(1,digits-2)
		if(any(!is0)) {
			nc <- max(nchar(rr))
			if(digits > 1 && digits+6 > nc)
				digits <- max(1, nc - 7)
			sep <- if(digits==1 && nc <= 6) "" else " "
		} else sep <- if(digits==1) "" else " "
		r[is0] <- paste("<", format(eps, digits=digits), sep = sep)
	}
	if(has.na) { ## rarely...
		rok <- r
		r <- character(length(ina))
		r[!ina] <- rok
		r[ina] <- na.form
	}
	r
}
## Martin Maechler <maechler@stat.math.ethz.ch> , 1994-1998
formatC <- function (x, digits = NULL, width = NULL,
		     format = NULL, flag = "", mode = NULL)
{
        blank.chars <- function(no)
        	sapply(no+1, function(n) paste(character(n), collapse=" "))
        if (!(n <- length(x))) return("")
	if (missing(mode))    mode <- storage.mode(x)
	else if (any(mode == c("double", "real", "integer")))
          storage.mode(x) <- if(mode=="real")"double" else mode
	else stop("\"mode\" must be \"double\" (\"real\") or \"integer\"")
	if (mode == "character" || (!is.null(format) && format == "s")) {
	 if (mode != "character") {
	  warning('should give "character" argument for format="s" -- COERCING')
	  x <- as.character(x)
	 }
	 return(format.char(x, width=width, flag=flag))
	}
	some.special <- !all(Ok <- is.finite(x))
	if (some.special) {
		rQ <- as.character(x[!Ok])
		x[!Ok] <- 0
	}
	if (missing(format) || is.null(format))
	 format <- if (mode == "integer") "d" else "g"
	else {
	 if (any(format == c("f", "e", "E", "g", "G", "fg"))) {
		 if (mode == "integer") mode <- storage.mode(x) <- "double"
	 }
	 else if (format == "d") {
		 if (mode != "integer") mode <- storage.mode(x) <- "integer"
	 }
	 else stop('"format" must be in {"f","e","E","g","G", "fg", "s"}')
	}
	if (missing(digits) || is.null(digits))
	  digits <- if (mode == "integer") 2 else 4
        else if(digits<0)
          digits <- 6
	if(is.null(width)) width <- digits + 1
	else if (width == 0) width <- digits##was stop("`width' must not be 0")
        i.strlen <-
          pmax(abs(width),
               if(format == "fg"||format == "f") {
                 xEx <- as.integer(floor(log10(abs(x+ifelse(x==0,1,0)))))
                 as.integer(x < 0 | flag!="") + digits +
                   if(format == "f") {
                     2 + pmax(xEx,0)
                   } else {# format == "fg"
                     pmax(xEx, digits,digits+(-xEx)+1) +
                       ifelse(flag!="",nchar(flag),0) + 1
                   }
               } else # format == "g" or "e":
               rep(digits+8, n)
               )
        ##Dbg if(format=="fg"||format == "f")
        ##Dbg   cat("formatC(,.): xEx=",xEx,"\n\t==> i.strlen=",i.strlen,"\n")
	r <- .C("str_signif",
		x = x,
		n = n,
		mode   = as.character(mode),
		width  = as.integer(width),
		digits = as.integer(digits),
		format = as.character(format),
		flag   = as.character(flag),
		result = blank.chars(i.strlen))$result
        ##Dbg if(any(ii <- (nc.res <- nchar(r)) > i.strlen)) {
        ##Dbg  cat("formatC: some  i.strlen[.] were too small:\n")
        ##Dbg  print(cbind(ii=which(ii), strlen=i.strlen[ii], nchar=nc.res[ii]))
        ##Dbg }
	if (some.special)
	  r[!Ok] <- format.char(rQ, width=width, flag=flag)
	if (!is.null(x.atr <- attributes(x)))
	  attributes(r) <- x.atr
	r
}
subset.data.frame <-
function (dfr, subset, select)
{
	if(missing(subset))
		r <- TRUE
	else {
		e <- substitute(subset)
		r <- eval(e,dfr)
		r <- r & !is.na(r)
	}
	if(missing(select))
		vars <- TRUE
	else {
		nl <- as.list(1:ncol(dfr))
		names(nl) <- names(dfr)
		vars <- eval(substitute(select),nl)
	}
	dfr[r,vars,drop=FALSE]
}
subset<-
function(x,...)
	UseMethod("subset")
subset.default <-
function(x,subset)
	x[subset & !is.na(subset)]
transform.data.frame <-
function (dfr, ...)
{
        e <- eval(substitute(list(...)), dfr)
        tags <- names(e)
        inx <- match(tags, names(dfr))
        matched <- !is.na(inx)
        if (any(matched)) {
                dfr[inx[matched]] <- e[matched]
		dfr <- data.frame(dfr)
	}
        if (!all(matched))
                data.frame(dfr, e[!matched])
        else dfr
}
transform <-
function(x,...)
	UseMethod("transform")
## Actually, I have no idea what to transform(), except dataframes.
## The default converts its argument to a dataframe and transforms
## that. This is probably marginally useful at best. --pd
transform.default <-
function(x,...)
	transform.data.frame(data.frame(x),...)
get <-
function(x, pos=-1, envir=pos.to.env(pos), mode="any", inherits=TRUE)
.Internal(get(x, envir, mode, inherits))
# gl function of GLIM:
gl <- function (n, k, length = n*k, labels=1:n, ordered=FALSE)
	factor(rep(rep(1:n,rep(k,n)), length=length),
		labels=labels, ordered=ordered)
### This function fits a generalized linear model via
### iteratively reweighted least squares for any family.
### Written by Simon Davies, Dec 1995
### glm.fit modified by Thomas Lumley, Apr 1997, and then others..
glm <- function(formula, family=gaussian, data=list(), weights=NULL,
	subset=NULL, na.action=na.fail, start=NULL, offset=NULL,
	control=glm.control(epsilon=0.0001, maxit=10, trace=FALSE),
	model=TRUE, method="glm.fit", x=FALSE, y=TRUE, contrasts = NULL)
{
	call <- match.call()
	## family
	if(is.character(family)) family <- get(family)
	if(is.function(family)) family <- family()
	if(is.null(family$family)) {
		print(family)
		stop("'family' not recognised")
	}
	## extract x, y, etc from the model formula and frame
	mt <- terms(formula, data=data)
	if(missing(data)) data <- sys.frame(sys.parent())
	mf <- match.call()
	mf$family <- mf$start <- mf$control <- mf$maxit <- NULL
	mf$model <- mf$method <- mf$x <- mf$y <- mf$contrasts <- NULL
##	  mf$drop.unused.levels <- TRUE
	mf[[1]] <- as.name("model.frame")
	mf <- eval(mf, sys.frame(sys.parent()))
	switch(method,
	       "model.frame" = return(mf),
	       "glm.fit"= 1,
	       "glm.fit.null"= 1,
	       ## else
	       stop(paste("invalid 'method':", method)))
	xvars <- as.character(attr(mt, "variables"))[-1]
	if(yvar <- attr(mt, "response") > 0) xvars <- xvars[-yvar]
	xlev <- if(length(xvars) > 0) {
	  xlev <- lapply(mf[xvars], levels)
	  xlev[!sapply(xlev, is.null)]
	} # else NULL
	## null model support
	X <- if (!is.empty.model(mt)) model.matrix(mt, mf, contrasts)# else NULL
	Y <- model.response(mf, "numeric")
	weights <- model.weights(mf)
	if(is.null(offset)) offset <- model.offset(mf)
	## check weights and offset
	if( !is.null(weights) && any(weights<0) )
		stop("Negative wts not allowed")
	if(!is.null(offset) && length(offset) != NROW(Y))
		stop(paste("Number of offsets is", length(offset),
			", should equal", NROW(Y), "(number of observations)"))
	## fit model via iterative reweighted least squares
	fit <- (if (is.empty.model(mt)) glm.fit.null else glm.fit)(
			x=X, y=Y, weights=weights, start=start,
			offset=offset, family=family, control=control,
			intercept=attr(mt, "intercept") > 0)
	if(any(offset) && attr(mt, "intercept") > 0) {
	  fit$null.deviance <-
	    if(is.empty.model(mt)) fit$deviance
	    else glm.fit(x=X[,"(Intercept)",drop=FALSE], y=Y, weights=weights,
			 start=start, offset=offset, family=family,
			 control=control, intercept=TRUE)$deviance
	}
	if(model) fit$model <- mf
	if(x) fit$x <- X
	if(!y) fit$y <- NULL
	fit <- c(fit, list(call=call, formula=formula,
			   terms=mt, data=data,
			   offset=offset, control=control, method=method,
			   contrasts = attr(X, "contrasts"), xlevels = xlev))
	class(fit) <- c(if(is.empty.model(mt)) "glm.null", "glm", "lm")
	fit
}
glm.control <- function(epsilon = 0.0001, maxit = 10, trace = FALSE)
{
	if(!is.numeric(epsilon) || epsilon <= 0)
		stop("value of epsilon must be > 0")
	if(!is.numeric(maxit) || maxit <= 0)
		stop("maximum number of iterations must be > 0")
	list(epsilon = epsilon, maxit = maxit, trace = trace)
}
## Modified by Thomas Lumley 26 Apr 97
## Added boundary checks and step halving
## Modified detection of fitted 0/1 in binomial
## Updated by KH as suggested by BDR on 1998/06/16
glm.fit <-
function (x, y, weights = rep(1, nobs), start = NULL,
	etastart = NULL, mustart = NULL, offset = rep(0, nobs),
	family = gaussian(), control = glm.control(), intercept = TRUE)
{
	x <- as.matrix(x)
	xnames <- dimnames(x)[[2]]
	ynames <- names(y)
	conv <- FALSE
	nobs <- NROW(y)
	nvars <- NCOL(x)
	## define weights and offset if needed
	if (is.null(weights))
		weights <- rep(1, nobs)
	if (is.null(offset))
		offset <- rep(0, nobs)
	## get family functions:
	variance <- family$variance
	dev.resids <- family$dev.resids
	aic <- family$aic
	linkinv <- family$linkinv
	mu.eta <- family$mu.eta
	if (!is.function(variance) || !is.function(linkinv) )
	  stop("illegal 'family' argument")
	valideta <- family$valideta
	if (is.null(valideta))
	  valideta <- function(eta) TRUE
	validmu <- family$validmu
	if (is.null(validmu))
	  validmu <- function(mu) TRUE
	if(is.null(mustart))
	  ## next line calculates mustart and may change y and weights
	eval(family$initialize, sys.frame(sys.nframe()))
	if (NCOL(y) > 1)
	  stop("y must be univariate unless binomial")
	eta <-
	  if(!is.null(etastart) && valideta(etastart))
	    etastart
	  else if(!is.null(start))
	    if (length(start) != nvars)
	      stop(paste("Length of start should equal", nvars,
			 "and correspond to initial coefs for",
			 deparse(xnames)))
	    else as.vector(if (NCOL(x) == 1) x * start else x %*% start)
	  else family$linkfun(mustart)
	mu <- linkinv(eta + offset)
	if (!(validmu(mu) && valideta(eta)))
	  stop("Can't find valid starting values: please specify some")
	## calculate initial deviance and coefficient
	devold <- sum(dev.resids(y, mu, weights))
	coefold <- start
	boundary <- FALSE
	##------------- THE Iteratively Reweighting L.S. iteration -----------
	for (iter in 1:control$maxit) {
		mu.eta.val <- mu.eta(eta + offset)
		if (any(ina <- is.na(mu.eta.val)))
		  mu.eta.val[ina] <- mu.eta(mu)[ina]
		if (any(is.na(mu.eta.val)))
		  stop("NAs in d(mu)/d(eta)")
		## calculate z and w using only values where mu.eta != 0
		good <- mu.eta.val != 0
		if (all(!good)) {
			conv <- FALSE
			warning(paste("No observations informative at iteration",
				      iter))
			break
		}
		z <- eta[good] + (y - mu)[good]/mu.eta.val[good]
		w <- sqrt((weights * mu.eta.val^2)[good]/variance(mu)[good])
		ngoodobs <- as.integer(nobs - sum(!good))
		ncols <- as.integer(1)
		## call linpack code
		fit <- .Fortran("dqrls",
				qr = x[good, ] * w, n = as.integer(ngoodobs),
				p = nvars, y = w * z, ny = ncols,
				tol = min(1e-7, control$epsilon/1000),
				coefficients = numeric(nvars),
				residuals = numeric(ngoodobs),
				effects = numeric(ngoodobs),
				rank = integer(1),
				pivot = 1:nvars, qraux = double(nvars),
				work = double(2 * nvars)
		)
		## stop if not enough parameters
		if (nobs < fit$rank)
		  stop(paste("X matrix has rank", fit$rank, "but only",
			     nobs, "observations"))
		## calculate updated values of eta and mu with the new coef:
		start <- coef <- fit$coefficients
		start[fit$pivot] <- coef
		eta[good] <-
		  if (nvars == 1) x[good] * start else as.vector(x[good, ] %*% start)
		mu <- linkinv(eta + offset)
		if (family$family == "binomial") {
			if (any(mu == 1) || any(mu == 0))
			  warning("fitted probabilities of 0 or 1 occurred")
			mu0 <- 0.5 * control$epsilon/length(mu)
			mu[mu == 1] <- 1 - mu0
			mu[mu == 0] <- mu0
		}
		else if (family$family == "poisson") {
			if (any(mu == 0))
			  warning("fitted rates of 0 occured")
			mu[mu == 0] <- 0.5 * control$epsilon/length(mu)^2
		}
		dev <- sum(dev.resids(y, mu, weights))
		if (control$trace)
		  cat("Deviance =", dev, "Iterations -", iter, "\n")
		## check for divergence
		boundary <- FALSE
		if (any(is.na(dev)) || any(is.na(coef))) {
			warning("Step size truncated due to divergence")
			ii <- 1
			while ((any(is.na(dev)) || any(is.na(start)))) {
				if (ii > control$maxit)
				  stop("inner loop 1; can't correct step size")
				ii <- ii+1
				start <- (start + coefold)/2
				eta[good] <-
				  if (nvars == 1) x[good] * start else as.vector(x[good, ] %*% start)
				mu <- linkinv(eta + offset)
				dev <- sum(dev.resids(y, mu, weights))
			}
			boundary <- TRUE
			coef <- start
			if (control$trace)
			  cat("New Deviance =", dev, "\n")
		}
		## check for fitted values outside domain.
		if (!(valideta(eta) && validmu(mu))) {
			warning("Step size truncated: out of bounds.")
			ii <- 1
			while (!(valideta(eta) && validmu(mu))) {
				if (ii > control$maxit)
				  stop("inner loop 2; can't correct step size")
				ii <- ii + 1
				start <- (start + coefold)/2
				eta[good] <-
				  if (nvars == 1) x[good] * start else as.vector(x[good, ] %*% start)
				mu <- linkinv(eta + offset)
			}
			boundary <- TRUE
			coef <- start
			dev <- sum(dev.resids(y, mu, weights))
			if (control$trace)
			  cat("New Deviance =", dev, "\n")
		}
		## check for convergence
		if (abs(dev - devold)/(0.1 + abs(dev)) < control$epsilon) {
			conv <- TRUE
			break
		} else {
			devold <- dev
			coefold <- coef
		}
	}##-------------- end IRLS iteration -------------------------------
	if (!conv) warning("Algorithm did not converge")
	if (boundary) warning("Algorithm stopped at boundary value")
	## If X matrix was not full rank then columns were pivoted,
	## hence we need to re-label the names ...
	## Original code changed as suggested by BDR---give NA rather
	## than 0 for non-estimable parameters
	if (fit$rank != nvars) {
	    coef[seq(fit$rank+1, nvars)] <- NA
	    dimnames(fit$qr) <- list(NULL, xnames)
	}
	coef[fit$pivot] <- coef
	xxnames <- xnames[fit$pivot]
	residuals <- rep(NA, nobs)
	residuals[good] <- z - eta[good]
	fit$qr <- as.matrix(fit$qr)
	nr <- min(sum(good), nvars)
	if (nr < nvars) {
		Rmat <- diag(nvars)
		Rmat[1:nr,1:nvars] <- fit$qr[1:nr,1:nvars]
	}
	else Rmat <- fit$qr[1:nvars, 1:nvars]
	Rmat <- as.matrix(Rmat)
	Rmat[row(Rmat) > col(Rmat)] <- 0
	names(coef) <- xnames
	colnames(fit$qr) <- xxnames
	dimnames(Rmat) <- list(xxnames, xxnames)
	names(residuals) <- ynames
	names(mu) <- ynames
	names(eta) <- ynames
	names(w) <- ynames
	names(weights) <- ynames
	names(y) <- ynames
	names(fit$effects) <-
	  c(xxnames[seq(fit$rank)], rep("", nobs - fit$rank))
	## calculate null deviance
	wtdmu <-
	  if (intercept) sum(weights * y)/sum(weights) else linkinv(offset)
	nulldev <- sum(dev.resids(y, wtdmu, weights))
	## calculate df
	n.ok <- nobs - sum(weights==0)
	nulldf <- n.ok - as.integer(intercept)
	resdf  <- n.ok - fit$rank
	## calculate AIC
	aic.model <-
	  ##Should not be necessary: --pd
	  #if(resdf>0) aic(y, n, mu, weights, dev) + 2*fit$rank else -Inf
	  aic(y, n, mu, weights, dev) + 2*fit$rank
	list(coefficients = coef, residuals = residuals, fitted.values = mu,
	     effects = fit$effects, R = Rmat, rank = fit$rank,
	     qr = fit[c("qr", "rank", "qraux", "pivot", "tol")], family = family,
	     linear.predictors = eta, deviance = dev, aic = aic.model,
	     null.deviance = nulldev, iter = iter, weights = w^2,
	     prior.weights = weights, df.residual = resdf, df.null = nulldf,
	     y = y, converged = conv, boundary = boundary)
}
print.glm <- function (x, digits= max(3, .Options$digits - 3), na.print="", ...)
{
	cat("\nCall: ", deparse(x$call), "\n\n")
	cat("Coefficients")
	if(is.character(co <- x$contrasts))
		cat("  [contrasts: ",
			apply(cbind(names(co),co), 1, paste, collapse="="), "]")
	cat(":\n")
	print.default(format(x$coefficients, digits=digits),
		      print.gap = 2, quote = FALSE)
	cat("\nDegrees of Freedom:", x$df.null, "Total (i.e. Null); ",
		 x$df.residual, "Residual\n")
	cat("Null Deviance:    ", format(signif(x$null.deviance, digits)), "\n")
	cat("Residual Deviance:", format(signif(x$deviance, digits)), "\t")
	cat("AIC:", format(signif(x$aic, digits)), "\n")
	invisible(x)
}
anova.glm <- function(object, ..., test=NULL, na.action=na.omit)
{
	## check for multiple objects
	dotargs <- list(...)
	named <- if (is.null(names(dotargs)))
			rep(FALSE,length(dotargs))
		else (names(dotargs) != "")
	if(any(named))
		warning(paste("The following arguments to anova.glm(..)",
			      "are invalid and dropped:",
			      paste(deparse(dotargs[named]), collapse=", ")))
	dotargs <- dotargs[!named]
	is.glm <- unlist(lapply(dotargs,function(x) inherits(x,"glm")))
	dotargs <- dotargs[is.glm]
	if (length(dotargs)>0)
		return(anova.glmlist(c(list(object),dotargs),test=test,
				na.action=na.action))
	#args <- function(...) nargs()
	#if(args(...)) return(anova.glmlist(list(object, ...), test=test))
	## extract variables from model
	varlist <- attr(object$terms, "variables")
	## must avoid partial matching here.
	x <-
	  if (n <- match("x", names(object), 0))
	    object[[n]]
	  else model.matrix(object)
	varseq <- attr(x, "assign")
	nvars <- max(varseq)
	resdev <- resdf <- NULL
	## if there is more than one explanatory variable then
	## recall glm.fit to fit variables sequentially
	if(nvars > 1) {
	  method <- object$method
	  if(!is.function(method))
		method <- get(method, mode = "function")
	  for(i in 1:(nvars-1)) {
		## explanatory variables up to i are kept in the model
		## use method from glm to find residual deviance
		## and df for each sequential fit
		fit <- method(x=x[, varseq <= i],
			      y=object$y,
			weights=object$prior.weights,
			start  =object$start,
			offset =object$offset,
			family =object$family,
			control=object$control)
		resdev <- c(resdev, fit$deviance)
		resdf <- c(resdf, fit$df.residual)
	  }
	}
	## add values from null and full model
	resdf <- c(object$df.null, resdf, object$df.residual)
	resdev <- c(object$null.deviance, resdev, object$deviance)
	## construct table and title
	table <- cbind(c(NA, -diff(resdf)), c(NA, -diff(resdev)), resdf, resdev)
	if (nvars == 0) table <- table[1,,drop=FALSE] # kludge for null model
	dimnames(table) <- list(c("NULL", attr(object$terms, "term.labels")),
				c("Df", "Deviance", "Resid. Df", "Resid. Dev"))
	title <- paste("Analysis of Deviance Table", "\n\nModel: ",
		object$family$family, ", link: ", object$family$link,
		"\n\nResponse: ", as.character(varlist[-1])[1],
		"\n\nTerms added sequentially (first to last)\n\n", sep="")
	## calculate test statistics if needed
	if(!is.null(test))
	 table <- stat.anova(table=table, test=test, scale=sum(
			object$weights*object$residuals^2)/object$df.residual,
			df.scale=object$df.residual, n=NROW(x))
	structure(list(title=title, table=table), class= "anova.glm")
}
anova.glmlist <- function(object, test=NULL, na.action=na.omit)
{
	## find responses for all models and remove
	## any models with a different response
	responses <- as.character(lapply(object, function(x) {
			deparse(formula(x)[[2]])} ))
	sameresp <- responses==responses[1]
	if(!all(sameresp)) {
		object <- object[sameresp]
		warning(paste("Models with response", deparse(responses[
			!sameresp]), "removed because response differs from",
			"model 1"))
	}
	## calculate the number of models
	nmodels <- length(object)
	if(nmodels==1)	return(anova.glm(object[[1]], na.action=na.action,
					test=test))
	## extract statistics
	resdf <- as.numeric(lapply(object, function(x) x$df.residual))
	resdev <- as.numeric(lapply(object, function(x) x$deviance))
	## construct table and title
	table <- cbind(resdf, resdev, c(NA, -diff(resdf)), c(NA, -diff(resdev)))
	variables <- as.character(lapply(object, function(x) {
			deparse(formula(x)[[3]])} ))
	dimnames(table) <- list(variables, c("Resid. Df", "Resid. Dev", "Df",
				"Deviance"))
	title <- paste("Analysis of Deviance Table \n\nResponse: ", responses[1],
			"\n\n", sep="")
	## calculate test statistic if needed
	if(!is.null(test)) {
		bigmodel <- object[[(order(resdf)[1])]]
		table <- stat.anova(table=table, test=test, scale=sum(
			bigmodel$weights * bigmodel$residuals^2)/
			bigmodel$df.residual, df.scale=min(resdf),
			n=length(bigmodel$residuals))
	}
	structure(list(table=table, title=title),
		  class= "anova.glm")
}
stat.anova <- function(table, test=c("Chisq", "F", "Cp"), scale, df.scale, n)
{
 test <- match.arg(test)
 dev.col <- match("Deviance", colnames(table))
 if ( is.na(dev.col) ) dev.col <- match("Sum of Sq", colnames(table))
 switch(test,
	"Chisq" = {
	  cbind(table,"P(>|Chi|)"= 1-pchisq(abs(table[, dev.col]), abs(table[, "Df"])))
	},
	"F" = {
	  Fvalue <- abs((table[, dev.col]/table[, "Df"])/scale)
	  cbind(table, F = Fvalue,
	  "Pr(>F)" = 1-pf(Fvalue, abs(table[, "Df"]), abs(df.scale)))
	},
	"Cp" = {
	  cbind(table, Cp = table[,"Resid. Dev"] + 2*scale*(n - table[,"Resid. Df"]))
	})
}
summary.glm <- function(object, dispersion = NULL,
	correlation = FALSE, na.action=na.omit)
{
	Qr <- .Alias(object$qr)
	est.disp <- FALSE
	df.r <- object$df.residual
	if(is.null(dispersion))	# calculate dispersion if needed
	  dispersion <-
		if(any(object$family$family == c("poisson", "binomial")))
		  1
		else if(df.r > 0) {
			est.disp <- TRUE
			if(any(object$weights==0))
				warning(paste("observations with zero weight",
				"not used for calculating dispersion"))
			sum(object$weights*object$residuals^2)/ df.r
		} else Inf
	## calculate scaled and unscaled covariance matrix
	p <- object$rank
	p1 <- 1:p
	## WATCHIT! doesn't this rely on pivoting not permuting 1:p?
	coef.p <- object$coefficients[Qr$pivot[p1]]
	covmat.unscaled <- chol2inv(Qr$qr[p1,p1,drop=FALSE])
	dimnames(covmat.unscaled) <- list(names(coef.p),names(coef.p))
	covmat <- dispersion*covmat.unscaled
	var.cf <- diag(covmat)
	## calculate coef table
	s.err <- sqrt(var.cf)
	tvalue <- coef.p/s.err
	dn <- c("Estimate", "Std. Error")
	if(!est.disp) {
		pvalue <- 2*pnorm(-abs(tvalue))
		coef.table <- cbind(coef.p, s.err, tvalue, pvalue)
		dimnames(coef.table) <- list(names(coef.p),
				     c(dn, "z value","Pr(>|z|)"))
	} else if(df.r > 0) {
		pvalue <- 2*pt(-abs(tvalue), df.r)
		coef.table <- cbind(coef.p, s.err, tvalue, pvalue)
		dimnames(coef.table) <- list(names(coef.p),
				     c(dn, "t value","Pr(>|t|)"))
	} else { ## df.r == 0
		coef.table <- cbind(coef.p, Inf)
		dimnames(coef.table) <- list(names(coef.p), dn)
	}
	## return answer
	ans <- c(object[c("call","terms","family","deviance", "aic",
			  "contrasts",
			  "df.residual","null.deviance","df.null","iter")],
		 list(deviance.resid= residuals(object, type = "deviance"),
		      aic = object$aic,
		      coefficients=coef.table,
		      dispersion=dispersion,
		      df=c(object$rank, df.r),
		      cov.unscaled=covmat.unscaled,
		      cov.scaled=covmat))
	if(correlation) {
		dd <- sqrt(diag(covmat.unscaled))
		ans$correlation <-
			covmat.unscaled/outer(dd,dd)
	}
	class(ans) <- "summary.glm"
	return(ans)
}
print.summary.glm <- function (x, digits = max(3, .Options$digits - 3),
	na.print = "", symbolic.cor = p > 4,
	signif.stars= .Options$show.signif.stars, ...)
{
	cat("\nCall:\n")
	cat(paste(deparse(x$call), sep="\n", collapse="\n"), "\n\n", sep="")
	cat("Deviance Residuals: \n")
	if(x$df.residual > 5) {
		x$deviance.resid <- quantile(x$deviance.resid,na.rm=TRUE)
		names(x$deviance.resid) <- c("Min", "1Q", "Median", "3Q", "Max")
	}
	print.default(x$deviance.resid, digits=digits, na = "", print.gap = 2)
	cat("\nCoefficients:\n")
	print.coefmat(x$coef, digits=digits, signif.stars=signif.stars, ...)
	##
	cat("\n(Dispersion parameter for ", x$family$family,
	    " family taken to be ", format(x$dispersion), ")\n\n",
	    apply(cbind(paste(format.char(c("Null","Residual"),width=8,flag=""),
			      "deviance:"),
			format(unlist(x[c("null.deviance","deviance")]),
			       digits= max(5, digits+1)), " on",
			format(unlist(x[c("df.null","df.residual")])),
			" degrees of freedom\n"),
		  1, paste, collapse=" "),
	    "AIC: ", format(x$aic, digits= max(4, digits+1)),"\n\n",
	    "Number of Fisher Scoring iterations: ", x$iter,
	    "\n\n", sep="")
	correl <- x$correlation
	if(!is.null(correl)) {
		p <- dim(correl)[2]
		if(p > 1) {
			cat("Correlation of Coefficients:\n")
			correl[!lower.tri(correl)] <- NA
			print(correl[-1, -NCOL(correl), drop=FALSE],
			      digits=digits, na="")
		}
		cat("\n")
	}
	invisible(x)
}
print.anova.glm <- function(x, digits = max(3, .Options$digits - 3),
	na.print = "", ...)
{
	cat("\n", x$title, sep="")
	print.default(x$table, digits=digits, na = "", print.gap = 2)
	cat("\n")
}
## GLM Methods for Generic Functions :
coef.glm <- function(x) x$coefficients
deviance.glm <- function(x) x$deviance
effects.glm <- function(x) x$effects
fitted.glm <- function(x) x$fitted.values
family.glm <- function(x) x$family
residuals.glm <- function(x, type="deviance")
{
	ntyp <- match(type, c("deviance", "pearson", "working", "response"))
	if(is.na(ntyp))
		stop(paste("invalid `type':", type))
	y  <- x$y
	mu <- x$fitted.values
	wts <- x$prior.weights
	switch(ntyp,
		deviance = if(x$df.res > 0) {
		  d.res <- sqrt((x$family$dev.resids)(y, mu, wts))
		  ifelse(y > mu, d.res, -d.res)
		} else rep(0, length(mu)),
		pearson	 = x$residuals * sqrt(x$weights),
		working	 = x$residuals,
		response = y - mu
		)
}
## Commented by KH on 1998/06/22
## update.default() should be more general now ...
##update.glm <- function (glm.obj, formula, data, weights, subset, na.action,
##			offset, family, x)
##{
##	call <- glm.obj$call
##	if (!missing(formula))
##	  call$formula <- update.formula(call$formula, formula)
##	if (!missing(data))	call$data <- substitute(data)
##	if (!missing(subset))	call$subset <- substitute(subset)
##	if (!missing(na.action))call$na.action <- substitute(na.action)
##	if (!missing(weights))	call$weights <- substitute(weights)
##	if (!missing(offset))	call$offset <- substitute(offset)
##	if (!missing(family))	call$family <- substitute(family)
##	if (!missing(x))	call$x <- substitute(x)
####	notparent <- c("NextMethod", "update", methods(update))
####	for (i in 1:(1+sys.parent())) {
####		parent <- sys.call(-i)[[1]]
####		if (is.null(parent))
####		break
####	if (is.na(match(as.character(parent), notparent)))
####			break
####	}
####	eval(call, sys.frame(-i))
##	eval(call, sys.frame(sys.parent()))
##}
model.frame.glm <-
function (formula, data, na.action, ...)
{
  if (is.null(formula$model)) {
    fcall <- formula$call
    fcall$method <- "model.frame"
    fcall[[1]] <- as.name("glm")
    eval(fcall, sys.frame(sys.parent()))
  }
  else formula$model
}
"anova.glm.null" <-
function (object, ..., test = NULL, na.action = na.omit) 
{
        # check for multiple objects
        args <- function(...) nargs()
        # extract variables from model
        if (args(...)) 
                return(anova.glmlist(list(object, ...), test = test))
        varlist <- attr(object$terms, "variables")
        nvars <- 0
        resdev <- resdf <- NULL
        # if there is more than one explanatory variable then
        # recall glm.fit to fit variables sequentially
        # add values from null and full model
        resdf <- c(object$df.null)
        resdev <- c(object$null.deviance)
        # construct table and title
        table <- cbind(c(NA), c(NA), resdf, resdev)
        dimnames(table) <- list(c("NULL", attr(object$terms, 
                "term.labels")), c("Df", "Deviance", "Resid. Df", 
                "Resid. Dev"))
        title <- paste("Analysis of Deviance Table", "\n\nModel: ", 
                object$family$family, ", link: ", object$family$link, 
                "\n\nResponse: ", as.character(varlist[-1])[1], 
                "\n\nTerms added sequentially (first to last)\n\n", 
                sep = "")
        # calculate test statistics if needed
        # return output
        if (!is.null(test)) 
                table <- stat.anova(table = table, test = test, 
                        scale = sum(object$weights * object$residuals^2)/object$df.residual, 
                        df.scale = object$df.residual, n = NROW(x))
        output <- list(title = title, table = table)
        class(output) <- c("anova.glm.null", "anova.glm")
        return(output)
}
"print.glm.null" <-
function (x, digits = max(3, .Options$digits - 3), na.print = "", 
        ...) 
{
        cat("\nCall: ", deparse(x$call), "\n\n")
        cat("No coefficients\n")
        cat("\nDegrees of Freedom:", length(x$residuals), "Total;", 
                x$df.residual, "Residual\n")
        cat("Null Deviance:", format(signif(x$null.deviance, 
                digits)), "\n")
        cat("Residual Deviance:", format(signif(x$deviance, digits)), 
                "\t")
        cat("AIC:", format(signif(x$aic, digits)), "\n")
        invisible(x)
}
"print.summary.glm.null" <-
function (x, digits = max(3, .Options$digits - 3), na.print = "", 
        ...) 
{
        cat("\nCall:\n")
        cat(paste(deparse(x$call), sep = "\n", collapse = "\n"), 
                "\n\n", sep = "")
        cat("Deviance Residuals: \n")
        if (x$df.residual > 5) {
                x$deviance.resid <- quantile(x$deviance.resid)
                names(x$deviance.resid) <- c("Min", "1Q", "Median", 
                        "3Q", "Max")
        }
        print.default(x$deviance.resid, digits = digits, na = "", 
                print.gap = 2)
        cat("\nNo coefficients\n")
        cat(paste("\n(Dispersion parameter for ", x$family$family, 
                " family taken to be ", x$dispersion, ")\n\n    Null deviance: ", 
                x$null.deviance, " on ", x$df.null, " degrees of freedom\n\n", 
                "Residual deviance: ", x$deviance, " on ", x$df.residual, 
                " degrees of freedom\n\n", "Number of Fisher Scoring iterations: ", 
                x$iter, "\n\n", sep = ""))
        invisible(x)
}
"summary.glm.null" <-
function (object, dispersion = NULL, correlation = TRUE, na.action = na.omit) 
{
        # calculate dispersion if needed
        # extract x to get column names
        # calculate scaled and unscaled covariance matrix
        if (is.null(dispersion)) {
                if (any(object$family$family == c("poisson", 
                        "binomial"))) 
                        dispersion <- 1
                else {
                        if (any(object$weights == 0)) 
                                warning(paste("observations with zero weight", 
                                 "not used for calculating dispersion"))
                        dispersion <- sum(object$weights * object$residuals^2)/object$df.residual
                }
        }
        p <- 0
        # return answer
        ans <- list(call = object$call, terms = object$terms, 
                family = object$family, deviance.resid = residuals(object, 
                        type = "deviance"), dispersion = dispersion, 
                df = c(object$rank, object$df.residual), deviance = object$deviance, 
                df.residual = object$df.residual, null.deviance = object$null.deviance, 
                df.null = object$df.null, iter = object$iter, 
                )
        class(ans) <- c("summary.glm.null", "summary.glm")
        return(ans)
}
"glm.fit.null" <-
function (x, y, weights = rep(1, nobs), start = NULL, offset = rep(0, 
        nobs), family = gaussian(), control = glm.control(), 
        intercept = NULL) 
{
        if(intercept) stop("null models have no intercept")
        ynames <- names(y)
        conv <- TRUE
        nobs <- NROW(y)
        nvars <- NCOL(x)
        # define weights and offset if needed
        # get family functions
        if (is.null(weights)) 
                weights <- rep(1, nobs)
        if (is.null(offset)) 
                offset <- rep(0, nobs)
        variance <- family$variance
        dev.resids <- family$dev.resids
        linkinv <- family$linkinv
        mu.eta <- family$mu.eta
        valideta <- family$valideta
        if (is.null(valideta)) 
                valideta <- function(eta) TRUE
        validmu <- family$validmu
        if (is.null(validmu)) 
                validmu <- function(mu) TRUE
        eta <- rep(0, nobs)
        if (!valideta(eta + offset)) 
                stop("Invalid linear predictor values in empty model")
        mu <- linkinv(eta + offset)
        # calculate initial deviance and coefficient
        if (!validmu(mu)) 
                stop("Invalid fitted means in empty model")
        dev <- sum(dev.resids(y, mu, weights))
        w <- ((weights * mu.eta(eta + offset)^2)/variance(mu))^0.5
        ## 	residuals[good] <- z - eta
        residuals <- (y - mu)/mu.eta(eta + offset)
        # name output
        names(residuals) <- ynames
        names(mu) <- ynames
        names(eta) <- ynames
        names(w) <- ynames
        names(weights) <- ynames
        names(y) <- ynames
        # calculate null deviance
        wtdmu <- linkinv(offset)
        nulldev <- sum(dev.resids(y, wtdmu, weights))
        # calculate df
        resdf <- nulldf <- n.ok <- nobs - sum(weights==0)
        aic.model <- family$aic(y, n, mu, weights, dev)
        return(list(coefficients = numeric(0), residuals = residuals, 
                fitted.values = mu, rank = 0, family = family, 
                linear.predictors = eta + offset, deviance = dev,
                aic = aic.model,
                null.deviance = nulldev, iter = 0, weights = w^2, 
                prior.weights = weights, df.residual = resdf, 
                df.null = nulldf, y = y, converged = conv, boundary = FALSE))
}
grep <-
function(pattern, x, ignore.case=FALSE, extended=TRUE, value=FALSE)
{
	.Internal(grep(pattern, x, ignore.case, extended, value))
}
sub <-
function(pattern, replacement, x, ignore.case=FALSE, extended=TRUE)
{
	.Internal(sub(pattern, replacement, x, ignore.case, extended))
}
gsub <-
function(pattern, replacement, x, ignore.case=FALSE, extended=TRUE)
{
	.Internal(gsub(pattern, replacement, x, ignore.case, extended))
}
"grid" <-
function (nx=3, ny=3, col="lightgray", lty="dotted") 
{
	lims <- par("usr")
	if (nx > 1) {
		coord <- seq(lims[1], lims[2], len = nx + 2)[c(-1, -(nx + 2))]
		abline(v = coord, col = col, lty = lty)
	}
	if (ny > 1) {
		coord <- seq(lims[3], lims[4], len = ny + 2)[c(-1, -(ny + 2))]
		abline(h = coord, col = col, lty = lty)
	}
}
help.start <- function (gui = "irrelevant", browser = "netscape", remote = NULL)
{
 url <- paste(if (is.null(remote)) "$RHOME" else remote,
              "/doc/html/index.html", sep = "")
 cat("If", browser, " is already running,\tit is *not* restarted,\n",
     "and you must switch to its window.\nOtherwise, be patient..\n")
 system(paste(browser, " -remote \"openURL(", url, ")\" 2>/dev/null || ",
              browser, " ", url, " &", sep = ""))
}
hist <- function(x, ...) UseMethod("hist")
hist.default <-
function (x, breaks, freq = NULL, probability = !freq, include.lowest = TRUE,
	col = NULL, border = par("fg"),
	main = paste("Histogram of" , deparse(substitute(x))),
	xlim = range(breaks), ylim = range(y, 0),
	xlab = deparse(substitute(x)), ylab,
	axes = TRUE, plot = TRUE, labels = FALSE, ...)
{
	if (!is.numeric(x))
		stop("hist: x must be numeric")
	eval(main)
	eval(xlab)
	n <- length(x <- x[!is.na(x)])
	use.br <- !missing(breaks) && length(breaks) > 1
	breaks <-
	  if(use.br) sort(breaks)
	  else {
		rx <- range(x)
		pretty (rx + c(0, diff(rx)/1000),
			n = if(missing(breaks)) 1 + log2(n)
			else { # breaks = `nclass'
				if (is.na(breaks) | breaks < 2)
				  stop("invalid number of breaks")
				breaks
			})
	  }
	nB <- length(breaks)
	counts <- .C("bincount",
		as.double(x),
		n,
		as.double(breaks),
		nB,
		counts = integer(nB - 1),
		include= as.logical(include.lowest),
		NAOK = FALSE) $counts
	if (any(counts < 0))
	  stop("negative `counts'. Internal Error in C-code for \"bincount\"")
	if (sum(counts) < n)
	  stop("some `x' not counted; maybe `breaks' do not span range of `x'")
	h <- diff(breaks)
	if (!use.br && any(h <= 0))
		stop("not strictly increasing `breaks'.")
	if (is.null(freq)) {
	  freq <- if(!missing(probability))
		!as.logical(probability)
	  else if(use.br) {
		##-- Do frequencies if breaks are evenly spaced
		max(h)-min(h) < 1e-7 * mean(h)
	  } else TRUE
	} else if(!missing(probability) && any(probability == freq))
	 stop("`probability is an alias for `!freq', however they differ.")
	intensities <- counts/(n*h)
	mids <- 0.5 * (breaks[-1] + breaks[-nB])
	y <- if (freq) counts else intensities
	if (plot) {
		plot.new()
		plot.window(xlim, ylim, "") #-> ylim's default from 'y'
          	if (missing(ylab))
                	ylab <- paste(if(!freq)"Relative ", "Frequency", sep="")
                if(freq && use.br && max(h)-min(h) > 1e-7 * mean(h))
                	warning("the AREAS in the plot are wrong -- maybe use `freq=F'")
		title(main = main, xlab = xlab, ylab = ylab, ...)
		if(axes) {
			axis(1, ...)
			axis(2, ...)
		}
		rect(breaks[-nB], 0, breaks[-1], y,
		     col = col, border = border)
		if(labels)
			text(mids, y,
			     labels = if(freq) counts else round(intensities,3),
			     adj = c(0.5, -0.5))
	}
	invisible(list(breaks = breaks, counts = counts,
		intensities = intensities, mids = mids))
}
print.htest<-function(x, digits = 4, quote = TRUE, prefix = "")
{
        cat("\n\t", x$method, "\n\n")
        cat("data: ", x$data.name, "\n")
        if(!is.null(x$statistic))
                cat(names(x$statistic), " = ", format(round(x$statistic, 4)),
                        ", ", sep = "")
	if(!is.null (x$parameter))
		cat(paste(names(x$parameter), " = ", format(round(x$parameter,
			3)), ",", sep = ""), "")
        cat("p-value =", format.pval(x$p.value, digits= digits), "\n")
        if(!is.null(x$alternative)) {
                if(!is.null(x$null.value)) {
                        if(length(x$null.value) == 1) {
                                if (x$alternative == "two.sided" )
					alt.char <- "not equal to"
				else if( x$alternative == "less" )
					alt.char <- "less than"
				else if( x$alternative == "greater" )
                                  	alt.char <- "greater than"
                                cat("alternative hypothesis:", "true", names(x$
                                  null.value), "is", alt.char, x$null.value,
                                  "\n")
                        }
                        else {
                                cat("alternative hypothesis:", x$alternative,
                                  "\n")
                                cat("null values:\n")
                                print(x$null.value)
                        }
                }
                else cat("alternative hypothesis:", x$alternative, "\n")
        }
        if(!is.null(x$conf.int)) {
                cat(format(100 * attr(x$conf.int, "conf.level")),
                        "percent confidence interval:\n", format(c(x$conf.int[1
                        ], x$conf.int[2])), "\n")
        }
        if(!is.null(x$estimate)) {
                cat("sample estimates:\n")
                print(x$estimate)
        }
        cat("\n")
        invisible(x)
}
identify <- function(x, ...) UseMethod("identify")
identify.default <-
    function(x, y=NULL, labels=seq(along=x), pos=FALSE,
             n=length(x), plot=TRUE, offset=0.5, ...) {
	opar <- par(list(...))
	on.exit(par(opar))
	xy <- xy.coords(x, y)
	z <- .Internal(identify(xy$x,xy$y,as.character(labels),
                                n, plot, offset))
	i <- seq(z[[1]])[z[[1]]]
	p <- z[[2]][z[[1]]]
	if(pos) list(ind=i,pos=p) else i
}
ifelse <- 
function (test, yes, no) 
{
        ans <- test
        test <- as.logical(test)
        nas <- is.na(test)
        ans[test] <- rep(yes, length = length(ans))[test]
        ans[!test] <- rep(no, length = length(ans))[!test]
        ans[nas] <- NA
        ans
}
image <- 
function (x = seq(0, 1, len = nrow(z)), y = seq(0, 1, len = ncol(z)), 
            z, zlim = range(z, finite = TRUE), xlim = range(x, finite = TRUE), 
            ylim = range(y, finite = TRUE), col = heat.colors(12), add = FALSE, 
            xaxs = "i", yaxs = "i", xlab, ylab, ...) 
{
  if (missing(z)) {
    if (!missing(x)) {
      if (is.list(x)) {
        z <- x$z; y <- x$y; x <- x$x
      } else {
        z <- x
        x <- seq(0, 1, len = nrow(z))
      }
      if (missing(xlab)) xlab <- ""
      if (missing(ylab)) ylab <- ""
    } else stop("no `z' matrix specified")
  } else if (is.list(x)) {
    xn <- deparse(substitute(x))
    if (missing(xlab)) xlab <- paste(xn, "x", sep = "$")
    if (missing(ylab)) ylab <- paste(xn, "y", sep = "$")
    y <- x$y
    x <- x$x
  } else {
    if (missing(xlab)) 
      xlab <- if (missing(x)) "" else deparse(substitute(x))
    if (missing(ylab)) 
      ylab <- if (missing(y)) "" else deparse(substitute(y))
  }
  if (any(diff(x) <= 0) || any(diff(y) <= 0)) 
    stop("increasing x and y values expected")
  if (!add) 
    plot(0, 0, xlim = xlim, ylim = ylim, type = "n", xaxs = xaxs, 
         yaxs = yaxs, xlab = xlab, ylab = ylab, ...)
  .Internal(image(as.double(x), as.double(y), as.double(z), 
                  as.double(zlim), col))
}
is.vector <- function(x, mode="any") .Internal(is.vector(x,mode))
# is.finite <- function(x) !is.na(x)
is.symbol <- function(x) typeof(x)=="symbol"
lapply <- function(x, FUN, ...) {
  if (is.character(FUN))
    FUN <- get(FUN, mode = "function")
  if (mode(FUN) != "function")
    stop(paste("\"", FUN, "\" is not a function", sep = " "))
  if (!is.list(x))
    x <- as.list(x)
  rval <- vector("list", length(x))
  for(i in seq(along = x))
    rval[i] <- list(FUN(x[[i]], ...))
  names(rval) <- names(x)               # keep `names' !
  return(rval)
}
##--- NOTE:
##    when no device is open, layout() should open the default device,
## as  par(.) does
##
## !!!!
lcm <- function(x) paste(x, "cm")#-> 3 characters (used in layout!)
layout <-
function(mat, widths=rep(1, dim(mat)[2]),
	 heights=rep(1, dim(mat)[1]), respect=FALSE)
{
	storage.mode(mat) <- "integer"
	mat <- as.matrix(mat) # or barf
	if(!is.logical(respect)) {
		respect <- as.matrix(respect)#or barf
		if(!is.matrix(respect) || any(dim(respect) != dim(mat)))
		  stop("'respect' must be logical or matrix with same dimension as 'mat'")
	}
	num.figures <- as.integer(max(mat))
	## check that each value in 1..n is mentioned
	for (i in 1:num.figures)
	  if (match(i, mat, nomatch=0) == 0)
	    stop(paste("Layout matrix must contain at least one reference\n",
		       "  to each of the values {1..n}; here  n = ",
		       num.figures,"\n", sep=""))
	dm <- dim(mat)
	num.rows <- dm[1]
	num.cols <- dm[2]
	cm.widths  <- if (is.character(widths)) grep("cm", widths)
	cm.heights <- if (is.character(heights))grep("cm", heights)
	## pad widths/heights with 1's	and remove "cm" tags
	pad1.rm.cm <- function(v, cm.v, len) {
		if ((ll <- length(v)) < len)
		  v <- c(v, rep(1, len-ll))
		if (is.character(v)) {
			wcm <- v[cm.v]
			v[cm.v] <- substring(wcm, 1, nchar(wcm)-3)
		}
		as.numeric(v)
	}
	widths	<- pad1.rm.cm(widths, cm.widths,  len = num.cols)
	heights <- pad1.rm.cm(heights,cm.heights, len = num.rows)
	if (is.matrix(respect)) {
		respect.mat <- as.integer(respect)
		respect <- 2
	} else {# respect: logical  |--> 0 or 1
		respect.mat <- matrix(as.integer(0), num.rows, num.cols)
	}
	.Internal(layout(num.rows, num.cols,
			 mat,# integer
			 as.integer(num.figures),
			 col.widths = widths,
			 row.heights = heights,
			 cm.widths,
			 cm.heights,
			 respect = as.integer(respect),
			 respect.mat))
	invisible(num.figures)
}
layout.show <- function(n=1)
{
	## show the regions that will be allocated to the next
	## n figures
	## cheat to make sure that current plot is figure 1
	oma.saved <- par("oma")
	par(oma=rep(0,4))
	par(oma=oma.saved)
	o.par <- par(mar=rep(0,4))
	on.exit(par(o.par))
	for (i in 1:n) {
		plot.new()
		box()
		text(0.5, 0.5, i)
	}
}
legend <-
function (x, y, legend, fill, col = "black", lty, lwd, pch, bty = "o",
	bg = par("bg"), cex = 1, xjust = 0, yjust = 1, x.intersp = NULL,
        y.intersp = NULL, text.width = NULL, merge = FALSE)
{
  if (missing(y)) {
    if (is.list(x)) { y <- x$y; x <- x$x } else stop("missing y")
  }
  if (!is.numeric(x) || !is.numeric(y))
    stop("non-numeric coordinates")
  if (length(x) <= 0 || length(x) != length(y))
    stop("differing coordinate lengths")
  xlog <- par("xlog")
  ylog <- par("ylog")
  rect2 <- function(left, top, dx, dy, ...) {
    r <- left + dx; if(xlog) { left <- 10^left; r <- 10^r }
    b <- top  - dy; if(ylog) {  top <- 10^top;  b <- 10^b }
    rect(left, top, r, b, ...)
  }
  segments2 <- function(x1, y1, dx, dy, ...) {
    x2 <- x1 + dx; if(xlog) { x1 <- 10^x1; x2 <- 10^x2 }
    y2 <- y1 + dy; if(ylog) { y1 <- 10^y1; y2 <- 10^y2 }
    segments(x1, y1, x2, y2, ...)
  }
  points2 <- function(x, y, ...) {
    if(xlog) x <- 10^x
    if(ylog) y <- 10^y
    points(x, y, ...)
  }
  text2 <- function(x, y, ...) {
    ##--- need to adjust  adj == c(xadj, yadj) ?? --
    if(xlog) x <- 10^x
    if(ylog) y <- 10^y
    text(x, y, ...)
  }
  cin <- par("cin")
  Cex <- cex * par("cex")  # = the 'effective' cex for text
  if(is.null(text.width))
    text.width <- max(strwidth(legend, u="user", cex=cex))
  else if(!is.numeric(text.width) || text.width < 0)
    stop("text.width must be numeric, >= 0")
  ## These defaults should  DEPEND  on  text.width (& maybe x/y log):
  if(is.null(x.intersp)) x.intersp <- min(4, 1.8 + 1.2* Cex^-1.25)
  if(is.null(y.intersp)) y.intersp <- min(2, 0.2 + Cex^-1.25)
  xc <- Cex * xinch(cin[1], warn.log=FALSE) # [uses par("usr") and "pin"]
  yc <- Cex * yinch(cin[2], warn.log=FALSE)
  xchar  <- xc
  yextra <- yc * (y.intersp - 1)
  ychar <- yextra + max(yc, strheight(legend, u="user", cex=cex))
  xbox <- xc * 0.8 ##= sizes of filled boxes.
  ybox <- yc * 0.8
  n.leg <- length(legend)
  ## -- (w,h) := (width,height) of the box to draw -- computed stepwise...
  w <- 2 * xchar + text.width
  h <- (n.leg + 1) * ychar
  if(!missing(fill))
    w <- w + (dx.fill <- xbox + xchar)
  if(!missing(pch)) {
    if(is.character(pch) && nchar(pch) > 1) {
      np <- nchar(pch)
      pch <- substr(rep(pch[1], np), 1:np, 1:np)
    }
    if(!merge) w <- w + (dx.pch <- x.intersp/2 * xchar)
  }
  do.lines <- (!missing(lty) && any(lty > 0)) || !missing(lwd)
  if(do.lines)
    if(!merge) w <- w + x.intersp * xchar
  if(merge) # we didn't add space above, so must do now
    w <- w + x.intersp * xchar
  ##
  ##-- (w,h) are now the final box width/height. --> Adjust (x,y) :
  if (xlog) x <- log10(x)
  if (ylog) y <- log10(y)
  if(length(x) != 1) { # in which situations do we need/want this ??
    x <- mean(x)
    y <- mean(y)
    xjust <- 0.5
    yjust <- 0.5
  }
  left <- x - xjust * w
  top  <- y + (1 - yjust) * h
  if (bty != "n")
    rect2(left, top, dx = w, dy = h, col = bg)
  ## (xt[],yt[]) := 'current' vectors of (x/y) legend text
  xt <- rep(left, n.leg) + xchar
  yt <- top - (1:n.leg) * ychar
  if (!missing(fill)) {                 #- draw filled boxes -------------
    rect2(xt, yt + ybox/2, dx = xbox, dy = ybox/2, col = fill)
    xt <- xt + dx.fill
  }
  col <- rep(col,length.out=n.leg)
  if (!missing(pch)) {                  #- draw points -------------------
    pch <- rep(pch,length.out=n.leg)
    ok <- is.character(pch) | pch > 0
    x1 <- (xt + ifelse(merge,0, 0.25) * xchar)[ok]
    y1 <- yt[ok]
    points2(x1, y1, pch=pch[ok], col=col[ok], cex=cex)
    if (!merge) xt <- xt + dx.pch
  }
  if (do.lines) {                       #- draw lines ---------------------
    if(missing(lty)) { lty <- 1; ok.l <- TRUE }
    else ok.l <- lty > 0
    if(missing(lwd)) lwd <- 1
    lty <- rep(lty, length.out = n.leg)
    lwd <- rep(lwd, length.out = n.leg)
    x.off <- if(merge) -0.8 else 0
    segments2(xt[ok.l] + x.off*xchar, yt[ok.l], dx= 2*xchar, dy=0,
              lty = lty[ok.l], #- next version of R: lwd = lwd[ok.l],
              col = col[ok.l])
    if (!merge) xt <- xt + 3 * xchar
  }
  if (merge) xt <- xt + x.intersp * xchar
  ## adj = (x,y) text-box adjustment
  text2(xt, yt, labels= legend, adj= c(0, 0.3*y.intersp), cex= cex)
}
require <- function(name, quietly = FALSE) {
  name <- as.character(substitute(name)) # allowing "require(eda)"
  if (!exists(".Provided", inherits = TRUE)) 
    assign(".Provided", character(0), envir = .GlobalEnv)
  if (is.na(match(paste("package", name, sep = ":"), search()))
      && is.na(match(name, .Provided))) {
    if (!quietly)
      cat("Loading required package:", name, "\n")
    library(name, char = TRUE, logical = TRUE)
  }
  else
    TRUE
}
provide <- function(name) {
  if (!exists(".Provided", inherits = TRUE)) 
    assign(".Provided", character(0), envir = .GlobalEnv)
  if (missing(name)) 
    .Provided
  else {
    name <- as.character(substitute(name))
    if (is.na(match(name, .packages())) &&
	is.na(match(name, .Provided))) {
      assign(".Provided", c(name, .Provided), envir = .GlobalEnv)
      TRUE
    }
    else
      FALSE
  }
}
.packages <- function() {
  s <- search()
  return(invisible(substring(s[substr(s, 1, 8) == "package:"], 9)))
}  
licence <- license <- function() {
cat("\nThis software is distributed under the terms of the GNU GENERAL\n")
cat("PUBLIC LICENSE Version 2, June 1991.  The terms of this license\n")
cat("are in a file called COPYING which you should have received with\n")
cat("this software.\n")
cat("\n")
cat("If you have not received a copy of this file, you can obtain one\n")
cat("by writing to:\n")
cat("\n")
cat("   The Free Software Foundation, Inc.,\n")
cat("   59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.\n")
cat("\n")
cat("``Share and Enjoy.''\n\n")
}
lines <- function(x, ...)
UseMethod("lines")
lines.default <- function(x, y=NULL, type="l", col=par("col"), ...) {
	plot.xy(xy.coords(x, y), type=type, col=col, ...)
}
lm <-
function(formula, data = list(), subset, weights, na.action,
	 method = "qr", model = TRUE, x = FALSE, y = FALSE,
	 qr = TRUE, singular.ok = TRUE, contrasts = NULL, ...)
{
	ret.x <- x
	ret.y <- y
	mt <- terms(formula, data = data)
	mf <- match.call()
	mf$singular.ok <- NULL
	mf$model <- NULL
	mf$method <- NULL
	mf$x <- mf$y <- mf$qr <- mf$contrasts <- NULL
	mf$drop.unused.levels <- TRUE
	mf[[1]] <- as.name("model.frame")
	mf <- eval(mf, sys.frame(sys.parent()))
	if (method == "model.frame")
		return(mf)
	else if (method != "qr")
		warning(paste("method =", method,
			      "is not supported. Using \"qr\"."))
	xvars <- as.character(attr(mt, "variables"))[-1]
	if(yvar <- attr(mt, "response") > 0) xvars <- xvars[-yvar]
	if(length(xvars) > 0) {
	  xlev <- lapply(mf[xvars], levels)
	  xlev <- xlev[!sapply(xlev, is.null)]
	} else xlev <- NULL
	if (length(list(...)))
		warning(paste("Extra arguments", deparse(substitute(...)),
			"are just disregarded."))
	if (!is.null(model.offset(mf)))
		stop("offset() not available in lm(), use glm()")
	if (!singular.ok)
		warning("only `singular.ok = TRUE' is currently implemented.")
	y <- model.response(mf, "numeric")
	w <- model.weights(mf)
	if (is.empty.model(mt)) {
		x <- NULL
		z <- list(coefficients = numeric(0), residuals = y,
			fitted.values = 0 * y, weights = w, rank = 0,
			df.residual = length(y))
		class(z) <-
		  if (is.matrix(y))
		    c("mlm.null", "lm.null", "mlm", "lm")
		  else c("lm.null", "lm")
	} else {
		x <- model.matrix(mt, mf, contrasts)
		z <-
		  if (is.null(w))
			lm.fit(x, y)
		  else lm.wfit(x, y, w)
		class(z) <- c(if (is.matrix(y)) "mlm", "lm")
	}
	z$contrasts <- attr(x, "contrasts")
	z$xlevels <- xlev
	z$call <- match.call()
	z$terms <- mt
	if (model)
		z$model <- mf
	if (ret.x)
	  z$x <- x
	if (ret.y)
	  z$y <- y
	z
}
lm.fit <- function (x, y, method = "qr", tol = 1e-07, ...)
{
	n <- nrow(x)
	p <- ncol(x)
	ny <- NCOL(y)
	if (NROW(y) != n)
		stop("incompatible dimensions")
	if(method != "qr")
		warning(paste("method =",method,
			      "is not supported. Using \"qr\"."))
	if(length(list(...)))
		warning(paste("Extra arguments", deparse(substitute(...)),
			      "are just disregarded."))
	z <- .Fortran("dqrls", qr = x, n = n, p = p, y = y, ny = ny,
		tol = tol, coefficients = mat.or.vec(p, ny),
		residuals = y, effects = y, rank = integer(1),
		pivot = 1:p, qraux = double(p), work = double(2*p))
	coef <- z$coefficients
	pivot <- z$pivot
	r1 <- 1:z$rank
	dn <- colnames(x)
	nmeffects <- c(dn[pivot[r1]], rep("", n - z$rank))
	if (is.matrix(y)) {
		coef[-r1, ] <- NA
		coef[pivot, ] <- coef
		dimnames(coef) <- list(dn, colnames(y))
		dimnames(z$effects) <- list(nmeffects,colnames(y))
	} else {
		coef[-r1] <- NA
		coef[pivot] <- coef
		names(coef) <- dn
		names(z$effects) <- nmeffects
	}
	z$coefficients <- coef
	c(z[c("coefficients", "residuals", "effects", "rank")],
		list(fitted.values= y - z$residuals, assign= attr(x, "assign"),
			qr = z[c("qr", "qraux", "pivot", "tol", "rank")],
			df.residual = n - z$rank))
}
lm.wfit <- function (x, y, w, method = "qr", tol = 1e-7, ...)
{
	n <- nrow(x)
	p <- ncol(x)
	ny <- NCOL(y)
	if (NROW(y) != n | length(w) != n)
		stop("incompatible dimensions")
	if (any(w < 0 | is.na(w)))
		stop("missing or negative weights not allowed")
	if(method != "qr")
		warning(paste("method =",method,
			      "is not supported. Using \"qr\"."))
	if(length(list(...)))
		warning(paste("Extra arguments", deparse(substitute(...)),
			      "are just disregarded."))
	zero.weights <- any(w == 0)
	if (zero.weights) {
		save.r <- y
		save.f <- y
		save.w <- w
		ok <- w != 0
		nok <- !ok
		w <- w[ok]
		x0 <- x[!ok, ]
		x <- x[ok, ]
		y0 <- if (ny > 1) y[!ok, , drop = FALSE] else y[!ok]
		y  <- if (ny > 1) y[ ok, , drop = FALSE] else y[ok]
	}
	n <- nrow(x)
	p <- ncol(x)
	wts <- w^0.5
	z <- .Fortran("dqrls", qr = x * wts, n = n, p = p, y = y *
		wts, ny = ny, tol = tol, coefficients = mat.or.vec(p,
		ny), residuals = y, effects = mat.or.vec(n, ny),
		rank = integer(1), pivot = 1:p, qraux = double(p),
		work = double(2 * p))
	coef <- z$coefficients
	pivot <- z$pivot
	r1 <- 1:z$rank
	dn <- colnames(x)
	nmeffects <- c(dn[pivot[r1]], rep("", n - z$rank))
	if (is.matrix(y)) {
		coef[-r1, ] <- NA
		coef[pivot, ] <- coef
		dimnames(coef) <- list(dn, colnames(y))
		dimnames(z$effects) <- list(nmeffects,colnames(y))
	} else {
		coef[-r1] <- NA
		coef[pivot] <- coef
		names(coef) <- dn
		names(z$effects) <- nmeffects
	}
	z$coefficients <- coef
	z$residuals <- z$residuals/wts
	z$fitted.values <- (y - z$residuals)
	z$weights <- w
	if (zero.weights) {
		coef[is.na(coef)] <- 0
		f0 <- x0 %*% coef
		if (ny > 1) {
			save.r[ok, ] <- z$residuals
			save.r[nok, ] <- y0 - f0
			save.f[ok, ] <- z$fitted.values
			save.f[nok, ] <- f0
		}
		else {
			save.r[ok] <- z$residuals
			save.r[nok] <- y0 - f0
			save.f[ok] <- z$fitted.values
			save.f[nok] <- f0
		}
		z$residuals <- save.r
		z$fitted.values <- save.f
		z$weights <- save.w
	}
	c(z[c("coefficients", "residuals", "fitted.values", "effects",
		"weights", "rank")], list(assign = attr(x, "assign"),
		qr = z[c("qr", "qraux", "pivot", "tol", "rank")],
		df.residual = n - z$rank))
}
print.lm <- function(x, digits = max(3, .Options$digits - 3), ...)
{
	cat("\nCall:\n",deparse(x$call),"\n\n",sep="")
	cat("Coefficients:\n")
	print.default(format(coef(x), digits=digits),
		      print.gap = 2, quote = FALSE)
	cat("\n")
	invisible(x)
}
summary.lm <- function (object, correlation = FALSE)
{
	z <- .Alias(object)
	Qr <- .Alias(object$qr)
	n <- NROW(Qr$qr)
	p <- z$rank
	rdf <- n - p
	p1 <- 1:p
	r <- resid(z)
	f <- fitted(z)
	w <- weights(z)
	if (is.null(z$terms)) {
		stop("invalid \'lm\' object:  no terms component")
	} else {
		if (is.null(w)) {
			mss <- if (attr(z$terms, "intercept"))
				sum((f - mean(f))^2) else sum(f^2)
			rss <- sum(r^2)
		} else {
			mss <- if (attr(z$terms, "intercept")) {
				m <- sum(w * f /sum(w))
				sum(w * (f - m)^2)
			} else sum(w * f^2)
			rss <- sum(w * r^2)
			r <- sqrt(w) * r
		}
	}
	resvar <- rss/rdf
	R <- chol2inv(Qr$qr[p1, p1, drop = FALSE])
	se <- sqrt(diag(R) * resvar)
	est <- z$coefficients[Qr$pivot[p1]]
	tval <- est/se
	ans <- z[c("call", "terms")]
	ans$residuals <- r
	ans$coefficients <- cbind(est, se, tval, 2*(1 - pt(abs(tval), rdf)))
	dimnames(ans$coefficients)<-list(names(z$coefficients)[Qr$pivot[p1]],
		c("Estimate", "Std. Error", "t value", "Pr(>|t|)"))
	ans$sigma <- sqrt(resvar)
	ans$df <- c(p, rdf, NCOL(Qr$qr))
	if (p != attr(z$terms, "intercept")) {
		df.int <- if (attr(z$terms, "intercept")) 1 else 0
		ans$r.squared <- mss/(mss + rss)
		ans$adj.r.squared <- 1 - (1 - ans$r.squared) *
			((n - df.int)/rdf)
		ans$fstatistic <- c(value = (mss/(p - df.int))/resvar,
				    numdf = p - df.int, dendf = rdf)
	}
	ans$cov.unscaled <- R
	dimnames(ans$cov.unscaled) <- dimnames(ans$coefficients)[c(1,1)]
	if (correlation) {
		ans$correlation <- (R * resvar)/outer(se, se)
		dimnames(ans$correlation) <- dimnames(ans$cov.unscaled)
	}
	class(ans) <- "summary.lm"
	ans
}
print.summary.lm <- function (x, digits = max(3, .Options$digits - 3),
	symbolic.cor = p > 4, signif.stars= .Options$show.signif.stars,	...)
{
	cat("\nCall:\n")#S: ' ' instead of '\n'
	cat(paste(deparse(x$call), sep="\n", collapse = "\n"), "\n\n", sep="")
	resid <- x$residuals
	df <- x$df
	rdf <- df[2]
	cat("Residuals:\n")
	if (rdf > 5) {
		nam <- c("Min", "1Q", "Median", "3Q", "Max")
		rq <- if (length(dim(resid)) == 2)
			structure(apply(t(resid), 1, quantile),
				  dimnames = list(nam, dimnames(resid)[[2]]))
		else  structure(quantile(resid), names = nam)
		print(rq, digits = digits, ...)
	}
	else if (rdf > 0) {
		print(resid, digits = digits, ...)
	}
	if (nsingular <- df[3] - df[1])
		cat("\nCoefficients: (", nsingular,
		    " not defined because of singularities)\n", sep = "")
	else cat("\nCoefficients:\n")
	print.coefmat(x$coef, digits=digits, signif.stars=signif.stars, ...)
	##
	cat("\nResidual standard error:", format(signif(x$sigma,
		digits)), "on", rdf, "degrees of freedom\n")
	if (!is.null(x$fstatistic)) {
		cat("Multiple R-Squared:", formatC(x$r.squared, digits=digits))
		cat(",\tAdjusted R-squared:",formatC(x$adj.r.squared,d=digits),
		    "\nF-statistic:", formatC(x$fstatistic[1], digits=digits),
		    "on", x$fstatistic[2], "and",
		    x$fstatistic[3], "degrees of freedom,\tp-value:",
		    formatC(1 - pf(x$fstatistic[1], x$fstatistic[2],
				   x$fstatistic[3]), dig=digits),
		    "\n")
	}
	correl <- x$correlation
	if (!is.null(correl)) {
		p <- dim(correl)[2]
		if (p > 1) {
			cat("\nCorrelation of Coefficients:\n")
			if(symbolic.cor)
				print(symnum(correl)[-1,-p])
			else {
				correl[!lower.tri(correl)] <- NA
				print(correl[-1, -p],
				      digits = digits, na = "")
			}
		}
	}
	cat("\n")#- not in S
	invisible(x)
}
## Commented by KH on 1998/07/10
## update.default() should be more general now ...
## update.lm <- function(lm.obj, formula, data, weights, subset, na.action)
## {
##	call <- lm.obj$call
##	if(!missing(formula))
##		call$formula <- update.formula(call$formula, formula)
##	if(!missing(data))	call$data <- substitute(data)
##	if(!missing(subset))	call$subset <- substitute(subset)
##	if(!missing(na.action)) call$na.action <- substitute(na.action)
##	if (!missing(weights))	call$weights<-substitute(weights)
##	eval(call, sys.frame(sys.parent()))
## }
residuals.lm <- function(x) x$residuals
fitted.lm <- function(x) x$fitted.values
coef.lm <- function(x) x$coefficients
weights.lm <- function(x) x$weights
df.residual.lm <- function(x) x$df.residual
deviance.lm <- function(x) sum((x$residuals)^2)
formula.lm <- function(x) formula(x$terms)
family.lm <- function(x) { gaussian() }
model.frame.lm <-
function(formula, data, na.action, ...) {
  if (is.null(formula$model)) {
    fcall <- formula$call
    fcall$method <- "model.frame"
    fcall[[1]] <- as.name("lm")
    eval(fcall, sys.frame(sys.parent()))
  }
  else formula$model
}
variable.names.lm <- function(obj, full=FALSE)
{
	if(full)dimnames(obj$qr$qr)[[2]]
	else	dimnames(obj$qr$qr)[[2]][1:obj$rank]
}
case.names.lm <- function(obj, full=FALSE)
{
	w <- weights(obj)
	dn <- .Alias(names(obj$residuals))
	if(full || is.null(w)) dn else dn[w!=0]
}
anova.lm <- function(object, ...)
{
	if(length(list(object, ...)) > 1)
		return(anovalist.lm(object, ...))
	w <- weights(object)
	ssr <- if(is.null(w)) sum(resid(object)^2) else sum(w*resid(object)^2)
	p1 <- 1:object$rank
	comp <- object$effects[p1]
	asgn <- object$assign[object$qr$pivot][p1]
	dfr <- df.residual(object)
	ss <- c(as.numeric(lapply(split(comp^2,asgn),sum)),ssr)
	df <- c(as.numeric(lapply(split(asgn,  asgn),length)), dfr)
	if(attr(object$terms,"intercept")) {
		ss <- ss[-1]
		df <- df[-1]
	}
	ms <- ss/df
	f <- ms/(ssr/dfr)
	p <- 1 - pf(f,df,dfr)
	table <- cbind(df,ss,ms,f,p)
	table[length(p),4:5] <- NA
	dimnames(table) <- list(c(attr(object$terms,"term.labels"), "Residual"),
				c("Df","Sum Sq", "Mean Sq", "F", "Pr(>F)"))
	result <- list(table=table,
		       title=paste("Analysis of Variance Table\nResponse:",
			 formula(object)[[2]]))
	class(result) <- "tabular"
	result
}
anovalist.lm <- function (object, ..., test = NULL)
{
	objects <- list(object, ...)
	responses <- as.character(lapply(objects,
		function(x) as.character(x$terms[[2]])))
	sameresp <- responses == responses[1]
	if (!all(sameresp)) {
		objects <- objects[sameresp]
		warning(paste("Models with response",
			deparse(responses[!sameresp]),
			"removed because response differs from", "model 1"))
	}
	## calculate the number of models
	nmodels <- length(objects)
	if (nmodels == 1)
		return(anova.lm(object))
	models <- as.character(lapply(objects, function(x) x$terms))
	## extract statistics
	df.r <- unlist(lapply(objects, df.residual))
	ss.r <- unlist(lapply(objects, deviance))
	df <- c(NA, -diff(df.r))
	ss <- c(NA, -diff(ss.r))
	ms <- ss/df
	f <- p <- rep(NA,nmodels)
	for(i in 2:nmodels) {
		if(df[i] > 0) {
			f[i] <- ms[i]/(ss.r[i]/df.r[i])
			p[i] <- 1 - pf(f[i], df[i], df.r[i])
		}
		else {
			f[i] <- ms[i]/(ss.r[i-1]/df.r[i-1])
			p[i] <- 1 - pf(f[i], -df[i], df.r[i-1])
		}
	}
	table <- cbind(df.r,ss.r,df,ss,f,p)
	dimnames(table) <- list(1:nmodels, c("Res.Df", "Res.Sum-Sq", "Df",
		"Sum-Sq", "F", "Pr(>F)"))
	## construct table and title
	title <- "Analysis of Variance Table"
	topnote <- paste("Model ", format(1:nmodels),": ",
				models, sep="", collapse="\n")
	## calculate test statistic if needed
	output <- list(table = table, title = title, topnote=topnote)
	class(output) <- "tabular"
	return(output)
}
print.anova.lm <- function(x, digits = max(3, .Options$digits - 3), ...)
{
	cat("\nAnalysis of Variance:\n\n")
	print.default(round(unclass(x), digits), na="", print.gap=2)
	cat("\n")
	invisible(x)
}
predict.lm <- function(object, newdata,
    se.fit = FALSE, scale = NULL, df = Inf,
    interval=c("none","confidence","prediction"), level=.95)
{
  if(missing(newdata)) X <- model.matrix(object)
  else
    X <- model.matrix(delete.response(terms(object)), newdata,
		      contrasts = object$contrasts, xlev = object$xlevels)
  n <- NROW(object$qr$qr)
  p <- object$rank
  p1 <- 1:p
  piv <- object$qr$pivot[p1]
  est <- object$coefficients[piv]
  predictor <- drop(X[, piv, drop = FALSE] %*% est)
  interval <- match.arg(interval)
  if(se.fit || interval != "none") {
    if (is.null(scale)){
      r <- resid(object)
      f <- fitted(object)
      w <- weights(object)
      if (is.null(w)) rss <- sum(r^2)
      else rss <- sum(r^2 * w)
      df <- n - p
      res.var <- rss/df
    } else
      res.var <- scale^2
    R <- chol2inv(object$qr$qr[p1, p1, drop = FALSE])
    vcov <- res.var * R
    ip <- real(NROW(X))
    for (i in (1:NROW(X))) {
      xi <- X[i, piv]
      ip[i] <- xi %*% vcov %*% xi
    }
  }
  if (interval != "none")
  {
    tfrac <- qt((1 - level)/2,df)
    w <- tfrac * switch(interval,
	confidence=sqrt(ip),
	prediction=sqrt(ip+res.var)
    )
    predictor<-cbind(predictor,predictor+
      w %o% c(1,-1))
    colnames(predictor) <- c("fit","lwr","upr")
  }
  if (se.fit)
    list(fit = predictor, se.fit = sqrt(ip),
      df = df, residual.scale = sqrt(res.var))
  else predictor
}
effects.lm <-
function(object, set.sign = FALSE)
{
  eff <- object$effects
  if(set.sign) {
    dd <- coef(object)
    if(is.matrix(eff)) {
      r <- 1:dim(dd)[1]
      eff[r,  ] <- sign(dd) * abs(eff[r,  ])
    } else {
      r <- 1:length(dd)
      eff[r] <- sign(dd) * abs(eff[r])
    }
  }
  structure(eff, assign = object$assign, class = "coef")
}
## Old version below, did it ever work?
## effects.lm <- function(z, term) {
##  term <- deparse(substitute(term))
##  k <- match(term,attr(z$terms,"term.labels"))
##  if(is.na(k)) stop("effect not found")
##  pattern <- attr(z$terms,"factors")[,k]
##  factors <- as.logical(lapply(z$model.frame,is.factor))
##  y <- model.response(z$model.frame,"numeric")
##  k <- range(seq(length(z$assign))[z$assign==k])
##  yhat0 <- if(k[1] > 1) qr.fitted(z$qr,y,k[1]-1) else 0
##  yhat1 <- qr.fitted(z$qr,y,k[2])
##  effects <- yhat1-yhat0
##  tapply(effects,z$model.frame[factors & pattern!=0],mean,na.rm=TRUE)
##}
plot.lm <- function(...) .NotYetImplemented()
model.matrix.lm <- function(object, ...)
{
  if(n <- match("x", names(object), 0)) object[[n]]
  else {
    data <- model.frame(object, xlev = object$xlevels, ...)
    NextMethod("model.matrix", data = data, contrasts = object$contrasts)
  }
}
predict.mlm <-
function(fit, newdata, se.fit = FALSE)
{
  if(missing(newdata)) return(fit$fitted)
  if(se.fit)
    stop("The\"se.fit\" argument is not currently implemented for mlm objects")
  x <- model.matrix(fit, newdata) # will use model.matrix.lm
  piv <- object$qr$pivot[1:object$rank]
  pred <- X[, piv, drop = FALSE] %*% object$coefficients[piv,]
  if(inherits(fit, "mlm")) pred else pred[, 1]
}
hat <- function(x, intercept = TRUE)
{
	if(is.qr(x)) n <- nrow(x$qr)
	else {
		if(intercept) x <- cbind(1, x)
		n <- nrow(x)
		x <- qr(x)
	}
	apply(qr.qy(x, diag(1, nrow = n, ncol = x$rank))^2, 1, sum)
}
weighted.residuals <- function(obj)
{
	w <- weights(obj)
	if(is.null(w)) residuals(obj)
	else (sqrt(w)*residuals(obj))[w!=0]
}
lm.influence <- function (lm.obj)
{
	if (is.empty.model(lm.obj$terms)) {
		warning("Can\'t compute influence on an empty model")
		return(NULL)
	}
	n<-as.integer(nrow(lm.obj$qr$qr))
	k <- as.integer(lm.obj$qr$rank)
	e <- weighted.residuals(lm.obj)
	.Fortran("lminfl",
		lm.obj$qr$qr,
		n,
		n,
		k,
		lm.obj$qr$qraux,
		lm.obj$coefficients,
		e,
		hat = double(n),
		coefficients = matrix(0, nr = n, nc = k),
		sigma = double(n),
		DUP = FALSE)[c("hat", "coefficients", "sigma")]
}
rstudent <- function(lm.obj)
{
	infl <- lm.influence(lm.obj)
	weighted.residuals(lm.obj)/(infl$sigma * sqrt(1 - infl$hat))
}
dfbetas <- function (lm.obj)
{
	infl <- lm.influence(lm.obj)
	xxi <- chol2inv(lm.obj$qr$qr, lm.obj$qr$rank)
	d <- infl$coefficients/(outer(infl$sigma, sqrt(diag(xxi))))
	dimnames(d) <- list(case.names(lm.obj), variable.names(lm.obj))
	d
}
dffits <- function(lm.obj)
{
	infl <- lm.influence(lm.obj)
	sqrt(infl$hat)*residuals(lm.obj)/(infl$sigma*(1-infl$hat))
}
covratio <- function(lm.obj)
{
	infl <- lm.influence(lm.obj)
	n <- nrow(lm.obj$qr$qr)
	p <- lm.obj$rank
	e.star <- residuals(lm.obj)/(infl$sigma*sqrt(1-infl$hat))
	1/((((n - p - 1)+e.star^2)/(n - p))^p*(1-infl$hat))
}
cooks.distance <- function(lm.obj)
{
	p <- lm.obj$rank
	e <- weighted.residuals(lm.obj)
	s <- sqrt(sum(e^2)/df.residual(lm.obj))
	h <- lm.influence(lm.obj)$hat
	((e/(s * (1 - h)))^2 * h)/p
}
influence.measures <- function(lm.obj)
{
	is.influential <- function(infmat)
	{
		## Argument is result of using influence.measures
		## Returns a matrix  of logicals structured like the argument
		n <- nrow(infmat)
		k <- ncol(infmat) - 4
		if(n <= k)
			stop("Too few cases, n < k")
		absmat <- abs(infmat)
		result <- cbind(absmat[, 1:k] > 1,
				absmat[, k + 1] > 3 * sqrt(k/(n - k)),
				abs(1 - infmat[, k + 2]) > (3 * k)/(n - k),
				qf(infmat[, k + 3], k, n - k) > 0.9,
				infmat[, k + 4] > (3 * k)/n)
		dimnames(result) <- dimnames(infmat)
		result
	}
	infl <- lm.influence(lm.obj)
	p <- lm.obj$rank
	e <- weighted.residuals(lm.obj)
	s <- sqrt(sum(e^2)/df.residual(lm.obj))
	xxi <- chol2inv(lm.obj$qr$qr, lm.obj$qr$rank)
	si <- infl$sigma
	h <- infl$hat
	dfbetas <- infl$coefficients / outer(infl$sigma, sqrt(diag(xxi)))
	vn <- variable.names(lm.obj); vn[vn == "(Intercept)"] <- "1_"
	colnames(dfbetas) <- paste("dfb",abbreviate(vn),sep=".")
	dffits <- e*sqrt(h)/(si*(1-h))
	cov.ratio <- (si/s)^(2 * p)/(1 - h)
	cooks.d <- ((e/(s * (1 - h)))^2 * h)/p
	dn <- dimnames(lm.obj$qr$qr)
	infmat <- cbind(dfbetas, dffit = dffits, cov.r = cov.ratio,
			cook.d = cooks.d, hat=h)
	is.inf <- is.influential(infmat)
	##is.star <- apply(is.inf, 1, any)
	ans <- list(infmat = infmat, is.inf = is.inf, call = lm.obj$call)
	class(ans) <- "infl"
	ans
}
print.infl <- function(x, digits = max(3, .Options$digits - 4), ...)
{
	## `x' : as the result of  influence.measures(.)
	cat("Influence measures of\n\t", deparse(x$call),":\n\n")
	is.star <- apply(x$is.inf, 1, any)
	print(data.frame(x$infmat,
			 inf = ifelse(is.star, "*", " ")),
	      digits = digits, ...)
	invisible(x)
}
summary.infl <- function(object, digits = max(2, .Options$digits - 5), ...)
{
	## object must be as the result of  influence.measures(.)
	is.inf <- object$is.inf
	is.star <- apply(is.inf, 1, any)
	is.inf <- is.inf[is.star,]
	cat("Potentially influential observations of\n\t",
	    deparse(object$call),":\n")
	if(any(is.star)) {
		imat <- object $ infmat[is.star,, drop = FALSE]
		if(is.null(rownam <- dimnames(object $ infmat)[[1]]))
		  rownam <- format(seq(is.star))
		dimnames(imat)[[1]] <- rownam[is.star]
		chmat <- format(round(imat, digits = digits))
		cat("\n")
		print(array(paste(chmat,c("","_*")[1+is.inf], sep=''),
			    dimnames = dimnames(imat), dim=dim(imat)),
		      quote = FALSE)
		invisible(imat)
	} else {
		cat("NONE\n")
		numeric(0)
	}
}
"anova.lm.null" <-
function (object, ...) 
{
        if (length(list(object, ...)) > 1) 
                return(anovalist.lm(object, ...))
        w <- weights(object)
        if (is.null(w)) 
                ssr <- sum(resid(object)^2)
        else ssr <- sum(w * resid(object)^2)
        #comp <- object$effects[1:object$rank]
        #asgn <- object$assign[object$qr$pivot][1:object$rank]
        dfr <- df.residual(object)
        ss <- ssr
        df <- dfr
        ms <- ss/df
        f <- ms/(ssr/dfr)
        p <- 1 - pf(f, df, dfr)
        table <- cbind(df, ss, ms, f, p)
        table[length(p), 4:5] <- NA
        dimnames(table) <- list(c(attr(object$terms, "term.labels"), 
                "Residual"), c("Df", "Sum Sq", "Mean Sq", "F", 
                "Pr(>F)"))
        result <- list(table = table, title = "Analysis of Variance Table")
        class(result) <- "tabular"
        result
}
"print.lm.null" <-
function (x, digits = max(3, .Options$digits - 3), ...) 
{
        cat("\nCall:\n", deparse(x$call), "\n\n", sep = "")
        cat("No coefficients:\n")
        ###print(coef(x))
        cat("\n")
}
"print.summary.lm.null" <-
function (x, digits = max(3, .Options$digits - 3), ...) 
{
        cat("\nCall:\n")
        cat(paste(deparse(x$call), sep = "\n", collapse = "\n"), 
                "\n\n", sep = "")
        resid <- x$residuals
        df <- x$df
        rdf <- df[2]
        if (rdf > 5) {
                cat("Residuals:\n")
                if (length(dim(resid)) == 2) {
                        rq <- apply(t(resid), 1, quantile)
                        dimnames(rq) <- list(c("Min", "1Q", "Median", 
                                "3Q", "Max"), dimnames(resid)[[2]])
                }
                else {
                        rq <- quantile(resid)
                        names(rq) <- c("Min", "1Q", "Median", 
                                "3Q", "Max")
                }
                print(rq, digits = digits, ...)
        }
        else if (rdf > 0) {
                cat("Residuals:\n")
                print(resid, digits = digits, ...)
        }
        else cat("\nNo Coefficients:\n")
        cat("\nResidual standard error:", format(signif(x$sigma, 
                digits)), "on", rdf, "degrees of freedom\n")
        cat("\n")
        invisible(x)
}
"summary.lm.null" <-
function (z, correlation = FALSE) 
{
        n <- length(z$fitted.values)
        p <- 0
        r <- resid(z)
        f <- fitted(z)
        w <- weights(z)
        if (is.null(z$terms)) {
                stop("invalid \'lm\' object:  no terms component")
        }
        else {
                rss <- sum(r^2)
                mss <- sum(f^2)
        }
        resvar <- rss/(n - p)
        ###R <- chol2inv(z$qr$qr[p1, p1, drop = FALSE])
        ###se <- sqrt(diag(R) * resvar)
        ###est <- z$coefficients[z$qr$pivot[p1]]
        ###tval <- est/se
        ans <- z[c("call", "terms")]
        ans$residuals <- r
        ans$coefficients <- NULL
        ans$sigma <- sqrt(resvar)
        ans$df <- c(p, n - p, n - p)
        ans$r.squared <- 0
        ans$cov.unscaled <- NULL
        class(ans) <- "summary.lm.null"
        ans
}
load <- function(file) 
	.Internal(load(file))
save <- function(..., list = character(0), file = "", ascii = FALSE) {
	names <- as.character( substitute( list(...)))[-1]
	list<- c(list, names)
	invisible(.Internal(save( list, file, ascii)))
}
save.image <- function (f = ".RData") 
    eval(substitute(save(list = ls(), file = f)), .GlobalEnv)
locator <- function(n=1) {
	z <- .Internal(locator(n))
	x <- z[[1]]
	y <- z[[2]]
	n <- z[[3]]
	if(n==0) NULL else list(x=x[1:n],y=y[1:n])
}
log10 <- function(x) log(x,10)
log2 <- function(x) log(x,2)
lower.tri <- function(x, diag = FALSE)
{
	x <- as.matrix(x)
        if(diag) row(x) >= col(x)
        else row(x) > col(x)
}
lowess <- function(x, y=NULL, f=2/3, iter=3, delta=.01*diff(range(xy$x[o]))) {
	xy <- xy.coords(x,y)
	if(length(xy$x) != length(xy$y)) stop("x and y lengths differ")
	n <- length(xy$x)
	o <- order(xy$x)
	.C("lowess",
		x=as.double(xy$x[o]),
		as.double(xy$y[o]),
		n,
		as.double(f),
		as.integer(iter),
		as.double(delta),
		y=double(n),
		double(n),
		double(n))[c("x","y")]
}
lsfit <- function(x, y, wt=NULL, intercept=TRUE, tolerance=1e-07, yname=NULL)
{
	# find names of x variables (design matrix)
	x <- as.matrix(x)
	y <- as.matrix(y)
	xnames <- colnames(x)
	if( is.null(xnames) ) {
		if(ncol(x)==1) xnames <- "X"
		else xnames <- paste("X", 1:ncol(x), sep="")
	}
	if( intercept ) {
		x <- cbind(1, x)
		xnames <- c("Intercept", xnames)
	}
	# find names of y variables (responses)
	if(is.null(yname) && ncol(y) > 1) yname <- paste("Y", 1:ncol(y), sep="")
	# remove missing values
	good <- complete.cases(x, y, wt)
	dimy <- dim(as.matrix(y))
	if( any(!good) ) {
		warning(paste(sum(!good), "missing values deleted"))
		x <- as.matrix(x)[good, ]
		y <- as.matrix(y)[good, ]
		wt <- wt[good]
	}
	# check for compatible lengths
	nrx <- NROW(x)
	ncx <- NCOL(x)
	nry <- NROW(y)
	ncy <- NCOL(y)
	nwts <- length(wt)
	if(nry != nrx) stop(paste("X matrix has", nrx, "responses, Y",
			"has", nry, "responses."))
	if(nry < ncx) stop(paste(nry, "responses, but only", ncx, "variables"))
	# check weights if necessary
	if( !is.null(wt) ) {
		if(any(wt < 0)) stop("negative weights not allowed")
		if(nwts != nry) stop(paste("Number of weights =", nwts,
				", should equal", nry, "(number of responses)"))
		wtmult <- wt^0.5
		if( any(wt==0) ) {
			xzero <- as.matrix(x)[wt==0, ]
			yzero <- as.matrix(y)[wt==0, ]
		}
		x <- x*wtmult
		y <- y*wtmult
		invmult <- 1/ifelse(wt==0, 1, wtmult)
	}
	# call linpack
	storage.mode(x) <- "double"
	storage.mode(y) <- "double"
	z <- .Fortran("dqrls",
		qr=x,
		n=nrx,
		p=ncx,
		y=y,
		ny=ncy,
		tol=tolerance,
		coefficients=mat.or.vec(ncx, ncy),
		residuals=mat.or.vec(nrx, ncy),
		effects=mat.or.vec(nrx, ncy),
		rank=integer(1),
		pivot=as.integer(1:ncx),
		qraux=double(ncx),
		work=double(2*ncx))
	# dimension and name output from linpack
	resids <- array(NA, dim=dimy)
	dim(z$residuals) <- c(nry, ncy)
	if(!is.null(wt)) {
		if(any(wt==0)) {
			if(ncx==1) fitted.zeros <- xzero * z$coefficients
			else fitted.zeros <- xzero %*% z$coefficients
			z$residuals[wt==0, ] <- yzero - fitted.zeros
		}
		z$residuals <- z$residuals*invmult
	}
	resids[good, ] <- z$residuals
	if(dimy[2] == 1 && is.null(yname)) {
		resids <- as.vector(resids)
		names(z$coefficients) <- xnames
	}
	else {
		colnames(resids) <- yname
		colnames(z$effects) <- yname
		dim(z$coefficients) <- c(ncx, ncy)
		dimnames(z$coefficients) <- list(xnames, yname)
	}
	z$qr <- as.matrix(z$qr)
	colnames(z$qr) <- xnames
	output <- list(coefficients=z$coefficients, residuals=resids)
	# if X matrix was collinear, then the columns would have been
	# pivoted hence xnames need to be corrected
	if( z$rank != ncx ) {
		xnames <- xnames[z$pivot]
		dimnames(z$qr) <- list(NULL, xnames)
		warning("X matrix was collinear")
	}
	# return weights if necessary
	if (!is.null(wt) ) {
		weights <- rep(NA, dimy[1])
		weights[good] <- wt
		output <- c(output, list(wt=weights))
	}
	# return rest of output
	rqr <- list(qt=z$effects, qr=z$qr, qraux=z$qraux, rank=z$rank,
		pivot=z$pivot, tol=z$tol)
	output <- c(output, list(intercept=intercept, qr=rqr))
	return(output)
}
ls.diag <- function(ls.out)
{
	resids <- as.matrix(ls.out$residuals)
	xnames <- colnames(ls.out$qr$qr)
	yname <- colnames(resids)
	# remove any missing values
	good <- complete.cases(resids, ls.out$wt)
	if( any(!good) ) {
		warning("missing observations deleted")
		resids <- as.matrix(resids)[good, ]
	}
	# adjust residuals if needed
	if( !is.null(ls.out$wt) ) {
		if( any(ls.out$wt[good] == 0) )
			warning(paste("Observations with 0 weight not used in",
				"calculating standard deviation"))
		resids <- resids * ls.out$wt[good]^0.5
	}
	# initialize
	p <- ls.out$qr$rank
	n <- nrow(resids)
	hatdiag <- rep(NA, n)
	stats <- array(NA, dim = dim(resids))
	colnames(stats) <- yname
	stdres <- studres <- dfits <- Cooks <- stats
	# calculate hat matrix diagonals
	q <- qr.qy(ls.out$qr, rbind(diag(p), matrix(0, nrow=n-p, ncol=p)))
	hatdiag[good] <- apply(as.matrix(q^2), 1, sum)
	# calculate diagnostics
	stddev <- (apply(as.matrix(resids^2), 2, sum)/(n - p))^0.5
	stddevmat <- matrix(stddev, nrow=sum(good), ncol=ncol(resids), byrow=TRUE)
	stdres[good, ] <- resids/((1-hatdiag[good])^0.5 * stddevmat)
	studres[good, ] <- (stdres[good, ]*stddevmat)/(((n-p)*stddevmat^2 -
		resids^2/(1-hatdiag[good]))/(n-p-1))^0.5
	dfits[good, ] <- (hatdiag[good]/(1-hatdiag[good]))^0.5 * studres[good, ]
	Cooks[good, ] <- ((stdres[good, ]^2 * hatdiag[good])/p)/(1-hatdiag[good])
	if(ncol(resids)==1 && is.null(yname)) {
		stdres <- as.vector(stdres)
		Cooks <- as.vector(Cooks)
		studres <- as.vector(studres)
		dfits <- as.vector(dfits)
	}
	# calculate unscaled covariance matrix
	qr <- as.matrix(ls.out$qr$qr[1:p, 1:p])
	qr[row(qr)>col(qr)] <- 0
	qrinv <- solve(qr)
	covmat.unscaled <- qrinv%*%t(qrinv)
	dimnames(covmat.unscaled) <- list(xnames, xnames)
	# calculate scaled covariance matrix
	covmat.scaled <- sum(stddev^2) * covmat.unscaled
	# calculate correlation matrix
	cormat <- covmat.scaled/
		(outer(diag(covmat.scaled), diag(covmat.scaled))^0.5)
	# calculate standard error
	stderr <- outer(diag(covmat.unscaled)^0.5, stddev)
	dimnames(stderr) <- list(xnames, yname)
	return(list(std.dev=stddev, hat=hatdiag, std.res=stdres,
		stud.res=studres, cooks=Cooks, dfits=dfits,
		correlation=cormat, std.err=stderr,
		cov.scaled=covmat.scaled, cov.unscaled=covmat.unscaled))
}
ls.print <- function(ls.out, digits=4, print.it=TRUE)
{
	# calculate residuals to be used
	resids <- as.matrix(ls.out$residuals)
	if( !is.null(ls.out$wt) ) {
		if(any(ls.out$wt == 0))
			warning("Observations with 0 weights not used")
		resids <- resids * ls.out$wt^0.5
	}
	n <- apply(resids, 2, length)-apply(is.na(resids), 2, sum)
	lsqr <- ls.out$qr
	p <- lsqr$rank
	# calculate total sum sq and df
	if(ls.out$intercept) {
		if(is.matrix(lsqr$qt))
			totss <- apply(lsqr$qt[-1, ]^2, 2, sum)
		else totss <- sum(lsqr$qt[-1]^2)
		degfree <- p - 1
	} else {
		totss <- apply(as.matrix(lsqr$qt^2), 2, sum)
		degfree <- p
	}
	# calculate residual sum sq and regression sum sq
	resss <- apply(resids^2, 2, sum, na.rm=TRUE)
	resse <- (resss/(n-p))^.5
	regss <- totss - resss
	rsquared <- regss/totss
	fstat <- (regss/degfree)/(resss/(n-p))
	pvalue <- 1 - pf(fstat, degfree, (n-p))
	# construct summary
	Ynames <- colnames(resids)
	summary <- cbind(format(round(resse, digits)), format(round(rsquared,
		digits)), format(round(fstat, digits)), format(degfree), format(
		n-p), format(round(pvalue, digits)))
	dimnames(summary) <- list(Ynames, c("Mean Sum Sq",
		"R Squared", "F-value", "Df 1", "Df 2", "Pr(>F)"))
	mat <- as.matrix(lsqr$qr[1:p, 1:p])
	mat[row(mat)>col(mat)] <- 0
	qrinv <- solve(mat)
	# construct coef table
	m.y <- ncol(resids)
	coef.table <- as.list(1:m.y)
	if(m.y==1) coef <- matrix(ls.out$coef, nc=1)
	else coef <- ls.out$coef
	for(i in 1:m.y) {
		covmat <- (resss[i]/(n[i]-p)) * (qrinv%*%t(qrinv))
		coef.table[[i]] <- cbind(coef[, i], diag(covmat)^.5,
			coef[, i]/diag(covmat)^.5,
			2*(1 - pt(abs(coef[, i]/diag(covmat)^.5), n[i]-p)))
		dimnames(coef.table[[i]]) <- list(colnames(lsqr$qr),
			c("Estimate", "Std.Err", "t-value", "Pr(>|t|)"))
		##-- print results --
		if(print.it) {
			if(m.y>1)
				cat("Response:", Ynames[i], "\n\n")
			cat(paste("Residual Standard Error=", format(round(
				resse[i], digits)), "\nR-Square=", format(round(
				rsquared[i], digits)), "\nF-statistic (df=",
				format(degfree), ", ", format(n[i]-p), ")=",
				format(round(fstat[i], digits)), "\np-value=",
				format(round(pvalue[i], digits)), "\n\n", sep=""))
			print(round(coef.table[[i]], digits))
			cat("\n\n")
		}
	}
	names(coef.table) <- Ynames
	invisible(list(summary=summary, coef.table=coef.table))
}
macintosh <- function() .Internal(device("Macintosh","",c(0,0,0)))
mad <- function(y, center, constant = 1.4826, na.rm = FALSE) {
	if(na.rm)
		y <- y[!is.na(y)]
	if(missing(center))
		constant * (median(abs(y - median(y))))
	else constant * (median(abs(y - center)))
}
mahalanobis <- function(x, center, cov, inverted=FALSE)
{
  x <- if(is.vector(x)) matrix(x, ncol=length(x)) else as.matrix(x)
  x <- sweep(x, 2, center)# = (x - center)
  if(!inverted)
    cov <- solve(cov)
  retval <- apply((x%*%cov) * x, 1, sum)
  names(retval) <- rownames(x)
  retval
}
match <- function(x, table, nomatch=NA)
  .Internal(match(as.character(x), as.character(table), nomatch))
match.call <-
function(definition=NULL, call=sys.call(sys.parent()), expand.dots=TRUE)
        .Internal(match.call(definition,call,expand.dots))
pmatch <-
function(x, table, nomatch=NA, duplicates.ok=FALSE)
{
	y <- .Internal(pmatch(x,table,duplicates.ok))
	y[y == 0] <- nomatch
	y
}
"%in%" <- function(x, y)
match(x, y, nomatch = 0) > 0
match.arg <- function (arg, choices) {
  if (missing(choices)) {
    formal.args <- formals(sys.function(sys.parent()))
    choices <- eval(formal.args[[deparse(substitute(arg))]])
  }
  if (all(arg == choices)) return(choices[1])
  i <- pmatch(arg, choices)
  if (is.na(i)) 
    stop(paste("ARG should be one of", paste(choices, collapse = ", "), 
               sep = " "))
  if (length(i) > 1) stop("there is more than one match in match.arg")
  choices[i]
}
charmatch <-
function(x, table, nomatch=NA)
{
	y <- .Internal(charmatch(x,table))
	y[is.na(y)] <- nomatch
	y
}
char.expand <-
function(input, target, nomatch = stop("no match"))
{
	if(length(input) != 1)
		stop("char.expand: input must have length 1")
	if(!(is.character(input) && is.character(target)))
		stop("char.expand: input must be character")
	y <- .Internal(charmatch(input,target))
	if(any(is.na(y))) eval(nomatch)
	target[y]
}
###---- As S  (just 'better' ...)
matpoints <- function(x, y, lty=1:5, pch=NULL, col=1:6, ...)
	matplot(x=x, y=y, type = 'p', lty=lty, pch=pch, col=col, add=TRUE, ...)
matlines  <- function(x, y, lty=1:5, pch=NULL, col=1:6, ...)
	matplot(x=x, y=y, type = 'l', lty=lty, pch=pch, col=col, add=TRUE, ...)
matplot <- function(x, y, type="p",
		    lty=1:5, pch=NULL, col=1:6,
		    xlab=NULL, ylab=NULL, xlim=NULL, ylim=NULL,
		    ..., add= FALSE, verbose = FALSE)
{
	## Purpose: Plots columns of  x	  vs. columns of  y.	--> ?matplot
	## ------------------------------------------------------------------
	## Author: Martin Maechler, Date: 27 Jun 97
	types <- c("p", "l", "b", "o", "h", "n")
	paste.ch <- function(chv) paste('"',chv,'"', sep="", collapse=" ")
	str2vec <- function(string)
	  if((nch <- nchar(string))>1) substr(rep(string[1], nch), 1:nch, 1:nch)
	  else string
	##--- These are from  plot.default ----
	xlabel <- if (!missing(x)) deparse(substitute(x))  else NULL
	ylabel <- if (!missing(y)) deparse(substitute(y))  else NULL
	##
	if(missing(x)) {
		if(missing(y)) stop("Must specify at least one of  'x' and 'y'")
		else x <- 1:NROW(y)
	} else if(missing(y)) {
		y <- x;		ylabel <- xlabel
		x <- 1:NROW(y); xlabel <- ""
	}
	##
	kx <- ncol(x <- as.matrix(x))
	ky <- ncol(y <- as.matrix(y))
	n <- nrow(x)
	if(n != nrow(y)) stop("'x' and 'y' must have same number of rows")
	if(kx > 1 && ky > 1 && kx != ky)
	  stop("'x' and 'y' must have only 1 or the same number of columns")
	if(kx == 1) x <- matrix(x, nrow = n, ncol = ky)
	if(ky == 1) y <- matrix(y, nrow = n, ncol = kx)
	k <- max(kx,ky)## k == kx == ky
	type <- str2vec(type)
	do.points <- any(type=='p') || any(type=='o')
	if(do.points) {
		if(is.null(pch)) pch <- c(paste(c(1:9,0)),letters)[1:k]
		else if(is.character(pch)) pch <- str2vec(pch)
	}
	if(verbose)
	    cat("matplot: doing ", k, " plots with ",
		paste(" col= (", paste.ch(col), ")", sep=''),
		if(do.points) paste(" pch= (", paste.ch(pch), ")", sep=''),
		" ...\n\n")
	xy <- xy.coords(x, y, xlabel, ylabel)
	xlab <- if (is.null(xlab)) xy$xlab  else xlab
	ylab <- if (is.null(ylab)) xy$ylab  else ylab
	xlim <- if (is.null(xlim)) range(xy$x, finite = TRUE)  else xlim
	ylim <- if (is.null(ylim)) range(xy$y, finite = TRUE)  else ylim
	if(length(type)< k) type<- rep(type,length= k)
	if(length(lty) < k) lty <- rep(lty, length= k)
	if(length(pch) < k) pch <- rep(pch, length= k)
	if(length(col) < k) col <- rep(col, length= k)
	ii <- 1:k
	if(!add) {
		ii <- ii[-1]
		plot(x[,1],y[,1], type=type[1], xlab=xlab, ylab=ylab,
		     xlim = xlim, ylim = ylim,
		     lty=lty[1], pch=pch[1], col=col[1], ...)
	}
	for (i in ii) {
		tp <- type[i]
		if(tp=='l' || tp=='b'|| tp=='o'|| tp=='h')
		  lines(x[,i],y[,i], type=tp, lty=lty[i],pch=pch[i],col=col[i])
		if(do.points && tp=='p')
		  points(x[,i],y[,i], pch=pch[i], col=col[i])
	}
}
matrix <- function(data=NA, nrow=1, ncol=1, byrow=FALSE, dimnames=NULL) {
	if(missing(nrow))	nrow <- ceiling(length(data)/ncol)
	else if(missing(ncol))	ncol <- ceiling(length(data)/nrow)
	x <- .Internal(matrix(data, nrow, ncol, byrow))
	dimnames(x)<-dimnames
	x
}
nrow <- function(x) dim(x)[1]
ncol <- function(x) dim(x)[2]
NROW <- function(x) if(is.array(x)||is.data.frame(x)) nrow(x) else length(x)
NCOL <- function(x) if(is.array(x)||is.data.frame(x)) ncol(x) else as.integer(1)
rownames <- function(x) {
	dn <- dimnames(x)
	if(is.null(dn)) dn else dn[[1]]
}
"rownames<-" <- function(x, value) {
	dn <- dimnames(x)
	dimnames(x) <- list(value, if(is.null(dn)) dn else dn[[2]])
	x
}
colnames <- function(x) {
	dn <- dimnames(x)
	if(is.null(dn)) dn else dn[[2]]
}
"colnames<-" <- function(x, value) {
	dn <- dimnames(x)
	dimnames(x) <- list(if(is.null(dn)) dn else dn[[1]], value)
	x
}
row <- function(x, as.factor=FALSE) {
	if(as.factor) factor(.Internal(row(x)), labels=rownames(x))
	else .Internal(row(x))
}
col <- function(x, as.factor=FALSE) {
	if(as.factor) factor(.Internal(col(x)), labels=colnames(x))
	else .Internal(col(x))
}
crossprod <- function(x, y=x) .Internal(crossprod(x,y))
t <- function(x) UseMethod("t")
## t.default is <primitive> 
t.data.frame<- function(x)
{
	x <- as.matrix(x)
	NextMethod("t")
}
## as.matrix  is in "as"
mean <- function(x, ...) UseMethod("mean")
mean.default <- function(x, trim = 0, na.rm = FALSE) {
        if (na.rm)
                x<-x[!is.na(x)]
        trim <- trim[1]
	if(trim > 0) {
		if(trim >= 0.5) return(median(x, na.rm=FALSE))
		lo <- floor(length(x)*trim)+1
		hi <- length(x)+1-lo
		x <- sort(x, partial=unique(c(lo, hi)))[lo:hi]
	}
        sum(x)/length(x)
}
weighted.mean <- function(x, w, na.rm = FALSE ){
	if(missing(w)) w <- rep(1,length(x))
	if (na.rm) {
		w<-w[!is.na(x)]
		x<-x[!is.na(x)]
	}
	sum(x*w)/sum(w)
}
median <- function(x, na.rm = FALSE) {
	if(na.rm)
		x <- x[!is.na(x)]
	else if(any(is.na(x)))
		return(NA)
	n <- length(x)
	half <- (n + 1)/2
	if(n %% 2 == 1) {
		sort(x, partial = half)[half]
	}
	else {
		sum(sort(x, partial = c(half, half + 1))[c(half, half + 1)])/2
	}
}
menu <- function(x, graphics = FALSE, title = "")
{
  xlen <- length(x)
  cat(title, "\n")
  for(i in seq(length=xlen))
    cat(i, ":", x[i]," \n", sep = "")
  repeat {
    cat("Selection: ")
    ind <- .Internal(menu(as.character(x)))
    if(ind <= xlen)
      return(ind)
    cat("Enter an item from the menu, or 0 to exit\n")
  }
}
mode <- function(x) {
	if(is.expression(x)) return("expression")
	if(is.call(x))
	  return(switch(deparse(x[[1]]),
			"(" = "(",
			# otherwise
			"call"))
	if(is.name(x)) "name" else
	switch(tx <- typeof(x),
	       double=, real=, integer= "numeric",# 'real' not used anymore [4/98,MM]
	       closure=, builtin=, special= "function",
	       # otherwise
	       tx)
}
"mode<-" <- function(x, value)
{
	mde <- paste("as.",value,sep="")
	atr <- attributes(x)
	x <- eval(call(mde,x), sys.frame(sys.parent()))
	attributes(x) <- atr
	x
}
storage.mode <- function(x) {
	x <- typeof(x)
	if (x == "closure" || x == "builtin" || x == "special") return("function")
	x
}
"storage.mode<-" <- get("mode<-", envir=NULL)
formula <- function(x, ...) UseMethod("formula")
formula.default<-function (x)
{
	if (!is.null(x$formula))
		return(eval(x$formula))
	if (!is.null(x$call$formula))
		return(eval(x$call$formula))
	if (!is.null(x$terms))
		return(x$terms)
	switch(mode(x), NULL = structure(NULL, class = "formula"),
		character = formula(eval(parse(text = x)[[1]])),
		call = eval(x), stop("invalid formula"))
}
formula.formula <- function(x) x
formula.terms <- function(x) {
	attributes(x) <- list(class="formula")
	x
}
print.formula <- function(x) print.default(unclass(x))
"[.formula" <- function(x,i) {
	ans <- NextMethod("[")
	if(as.character(ans[[1]]) == "~")
		class(ans) <- "formula"
	ans
}
terms <- function(x, ...) UseMethod("terms")
terms.default <- function(x) x$terms
terms.terms <- function(x, ...) x
print.terms <- function(x) print.default(unclass(x))
delete.response <- function (termobj)
{
	intercept <- if (attr(termobj, "intercept")) "1" else "0"
	terms(reformulate(c(attr(termobj, "term.labels"), intercept), NULL),
	      specials = names(attr(termobj, "specials")))
}
reformulate <- function (termlabels, response=NULL)
{
	termtext <- paste(termlabels, collapse="+")
	if (is.null(response)){
		termtext <- paste("~", termtext, collapse="")
		eval(parse(text=termtext)[[1]])
	}
	else {
		termtext <- paste("response", "~", termtext, collapse="")
		termobj <- eval(parse(text=termtext)[[1]])
		termobj[[2]] <- response
		termobj
	}
}
drop.terms <-function(termobj, dropx=NULL, keep.response=FALSE)
{
 if (is.null(dropx))
	termobj
 else {
	newformula <- reformulate(attr(termobj, "term.labels")[-dropx],
				if (keep.response) termobj[[2]] else NULL)
	terms(newformula, specials=names(attr(termobj, "specials")))
 }
}
terms.formula <- function(x, specials = NULL, abb = NULL, data = NULL,
			  neg.out = TRUE, keep.order = FALSE)
{
  fixFormulaObject <- function(object) {
    tmp <- attr(terms(object), "term.labels")
    form <- formula(object)
    lhs <- if(length(form) == 2) NULL else deparse(form[[2]])
    rhs <- if(length(tmp)) paste(tmp, collapse = " + ") else "1"
    if(!attr(terms(object), "intercept")) rhs <- paste(rhs, "- 1")
    formula(paste(lhs, "~", rhs))
  }
  if (!is.null(data) && !is.environment(data) && !is.data.frame(data))
    data <- as.data.frame(data)
  new.specials <- unique(c(specials, "offset"))
  tmp <- .Internal(terms.formula(x, new.specials, abb, data, keep.order))
  ## need to fix up . in formulae in R
  terms <- fixFormulaObject(tmp)
  attributes(terms) <- attributes(tmp)
  offsets <- attr(terms, "specials")$offset
  if (!is.null(offsets)) {
    names <- dimnames(attr(terms, "factors"))[[1]][offsets]
    offsets <- match(names, dimnames(attr(terms, "factors"))[[2]])
    offsets <- offsets[!is.na(offsets)]
    if (length(offsets) > 0) {
      attr(terms, "factors") <- attr(terms, "factors")[, -offsets, drop = FALSE]
      attr(terms, "term.labels") <- attr(terms, "term.labels")[-offsets]
      attr(terms, "order") <- attr(terms, "order")[-offsets]
      attr(terms, "offset") <- attr(terms, "specials")$offset
    }
  }
  attr(terms, "specials")$offset <- NULL
  terms
}
coef <- function(x, ...) UseMethod("coef")
coef.default <- function(x, ...) x$coefficients
coefficients <- coef
residuals <- function(x, ...) UseMethod("residuals")
resid <- residuals
deviance <- function(x, ...) UseMethod("deviance")
fitted <- function(x, ...) UseMethod("fitted")
fitted.default <- function(x) x$fitted
fitted.values <- fitted
anova <- function(x, ...)UseMethod("anova")
effects <- function(x, ...)UseMethod("effects")
weights <- function(x, ...)UseMethod("weights")
df.residual <- function(x, ...)UseMethod("df.residual")
variable.names <-function(obj, ...)UseMethod("variable.names")
case.names <-function(obj, ...)UseMethod("case.names")
offset <- function(x) x
## ?
na.action <- function(x, ...)UseMethod("na.action")
na.action.default <- function(x) attr(x, "na.action")
na.fail <- function(frame)
{
	ok <- complete.cases(frame)
	if(all(ok)) frame else stop("missing values in data frame");
}
na.omit <- function(frame)
{
	ok <- complete.cases(frame)
	if (all(ok))
		frame
	else frame[ok, ]
}
##-- used nowhere (0.62)
##- model.data.frame <- function(...) {
##-	cn <- as.character(substitute(list(...))[-1])
##-	rval<-data.frame(..., col.names=cn, as.is=TRUE)
##-	names(rval)<-cn
##-	rval
##- }
model.frame <- function(formula, ...)	UseMethod("model.frame")
model.frame.default <-
function(formula, data = NULL, subset=NULL, na.action = na.fail,
	 drop.unused.levels = FALSE, xlev = NULL,...)
{
	if(missing(formula)) {
		if(!missing(data) && inherits(data, "data.frame") &&
		length(attr(data, "terms")) > 0)
			return(data)
		formula <- as.formula(data)
	}
	else if(missing(data) && inherits(formula, "data.frame")) {
		if(length(attr(formula, "terms")))
			return(formula)
		data <- formula
		formula <- as.formula(data)
	}
	if(missing(na.action)) {
		if(!is.null(naa <- attr(data, "na.action")))
			na.action <- naa
		else if(!is.null(naa <- options("na.action")[[1]]))
			na.action <- naa
	}
	if(missing(data))
		data <- sys.frame(sys.parent())
	if(!inherits(formula, "terms"))
		formula <- terms(formula, data = data)
	subset <- eval(substitute(subset),data)
	data <- .Internal(model.frame(formula, data, substitute(list(...)),
		subset, na.action))
  ## fix up the levels
  if(length(xlev) > 0) {
    for(nm in names(xlev))
      if(!is.null(xl <- xlev[[nm]])) {
	xi <- data[[nm]]
	if(is.null(nxl <- levels(xi)))
	  warning("variable", nm, "is not a factor")
	else {
	  xi <- xi[, drop= TRUE] # drop unused levels
	  if(any(m <- is.na(match(nxl, xl))))
	    stop("factor", nm, "has new level(s)", nxl[m])
	  data[[nm]] <- factor(xi, levels=xl)
	}
      }
  } else if(drop.unused.levels) {
    for(nm in names(data)) {
      x <- data[[nm]]
      if(is.factor(x) &&
	 length(unique(x)) < length(levels(x)))
	data[[nm]] <- data[[nm]][, drop = TRUE]
    }
  }
  data
}
model.weights <- function(x) x$"(weights)"
model.offset <- function(x) {
	offsets <- attr(attr(x, "terms"),"offset")
	if(length(offsets) > 0) {
		ans <- 0
		for(i in offsets) ans <- ans+x[[i]]
		ans
	}
	else NULL
}
model.matrix <- function(object, ...) UseMethod("model.matrix")
model.matrix.default <- function(formula, data = sys.frame(sys.parent()),
				 contrasts.arg = NULL, xlev = NULL)
{
 t <- terms(formula)
 if (is.null(attr(data, "terms")))
     data <- model.frame(formula, data, xlev=xlev)
 else {
   reorder <- match(as.character(attr(t,"variables"))[-1],names(data))
   if (any(is.na(reorder)))
     stop("model frame and formula mismatch in model.matrix()")
   data <- data[,reorder, drop=FALSE]
 }
 contr.funs <- as.character(.Options$contrasts)
 isF <- sapply(data, is.factor)[-1]
 isOF <- sapply(data, is.ordered)
 namD <- names(data)
 for(nn in namD[-1][isF]) # drop response
   if(is.null(attr(data[[nn]], "contrasts")))
     contrasts(data[[nn]]) <- contr.funs[1 + isOF[nn]]
## it might be safer to have numerical contrasts:
##	  get(contr.funs[1 + isOF[nn]])(nlevels(data[[nn]]))
 if (!is.null(contrasts.arg) && is.list(contrasts.arg)) {
   if (is.null(namC <- names(contrasts.arg)))
     stop("invalid contrasts argument")
   for (nn in namC) {
     if (is.na(ni <- match(nn, namD)))
       warning(paste("Variable", nn, "absent, contrast ignored"))
     else contrasts(data[[ni]]) <- contrasts.arg[[nn]]
   }
 }
 ans <- .Internal(model.matrix(t, data))
 cons <- if(any(isF))
   lapply(data[-1][isF], function(x) attr(x,  "contrasts"))
 else NULL
 attr(ans, "contrasts") <- cons
 ans
}
model.response <- function (data, type = "any")
{
  if (attr(attr(data, "terms"), "response")) {
    if (is.list(data) | is.data.frame(data)) {
      v <- data[[1]]
      if (type == "numeric" | type == "double") storage.mode(v) <- "double"
      else if (type != "any") stop("invalid response type")
      if (is.matrix(v) && ncol(v) == 1) dim(v) <- NULL
      rows <- attr(data, "row.names")
      if (nrows <- length(rows)) {
	if (length(v) == nrows) names(v) <- rows
	else if (length(dd <- dim(v)) == 2)
	  if (dd[1] == nrows && !length((dn <- dimnames(v))[[1]]))
	    dimnames(v) <- list(rows, dn[[2]])
      }
      return(v)
    } else stop("invalid data argument")
  } else return(NULL)
}
##model.response <- function (data, type = "any")
##{
##	if (attr(attr(data, "terms"), "response")) {
##		if (is.list(data) | is.data.frame(data)) {
##			v <- data[[1]]
##			if (type == "numeric" | type == "double") {
##				storage.mode(v) <- "double"
##			}
##			else if (type != "any")
##				stop("invalid response type")
##			if (is.matrix(v) && ncol(v) == 1)
##				dim(v) <- NULL
##			return(v)
##		}
##		else stop("invalid data argument")
##	}
##	else return(NULL)
##}
model.extract <- function (frame, component)
{
	component <- as.character(substitute(component))
	rval <- switch(component,
		response = model.response(frame),
		offset = model.offset(frame), weights = frame$"(weights)",
		start = frame$"(start)")
	if (is.null(rval)) {
		name <- paste("frame$\"(", component, ")\"", sep = "")
		rval <- eval(parse(text = name)[1])
	}
	if(!is.null(rval)){
	  if (length(rval) == nrow(frame))
	    names(rval) <- attr(frame, "row.names")
	  else if (is.matrix(rval) && nrow(rval) == nrow(frame)) {
	    t1 <- dimnames(rval)
	    dimnames(rval) <- list(attr(frame, "row.names"), t1[[2]])
	  }
	}
	return(rval)
}
preplot <- function(object, ...) UseMethod("preplot")
update <- function(object, ...) UseMethod("update")
is.empty.model<-function (x)
{
	tt <- terms(x)
	(length(attr(tt, "factors")) == 0) & (attr(tt, "intercept")==0)
}
mtext <- function(text, side=3, line=0, outer=FALSE, at=NULL, adj=NA, ...)
  .Internal(mtext(as.char.or.expr(text), side, line, outer, at, adj, ...))
	#> ../../../main/plot.c
names <-
function(x, ...)
UseMethod("names")
names.default <-
function(x)
.Internal(names(x))
"names<-" <-
function(x, ...)
UseMethod("names<-")
"names<-.default" <- 
function(x, value)
.Internal("names<-"(x, value))
nlm <-
function(f, p, hessian=FALSE, typsize=rep(1,length(p)),
	fscale=1, print.level=0, ndigit=12, gradtol=1e-6,
	stepmax=max(1000 * sqrt(sum((p/typsize)^2)), 1000),
	steptol=1e-6, iterlim=100)
{
	print.level <- as.integer(print.level)
	if(print.level < 0 || print.level > 2)
		stop("`print.level' must be in {0,1,2}")
	msg <- c(9,1,17)[1+print.level]
	.Internal(nlm(f, p, hessian, typsize, fscale, msg, ndigit, gradtol,
		stepmax, steptol, iterlim))
}
optimize <- function(f, interval, lower=min(interval), upper=max(interval),
	maximum=FALSE, tol=.Machine$double.eps^0.25, ...)
{
 if(maximum) {
	val <- .Internal(fmin(function(arg) -f(arg, ...), lower, upper, tol))
	list(maximum=val, objective= f(val, ...))
 } else {
	val <- .Internal(fmin(function(arg) f(arg, ...), lower, upper, tol))
	list(minimum=val, objective=f(val, ...))
 }
}
#nice to the English
optimise <- optimize
uniroot <- function(f, interval, lower=min(interval), upper=max(interval),
	tol=.Machine$double.eps^0.25, ...)
{
	if(f(interval[1], ...)*f(interval[2], ...) >= 0)
		stop("signs at end points not of opposite sign")
	val <- .Internal(zeroin(function(arg) f(arg, ...), lower, upper, tol))
	list(root=val, f.root=f(val, ...))
}
deriv <- function(x, ...) UseMethod("deriv")
deriv.formula <- function(expr, namevec, function.arg=NULL, tag=".expr") {
	if(length(expr) == 2)
		.Internal(deriv.default(expr[[2]], namevec, function.arg, tag))
	else stop("invalid formula in deriv")
}
deriv.default <- function(expr, namevec, function.arg=NULL, tag=".expr")
.Internal(deriv.default(expr, namevec, function.arg, tag))
.NotYetImplemented <- function() {
  stop(paste("`", as.character(sys.call(sys.parent())[[1]]), "' ",
             "is not implemented yet", sep = ""))
}
.NotYetUsed <- function(x) {
  warning(paste("argument `", x, "' is not used (yet)", sep = ""))
}
## 'objects <- function(....) ...    --->>> ./attach.R
inherits <- function(x, name)
	any(!is.na(match(name,class(x))))
NextMethod <- function(generic=NULL, object=NULL, ...)
	.Internal(NextMethod(generic, object,...))
methods <- function (generic.function, class)
{
	allnames <- unique(c(ls(pos=seq(along=search()))))
	if (!missing(generic.function)) {
	 if (!is.character(generic.function))
		generic.function <- deparse(substitute(generic.function))
	 name <- paste("^", generic.function, ".", sep = "")
	}
	else if (!missing(class)) {
		if (!is.character(class))
			class <- paste(deparse(substitute(class)))
		name <- paste(".", class, "$", sep = "")
	}
	else stop("must supply generic.function or class")
	grep(gsub("([.[])", "\\\\\\1", name), allnames, value = TRUE)
}
data.class <- function(x) {
	if (length(cl <- class(x)))
		cl[1]
	else {
		l <- length(dim(x))
		if (l == 2)	"matrix"
		else if (l > 0)	"array"
		else mode(x)
	}
}
options <-
function(...) .Internal(options(...))
outer <- function(x, y, FUN="*", ...) {
        if(is.character(FUN))
                FUN <- get(FUN, mode="function", inherits=TRUE)
        nr <- length(x)
        nc <- length(y)
        matrix(
                FUN(matrix(x, nr, nc), matrix(y, nr, nc, byrow=TRUE), ...),
                nr, nc)
}
"%o%"<-outer
pairs <- function(x, ...) UseMethod("pairs")
pairs.default <- function(x, labels, panel=points, main = NULL,
                          font.main=par("font.main"),
                          cex.main=par("cex.main"), ...) 
{
	if(!is.matrix(x)) x <- data.matrix(x)
	if(!is.numeric(x)) stop("non-numeric argument to pairs")
	nc <- ncol(x)
	if(nc < 2) stop("only one column in the argument to pairs")
	if (missing(labels)) {
		labels <- dimnames(x)[[2]]
		if (is.null(labels)) 
			labels <- paste("var", 1:nc)
	}
	oma <- c(4, 4, 4, 4)
	if (!is.null(main)) 
		oma[3] <- 6
	opar <- par(mfrow = c(nc, nc), mar = rep(0.5, 4), oma = oma)
	on.exit(par(opar))
	for (i in 1:nc) for (j in 1:nc) {
		if (i == j) {
			plot(x[, j], x[, i], xlab = "", ylab = "", axes = FALSE, type = "n", 
				...)
			box()
			text(mean(par("usr")[1:2]), mean(par("usr")[3:4]), labels[i])
		}
		else {
			plot(x[, j], x[, i], type="n", xlab = "", ylab = "", axes = FALSE, ...)
			box()
			panel(x[, j], x[, i], ...)
		}
		if (j == 1 & 2 * floor(i/2) == i) 
			axis(2)
		if (i == 1 & 2 * floor(j/2) == j) 
			axis(3)
		if (j == nc & 2 * floor(i/2) != i) 
			axis(4)
		if (i == nc & 2 * floor(j/2) != j) 
			axis(1)
	}
	if (!is.null(main)) mtext(main, 3, 3, T, 0.5,
		cex=cex.main, font=font.main)
	invisible(NULL)
}
##-- These are the ones used in 0.16.1 -- ../../../main/par.c  Query(..) :
.Pars <- c(
"adj", "ann", "ask", "bg", "bty",
"cex", "cex.axis", "cex.lab", "cex.main", "cex.sub", "cin",
"col", "col.axis", "col.lab", "col.main", "col.sub", "cra", "crt", "csi",
"din", "err", "fg", "fig", "fin",
"font", "font.axis", "font.lab", "font.main", "font.sub", "lab", "las",
"lty", "lwd", "mai", "mar", "mex", "mfcol", "mfg", "mfrow", "mgp", "mkh",
"new", "oma", "omd", "omi", "pch", "pin", "plt", "ps", "pty",
"smo", "srt", "tck", "tmag", "type", "usr",
"xaxp", "xaxs", "xaxt", "xlog", "xpd",
"yaxp", "yaxs", "yaxt", "ylog",
##-- newer ones:
"gamma", "tcl"
)
par <-
function (...)
{
	single <- FALSE
	if (nargs() == 0) {
		args <- as.list(.Pars)
	}
	else {
		args <- list(...)
                if (all(unlist(lapply(args, is.character))))
                  args <- as.list(unlist(args))
		if (length(args) == 1) {
			if (is.list(args[[1]]) | is.null(args[[1]]))
				args <- args[[1]]
			else
				if(is.null(names(args)))
					single <- TRUE
		}
	}
	value <- if (single) .Internal(par(args))[[1]]
	else .Internal(par(args))
	if(!is.null(names(args))) invisible(value) else value
}
# we don't use white; it's for compatibility
parse <- function(file="", n=NULL, text=NULL, prompt=NULL, white=FALSE)
.Internal(parse(file, n, text, prompt))
paste <- function (..., sep = " ", collapse=NULL)
{
        args <- list(...)
	if(is.null(args)) ""
	else {
		for (i in 1:length(args)) args[[i]] <- as.character(args[[i]])
		.Internal(paste(args, sep, collapse))
	}
}
##=== Could we extend  paste(.) to (optionally) accept a
##    2-vector for collapse ?    With the following functionality
##- paste.extra <- function(r, collapse=c(", "," and ")) {
##-         n <- length(r)
##-         if(n <= 1) paste(r)
##-         else
##-           paste(paste(r[-n],collapse=collapse[1]),
##-                 r[n], sep=collapse[min(2,length(collapse))])
##- }
pictex <-
function(file="Rplots.tex", width=5, height=4, debug = FALSE,
        bg="white", fg="black")
{
	.Internal(PicTeX(file, bg, fg, width, height, debug))
        par(mar=c(5,4,2,4)+0.1)
}
piechart <-
function (x, labels=names(x), edges=200, radius=0.8, col=NULL, main=NULL, ...)
{
	if (!is.numeric(x) || any(is.na(x) | x <= 0))
		stop("piechart: `x' values must be positive.")
	if (is.null(labels))
		labels <- as.character(1:length(x))
	x <- c(0, cumsum(x)/sum(x))
	dx <- diff(x)
	pin <- par("pin")
	xlim <- ylim <- c(-1, 1)
	if (pin[1] > pin[2]) xlim <- (pin[1]/pin[2]) * xlim
	else ylim <- (pin[2]/pin[1]) * ylim
	plot.new()
	plot.window(xlim, ylim, "", asp=1)
	for (i in 1:length(dx)) {
		n <- max(2, floor(edges * dx[i]))
		t2p <- 2*pi * seq(x[i], x[i + 1], length = n)
		xc <- c(cos(t2p), 0) * radius
		yc <- c(sin(t2p), 0) * radius
		polygon(xc, yc, col=col[(i-1)%%length(col)+1])
		t2p <- 2*pi * mean(x[i + 0:1])
		xc <- cos(t2p) * radius
		yc <- sin(t2p) * radius
		lines(c(1,1.05)*xc, c(1,1.05)*yc)
		text(1.1*xc, 1.1*yc, labels[i],
		     xpd = TRUE, adj = ifelse(xc < 0, 1, 0))
	}
	title(main = main, ...)
	invisible(NULL)
}
xy.coords <- function(x, y, xlab=NULL, ylab=NULL) {
	if(is.null(y)) {
		ylab<- xlab
		if(is.language(x)) {
			if(length(x) == 3 && deparse(x[[1]]) == '~') {
				ylab <- deparse(x[[2]])
				xlab <- deparse(x[[3]])
				y <- eval(x[[2]], sys.frame(sys.parent()))
				x <- eval(x[[3]], sys.frame(sys.parent()))
			}
			else stop("invalid first argument")
		}
		else if(is.ts(x)) {
			if(is.matrix(x)) y <- x[,1]
			else y <- x
			x <- time(x)
			xlab <- "Time"
		}
		else if(is.complex(x)) {
			y <- Im(x)
			x <- Re(x)
			xlab <- paste("Re(", ylab, ")", sep="")
			ylab <- paste("Im(", ylab, ")", sep="")
		}
		else if(is.matrix(x) || is.data.frame(x)) {
			x <- data.matrix(x)
			if(ncol(x) == 1) {
				xlab <- "Index"
				y <- x[,1]
				x <- 1:length(y)
			}
			else {
				colnames <- dimnames(x)[[2]]
				if(is.null(colnames)) {
					xlab <- paste(ylab,"[,1]",sep="")
					ylab <- paste(ylab,"[,2]",sep="")
				}
				else {
					xlab <- colnames[1]
					ylab <- colnames[2]
				}
				y <- x[,2]
				x <- x[,1]
			}
		}
		else if(is.list(x)) {
			xlab <- paste(ylab,"$x",sep="")
			ylab <- paste(ylab,"$y",sep="")
			y <- x[["y"]]
			x <- x[["x"]]
		}
		else {
			if(is.factor(x)) x <- as.numeric(x)
			xlab <- "Index"
			y <- x
			x <- 1:length(x)
		}
	}
	else if(length(x) != length(y)) stop("x and y lengths differ")
	return(list(x=as.real(x), y=as.real(y), xlab=xlab, ylab=ylab))
}
plot <- function(x, ...)
UseMethod("plot")
plot.default <-
function (x, y=NULL, type="p", main=NULL, col=par("fg"), bg=NA,
          pch=par("pch"), xlim=NULL, ylim=NULL, log="", axes=TRUE,
          frame.plot=axes, panel.first=NULL, panel.last=NULL,
          sub=NULL, # 0.63 will reorder the args more logically..
          ann=par("ann"), xlab=NULL, ylab=NULL, cex=par("cex"),
          lty=par("lty"), lwd=par("lwd"), asp=NA, ...)
{
 xlabel <- if (!missing(x)) deparse(substitute(x))	else NULL
 ylabel <- if (!missing(y)) deparse(substitute(y))	else NULL
 xy <- xy.coords(x, y, xlabel, ylabel)
 xlab <- if (is.null(xlab)) xy$xlab	else xlab
 ylab <- if (is.null(ylab)) xy$ylab	else ylab
 xlim <- if (is.null(xlim)) range(xy$x, finite=TRUE) else xlim
 ylim <- if (is.null(ylim)) range(xy$y, finite=TRUE) else ylim
 plot.new()
 plot.window(xlim, ylim, log, asp, ...)
 panel.first
 plot.xy(xy, type, col=col, pch=pch, cex=cex, bg=bg, lty=lty, lwd=lwd, ...)
 panel.last
 pars <- list(...)
 if (axes) {
	axis(1, pars=pars)
	axis(2, pars=pars)
 }
 if (frame.plot)
	box(...)
 if (ann)
	title(main=main, xlab=xlab, ylab=ylab, pars=pars)
 invisible()
}
plot.factor <-
function(x, y, ...) {
  if (missing(y))
    barplot(table(x), ...)
  else if (is.numeric(y))
    boxplot(y ~ x, ...)
  else NextMethod("plot")
}
plot.formula <-
function(formula, data = NULL, subset, na.action, ..., ask = TRUE) {
  if (missing(na.action)) na.action <- options()$na.action
  m <- match.call(expand.dots = FALSE)
  if (is.matrix(eval(m$data, sys.parent())))
    m$data <- as.data.frame(data)
  m$... <- NULL
  m[[1]] <- as.name("model.frame")
  mf <- eval(m, sys.parent())
  response <- attr(attr(mf, "terms"), "response")
  if (response) {
    varnames <- names(mf)
    y <- mf[[response]]
    ylab <- varnames[response]
    if (length(varnames) > 2) {
      opar <- par(ask = ask)
      on.exit(par(opar))
    }
    for (i in varnames[-response])
      plot(mf[[i]], y, xlab = i, ylab = ylab, ...)
  }
  else plot.data.frame(mf)
}
plot.xy <-
function(xy, type, pch=1, lty="solid", col=par("fg"), bg=NA, cex=1, ...)
	.Internal(plot.xy(xy, type, pch, lty, col, bg=bg, cex=cex, ...))
plot.new <- function(ask=NA)
	.Internal(plot.new(ask))
frame <- plot.new
pmax <-
function (..., na.rm = FALSE) 
{
        elts <- list(...)
        maxmm <- as.vector(elts[[1]])
        for (each in elts[-1]) {
            work <- cbind(maxmm, as.vector(each)) 
            nas <- is.na(work)
            work[,1][nas[,1]] <- work[,2][nas[,1]]
            work[,2][nas[,2]] <- work[,1][nas[,2]]
            change <- work[,1] < work[,2]
            work[,1][change] <- work[,2][change]
            if (!na.rm) work[,1][nas[,1]+nas[,2] > 0] <- NA
            maxmm <- work[,1]
        }
        maxmm
}
pmin <-
function (..., na.rm = FALSE)
{
        elts <- list(...)
        minmm <- as.vector(elts[[1]])
        for (each in elts[-1]) {
            work <- cbind(minmm, as.vector(each))
            nas <- is.na(work)
            work[,1][nas[,1]] <- work[,2][nas[,1]]
            work[,2][nas[,2]] <- work[,1][nas[,2]]
            change <- work[,1] > work[,2]
            work[,1][change] <- work[,2][change]
            if (!na.rm) work[,1][nas[,1]+nas[,2] > 0] <- NA
            minmm <- work[,1]
        }
        minmm
}
points <- function(x, ...) UseMethod("points")
points.default <-
function(x, y=NULL, type="p", pch=1, col="black", bg=NA, cex=1, ...) {
	plot.xy(xy.coords(x,y), type=type, pch=pch, col=col, bg=bg, cex=cex,...)
}
polygon <-
function(x, y=NULL, density = -1, angle = 45, border=par("fg"), ...)
{
  if (!missing(density))
    .NotYetUsed("density")
  if (!missing(angle))
    .NotYetUsed("angle")
  xy <- xy.coords(x, y)
  .Internal(polygon(xy$x, xy$y, border=border, ...))
}
.PostScript.Options <- list(
	paper="default",
	horizontal = TRUE,
	width = 0,
	height = 0,
	family = "Helvetica",
	pointsize = 12,
	bg = "white",
	fg = "black",
	onefile = TRUE,
	print.it = FALSE,
	append = FALSE)
check.options <-
function(new, name.opt, reset = FALSE, assign.opt = FALSE,
	 envir=.GlobalEnv, check.attributes = c("mode", "length"),
	 override.check= FALSE)
{
 ## Purpose: Utility function for setting options
 lnew <- length(new)
 if(lnew != length(newnames <- names(new)))
	 stop(paste("invalid arguments in \"",
		    deparse(sys.call(sys.parent())),
		    "\" (need NAMED args)", sep=""))
 if(reset && exists(name.opt, envir=envir, inherits=FALSE))
	 rm(list=name.opt, envir=envir)
 old <- get(name.opt, envir=envir)
 if(!is.list(old))
	 stop(paste("invalid options in `",name.opt,"'",sep=""))
 oldnames <- names(old)
 if(lnew > 0) {
	 matches <- pmatch(newnames, oldnames)
	 if(any(is.na(matches)))
		 stop(paste("invalid argument names in \"",
			 deparse(sys.call(sys.parent())),"\"",sep=""))
	 else if(any(matches==0))
		 stop(paste("ambiguous argument names in \"",
			 deparse(sys.call(sys.parent())),"\"",sep=""))
	 else { #- match(es) found:  substitute if appropriate
		 i.match <- oldnames[matches]
		 prev <- old[i.match]
		 doubt <- rep(FALSE, length(prev))
		 for(fn in check.attributes)
		   if(any(ii <- sapply(prev, fn) != sapply(new, fn))) {
                    doubt <- doubt | ii
                    do.keep <- ii & !override.check
		    warning(paste(
			paste(paste("`",fn,"(",names(prev[ii]),")'", sep=""),
                              collapse=" and "),
			" differ", if(sum(ii)==1) "s",
			" between new and previous!",
                        if(any(do.keep))
                          paste("\n\t ==> NOT changing ",
			        paste(paste("`",names(prev[do.keep]),
                                            "'", sep=""), collapse=" & "),
                                collapse = ""),
                        sep=""))
                  }
                 names(new) <- NULL
                 if(any(doubt)) {
                 	ii <- !doubt | override.check
                   	old[i.match[ii]] <- new[ii]
                 } else old[i.match] <- new
	}
	if(assign.opt) assign(name.opt, old, envir=envir)
 }
 old
}
ps.options <-
function(..., reset=FALSE, override.check= FALSE)
{
	l... <- length(new <- list(...))
	old <- check.options(new = new, name.opt = ".PostScript.Options",
			     reset = as.logical(reset), assign.opt = l... > 0,
                             override.check= override.check)
	if(reset || l... > 0) invisible(old)
	else old
}
postscript <- function (file = "Rplots.ps", ...)
{
	new <- list(...)# eval
	old <- check.options(new = new, name.opt = ".PostScript.Options",
			     reset = FALSE, assign.opt = FALSE)
##	cpars <- old[c("paper", "family", "bg", "fg")]
##	npars <- old[c("width", "height", "horizontal", "pointsize")]
##	cpars <- c(file, as.character(unlist(lapply(cpars, "[", 1))))
##	npars <- as.numeric(unlist(lapply(npars, "[", 1)))
	.Internal(PS(file, old$paper, old$family, old$bg, old$fg,
		old$width, old$height, old$horizontal, old$pointsize))
}
ppoints <- function (n, a = ifelse(n <= 10, 3/8, 1/2))
{
  if(length(n) > 1) n <- length(n)
  if(n > 0)
    (1:n - a)/(n + 1-2*a)
  else numeric(0)
}
predict <- function(fit,...) UseMethod("predict")
predict.default <- function (object, ...) {
                 namelist <- list(...)
                 names(namelist) <- substitute(list(...))[-1]
                 m <- length(namelist)
                 X <- as.matrix(namelist[[1]])
                 if (m > 1) 
                   for (i in (2:m)) X <- cbind(X, namelist[[i]])
                 if (object$intercept) 
                   X <- cbind(rep(1, NROW(X)), X)
                 k <- NCOL(X)
                 if (length(object$coef) != k) 
                   stop("Wrong number of predictors")
                 predictor <- X %*% object$coef
                 ip <- real(NROW(X))
                 for (i in (1:NROW(X))) ip[i] <- sum(X[i, ] * 
                       (object$covmat %*% X[i, ]))
                 stderr1 <- sqrt(ip)
                 stderr2 <- sqrt(object$rms^2 + ip)
                 tt <- qt(0.975, object$df)
                 conf.l <- predictor - tt * stderr1
                 conf.u <- predictor + tt * stderr1
                 pred.l <- predictor - tt * stderr2
                 pred.u <- predictor + tt * stderr2
                 z <- cbind(predictor, conf.l, conf.u, pred.l, pred.u)
                 rownames(z) <- paste("P", 1:NROW(X), sep = "")
                 colnames(z) <- c("Predicted", "Conf lower", "Conf upper",
                                  "Pred lower", "Pred upper")
                 z
}
# file predict.glm.R
# copyright (C) 1998 W. N. Venables and B. D. Ripley
#
predict.glm <-
function(object, newdata = NULL, type = c("link", "response"),
         se.fit = FALSE, dispersion = NULL, ...)
{
  ## 1998/06/23 KH:  predict.lm() now merged with the version in lm.R
  type <- match.arg(type)
  if(!se.fit) {
    ## No standard errors
    if(missing(newdata))
      pred <- switch(type,
                     link = object$linear.predictors,
                     response = object$fitted)
    else {
      pred <- predict.lm(object, newdata, se.fit, scale = 1)
      switch(type,
             response = {pred <- family(object)$linkinv(pred)},
             link = )
    }
  } else {
    ## summary.survreg has no ... argument.
    if(inherits(object, "survreg")) dispersion <- 1.
    if(is.null(dispersion) || dispersion == 0)
      dispersion <- summary(object, dispersion=dispersion)$dispersion
    residual.scale <- as.vector(sqrt(dispersion))
    pred <- predict.lm(object, newdata, se.fit, scale = residual.scale)
    fit <- pred$fit
    se.fit <- pred$se.fit
    switch(type,
	   response = {
	     fit <- family(object)$linkinv(fit)
	     se.fit <- se.fit * abs(family(object)$mu.eta(fit))
	   },
	   link = )
    pred <- list(fit=fit, se.fit=se.fit, residual.scale=residual.scale)
  }
  pred
}
pretty <- function(x, n=5, shrink.sml = 2^-3) {
	if(!is.numeric(x))
		stop("x must be numeric")
        if(length(x)==0)
          	return(x)
	if(is.na(n <- n[1]) || n < 1)
		stop("invalid n value")
	if(!is.numeric(shrink.sml) || shrink.sml <= 1e-8)
		stop("argument `shrink.sml' must be numeric > 1e-8")
	z <- .C("pretty",l=as.real(min(x)),u=as.real(max(x)),n=as.integer(n),
                shrink = as.real(shrink.sml))
	seq(z$l,z$u,length=z$n+1)
}
print <- function(x, ...)UseMethod("print")
##- Need '...' such that it can be called as  NextMethod("print", ...):
print.default <-
function(x,digits=NULL,quote=TRUE,na.print=NULL,print.gap=NULL, ...)
	.Internal(print.default(x,digits,quote,na.print,print.gap))
print.atomic <- function(x,quote=TRUE,...) print.default(x,quote=quote)
print.matrix <- function (x, rowlab = character(0), collab =
                          character(0), quote = TRUE, right = FALSE) {
  x <- as.matrix(x)
  .Internal(print.matrix(x, rowlab, collab, quote, right))
}
prmatrix <- .Alias(print.matrix)
## This should be replaced by  print.anova() [ currently in ./anova.R ], soon..
print.tabular <-
function(x, digits = max(3, .Options$digits - 3), na.print = "")
{
        cat("\n", if(!is.null(x$title))
            x$title else "Analysis of Variance:", "\n\n", sep="")
	if(!is.null(x$topnote))
		cat(paste(x$topnote, collapse="\n"), "\n\n", sep="")
	print.default(x$table, digits=digits, na = "", print.gap = 2)
	if(!is.null(x$botnote))
		cat("\n", paste(x$botnote, collapse="\n"), sep="")
	cat("\n")
}
noquote <- function(obj) {
	## constructor for a useful "minor" class
	if(!inherits(obj,"noquote")) class(obj) <- c(class(obj),"noquote")
	obj
}
"[.noquote" <- function (x, ...) {
	attr <- attributes(x,"legend")
	r <- unclass(x)[...]
	attributes(r) <- c(attributes(r),
			   attr[is.na(match(names(attr),c("dim","dimnames")))])
	r
}
print.noquote <- function(obj,...) {
	## method for (character) objects of class 'noquote'
	cl <- class(obj)
	if(!is.null(cl)) class(obj) <- cl[cl != "noquote"]
	NextMethod("print", obj, quote = FALSE, ...)
}
## used for version:
print.simple.list <-
function(x, ...) print(noquote(cbind("_"=unlist(x))), ...)
print.coefmat <-
function(x, digits = max(3, .Options$digits - 2),
         signif.stars= .Options$show.signif.stars,
         dig.tst = max(1, min(5, digits - 1)),
         cs.ind = 1:k, tst.ind = k+1,
         zap.ind = integer(0),
         has.Pvalue = d[2] >= 4 && substr(colnames(x)[d[2]],1,3) == "Pr(", ...)
{
  ## For printing ``coefficient matrices'' as they are in summary.xxx(.) where
  ## xxx in {lm, glm, aov, ..}. (Note: summary.aov(.) gives a class "anova").
  ## By Default
  ## Assume: x is a matrix-like numeric object.
  ## ------  with *last* column = P-values  --iff-- has.Pvalue (== TRUE)
  ##      columns {cs.ind}= numbers, such as coefficients & std.err  [def.: 1:k]
  ##      columns {tst.ind}= test-statistics (as "z", "t", or "F")  [def.: k+1]
  if(is.null(d <- dim(x)) || length(d) != 2)
    stop("1st arg. 'x' must be coefficient matrix/d.f./...")
  k <- d[2] - (if(missing(tst.ind)) 1 else length(tst.ind)) - has.Pvalue
  ##if(!missing(cs.ind)) && length(cs.ind) > k) stop("wrong k / cs.ind")
  Coefs <- array("", dim=d, dimnames = dimnames(x))
  if(length(cs.ind)>0) {
    acs <- abs(coef.se <- x[, cs.ind, drop=FALSE])# = abs(coef. , stderr)
    ## #{digits} BEFORE decimal point -- for min/max. value:
    digmin <- 1+floor(log10(range(acs[acs != 0], na.rm= TRUE)))
    Coefs[, cs.ind] <- format(round(coef.se,max(1,digits-digmin)),digits=digits)
  }
  if(length(tst.ind)>0)
    Coefs[, tst.ind]<- format(round(x[, tst.ind], dig=dig.tst), digits=digits)
  if(length(zap.ind)>0)
    Coefs[, zap.ind]<- format(zapsmall(x[, zap.ind], dig=digits), digits=digits)
  if(has.Pvalue)
    Coefs[, d[2]] <- format.pval(x[, d[2]], digits = dig.tst)
  if(any(r.ind <- !(1:(k+1) %in% c(cs.ind, tst.ind, zap.ind)))) # Remaining ind.
    Coefs[, r.ind] <- format(x[, r.ind], digits=digits)
  if(any(not.both.0 <- (c(x)==0)!=(as.numeric(Coefs)==0),na.rm=TRUE)) {
    ## not.both.0==T:  x !=0, but Coefs[] is: --> fix these:
    Coefs[not.both.0] <- format(x[not.both.0], digits= max(1,digits-1))
  }
  if(!has.Pvalue)
    signif.stars <- FALSE
  else if(signif.stars) {
    Signif <- symnum(x[, d[2]], corr = FALSE,
                     cutpoints = c(0,  .001,.01,.05, .1, 1),
                     symbols   =  c("***","**","*","."," "))
    Coefs <- cbind(Coefs, Signif)
  }
  print(Coefs, quote = FALSE, right = TRUE, ...)
  if(signif.stars) cat("---\nSignif. codes: ",attr(Signif,"legend"),"\n")
  invisible(x)
}
prompt <- function(object, ...) UseMethod("prompt")
## Later, we may want  a data.frame method ..
prompt.default <-
function(object, filename = paste0(name, ".Rd"), force.function = FALSE)
{
 paste0 <- function(...) paste(..., sep = "")
 is.missing.arg <- function(arg) typeof(arg) == "symbol" && deparse(arg) == ""
 name <- substitute(object)
 if(is.language(name) && !is.name(name)) name <- eval(name)
 name <- as.character(name)
 fn <- get(name)
 ##-- 'file' [character(NN)] will contain the lines to be put in the Rdoc file
 file <- paste0("\\name{", name, "}")
 if(is.function(fn) || force.function) {
	file <- c(file, "\\title{ ~~function to do ... ~~}")
	s <- seq(length = n <- length(argls <- formals(fn)))
	if(n > 0) {
		arg.names <- arg.n <- names(argls)
		arg.n[arg.n == "..."] <- "\\dots"
	}
	##-- Construct the 'call' -- for USAGE :
	call <- paste0(name, "(")
	for(i in s) { # i-th argument :
	  call <- paste0(call, arg.names[i],
			 if(!is.missing.arg(argls[[i]]))
			 paste0("=",deparse(argls[[i]])))
	  if(i != n) call <- paste0(call, ", ")
	}
	file <- c(file, "\\usage{", paste0(call, ")"), "}",
	 "%- maybe also `usage' for other functions documented here.",
	 paste0("\\alias{", name, "}"),
	 "%- Also NEED an `\\alias' for EACH other function documented here."
	)
	if(length(s))
	  file <- c(file, "\\arguments{",
		    paste0(" \\item{", arg.n, "}{",
			   " ~~Describe \\code{", arg.n, "} here~~ }"),"}")
	fn.def <- deparse(fn)
	if(any(br <- substr(fn.def,1,1) == "}"))
	  fn.def[br] <- paste(" ", fn.def[br])
	file <- c(file,
	"\\description{",
	" ~~ A concise (1-5 lines) description of what the function does. ~~",
	"}",
	"\\details{",
	" ~~ If necessary, more details than the __description__  above ~~",
	"}",
	"\\value{",
	"  ~Describe the value returned",
	"  If it is a LIST, use",
	"  \\item{comp1}{Description of `comp1'}",
	"  \\item{comp2}{Description of `comp2'}",
	"  ...",
	"}",
	"\\references{ ~put references to the literature/web site here ~ }",
	"\\author{ ~~if you are not one of R & R ..~~ }",
	"\\note{ ~~further notes~~ }",
	"",
	" ~Make other sections like WARNING with \\section{WARNING}{....} ~",
	"",
	"\\seealso{ ~~objects to SEE ALSO as \\code{\\link{~~fun~~}}, ~~~ }",
	"",
	"\\examples{",
	"##---- Should be DIRECTLY executable !! ----",
	"##-- ==>  Define data, use random,",
	"##--	     or do  help(data=index)  for the standard data sets.",
	"", "## The function is currently defined as",
	fn.def,
	"}",
	"\\keyword{ ~keyword }%-- one or more ..."
	)
} else {#-- not function --
	file <- c(file,"\\non_function{}",
		  paste("\\title{ ~~data-name / kind ...  }"),
		  "\\description{",
		  "~~ a precise description of what the function does. ~~",
		  "}")
      }
 cat(file, file = filename, sep = "\n")
 RHOME <- getenv("RHOME")
 if(substr(RHOME,1,8) == "/tmp_mnt") RHOME <- substr(RHOME,9,1000)
 cat("created file named ", filename, " in the current directory.\n",
     " Edit the file and move it to the appropriate directory,\n",
     paste(RHOME,"src/library/<pkg>/man/",sep="/"), "\n")
 invisible(file)
}
prop.test <- function(x, n, p = NULL, alternative = "two.sided",
		      conf.level = 0.95, correct = TRUE)
{
  DNAME <- deparse(substitute(x))
  if (is.matrix(x)) {
    if (ncol(x) != 2)
      stop("x must have 2 columns")
    l <- nrow(x)
    n <- apply(x, 1, sum)
    x <- x[, 1]
  }
  else {
    DNAME <- paste(DNAME, "out of", deparse(substitute(n)))
    if ((l <- length(x)) != length(n))
      stop("x and n must have the same length")
  }
  OK <- complete.cases(x, n)
  x <- x[OK]
  n <- n[OK]
  if ((k <- length(x)) < 1)
    stop("Not enough data")
  if (any(n <= 0))
    stop("Elements of n must be positive")
  if (any(x < 0))
    stop("Elements of x must be nonnegative")
  if (any(x > n))
    stop("Elements of x must not be greater than those of n")
  if (is.null(p) && (k == 1))
    p <- .5
  if (!is.null(p)) {
    DNAME <- paste(DNAME, ", null ",
		   ifelse(k == 1, "probability ", "probabilities "),
		   deparse(substitute(p)), sep = "")
    if (length(p) != l)
      stop("p must have the same length as x and n")
    p <- p[OK]    
    if (any((p <= 0) | (p >= 1)))
      stop("Elements of p must be in (0,1)")
  }
  CHOICES <- c("two.sided", "less", "greater")
  alternative <- CHOICES[pmatch(alternative, CHOICES)]
  if (length(alternative) > 1 || is.na(alternative)) 
    stop("alternative must be \"two.sided\", \"less\" or \"greater\"")
  if ((k > 2) || (k == 2) && !is.null(p))
    alternative <- "two.sided"
  if ((length(conf.level) != 1) || is.na(conf.level) ||
      (conf.level <= 0) || (conf.level >= 1))
    stop("conf.level must be a single number between 0 and 1")
  correct <- as.logical(correct)
  ESTIMATE <- x/n
  names(ESTIMATE) <- if (k == 1) "p" else paste("prop", 1:l)[OK]
  NVAL <- p
  CINT <- NULL
  YATES <- ifelse(correct && (k <= 2), .5, 0)
  if (k == 1) {
    z <- ifelse(alternative == "two.sided",
		qnorm((1 + conf.level) / 2),
		qnorm(conf.level))
    YATES <- min(YATES, abs(x - n * p))
    p.c <- ESTIMATE + YATES / n
    p.u <- ((p.c + z^2 / (2 * n) 
	     + z * sqrt(p.c * (1 - p.c) / n + z^2 / (4 * n^2)))
	    / (1 + z^2 / n))
    p.c <- ESTIMATE - YATES / n
    p.l <- ((p.c + z^2 / (2 * n) 
	     - z * sqrt(p.c * (1 - p.c) / n + z^2 / (4 * n^2)))
	    / (1 + z^2 / n))
    CINT <- switch(alternative,
		   "two.sided" = c(max(p.l, 0), min(p.u, 1)),
		   "greater" = c(max(p.l, 0), 1),
		   "less" = c(0, min(p.u, 1)))
  }
  else if ((k == 2) & is.null(p)) {
    DELTA <- ESTIMATE[1] - ESTIMATE[2]
    YATES <- min(YATES, abs(DELTA) / sum(1/n))
    WIDTH <- (switch(alternative,
		     "two.sided" = qnorm((1 + conf.level) / 2),
		     qnorm(conf.level))
	      * sqrt(sum(ESTIMATE * (1 - ESTIMATE) / n))
	      + YATES * sum(1/n))
    CINT <- switch(alternative,
		   "two.sided" = c(max(DELTA - WIDTH, -1),
		                   min(DELTA + WIDTH, 1)),
		   "greater" = c(max(DELTA - WIDTH, -1), 1),
		   "less" = c(-1, min(DELTA + WIDTH, 1)))
  }
  if (!is.null(CINT))
    attr(CINT, "conf.level") <- conf.level
  METHOD <- paste(ifelse(k == 1,
			 "1-sample proportions test",
			 paste(k, "-sample test for ",
			       ifelse(is.null(p), "equality of", "given"),
			       " proportions", sep = "")),
		  ifelse(YATES, "with", "without"),
		  "continuity correction")
  if (is.null(p)) {
    p <- sum(x)/sum(n)
    PARAMETER <- k - 1
  }
  else {
    PARAMETER <- k
    names(NVAL) <- names(ESTIMATE)
  }
  names(PARAMETER) <- "df"
  x <- cbind(x, n - x)
  E <- cbind(n * p, n * (1 - p))
  if (any(E < 5))
    warning("Chi-square approximation may be incorrect")
  STATISTIC <- sum((abs(x - E) - YATES)^2 / E)
  names(STATISTIC) <- "X-squared"
  if (alternative == "two.sided")
    PVAL <- 1 - pchisq(STATISTIC, PARAMETER)
  else {
    if (k == 1)
      z <- sign(ESTIMATE - p) * sqrt(STATISTIC)
    else
      z <- sign(DELTA) * sqrt(STATISTIC)
    if (alternative == "greater")
      PVAL <- 1 - pnorm(z)
    else
      PVAL <- pnorm(z)
  }
  RVAL <- list(statistic = STATISTIC,
	       parameter = PARAMETER,
	       p.value = PVAL,
	       estimate = ESTIMATE,
	       null.value = NVAL,
	       conf.int = CINT,
	       alternative = alternative,
	       method = METHOD,
	       data.name = DNAME)
  class(RVAL) <- "htest"
  return(RVAL)
}
# returns value, extra protection.  BDR 29/5/98.
qqnorm <-
function(y, ylim, main="Normal Q-Q Plot",
         xlab="Theoretical Quantiles", ylab="Sample Quantiles",
         plot.it=TRUE, ...)
{
        y <- y[!is.na(y)]
        if(!length(y)) stop("y is empty")
        if (missing(ylim)) ylim <- range(y)
        x <- qnorm((1:length(y) - 0.5)/length(y))
        if(plot.it) plot(x, sort(y), main = main, xlab = xlab,
                         ylab = ylab, ylim = ylim, ...)
        invisible(list(x = x, y = y))
}
qqline <- 
function(y, ...)
{
        y <- quantile(y[!is.na(y)],c(0.25, 0.75)) 
        x <- qnorm(c(0.25, 0.75))
        slope <- diff(y)/diff(x)
        int <- y[1]-slope*x[1]
        abline(int, slope, ...)    
}
qqplot <- function(x, y, plot.it = TRUE, xlab = deparse(substitute(x)), 
ylab = deparse(substitute(y)), ...)
{
	sx<-sort(x)
	sy<-sort(y)
	lenx<-length(sx)
	leny<-length(sy)
	if( leny < lenx )
		sx<-approx(1:lenx, sx, n=leny)$y
	if( leny > lenx )
		sy<-approx(1:leny, sy, n=lenx)$y
	if(plot.it)
		plot(sx, sy, xlab = xlab, ylab = ylab, ...)
	invisible(list(x = sx, y = sy))
}
is.qr <- function(x) !is.null(x$qr)
qr <- function(x, tol= 1e-07)
{
	x <- as.matrix(x)
	p <- as.integer(ncol(x))
	n <- as.integer(nrow(x))
	if(!is.double(x))
		storage.mode(x) <- "double"
	.Fortran("dqrdc2",
		qr=x,
		n,
		n,
		p,
		as.double(tol),
		rank=integer(1),
		qraux = double(p),
		pivot = as.integer(1:p),
		double(2*p))[c(1,6,7,8)]
}
qr.coef <- function(qr, y)
{
	if( !is.qr(qr) )
		stop("first argument must be a QR decomposition")
	n <- nrow(qr$qr)
	p <- ncol(qr$qr)
	k <- as.integer(qr$rank)
	y <- as.matrix(y)
	ny <- as.integer(ncol(y))
	storage.mode(y) <- "double"
	if( nrow(y) != n )
		stop("qr and y must have the same number of rows")
	z <- .Fortran("dqrcf",
		as.double(qr$qr),
		n, k,
		as.double(qr$qraux),
		y,
		ny,
		coef=matrix(0,nr=k,nc=ny),
		info=integer(1),
		NAOK = TRUE)[c("coef","info")]
	if(z$info != 0) stop("exact singularity in qr.coef")
	if(k < p) {
		coef <- matrix(as.double(NA),nr=p,nc=ny)
		coef[qr$pivot[1:k],] <- z$coef
	}
	else coef <- z$coef
	if(ncol(y) == 1)
		dim(coef) <- NULL
	return(coef)
}
qr.qy <- function(qr, y)
{
	if(!is.qr(qr)) stop("argument is not a QR decomposition")
	n <- as.integer(nrow(qr$qr))
	p <- as.integer(ncol(qr$qr))
	k <- as.integer(qr$rank)
	y <- as.matrix(y)
	ny <- as.integer(ncol(y))
	storage.mode(y) <- "double"
	if( nrow(y) != n )
		stop("qr and y must have the same number of rows")
	.Fortran("dqrqy",
		as.double(qr$qr),
		n, k,
		as.double(qr$qraux),
		y,
		ny,
		qy=mat.or.vec(n,ny))$qy
}
qr.qty <- function(qr, y)
{
	if(!is.qr(qr)) stop("argument is not a QR decomposition")
	n <- as.integer(nrow(qr$qr))
	p <- as.integer(ncol(qr$qr))
	k <- as.integer(qr$rank)
	y <- as.matrix(y)
	ny <- as.integer(ncol(y))
	storage.mode(y) <- "double"
	if( nrow(y) != n )
		stop("qr and y must have the same number of rows")
	.Fortran("dqrqty",
		as.double(qr$qr),
		n, k,
		as.double(qr$qraux),
		y,
		ny,
		qty=mat.or.vec(n,ny))$qty
}
qr.resid <- function(qr, y)
{
	if(!is.qr(qr)) stop("argument is not a QR decomposition")
	n <- as.integer(nrow(qr$qr))
	p <- as.integer(ncol(qr$qr))
	k <- as.integer(qr$rank)
	y <- as.matrix(y)
	ny <- as.integer(ncol(y))
	storage.mode(y) <- "double"
	if( nrow(y) != n )
		stop("qr and y must have the same number of rows")
	.Fortran("dqrrsd",
		as.double(qr$qr),
		n, k,
		as.double(qr$qraux),
		y,
		ny,
		rsd=mat.or.vec(n,ny))$rsd
}
qr.fitted <- function(qr, y, k=qr$rank)
{
	if(!is.qr(qr)) stop("argument is not a QR decomposition")
	n <- as.integer(nrow(qr$qr))
	p <- as.integer(ncol(qr$qr))
	k <- as.integer(k)
	if(k > qr$rank) stop("k is too large")
	y <- as.matrix(y)
	ny <- as.integer(ncol(y))
	storage.mode(y) <- "double"
	if( nrow(y) != n )
		stop("qr and y must have the same number of rows")
	.Fortran("dqrxb",
		as.double(qr$qr),
		n, k,
		as.double(qr$qraux),
		y,
		ny,
		xb=mat.or.vec(n,ny))$xb
}
## qr.solve is defined in 'solve'
##---- The next three are from Doug Bates ('st849'):
qr.Q <- function (qr, complete = FALSE,
		  Dvec = rep(if (cmplx) 1 + 0i else 1,
			     if (complete) dqr[1] else min(dqr)))
{
	if(!is.qr(qr)) stop("argument is not a QR decomposition")
	dqr <- dim(qr$qr)
	cmplx <- mode(qr$qr) == "complex"
	D <-
	  if (complete) diag(Dvec, dqr[1])
	  else {
		ncols <- min(dqr)
		diag(Dvec[1:ncols], nrow = dqr[1], ncol = ncols)
	  }
	qr.qy(qr, D)
}
qr.R <- function (qr, complete = FALSE)
{
	if(!is.qr(qr)) stop("argument is not a QR decomposition")
	R <- qr$qr
	if (!complete)
	  R <- R[seq(min(dim(R))), , drop = FALSE]
	R[row(R) > col(R)] <- 0
	R
}
qr.X <- function (qr, complete = FALSE,
		  ncol = if (complete) nrow(R) else min(dim(R)))
{
	if(!is.qr(qr)) stop("argument is not a QR decomposition")
	R <- qr.R(qr, complete = TRUE)
	cmplx <- mode(R) == "complex"
	p <- dim(R)[2]
	if (ncol < p)
	  R <- R[, 1:ncol, drop = FALSE]
	else if (ncol > p) {
		tmp <- diag(if (!cmplx) 1 else 1 + 0i, nrow(R), ncol)
		tmp[, 1:p] <- R
		R <- tmp
	}
	qr.qy(qr, R)
}
quantile <- function(x, ...) UseMethod("quantile")
quantile.default <-
function (x, probs = seq(0, 1, 0.25), na.rm = FALSE) {
  if (na.rm)
    x <- x[!is.na(x)]
  else if (any(is.na(x)))
    stop("Missing values and NaN's not allowed if `na.rm' is FALSE")
  n <- length(x)
  if (any(probs < 0 | probs > 1))
    stop("probs outside [0,1]")
  if (n > 0) {
    index <- 1 + (n - 1) * probs
    lo <- floor(index)
    hi <- ceiling(index)
    x <- sort(x, partial = unique(c(lo, hi)))
    i <- (index > lo)
    qs <- x[lo]
    qs[i] <- qs[i] + (x[hi[i]] - x[lo[i]]) * (index[i] - lo[i])
  } else {
    qs <- rep(as.numeric(NA), length(probs))
  }
  names(qs) <- paste(formatC(100 * probs, format = "fg", wid = 1,
                             dig = max(2,.Options$digits)),
                     "%", sep = "")
  qs
}
IQR <- function (x, na.rm = FALSE)
as.vector(diff(quantile(as.numeric(x), c(0.25, 0.75), na.rm=na.rm)))
quit <- function(save = "ask")
.Internal(quit(save))
q<-quit
range <- function(..., na.rm=FALSE, finite=FALSE)
	if(finite) { x <- c(...); x <- x[is.finite(x)]; c(min(x), max(x))
	} else c(min(..., na.rm=na.rm),max(..., na.rm=na.rm))
read.fwf <- function(file, widths, sep = " ", as.is = FALSE,
		     skip = 0, row.names, col.names) {
  FILE <- tempfile("R.")
  on.exit(unlink(FILE))
  system(paste("${RHOME}/cmd/fwf2table -f",
	       deparse(paste("A", widths, sep = "", collapse = " ")),
	       "-s", deparse(sep), file, ">", FILE))
  read.table(file = FILE, header = FALSE, sep = sep, as.is = as.is,
	     skip = skip, row.names = row.names, col.names = col.names)
}
count.fields <- function(file, sep = "", skip = 0)
	.Internal(count.fields(file, sep, skip))
read.table <-
function (file, header=FALSE, sep="", row.names, col.names, as.is=FALSE,
	na.strings="NA", skip=0)
{
	type.convert <-	function(x, na.strings="NA", as.is=FALSE)
		.Internal(type.convert(x, na.strings, as.is))
	##  basic column counting and header determination;
	##  rlabp (logical) := it looks like we have column names
	row.lens <- count.fields(file, sep, skip)
	nlines <- length(row.lens)
	rlabp <- nlines > 1 && (row.lens[2] - row.lens[1]) == 1
	if(rlabp && missing(header))
		header <- TRUE
	if (header) { # read in the header
		col.names <- scan(file, what="", sep=sep, nlines=1,
				  quiet=TRUE, skip=skip)
		skip <- skip + 1
		row.lens <- row.lens[-1]
		nlines <- nlines - 1
	} else if (missing(col.names))
		col.names <- paste("V", 1:row.lens[1], sep="")
	##  check that all rows have equal lengths
	cols <- unique(row.lens)
	if (length(cols) != 1) {
		cat("\nrow.lens=\n"); print(row.lens)
		stop("all rows must have the same length.")
	}
	##  set up for the scan of the file.
	##  we read all values as character strings and convert later.
	what <- rep(list(""), cols)
	if (rlabp)
		col.names <- c("row.names", col.names)
	names(what) <- col.names
	data <- scan(file=file, what=what, sep=sep, skip=skip,
                     na.strings=na.strings, quiet=TRUE)
	##  now we have the data;
	##  convert to numeric or factor variables
	##	(depending on the specifies value of "as.is").
	##  we do this here so that columns match up
	if(cols != length(data)) { # this should never happen
		warning(paste("cols =",cols," != length(data) =", length(data)))
		cols <- length(data)
	}
	if(is.logical(as.is)) {
		as.is <- rep(as.is, length=cols)
	} else if(is.numeric(as.is)) {
		if(any(as.is < 1 | as.is > cols))
			stop("invalid numeric as.is expression")
		i <- rep(FALSE, cols)
		i[as.is] <- TRUE
		as.is <- i
	} else if (length(as.is) != cols)
		stop(paste("as.is has the wrong length",
			   length(as.is),"!= cols =", cols))
	for (i in 1:cols)
		if (!as.is[i])
			data[[i]] <- type.convert(data[[i]])
	##  now determine row names
	if (missing(row.names)) {
		if (rlabp) {
			row.names <- data[[1]]
			data <- data[-1]
		}
		else row.names <- as.character(1:nlines)
	} else if (is.null(row.names)) {
		row.names <- as.character(1:nlines)
	} else if (is.character(row.names)) {
		if (length(row.names) == 1) {
			rowvar <- (1:cols)[match(col.names, row.names, 0) == 1]
			row.names <- data[[rowvar]]
			data <- data[-rowvar]
		}
	} else if (is.numeric(row.names) && length(row.names) == 1) {
		rlabp <- row.names
		row.names <- data[[rlabp]]
		data <- data[-rlabp]
	} else stop("invalid row.names specification")
	##  this is extremely underhanded
	##  we should use the constructor function ...
	##  don't try this at home kids
	class(data) <- "data.frame"
	row.names(data) <- row.names
	data
}
rect <-
function(xleft, ybottom, xright, ytop,
         col=NULL, border=par("fg"), lty=NULL, xpd=FALSE) {
 .Internal(rect(
	as.double(xleft),
	as.double(ybottom),
	as.double(xright),
	as.double(ytop),
	col=col,
	border=border,
	lty=lty,
	xpd=xpd))
}
rep <- function(x, times, length.out)
{
	if (length(x) == 0)
		return(x)
	if (missing(times))
		times <- ceiling(length.out/length(x))
	r <- .Internal(rep(x,times))
	if(!is.null(nm <- names(x))) names(r) <- .Internal(rep(nm, times))
	if (!missing(length.out))
		return(r[if(length.out>0) 1:length.out else integer(0)])
	return(r)
}
replace <-
function (x, list, values) 
{
        x[list] <- values
        x
}
rev <- function(x) x[length(x):1]
rm <-
function(..., list=character(0), pos=-1, envir=pos.to.env(pos), inherits=FALSE)
{
	names<- as.character(substitute(list(...)))[-1]
	list<-c(list, names)
	.Internal(remove(list, envir, inherits))
}
remove <- rm
rownames <- function(x) {
	dn <- dimnames(x)
	if(is.null(dn)) dn else dn[[1]]
}
"rownames<-" <- function(x, value) {
	dn <- dimnames(x)
	if(is.null(dn)) dimnames(x) <- list(value, dn)
	else dimnames(x) <- list(value, dn[[2]])
	x
}
rug <- function(x, ticksize = 0.03, side = 1, lwd = 0.5) {
  x <- as.vector(x)
  on.exit(par(oldtick))
  oldtick <- par(tck = ticksize)
  axis(side, at = x, lab = FALSE, lwd = lwd)
}
sample <- function(x, size, replace=FALSE)
{
	if(length(x) == 1 && x >= 1) {
		if(missing(size)) size <- x
		.Internal(sample(x, size, replace))
	}
	else {
		if(missing(size)) size <- length(x)
		x[.Internal(sample(length(x), size, replace))]
	}
}
sapply <- function(X, FUN, ..., simplify = TRUE)
{
	if(is.character(FUN))
		FUN <- get(FUN, mode = "function")
	else if(mode(FUN) != "function") {
		farg <- substitute(FUN)
		if(mode(farg) == "name")
			FUN <- get(farg, mode = "function")
		else stop(paste("\"", farg, "\" is not a function", sep = ""))
	}
	answer <- lapply(as.list(X), FUN, ...)
	if(simplify && length(answer) &&
	   length(common.len <- unique(unlist(lapply(answer, length)))) == 1) {
		if(common.len == 1)
			unlist(answer, recursive = FALSE)
		else if(common.len > 1)
			array(unlist(answer, recursive = FALSE),
				dim= c(common.len, length(X)),
				dimnames= list(names(answer[[1]]), names(answer)))
		else answer
	} else answer
}
scale <-
function(x, center = TRUE, scale = TRUE)
{
	x <- as.matrix(x)
	nc <- ncol(x)
	if (is.logical(center)) {
		if (center)
			x <- sweep(x, 2, apply(x, 2, mean, na.rm=TRUE))
	}
	else if (is.numeric(center) && (length(center) == nc))
		x <- sweep(x, 2, center)
	else
		stop("Length of center must equal the number of columns of x")
	if (is.logical(scale)) {
		if (scale) {
			f <- function(v) {
				nas <- is.na(v)
				if(any(is.na(nas)))
					v <- v[!is.na(nas)]
				sqrt(sum(v^2) / max(1, length(v) - 1))
			}
			x <- sweep(x, 2, apply(x, 2, f), "/")
		}
	}
	else if (is.numeric(scale) && length(scale) == nc)
		x <- sweep(x, 2, scale, "/")
	else
		stop("Length of scale must equal the number of columns of x")
	x
}
scan <-
function(file="", what= double(0), nmax=-1, n=-1, sep="", skip=0, nlines=0,
         na.strings="NA", flush=FALSE, strip.white=FALSE, quiet=FALSE) {
	if(!missing(sep))
        	na.strings<-c(na.strings,"")
        if(!missing(n)) {
          	if(missing(nmax))
                  	nmax <- n/length(what)
                else
                	stop("Either specify 'nmax' or 'n', but not both.")
        }
	.Internal(scan(file, what, nmax, sep, skip, nlines,
                       na.strings,flush,strip.white, quiet))
}
sd <- function(x, na.rm=FALSE) sqrt(var(x, na.rm=na.rm))
segments <- function(x0, y0, x1, y1, col=par("fg"), lty=par("lty"), xpd = FALSE)
	.Internal(segments(x0, y0, x1, y1, col=col, lty=lty, xpd=xpd))
seq <- function(x, ...) UseMethod("seq")
seq.default <-
function(from = 1, to = 1, by = ((to - from)/(length.out - 1)),
	 length.out = NULL, along.with = NULL) {
	if(!missing(along.with))
		length.out <- length(along.with)
	else if(!missing(length.out))
		length.out <- ceiling(length.out)
	if(nargs() == 1 && !missing(from)) {
		if(mode(from) == "numeric" && length(from) == 1)
			1:from
		else seq(along.with = from)
	}
	else if(is.null(length.out))
		if(missing(by))
			from:to
		else {
			n <- (del <- to - from)/by
			if(del == 0)
				return(from)
			else if(is.na(n)) {
				if(by == 0 && del == 0)
					return(from)
				else stop("invalid (to - from)/by in seq(.)")
			} else if(abs(n) > .Machine$integer.max)
				stop("'by' argument is much too small")
			else if(n < 0)
				stop("Wrong sign in by= argument")
			eps <- .Machine$double.eps *
				max(1, max(abs(to),abs(from)) / abs(del))
			n <- as.integer(n * (1 + eps))
			if(eps*2*n >= 1)
				warning(paste("seq.default(f,t,by): n=",n,
					      ": possibly imprecise intervals"))
			if(by>0) while(from+ n*by > to) n <- n - 1
			else	 while(from+ n*by < to) n <- n - 1
			from + (0:n) * by
		}
	else if(length.out < 0)
		stop("Length cannot be negative")
	else if(length.out == 0)
		integer(0)
	else if(missing(by)) {
		if(from == to || length.out < 2)
			by <- 1
		if(missing(to))
			to <- from + length.out - 1
		if(missing(from))
			from <- to - length.out + 1
		if(length.out > 2)
			if(from == to)
				rep(from, length.out)
			else as.vector(c(from, from + (1:(length.out - 2)) *
					by, to))
		else as.vector(c(from, to))[1:length.out]
	}
	else if(missing(to))
		from + (0:(length.out - 1)) * by
	else if(missing(from))
		to - ((length.out - 1):0) * by
	else stop("Too many arguments")
}
sequence <- function(nvec)
{
	sequence <- NULL
	for(i in nvec) sequence<-c(sequence,seq(1:i))
	return(sequence)
}
qr.solve <- function(a, b, tol = 1e-7)
{
	if( !is.qr(a) )
		a <- qr(a, tol = tol)
	nc <- ncol(a$qr)
	if( a$rank != nc )
		stop("singular matrix `a' in solve")
	if( missing(b) ) {
		if( nc != nrow(a$qr) )
			stop("only square matrices can be inverted")
		b<-diag(1,nc)
	}
	b<-as.matrix(b)
	return(qr.coef(a,b))
}
solve <- function(a, b, ...) UseMethod("solve")
solve.default <- qr.solve
solve.qr <- qr.solve
sort <- function(x, partial=NULL, na.last=NA) {
	isfact<-is.factor(x)
	if(isfact){
		lev<-levels(x)
		nlev<-nlevels(x)
	}
	nas <- x[is.na(x)]
	x <- c(x[!is.na(x)])
	if(!is.null(partial))
		y <- .Internal(psort(x, partial))
	else {
		nms <- names(x)
		if(!is.null(nms)) {
			o <- order(x)
			y <- x[o]
			names(y) <- nms[o]
		}
		else
			y <- .Internal(sort(x))
	}
	if(!is.na(na.last)) {
		if(!na.last) y <- c(nas, y)
		else if (na.last) y <- c(y, nas)
	}
	if(isfact) y<-factor(y,levels=1:nlev,labels=lev)
	y
}
source <-
function(file, local=FALSE, echo = debug, print.eval=echo, debug=FALSE,
	 max.deparse.length=150)
{
 envir <- if (local) sys.frame(sys.parent()) else .GlobalEnv
 if(debug) { cat("'envir' chosen:"); print(envir) }
 Ne <- length(exprs <- parse(n = -1, file = file))
 if(debug)
	cat("--> parsed", Ne, "expressions; now eval(.)ing them:\n")
 if (Ne == 0) return(invisible())
 ass1 <- expression(y <- x)[[1]][[1]] #-- ass1 :  the  '<-' symbol/name
 for (i in 1:Ne) {
	if(debug)
	  cat("\n>>>> eval(expression_nr.",i,")\n\t  =================\n")
	ei <- exprs[i]
	if(echo) {
		dep <- substr(paste(deparse(ei), collapse="\n"),
                              12, 1e6)# drop "expression("
                nd <- nchar(dep) -1 # -1: drop ")"
                do.trunc <- nd > max.deparse.length
		dep <- paste(substr(dep, 1,
                                    if(do.trunc)max.deparse.length else nd),
                             if(do.trunc)" .... [TRUNCATED] ")
		cat("\n> ", dep, "\n", sep="")
	}
	yy <- eval(ei, envir)
	i.symbol <- mode(ei[[1]]) == "name"
	if(!i.symbol) {
		curr.fun <- ei[[1]][[1]]## ei[[1]] : the function "<-" or other
		if(debug) { cat('curr.fun:'); str(curr.fun) }
	}
	if(debug >= 2) {
	  cat(".... mode(ei[[1]])=", mode(ei[[1]]),"; paste(curr.fun)=");
	  str(paste(curr.fun))
	}
	if(print.eval &&
	   (i.symbol|| (length(pf <- paste(curr.fun))==1 &&
			all(paste(curr.fun) != c("<-","cat", "str", "print")))))
		print(yy)
	if(debug) cat(" .. after `", deparse(ei), "'\n", sep="")
 }
 invisible(yy)
}
sys.source <- function (file)
{
	exprs <- parse(n = -1, file = file)
	if (length(exprs) == 0) return(invisible())
	for (i in exprs) {
		yy <- eval(i, NULL)
	}
	invisible(yy)
}
demo <- function(topic, device = x11, directory.sep = "/")
{
 Topics <-cbind(graphics = c("graphics","graphics.R",	"G"),
		image	 = c("graphics","image.R",	"G"),
		lm.glm	 = c("models",	"lm+glm.R",	"G"),
		glm.vr	 = c("models",	"glm-v+r.R",	""),
		nlm	 = c("nlm",	"valley.R",	""),
		recursion= c("language","recursion.R",	"G"),
		scoping	 = c("language","scoping.R",	""),
		is.things= c("language","is-things.R",	"")
		)
 dimnames(Topics)[[1]] <- c("dir", "file", "flag")
 topic.names <- dimnames(Topics)[[2]]
 demo.help <- function() {
	cat("Use ``demo(topic)'' where choices for argument `topic' are:\n")
	cbind(topics = topic.names)
 }
 if(missing(topic)) return(demo.help())
 topic <- substitute(topic)
 if (!is.character(topic)) topic <- deparse(topic)[1]
 i.top <- pmatch(topic, topic.names)
 if (is.na(i.top) || i.top == 0) {
	cat("unimplemented `topic' in demo.\n")
	print(demo.help())
	stop()
 } else {
	topic <- topic.names[i.top]
	cat("\n\n\tdemo(",topic,")\n\t---- ",rep("~",nchar(topic)),
	    "\n\nType  <Return>	 to start : ",sep="")
	readline()
	if(dev.cur()<=1 && Topics["flag",i.top] == "G")
		device()
	source(paste(getenv("RHOME"),
		     "demos",
		     Topics["dir",  i.top],
		     Topics["file", i.top], sep= directory.sep),
	       echo = TRUE, max.deparse.length=10000)
 }
}
spline <-
function(x, y=NULL, n=3*length(x), method="fmm", xmin=min(x), xmax=max(x))
{
	x <- xy.coords(x, y)
	y <- x$y
	x <- x$x
## ensured by  xy.coords(.) :
## 	if (!is.numeric(x) || !is.numeric(y))
## 		stop("spline: x and y must be numeric")
	nx <- length(x)
## ensured by  xy.coords(.) :
## 	if (nx != length(y))
## 		stop("x and y must have equal lengths")
	method <- match(method, c("periodic", "natural", "fmm"))
	if(is.na(method))
		stop("spline: invalid interpolation method")
	dx <- diff(x)
	if(any(dx < 0)) {
            o <- order(x)
            x <- x[o]
            y <- y[o]
        }
	if(method == 1 && y[1] != y[nx]) {
		warning("spline: first and last y values differ - using y[1] for both")
		y[nx] <- y[1]
	}
	z <- .C("spline_coef",
		method=as.integer(method),
		n=nx,
		x=x,
		y=y,
		b=double(nx),
		c=double(nx),
		d=double(nx),
		e=double(if(method == 1) nx else 0))
	u <- seq(xmin, xmax, length.out=n)
##-  cat("spline(.): result of  .C(\"spline_coef\",...):\n")
##-  str(z, vec.len=10)
##-  cat("spline(.): now calling .C(\"spline_eval\", ...)\n")
	.C("spline_eval",
		z$method,
                nu=length(u),
		x =u,
		y =double(n),
		z$n,
		z$x,
		z$y,
		z$b,
		z$c,
		z$d)[c("x","y")]
}
splinefun <- function(x, y=NULL, method="fmm")
{
	x <- xy.coords(x, y)
	y <- x$y
	x <- x$x
	n <- length(x)# = length(y), ensured by xy.coords(.)
	method <- match(method, c("periodic", "natural", "fmm"))
	if(is.na(method))
		stop("splinefun: invalid interpolation method")
	if(any(diff(x) < 0)) {
	    z <- order(x)
	    x <- x[z]
	    y <- y[z]
	}
	if(method == 1 && y[1] != y[n]) {
		warning("first and last y values differ in spline - using y[1] for both")
		y[n] <- y[1]
	}
	z <- .C("spline_coef",
		method=as.integer(method),
		n=n,
		x=x,
		y=y,
		b=double(n),
		c=double(n),
		d=double(n),
		e=double(if(method == 1) n else 0))
	rm(x,y,n,method)
	function(x) {
		.C("spline_eval",
			z$method,
			length(x),
			x=as.double(x),
			y=double(length(x)),
			z$n,
			z$x,
			z$y,
			z$b,
			z$c,
			z$d)$y
	}
}
split <-
  function( x, f )
  UseMethod( "split" )
split.default <-
  function( x, f )
  .Internal( split( x, as.factor( f ) ) )
split.data.frame <-
  function( x, f )
{
  lapply( split( 1:nrow( x ), f ), function( ind ) x[ ind, , drop = FALSE ] )
}
stem <- function(x, scale = 1, width = 80, atom = 0.00000001) {
  if (!is.numeric(x) )
    stop("stem: x must be numeric")
  x <- x[!is.na(x)]
  if (length(x)==0) stop("no non-missing values")
  if (scale <= 0) stop("scale must be positive")# unlike S
  .C("stemleaf", as.double(x), length(x),
     as.double(scale), as.integer(width), as.double(atom))
  invisible(NULL)
}
####------ str : show STRucture of an R object
str <- function(object, ...) UseMethod("str")
str.data.frame <- function(object, ...)
{
  ## Method to 'str' for  'data.frame' objects
  ## $Id: str.R,v 1.4 1998/05/06 16:53:28 maechler Exp $
  if(! is.data.frame(object)) {
    warning("str.data.frame(.) called with non-data.frame. Trying to coerce it")
    object <- data.frame(object)
  }
  ##- Show further classes // Assume that they do NOT have an own Method --
  ##- not quite perfect ! (.Class = 'remaining classes', starting with current)
  cl <- class(object); cl <- cl[cl != "data.frame"]  #- not THIS class
  if(0 < length(cl)) cat("Classes", cl, " and ")
  cat("`data.frame': ", nrow(object), "obs. of ",
      length(object), "variables:\n")
  ## calling next method, usually  str.default:
  ## still wrong(0.14):
  ## fails for 0.16.1, lm.xy $ model.frame:
  ##invisible(NextMethod("str", give.length=FALSE,...))
  if(!is.null(list(...)) && any("give.length" == names(list(...))))
    invisible(NextMethod("str", ...))
  else invisible(NextMethod("str", give.length=FALSE,...))
}
str.default <- function(object, max.level = 0, vec.len = 4, digits.d = 3,
                        give.attr = TRUE, give.length = TRUE,
                        wid = .Options$width,
                        nest.lev = 0,
                        indent.str = paste(rep(" ", max(0, nest.lev + 1)),
                          collapse = "..")
                        )
{
  ## Purpose: Display STRucture of any R - object (in a compact form).
  ## -------------------------------------------------------------------------
  ## Arguments: --- see HELP file --
  ##    max.level: Maximal level of nesting to be reported (0: as many as nec.)
  ##
  ## -------------------------------------------------------------------------
  ## Author: Martin Maechler <maechler@stat.math.ethz.ch>     1990--1997
  ## ------ Please send Bug-reports, -fixes and improvements !
  ## -------------------------------------------------------------------------
  ## $Id: str.R,v 1.4 1998/05/06 16:53:28 maechler Exp $
  oo <- options(digits = digits.d)
  ##was .Options $ digits <- digits.d # only in this function frame !
  on.exit(options(oo))
  le <- length(object)
  ## le.str: not used for arrays:
  le.str <-
    if(is.na(le)) " __no length(.)__ " else
    if(give.length) {
      if(le > 0) paste("[1:", paste(le), "]", sep = "")  else "(0)"
    } else ""
  std.attr <- "names"                   #-- Default NON interesting attributes
  has.class <- !is.null(cl <- class(object))
  mod <- ""
  if(give.attr) a <- attributes(object)#-- save for later...
  if(is.function(object)) {
    cat(if(is.null(ao <- args(object)))
           deparse(object)  else { dp <- deparse(ao); dp[-length(dp)] },"\n")
  } else if (is.null(object))
    cat(" NULL\n")
  else if(is.list(object)) {
    if(le == 0) { cat(" list()\n"); return(invisible()) }
    is.d.f <- is.data.frame(object)
    if(is.d.f ||
       (has.class &&
        any(sapply(paste("str", cl, sep="."), #use sys.function(.) ..
                   function(ob)exists(ob,mode="function", inherits = TRUE))))) {
      ##---- str.default  is a 'NextMethod' : omit the 'List of ..' ----
      std.attr <- c(std.attr, "class", if(is.d.f) "row.names")
    } else {
      cat("List of ", le, "\n", sep="")
      ##cat("List with ", le, " item", ifelse(le>1,"s",""), "\n",sep="")
    }
    if (max.level==0 || nest.lev < max.level) {
      nam.ob <-
        if(is.null(nam.ob <- names(object))) rep("", le)
        else { max.ncnam <- max(nchar(nam.ob))
               formatC(nam.ob, width = max.ncnam, flag = '-')
             }
      for(i in 1:le) {
        cat(indent.str,"$ ", nam.ob[i], ":", sep="")
        str(object[[i]], nest.lev = nest.lev + 1,
            indent.str = paste(indent.str,".."),
            max.level = max.level, vec.len = vec.len, digits.d = digits.d,
            give.attr = give.attr, give.length= give.length, wid=wid)
      }
    }
  } else { #- not function, not list
    if(is.vector(object)
       || (is.array(object) && is.atomic(object))
       || is.vector(object, mode='language')## R bug (<=0.50-a4) should be part
       || is.vector(object, mode='symbol')  ## R bug (<=0.50-a4) should be part
                    ) { ##-- Splus: FALSE for 'named vectors'
      if(is.atomic(object)) {
        ##-- atomic:   numeric  complex  character  logical
        mod <- substr(mode(object), 1, 4)
        if     (mod == "nume") mod <- if(is.integer(object))"int" else "num"
        else if(mod == "char") mod <- "chr"
        else if(mod == "comp") mod <- "cplx" #- else: keep 'logi'
        if(is.array(object)) {
          di <- dim(object)
          di <- paste(ifelse(di>1, "1:",""), di, ifelse(di>0,""," "), sep = "")
          le.str <- paste(c("[", paste(di[ - length(di)], ", ", sep = ""),
                            di[length(di)], "]"), collapse = "")
          std.attr <- "dim" #- "names"
        } else if(!is.null(names(object))) {
          mod <- paste("Named", mod)
          std.attr <- std.attr[std.attr != "names"]
        }
        str1 <- if(le == 1) paste(NULL, mod)
                 else       paste(" ", mod, if(le>0)" ", le.str, sep = "")
      } else {                          #-- not atomic, but vector: #
        mod <- typeof(object)#-- was mode(..);  typeof(.) is more precise!
        ## mode: call expression argument graphics name comment.expression ...
        str1 <- switch(mod,
                       call = " call",
                       language = " language",
                       symbol = " symbol",
                       expression = " ", # "expression(..)" put by deparse(.)
                       name = " name",
                       ##not in R:argument = "",  #-- .Argument(.) by deparse(.)
                       ## default :
                       paste("          #>#>", mod, NULL)
                       )
      }
    } else if (inherits(object,"rts") || inherits(object,"cts")
               || inherits(object,"its")) {
      tsp.a <- tspar(object)
      t.cl <- cl[b.ts <- substring(cl,2,3) == "ts"] #- "rts"  "cts" or "its"
      ts.kind <- switch(t.cl, rts="Regular", cts="Calendar", its="Irregular")
      ## from  print.summary.ts(.) :
      pars <- unlist(sapply(summary(object)$ pars, format,
                            nsmall=0, digits=digits.d, justify = "none"))
      if(length(pars)>=4) pars <- pars[-3]
      pars <- paste(abbreviate(names(pars),min=2), pars,
                    sep= "=", collapse=", ")
      str1 <- paste(ts.kind, " Time-Series ", le.str, " ", pars, ":", sep = "")
      vec.len <- switch(t.cl,rts=.8, cts=.6, its=.9) * vec.len
      class(object) <- if(any(!b.ts)) cl[!b.ts]
      std.attr <- c(std.attr, "tspar")
    } else if(is.ts(object)) {
      tsp.a <- tsp(object)
      str1 <- paste(" Time-Series ", le.str, " from ", format(tsp.a[1]),
                    " to ", format(tsp.a[2]), ":", sep = "")
      std.attr <- c("tsp","class")         #- "names"
    } else if (is.factor(object)) {
      str1 <- " Factor class"
      object <- unclass(object)
      nl <- length(lev.att <- levels(object))
      str1 <- paste(str1, " ", le.str, "; ", nl, " levels: ",
                    paste(lev.att[1:min(2,nl)], collapse =","),
                    ":", sep="")
      std.attr <- "levels"      #- "names"
    } else if(has.class) {
      ## str1 <- paste("Class '",cl,"' of length ", le, " :", sep="")
      ##===== NB. cl may be of length > 1 !!! ===========
      cat("Class ", cl, " ", sep="'")
      ## has.method <- exists( paste("str", cl, sep=".") )
      ##== If there is a str.METHOD,
      ##== it should have been called BEFORE this !
      str(unclass(object),
          max.level = max.level, vec.len = vec.len, digits.d = digits.d,
          indent.str = paste(indent.str,".."), nest.lev = nest.lev + 1,
          give.attr = give.attr, wid=wid)
      return(invisible())
    } else if(is.atomic(object)) {
      if((1 == length(a <- attributes(object))) && (names(a) == "names"))
        str1 <- paste(" Named vector", le.str)
        else {
          ##-- atomic / not-vector  "unclassified object" ---
          str1 <- paste(" atomic", le.str)
        }
    } else {
      ##-- NOT-atomic / not-vector  "unclassified object" ---
      ##str1 <- paste(" ??? of length", le, ":")
      str1 <- paste("length", le)
    }
###-###-- end  if elseif elseif .. --------------------------
    ##-- This needs some improvement: Not list nor atomic --
    if ((is.language(object) || !is.atomic(object)) && !has.class) {
                                        #-- has.class superfluous --
      mod <- mode(object)
      give.mode <- FALSE
      if (mod == "call" || mod == "language" || mod == "symbol"
          || is.environment(object)) {
        ##give.mode <- !is.vector(object) #-- then it has not yet been done
        object <- deparse(object)
        le <- length(object) # == 1 , always(?), depending on 'char.length??
        format.fun <- function(x)x
        vec.len <- round(.5 * vec.len)
      } else if (mod == "expression") {
        ##give.mode <- !is.vector(object) #-- then it has not yet been done
        format.fun <- function(x) deparse(as.expression(x))
        vec.len <- round(.75 * vec.len)
      } else if (mod == "name"){
        object <- paste(object); mod <- 'chr' #-- show "as" char.
      } else if (mod == "argument"){
        format.fun <- deparse
      } else {
        give.mode <- TRUE
      }
      if(give.mode) str1 <- paste(str1, ', mode "', mod,'":', sep = "")
    } else if(is.logical(object)) {
      vec.len <- 3 * vec.len
      format.fun <- format
    } else if(is.numeric(object)) {
      ivec.len <- round(2.5 * vec.len)
      if(!is.integer(object)){
        ob <- if(le > ivec.len) object[1:ivec.len] else object
        ao <- abs(ob <- ob[!is.na(ob)])
      }
      if(is.integer(object) ||
         (all(ao > 1e-10 | ao==0) && all(ao < 1e10| ao==0) &&
          all(ob == signif(ob, digits.d)))) {
        vec.len <- ivec.len
        format.fun <- function(x)x
      } else {
        vec.len <- round(1.25 * vec.len)
        format.fun <- format
      }
    } else if(is.complex(object)) {
      vec.len <- round(.75 * vec.len)
      format.fun <- format
    }
    if(mod == 'chr') {
      bracket <- if (le>0) '"' else ""
      format.fun <- function(x)x
      vec.len <- sum(cumsum(3 + if(le>0) nchar(object) else 0) <
                     wid - (4 + 5 * nest.lev + nchar(str1)))
                                        # 5*nest is 'arbitrary'
    } else {
      bracket <- ""
      if(!exists("format.fun", inherits=TRUE)) #-- define one --
        format.fun <-
          if(mod == 'num' || mod == 'cplx') format
            else           as.character
    }
    if(is.na(le)) { warning("'str.default': 'le' is NA !!"); le <- 0}
    cat(str1, " ", bracket,
        paste(format.fun(if(le>1) object[1:min(vec.len, le)] else object),
              collapse = paste(bracket, " ", bracket, sep="")),
        bracket, if(le > vec.len) " ...", "\n", sep="")
  } ## else (not function nor list)----------------------------------------
  if(give.attr) { #possible:   || has.class && any(cl == 'terms')
    nam <- names(a)
    for (i in seq(len=length(a)))
      if (all(nam[i] != std.attr)) { #-- only show ``non-standard'' attributes:
        cat(indent.str, paste('- attr(*, "',nam[i],'")=', sep=''), sep="")
        str(a[[i]],
            indent.str = paste(indent.str,".."), nest.lev = nest.lev + 1,
	    max.level = max.level, vec.len = vec.len, digits.d = digits.d,
            give.attr = give.attr, give.length = give.length, wid = wid)
      }
  }
  invisible()  ## invisible(object)#-- is SLOOOOW on large objects
} #-- end of function 'str.default' --
ls.str <- function(..., mode = "any", max.level = 1, give.attr = FALSE)
{
  ##--- An extended "ls()" using  str(.) --
  for(name in ls(..., envir = sys.frame(sys.parent())))
    if(exists(name, mode = mode)) {
      cat(name, ": ")
      str(get(name, mode = mode), max.level = max.level, give.attr = give.attr)
    }
  invisible()
}
lsf.str <- function(...)
{
  ##--- An extended "ls()" -- find ONLY functions -- using  str(.) --
  r <- character(0)
  for(name in ls(..., envir = sys.frame(sys.parent())))
    if(is.function(get(name))) {
      cat(name, ": ")
      r <- c(r,name)
      str(get(name))
    }
  invisible(r)
}
# Dotplots a la Box, Hunter and Hunter
stripplot <- function(x, method="overplot", jitter=0.1, offset=1/3,
		vertical=FALSE, group.names,
		xlim=NULL, ylim=NULL, main="", ylab="", xlab="",
		pch=0, col=par("fg"), cex=par("cex"))
{
	method <- pmatch(method, c("overplot", "jitter", "stack"))[1]
	if(is.na(method) || method==0)
		error("invalid plotting method")
	if(is.language(x)) {
		if(length(x) == 3 && deparse(x[[1]]) == '~') {
			groups <- eval(x[[3]], sys.frame(sys.parent()))
			x <- eval(x[[2]], sys.frame(sys.parent()))
			groups <- split(x, groups)
		}
		else stop("invalid first argument")
	}
	else if(is.list(x)) {
		groups <- x
	}
	else if(is.numeric(x)) {
		groups <- list(x)
	} else stop("invalid first argument")
	n <- length(groups)
	if(!missing(group.names)) attr(groups, "names") <- group.names
	else if(is.null(attr(groups, "names"))) attr(groups, "names") <- 1:n
	dlim <- rep(NA, 2)
	for(i in groups)
		dlim <- range(dlim, i, finite=TRUE)
	glim <- c(1, n)
	if(method == 2) { # jitter
		glim <- glim +	jitter * if(n == 1) c(-5, 5) else c(-2, 2)
	} else if(method == 3) { # stack
		glim <- glim + if(n == 1) c(-1,1) else c(0, 0.5)
	}
	if(is.null(xlim)) {
		xlim <- if(vertical) glim else dlim
	}
	if(is.null(ylim)) {
		ylim <- if(vertical) dlim else glim
	}
	plot(xlim, ylim, type="n", ann=FALSE, axes=FALSE)
	box()
	if(vertical) {
		if(n > 1) axis(1, at=1:n, lab=names(groups))
		axis(2)
	}
	else {
		axis(1)
		if(n > 1) axis(2, at=1:n, lab=names(groups))
	}
	csize <- cex*
	  if(vertical) xinch(par("cin")[1]) else yinch(par("cin")[2])
	f <- function(x) seq(length(x))
	for(i in 1:n) {
		x <- groups[[i]]
		y <- rep(i,length(x))
		if(method == 2)
			y <- y + runif(length(y), -jitter, jitter)
		else if(method == 3) {
			xg <- split(x, factor(x))
			xo <- lapply(xg, f)
			x <- unlist(xg)
			y <- y + (unlist(xo) - 1) * offset * csize
		}
		if(vertical) points(y, x, col=col[(i - 1)%%length(col) + 1],
			pch=pch[(i - 1)%%length(pch) + 1], cex=cex)
		else points(x, y, col=col[(i - 1)%%length(col) + 1],
			pch=pch[(i - 1)%%length(pch) + 1], cex=cex)
	}
	title(main=main, xlab=xlab, ylab=ylab)
}
"structure" <-
function (.Data, ...)
{
	specials <- c(".Dim", ".Dimnames", ".Names", ".Tsp", ".Label")
	replace <- c("dim", "dimnames", "names", "tsp", "levels")
	attrib <- list(...)
	if(!is.null(attrib)) {
		m <- match(names(attrib), specials)
		ok <- (!is.na(m) & m > 0)
		names(attrib)[ok] <- replace[m[ok]]
		if(any(names(attrib) == "tsp"))
			attrib$class <- unique(c("ts", attrib$class))
		if(is.numeric(.Data) && any(names(attrib) == "levels"))
			.Data <- factor(.Data)
		attributes(.Data) <- c(attributes(.Data), attrib)
	}
	return(.Data)
}
strwidth <- function(s, units="user", cex=NULL) {
	.Internal(strwidth(s, pmatch(units, c("user", "figure", "inches")), cex))
}
strheight <- function(s, units="user", cex=NULL) {
	.Internal(strheight(s, pmatch(units, c("user", "figure", "inches")), cex))
}
sum <- function(..., na.rm=FALSE) 
.Internal(sum(...,na.rm=na.rm))
min <- function(..., na.rm=FALSE) 
.Internal(min(...,na.rm=na.rm))
max <- function(..., na.rm=FALSE) 
.Internal(max(...,na.rm=na.rm))
prod <- function(...,na.rm=FALSE)
.Internal(prod(...,na.rm=na.rm))
all <- function(...,na.rm=FALSE)
.Internal(all(...,na.rm=na.rm))
any <- function(...,na.rm=FALSE)
.Internal(any(...,na.rm=na.rm))
summary <- function (object, ...) UseMethod("summary")
summary.default <- function(object, ..., digits = max(3, .Options$digits - 3))
{
	if(is.factor(object))
		return(summary.factor(object, ...))
	else if(is.matrix(object))
		return(summary.matrix(object, ...))
	value <- if(is.numeric(object)) {
		nas <- is.na(object)
		object <- object[!nas]
		qq <- quantile(object)
		qq <- signif(c(qq[1:3], mean(object), qq[4:5]), digits)
		names(qq) <- c("Min.", "1st Qu.", "Median", "Mean", "3rd Qu.", "Max.")
		if(any(nas))
			c(qq, "NA's" = sum(nas))
		else qq
	} else if(is.recursive(object) && !is.language(object) &&
	    (n <- length(object))) {
		sumry <- array("", c(n, 3), list(names(object),
			c("Length", "Class", "Mode")))
		ll <- numeric(n)
		for(i in 1:n) {
			ii <- object[[i]]
			ll[i] <- length(ii)
			cls <- class(ii)
			sumry[i, 2] <- if(length(cls)>0) cls[1] else "-none-"
			sumry[i, 3] <- mode(ii)
		}
		sumry[, 1] <- format(as.integer(ll))
		class(sumry) <- "table"
		sumry
	}
	else c(Length= length(object), Class= class(object), Mode= mode(object))
	class(value) <- "table"
	value
}
summary.factor <- function(object, maxsum = 100, ...)
{
	nas <- is.na(object)
	ll <- levels(object)
	if(any(nas)) maxsum <- maxsum - 1
	tbl <- table(object)
	tt <- c(tbl) # names dropped ...
	names(tt) <- dimnames(tbl)[[1]]
	if(length(ll) > maxsum) {
		drop <- maxsum:length(ll)
		o <- rev(order(tt))
		tt <- c(tt[o[ - drop]], "(Other)" = sum(tt[o[drop]]))
	}
	if(any(nas)) c(tt, "NA's" = sum(nas)) else tt
}
summary.matrix <- function(object, ...) summary.data.frame(data.frame(object))
summary.data.frame <- function(object, maxsum = 7, ...)
{
	z <- lapply(as.list(object), summary, maxsum = maxsum)
	nv <- length(object)
	nm <- names(object)
	lw <- numeric(nv)
	nr <- max(unlist(lapply(z, length)))
	for(i in 1:nv) {
		sms <- z[[i]]
		lbs <- format(names(sms))
		sms <- paste(lbs, ":", format(sms), "  ", sep = "")
		lw[i] <- nchar(lbs[1])
		length(sms) <- nr
		z[[i]] <- sms
	}
	z <- unlist(z, use.names=FALSE)
	dim(z) <- c(nr, nv)
 	blanks <- paste(character(max(lw) + 2), collapse = " ")
 	pad <- floor(lw-nchar(nm)/2)
 	nm <- paste(substring(blanks, 1, pad), nm, sep = "")
 	dimnames(z) <- list(rep("", nr), nm)
	attr(z, "class") <- c("table") #, "matrix")
	z
}
print.table <-
function(x, digits= .Options$digits, quote = FALSE, na.print='', ...)
{
 print.default(unclass(x), digits=digits, quote=quote, na.print=na.print, ...)
}
svd <- function(x, nu=min(n,p), nv=min(n,p)) {
	if(!is.numeric(x))
		stop("argument to svd must be numeric")
	x <- as.matrix(x)
	dx <- dim(x)
	n <- dx[1]
	p <- dx[2]
	if(nu == 0) {
		job <- 0
		u <- double(0)
	}
	else if(nu == n) {
		job <- 10
		u <- matrix(0, n, n)
	}
	else if(nu == p) {
		job <- 20
		u <- matrix(0, n, p)
	}
	else
		stop("nu must be 0, nrow(x) or ncol(x)")
	job <- job +
	  if(nv == 0) 0 else if(nv == p || nv == n) 1 else
		stop("nv must be 0 or ncol(x)")
	v <- if(job == 0) double(0) else matrix(0, p, p)
	mn <- min(n,p)
	mm <- min(n+1,p)
	z <- .Fortran("dsvdc",
		as.double(x),
		n,
		n,
		p,
		d=double(mm),
		double(p),
		u=u,
		n,
		v=v,
		p,
		double(n),
		as.integer(job),
		info=integer(1),
		DUP=FALSE)[c("d","u","v","info")]
	if(z$info)
		stop(paste("error ",z$info," in dsvdc"))
	z$d <- z$d[1:mn]
	if(nv && nv < p) z$v <- z$v[, 1:nv]
	z[c("d", if(nu) "u", if(nv) "v")]
}
sweep <-
function(x, MARGIN, STATS, FUN = "-", ...)
{
	if(is.character(FUN))
		FUN <- get(FUN)
	dims <- dim(x)
	perm <- c(MARGIN, (1:length(dims))[ - MARGIN])
	FUN(x, aperm(array(STATS, dims[perm]), order(perm)), ...)
}
switch <- function(EXPR,...)
	.Internal(switch(EXPR,...))
symbols <- function(...) .NotYetImplemented()
symnum <- function(x, cutpoints = c(  .3,  .6,	 .8,  .9, .95),
		   symbols =	 c(" ", ".", ",", "+", "*", "B"),
		   na = "?", eps = 1e-5,
		   corr = missing(cutpoints),
		   show.max = if(corr) "1", show.min = NULL,
		   lower.triangular = corr & is.matrix(x),
		   diag.lower.tri = corr & !is.null(show.max))
{
  ## Martin Maechler, 21 Jan 94;  Dedicated to	Benjamin Schaad,  born that day
  ##--------------- Argument checking -----------------------------
  eval(corr)
  cutpoints <- sort(cutpoints)
  if(corr) cutpoints <- c(0, cutpoints, 1)
  if(any(duplicated(cutpoints)) ||
     (corr && (any(cutpoints > 1) || any(cutpoints < 0)) ))
    stop(paste("'cutpoints' must be unique",
	       if(corr)"in 0 < cuts < 1", ", but are =",
	       paste(format(cutpoints), collapse="|")))
  nc <- length(cutpoints)
  minc <- cutpoints[1]
  maxc <- cutpoints[nc]
  range.msg <- paste("'x' must be between",
		     if(corr) "-1" else format(minc),
		     " and", if(corr) "1" else format(maxc)," !")
  has.na <- any(nax <- is.na(x))
  if(corr) x <- abs(x)
  else
    if(any(x < minc - eps, na.rm=TRUE)) stop(range.msg)
  if(  any(x >	      maxc  + eps, na.rm=TRUE)) stop(range.msg)
  symbols <- as.character(symbols)
  if(any(duplicated(symbols)))
    stop(paste("'symbols' must be unique, but are =",
	       paste(symbols, collapse="|")))
  ns <- length(symbols)
  if(nc != ns+1)
    stop(paste("number of cutpoints must be  ONE",
	       if(corr)"LESS" else "MORE", "than number of symbols"))
  ##: Scor <- as.character(cut(x, breaks= cutpoints, labels= symbols))
  ##:-- more efficiently, using the function from within  cut :
  iS <-
    .C("bincode2", x= as.double(x), length(x),
       as.double(cutpoints), as.integer(ns+1),
       code= integer(length(x)), include = TRUE, NAOK = TRUE)$code
  if(any(ii <- is.na(iS))) {
	  ##-- can get 0, if x[i]== minc  --- only case ?
	  iS[which(ii)[abs(x[ii] - minc) < eps]] <- 1 #-> symbol[1]
  }
  if(has.na) {
    Scor <- character(length(iS))
    Scor[nax] <- na
    Scor[!nax] <- symbols[iS[!nax]]
  } else Scor <- symbols[iS]
  if(!is.null(show.max)) Scor[x >= maxc - eps] <-
    if(is.character(show.max)) show.max else format(maxc, dig=1)
  if(!is.null(show.min)) Scor[x <= minc + eps] <-
    if(is.character(show.min)) show.min else format(minc, dig=1)
  if(lower.triangular && is.matrix(x))
    Scor[!lower.tri(x, diag = diag.lower.tri)] <- ""
  attributes(Scor) <- attributes(x)
  if(is.array(Scor)){
    coln <- if(is.null(dimnames(Scor))) {
      dimnames(Scor) <- list(NULL,NULL); NULL } else dimnames(Scor)[[2]]
    dimnames(Scor)[[2]] <-
      if(length(coln)) {
	      ch <- abbreviate(coln, minlength=1)
	      if(sum(1+nchar(ch)) + max(nchar(coln)) + 1 > .Options[["width"]])
					#-- would not fit on one line
		abbreviate(ch, minlength=2, use.classes=FALSE)
	      else ch
      }
      else rep("", dim(Scor)[2])
  }
  formatI <- function(x) { #- format individually
    n<-length(x); r<-character(n); for(i in 1:n) r[i]<-format(x[i]); r
  }
  legend <- c(rbind(formatI(cutpoints), c(paste("`",symbols,"'",sep=""),"")),
	      if(has.na) paste(" ## NA: `",na,"'",sep=""))
  attr(Scor,"legend") <- paste(legend[-2*(ns+1)], collapse="  ")
  noquote(Scor)
}
sys.call <-function(which=0)
 .Internal(sys.call(which))
sys.calls <-function()
 .Internal(sys.calls())
sys.frame <-function(which=0)
 .Internal(sys.frame(which))
sys.function <-function(which=0)
 .Internal(sys.function(which))
sys.frames <-function()
 .Internal(sys.frames())
sys.nframe <- function()
 .Internal(sys.nframe())
sys.parent <- function(n = 1)
 .Internal(sys.parent(n))
sys.parents <- function()
 .Internal(sys.parents())
sys.status <- function()
 list(sys.calls=sys.calls(), sys.parents=sys.parents(), sys.frames=sys.frames())
sys.on.exit <- function()
 .Internal(sys.on.exit())
table <- function (..., exclude = c(NA, NaN)) {
  args <- list(...)
  if (length(args) == 0)
    stop("nothing to tabulate")
  if (length(args) == 1 && is.list(args[[1]]))
    args <- args[[1]]
  bin <- 0
  lens <- NULL
  dims <- integer(0)
  pd <- 1
  dn <- NULL
  for (a in args) {
    if (is.null(lens)) lens <- length(a)
    else if (length(a) != lens) 
      stop("all arguments must have the same length")
    if (is.factor(a))
      cat <- a
    else
      cat <- factor(a, exclude = exclude)
    nl <- length(l <- levels(cat))
    dims <- c(dims, nl)
    dn <- c(dn, list(l))
    ## requiring   all(unique(as.integer(cat)) == 1:nlevels(cat))  :
    bin <- bin + pd * (as.integer(cat) - 1)
    pd <- pd * nl
  }
  bin <- bin[!is.na(bin)]
  array(tabulate(bin + 1, pd), dims, dimnames = dn)
}
tabulate <- function(bin, nbins = max(bin))
{
	if(!is.numeric(bin) && !is.factor(bin))
		stop("tabulate: bin must be numeric or a factor")
	if((n <- length(bin)) == 0) bin <- 1
	else bin <- as.integer(bin)
	.C("tabulate",
		ans = integer(nbins),
		bin,
		n)$ans
}
tapply <- function (x, INDEX, FUN=NULL, simplify=TRUE, ...) 
{
	if (is.character(FUN)) 
		FUN <- get(FUN, mode = "function")
	if (!is.null(FUN) && mode(FUN) != "function") 
		stop(paste("'", FUN, "' is not a function",sep=""))
	if (!is.list(INDEX)) INDEX <- list(INDEX)
	nI <- length(INDEX)
	namelist <- vector("list", nI)
	names(namelist) <- names(INDEX)
	extent <- integer(nI)
	nx <- length(x)
	group <- rep(1, nx)#- to contain the splitting vector
	ngroup <- 1
	for (i in seq(INDEX)) {
		index <- as.factor(INDEX[[i]])
		if (length(index) != nx) 
			stop("arguments must have same length")
		namelist[[i]] <- levels(index)#- all of them, yes !
		extent[i] <- nlevels(index)
		group <- group + ngroup * (as.numeric(index) - 1)
		ngroup <- ngroup * nlevels(index)
	}
	if (is.null(FUN)) return(group)
	ans <- lapply(split(x, group), FUN, ...)
	if (simplify && all(unlist(lapply(ans, length)) == 1)) {
		ansmat <- array(dim=extent, dimnames=namelist)
		ans <- unlist(ans, recursive = FALSE)
	}
	else  {
		ansmat <- array(vector("list", prod(extent)),
			dim=extent, dimnames=namelist)
	}
	# old : ansmat[as.numeric(names(ans))] <- ans
	index <- as.numeric(names(ans))
	names(ans) <- NULL
	ansmat[index] <- ans
	ansmat
}
as.char.or.expr <- function(x) {
  if (is.expression(x)) x else unlist(strsplit(as.character(x), "\n"))
}
text <- function(x, ...) UseMethod("text")
text.default <- function(x, y = NULL, labels = seq(along = x), adj =
                         NULL, ...) { 
  if (!missing(y) && (is.character(y) || is.expression(y))) {
    labels <- y; y <- NULL
  }
  .Internal(text(xy.coords(x,y), as.char.or.expr(labels), adj, ...))
}
title <- function(main=NULL, sub=NULL, xlab=NULL, ylab=NULL, ...)
	.Internal(title(
		as.char.or.expr(main),
		as.char.or.expr(sub),
		as.char.or.expr(xlab),
		as.char.or.expr(ylab),
		...
	))
traceback <-
function() unlist(.Traceback)
trunc <- function(x, ...) UseMethod("trunc")
trunc.default <- function(x) {
  a <- attributes(x)
  x <- ifelse(x < 0, ceiling(x), floor(x))
  attributes(x) <- a
  x
}
start	<- function(x, ...) UseMethod("start")
end	<- function(x, ...) UseMethod("end")
frequency <- function(x, ...) UseMethod("frequency")
time	<- function(x, ...) UseMethod("time")
window	<- function(x, ...) UseMethod("window")
# The first 2 as requested by  <la-jassine@aix.pacwan.net>
start.default	<- function (x) start(ts(x))
end.default	<- function (x)	end(ts(x))
frequency.default<-function (x) frequency(ts(x))
time.default	<- function (x)	time(ts(x))
window.default	<- function (x)	window(ts(x))
options(ts.eps = 1e-5)#- default as S
ts <- function(data=NA, start=1, end=numeric(0), frequency=1, deltat=1,
	 ts.eps = .Options$ts.eps)
{
	if(is.matrix(data)) {
		nseries <- ncol(data)
		ndata <- nrow(data)
	} else {
		nseries <- 1
		ndata <- length(data)
	}
	if(missing(frequency)) frequency <- 1/deltat
	if(missing(deltat)) deltat <- 1/deltat
	if(frequency > 1 && abs(frequency - round(frequency)) < ts.eps)
		frequency <- round(frequency)
	if(length(start) > 1) {
		if(start[2] > frequency) stop("invalid start")
		start <- start[1] + (start[2] - 1)/frequency
	}
	if(length(end) > 1) {
		if(end[2] > frequency) stop("invalid end")
		end <- end[1] + (end[2] - 1)/frequency
	}
	if(missing(end))
		end <- start + (ndata - 1)/frequency
	else if(missing(start))
		start <- end - (ndata - 1)/frequency
	nobs <- floor((end - start) * frequency + 1.01)
	if(nobs != ndata)
	  data <-
	    if(nseries == 1) {
	      if(ndata < nobs) rep(data, length=nobs)
	      else if(nobs > ndata) data[1:nobs]
	    } else {
	      if(ndata < nobs) data[rep(1:ndata, length=nobs)]
	      else if(nobs > ndata) data[1:nobs,]
	    }
	attr(data, "tsp") <- c(start, end, frequency)#-- order is fix !
	attr(data, "class") <- "ts"
	data
}
tsp <- function(x) attr(x, "tsp")
"tsp<-" <- function(x, value)
{
	attr(x,"tsp") <- value
	class(x) <- "ts"
	x
}
is.ts <-function (x) inherits(x, "ts")
as.ts <-function (x) if (is.ts(x)) x else ts(x)
start.ts <- function(x)
{
	ts.eps <- .Options$ts.eps
	##if(is.null(ts.eps)) ts.eps <- 1.e-5
	tsp <- attr(as.ts(x), "tsp")
	is <- tsp[1]*tsp[3]
	if(abs(is-round(is)) < ts.eps) {
		is <- floor(tsp[1])
		fs <- floor(tsp[3]*(tsp[1] - is)+0.001)
		c(is,fs+1)
	}
	else tsp[1]
}
end.ts <- function(x)
{
	ts.eps <- .Options$ts.eps
	##if(is.null(ts.eps)) ts.eps <- 1.e-5
	tsp <- attr(as.ts(x), "tsp")
	is <- tsp[2]*tsp[3]
	if(abs(is-round(is)) < ts.eps) {
		is <- floor(tsp[2])
		fs <- floor(tsp[3]*(tsp[2] - is)+0.001)
		c(is, fs+1)
	}
	else tsp[2]
}
frequency.ts <- function(x) { attr(as.ts(x), "tsp")[3] }
time.ts <- function (x)
{
	x <- as.ts(x)
	n <- if(is.matrix(x)) nrow(x) else length(x)
	xtsp <- attr(x, "tsp")
	ts(seq(xtsp[1], xtsp[2], length=n),
		start=start(x), end=end(x), frequency=frequency(x))
}
print.ts <- function(x, calendar, ...)
{
	fr.x <- frequency(x)
	if(missing(calendar))
		calendar <- any(fr.x==c(4,12))
	if(!is.matrix(x) && calendar) {
		if(fr.x > 1) {
			start.pad <- start(x)[2] - 1
			end.pad <- fr.x - end(x)[2]
			dn1 <- start(x)[1]:end(x)[1]
			dn2 <-
			  if(fr.x == 12)  month.abb
			  else if(fr.x == 4) {
				  dn1 <- paste(dn1, ":" , sep="")
				  c("Qtr1", "Qtr2", "Qtr3", "Qtr4")
			  } else paste("p", 1:fr.x, sep="")
			x <- matrix(c(rep(NA, start.pad), x,
				rep(NA, end.pad)), nc= fr.x, byrow=TRUE,
				dimnames = list(dn1, dn2))
		} else { ## fr.x == 1
			tx <- time(x)
			attributes(x) <- NULL
			names(x) <- tx
		}
	}
	else { ##-- no 'calendar' --
		cat("Time-Series:\nStart =", deparse(start(x)),
		    "\nEnd =", deparse(end(x)),
		    "\nFrequency =", deparse(fr.x), "\n")
		tx <- time(x)
		attr(x, "tsp") <- NULL
		attr(x, "class") <- NULL
		##>> something like this is needed here
		##---  if(is.matrix(x)) rownames(data) <- tx
	}
	NextMethod("print", ...)
	invisible(x)
}
plot.ts <-
function (x, type="l", xlim=NULL, ylim=NULL, xlab = "Time", ylab, log="",
	col=par("col"), bg=NA, pch=par("pch"), lty=par("lty"),
	axes = TRUE, frame.plot = axes, ann = par("ann"), main = NULL, ...)
{
	time.x <- time(x)
	if(is.null(xlim)) xlim <- range(time.x)
	if(is.null(ylim)) ylim <- range(x, finite=TRUE)
	if(missing(ylab)) ylab <- deparse(substitute(x))
	plot.new()
	plot.window(xlim, ylim, log)
	if(is.matrix(x)) {
		for(i in 1:ncol(x))
			lines.default(time.x, x[,i],
				col=col[(i-1)%%length(col) + 1],
				lty=lty[(i-1)%%length(lty) + 1],
				bg = bg[(i-1)%%length(bg) + 1],
				pch=pch[(i-1)%%length(pch) + 1],
				type=type)
	}
	else {
		lines.default(time.x, x, col=col[1], bg=bg, lty=lty[1],
			pch=pch[1], type=type)
	}
	pars <- list(...)
	if (ann)
		title(main = main, xlab = xlab, ylab = ylab, pars = pars)
	if (axes) {
		axis(1, pars = pars)
		axis(2, pars = pars)
	}
        if (frame.plot) box(...)
}
window.ts <- function(x, start, end)
{
 x <- as.ts(x)
 xtsp <- tsp(x)
 freq <- xtsp[3]
 xtime <- time(x)
 ts.eps <- .Options$ts.eps
 start <- if(missing(start))
		xtsp[1]
	  else switch(length(start),
		start,
		start[1] + (start[2] - 1)/freq,
		stop("Bad value for start"))
 if(start < xtsp[1]) {
	start <- xtsp[1]
	warning("start value not changed")
 }
 end <- if(missing(end))
		xtsp[2]
	else switch(length(end),
		end,
		end[1] + (end[2] - 1)/freq,
		stop("Bad value for end"))
 if(end > xtsp[2]) {
	end <- xtsp[2]
	warning("end value not changed")
 }
 if(start > end)
	stop("start cannot be after end")
 if(all(abs(start - xtime) > abs(start) * ts.eps)) {
	start <- xtime[(xtime > start) & ((start + 1/freq) > xtime)]
 }
 if(all(abs(end - xtime) > abs(end) * ts.eps)) {
	end <- xtime[(xtime < end) & ((end - 1/freq) < xtime)]
 }
 i <- trunc((start - xtsp[1]) * freq + 1.5):
      trunc(( end  - xtsp[1]) * freq + 1.5)
 x <- if(is.matrix(x)) x[i, , drop = FALSE] else x[i]
 tsp(x) <- c(start, end, freq)
 x
}
"[.ts" <- function (x, i, j, drop = TRUE)
{
 y <- NextMethod("[")
 if (missing(i))
        ts(y, start = start(x), freq = frequency(x))
 else {
        n <- if (is.matrix(x)) nrow(x) else length(x)
        li <- length(ind <- (1:n)[i])
        if(li > 1) delta <- unique(ind[-1] - ind[-li])
        if (li <= 1 || length(delta) != 1) {
                warning("Not returning a time series object")
        } else {
                xtsp <- tsp(x)
                xtimes <- seq(from = xtsp[1], to = xtsp[2], by = 1/xtsp[3])
                ytsp <- xtimes[range(ind)]
                tsp(y) <- c(ytsp, (li - 1)/(ytsp[2] - ytsp[1]))
        }
        y
 }
}
t.test <- function(x, y=NULL, alternative="two.sided",mu=0, paired = FALSE, var.equal = FALSE,  conf.level = 0.95) {
	choices<-c("two.sided","greater","less")
	alt<- pmatch(alternative,choices)
	alternative<-choices[alt]
	if( length(alternative)>1 || is.na(alternative) )
		stop("alternative must be one \"greater\", \"less\", \"two.sided\"")
	if( !missing(mu) ) 
		if( length(mu) != 1  || is.na(mu) )
			stop("mu must be a single number")
	if( !missing(conf.level) )
		if( length(conf.level) !=1 || is.na(conf.level) || conf.level<0 || conf.level > 1)
			stop("conf.level must be a number between 0 and 1")
	if( !is.null(y) ) {
		dname<-paste(deparse(substitute(x)),"and",paste(deparse(substitute(y))))
		if(paired) 
			xok<-yok<-complete.cases(x,y)
		else {
			yok<-!is.na(y)
			xok<-!is.na(x)
		}
		y<-y[yok]
	}
	else {
		dname<-deparse(substitute(x))
		if( paired ) stop("y is missing for paired test")
		xok<-!is.na(x)
		yok<-NULL
	}
	x<-x[xok]
	if( paired ) {
		x<- x-y
		y<- NULL
	}
	nx <- length(x)
	if(nx <= 2) stop("not enough x observations")
	mx <- mean(x)
	vx <- var(x)
	estimate<-mx
	if(is.null(y)) {
		df <- length(x)-1
		stderr<-sqrt(vx/nx)
		tstat <- (mx-mu)/stderr
		method<-ifelse(paired,"Paired t-test","One Sample t-test")
		names(estimate)<-ifelse(paired,"mean of the differences","mean of x")
	} else {
		ny <- length(y)
		if(ny <= 2) stop("not enough y observations")
		my <- mean(y)
		vy <- var(y)
		method<-ifelse(var.equal,"Two Sample t-test","Welch Two Sample t-test")
		estimate<-c(mx,my)
		names(estimate)<-c("mean of x","mean of y")
		if(var.equal) { 
			df <- nx+ny-2
			v <- ((nx-1)*vx + (ny-1)*vy)/df
			stderr <- sqrt(v*(1/nx+1/ny))
			tstat <- (mx-my-mu)/stderr
		} else {
			stderrx <-sqrt(vx/nx)
			stderry <-sqrt(vy/ny)
			stderr <- sqrt(stderrx^2 + stderry^2)
			df <- stderr^4/(stderrx^4/(nx-1) + stderry^4/(ny-1))
			tstat <- (mx - my - mu)/stderr
		}
	}
	if (alternative == "less") {
		pval <- pt(tstat, df)
		cint <- c(NA, tstat * stderr + qt(conf.level, df) * stderr)
	}
	else if (alternative == "greater") {
		pval <- 1 - pt(tstat, df)
		cint <- c(tstat * stderr - qt(conf.level, df) * stderr, NA)
	}
	else {
		pval <- 2 * pt(-abs(tstat), df)
		alpha <- 1 - conf.level
		cint <- c(tstat * stderr - qt((1 - alpha/2), df) * stderr,
			tstat * stderr + qt((1 - alpha/2), df) * stderr)
	}
	cint<-cint+mu
	names(tstat)<-"t"
	names(df)<-"df"
	if(paired || !is.null(y) ) 
		names(mu)<-"difference in means"
	else
		names(mu)<- "mean"
	attr(cint,"conf.level")<-conf.level
	rval<-list(statistic = tstat, parameter = df, p.value = pval, 
conf.int=cint, estimate=estimate, null.value = mu, alternative=alternative,
method=method, data.name=dname)
	attr(rval,"class")<-"htest"
	return(rval)
}
cm <- function(x) 2.54*x
xinch <- function(x=1, warn.log=TRUE) {
  if(warn.log && par("xlog")) warning("x log scale:  xinch() is non-sense")
  x * diff(par("usr")[1:2])/par("pin")[1]
}
yinch <- function(y=1, warn.log=TRUE) {
  if(warn.log && par("ylog")) warning("y log scale:  yinch() is non-sense")
  y * diff(par("usr")[3:4])/par("pin")[2]
}
xyinch <- function(xy=1, warn.log=TRUE) {
  if(warn.log && (par("xlog") || par("ylog")))
    warning("log scale:  xyinch() is non-sense")
  u <- par("usr"); xy * c(u[2]-u[1], u[4]-u[3]) / par("pin")
}
# file update.R
# copyright (C) 1998 W. N. Venables and B. D. Ripley
#
update.default <-
function (object, formula., ..., evaluate = TRUE) 
{
  if (is.null(call <- object$call)) 
    stop("need an object with call component")
  extras <- match.call(expand.dots = FALSE)$...
  if (!missing(formula.)) 
    call$formula <- update.formula(formula(object), formula.)
  if(length(extras) > 0) {
    existing <- !is.na(match(names(extras), names(call)))
    # do these individually to allow NULL to remove entries.
    for (a in names(extras)[existing]) call[[a]] <- extras[[a]]
    if(any(!existing)) {
      call <- c(as.list(call), extras[!existing])
      call <- as.call(call)
    }
  }
  if(evaluate) eval(call, sys.frame(sys.parent()))
  else call
}
update.formula <- function (old, new) {
  tmp <- .Internal(update.formula(as.formula(old), as.formula(new)))
  formula(terms.formula(tmp))
}
upper.tri <- function(x, diag = FALSE)
{
	x <- as.matrix(x)
        if(diag) row(x) <= col(x)
        else row(x) < col(x)
}
mat.or.vec <- function(nr,nc)
        if(nc==1) numeric(nr) else matrix(0,nr,nc)
is.R <-
function() exists("version") && !is.null(vl <- version$language) && vl == "R"
var <- function(x, y=x, na.rm = FALSE, use) {
	if(missing(use)) {
		if(na.rm) use <- "complete.obs"
		else use <- "all.obs"
	}
	cov(x, y, use=use)
}
vector <- function(mode = "logical", length = 0).Internal(vector(mode,length))
logical <- function(length = 0) vector("logical", length)
character <- function(length = 0) vector("character", length)
integer <- function(length = 0) vector("integer", length)
double <- function(length = 0) vector("double", length)
real <- .Alias(double)
numeric <- .Alias(double)
complex <- function(length.out = 0,
                    real = numeric(), imaginary = numeric(),
                    modulus = 1, argument = 0) {
        if(missing(modulus) && missing(argument)) {
                ## assume 'real' and 'imaginary'
                .Internal(complex(length.out, real, imaginary))
        } else {
                n <- max(length.out, length(argument), length(modulus))
                rep(modulus,length.out=n) *
                  exp(1i * rep(argument, length.out=n))
        }
}
## should return  integer :
which <- function(x) {
	if(is.logical(x))
          if((n <- length(x))) (1:n)[x] else integer(0)
	else stop("argument to \"which\" is not logical")
}
windows<- function(width = 7, height = 7, pointsize = 12) 
	.Internal(Windows(width,height,pointsize))
write <- function(x, file="data",ncolumns=if(is.character(x)) 1 else 5, append=FALSE)
		cat(x, file=file, sep=c(rep(" ",ncolumns-1), "\n"), append=append)
write.table <-
function(x, file = "", append = FALSE, quote = TRUE, sep = " ", eol = "\n",
	 na = NA, row.names = TRUE, col.names = TRUE)
{
  if (!is.data.frame(x))
    x <- data.frame(x)
  else if (is.logical(quote) && quote)
    quote <- which(unlist(lapply(x, is.character)))
  x <- as.matrix(x)
  p <- ncol(x)
  d <- dimnames(x)
  x[is.na(x)] <- na
  if (is.logical(quote))
    quote <- if (quote) 1 : p else NULL
  else if (is.numeric(quote)) {
    if (any(quote < 1 | quote > p))
      stop("invalid numbers in quote")
  }
  else
    stop("invalid quote specification")
  if (is.logical(row.names)) {
    if (row.names)
      x <- cbind(d[[1]], x)
  }
  else {
    row.names <- as.character(row.names)
    if (length(row.names) == nrow(x))
      x <- cbind(row.names, x)
    else
      stop("invalid row.names specification")
  }
  if (!is.null(quote) && (p < ncol(x)))
    quote <- c(0, quote) + 1
  if (is.logical(col.names))
    col.names <- if (col.names) d[[2]] else NULL
  else {
    col.names <- as.character(col.names)
    if (length(col.names) != p)
      stop("invalid col.names specification")
  }
  if (!is.null(col.names)) {
    if (append)
      warning("appending column names to file")
    if (!is.null(quote))
      col.names <- paste("\"", col.names, "\"", sep = "")
    cat(col.names, file = file, sep = rep(sep, p - 1), append = append)
    cat(eol, file = file, append = TRUE)
    append <- TRUE
  }
  for (i in quote)
    x[, i] <- paste("\"", x[, i], "\"", sep = "")
  cat(t(x), file = file, sep = c(rep(sep, ncol(x) - 1), eol),
      append = append)
}
X11 <- function(display="", width=7, height=7, pointsize=12)
.Internal(X11(display, width, height, pointsize))
x11 <- X11
xor <- function(x, y) { (x | y) & !(x & y) }
zapsmall <- function(x, digits = .Options$digits)
{
  if(all(ina <- is.na(x))) return(x)
  mx <- max(abs(x[!ina]))
  round(x, digits = if(mx > 0) max(0, digits - log10(mx)) else digits)
}
data <-
function(..., list = character(0), package =c(.packages(), .Autoloaded),
	 lib.loc = .lib.loc, trace = FALSE) {
  names <- c(as.character(substitute(list(...))[-1]), list)
  if (!missing(package))
    if (is.name(y <- substitute(package)))# && !is.character(package))
      package <- as.character(y)
  found <- FALSE
  if (length(names) == 0) {             # give `index' of all possible
                                        # data sets
    file <- tempfile("Rdata.")
    on.exit(unlink(file))
    for (lib in lib.loc)
      for (pkg in package) {
	INDEX <- system.file(paste("data", "index.doc", sep = "/"),
			     pkg, lib)
	if (INDEX != "") {
	  cat(paste(ifelse(found, "\n", ""),
		    "Data sets in package `", pkg, "':\n\n", sep = ""),
	      file = file, append = TRUE)
	  system(paste("cat", INDEX, ">>", file, "2>/dev/null"))
	  if(!found) found <- TRUE
	}
      }
    if (found)
      system(paste("$RHOME/cmd/pager", file))
  }
  else for (name in names) {
    dn <- paste("data/", name, sep = "")
    files <- system.file(paste(dn, ".*", sep = ""), package, lib.loc)
    found <- FALSE
    if (files != "") {
      for (file in files) {
	if(trace)
	  cat("name=",name,":\t file= .../",sub(".*/","",file),"::\t",sep="")
	if (found) break
	found <- TRUE
        ext <- sub(".*\\.", "", file)
        ## make sure the match is really for `name.ext'
        if (sub(".*/", "", file) != paste(name, ".", ext, sep = ""))
          found <- FALSE
        else
          switch(ext,
                 "R" =, "r" = source(file),
                 "RData" =, "rdata" =, "rda" = load(file),
                 "TXT" =, "txt" =, "tab" =
                 assign(name, read.table(file, header = TRUE),
                        env = .GlobalEnv),
                 "CSV" =, "csv" =
                 assign(name, read.table(file, header = TRUE, sep = ";"),
                        env = .GlobalEnv),
                 ## otherwise
                 found <- FALSE)
	if (trace) cat(if(!found) "*NOT* ", "found\n")
      }
    }
    if (!found)
      warning(paste("Data set `", name, "' not found", sep = ""))
  }
  invisible(names)
}
date <- function() { system("date", intern = TRUE) }
getenv <- function(x) {
  if (missing(x)) {
    x <- strsplit(.Internal(getenv(character())), "=")
    v <- n <- character(LEN <- length(x))
    for (i in 1:LEN) {
      n[i] <- x[[i]][1]
      v[i] <- paste(x[[i]][-1], collapse = "=")
    }
    structure(v, names = n)
  } else {
    structure(.Internal(getenv(x)), names = x)
  }
}
help <-
function(topic, offline = FALSE, package = c(.packages(), .Autoloaded),
         lib.loc = .lib.loc) {
  if (!missing(package))
    if (is.name(y <- substitute(package)))# && !is.character(package))
      package <- as.character(y)
  if (!missing(topic)) {
    topic <- substitute(topic)
    if (is.name(topic))
      topic <- as.character(topic)
    else if (!is.character(topic))
      stop("Unimplemented help feature")
    if (!is.na(match(topic, c("+", "-", "*", "/", "^", "%%"))))
      topic <- "Arithmetic"
    else if (!is.na(match(topic, c("<", ">", "<=", ">=", "==", "!="))))
      topic <- "Comparison"
    else if (!is.na(match(topic, c("[", "[[", "$"))))
      topic <- "Extract"
    else if (!is.na(match(topic, c("&", "&&", "|", "||", "!"))))
      topic <- "Logic"
    else if (!is.na(match(topic, c("%*%"))))
      topic<- "matmult"
    topic <- gsub("\\[","\\\\[", topic) # for cmd/help ..
    INDICES <- paste(t(outer(lib.loc, package, paste, sep = "/")),
		     "help", "AnIndex", sep = "/", collapse = " ")
    file <- system(paste("${RHOME}/cmd/help INDEX '", topic, "' ",
                         INDICES, sep=""),
		   intern = TRUE)
    if (file == "") {                   # try data .doc -- this is OUTDATED
      file <- system.file(paste("data", "/", topic, ".doc", sep = ""),
			  package, lib.loc)
    }
    if (length(file) && file != "") {
      if (!is.null(.Options$trace) && .Options$trace)
        cat ("\t\t\t\t\t\tHelp file name `", sub(".*/", "", file),
             ".Rd'\n", sep = "")
      if (!offline)
        system(paste("${RHOME}/cmd/pager", file))
      else {
        FILE <- tempfile()
        ## on.exit(unlink(paste(FILE, "*", sep = "")))
        cat("\\documentclass[", .Options$papersize, "paper]{article}\n",
            file = FILE, sep = "")
        system(paste("cat ${RHOME}/doc/manual/Rd.sty >>", FILE))
        cat("\\InputIfFileExists{Rhelp.cfg}{}{}\n\\begin{document}\n",
            file = FILE, append = TRUE)
        system(paste("cat ", sub("help/", "latex/", file), ".tex >>",
                     FILE, sep = ""))
        cat("\\end{document}\n", file = FILE, append = TRUE)
        system(paste("${RHOME}/cmd/help PRINT", FILE, topic))
        return()
      }
    } else
      stop(paste("No documentation for `", topic, "'", sep = ""))
  }
  else if (!missing(package))
    library(help = package, lib = lib.loc, character.only = TRUE)
  else if (!missing(lib.loc))
    library(lib = lib.loc)
  else
    help("help", package = "base", lib.loc = .Library)
}
library <-
function (name, help, lib.loc = .lib.loc, character.only = FALSE,
	  logical.return = FALSE)
{
  if (!missing(name)) {
    if (!character.only)
      name <- as.character(substitute(name))
    lib.source <- function(file, env) {
      exprs <- parse(n = -1, file = file)
      if (length(exprs) == 0)
	return(invisible())
      for (i in exprs) yy <- eval(i, env)
      invisible()
    }
    pkgname <- paste("package", name, sep = ":")
    if (is.na(match(pkgname, search()))) {
      packagedir <- system.file("", name, lib.loc)
      if (packagedir == "") {
	txt <- paste("There is no package called `", name, "'", sep = "")
	if (logical.return) {
	  warning(txt)
	  return(FALSE)
	}
	else stop(txt)
      }
      which.lib.loc <-
        lib.loc[match(packagedir[1], paste(lib.loc, name, "", sep = "/"))]
      if (length(packagedir) > 1) {
        warning(paste("Package `", name, "' found more than once,\n  ",
                      "using the one found in `", which.lib.loc, "'",
                      sep = ""))
      }
      file <- system.file(paste("R", name, sep = "/"), name, lib.loc)
      env <- attach(NULL, name = pkgname)
      if (file == "")
	warning(paste("Package `", name, "' contains no R code", sep = ""))
      else
	lib.source(file, env)
      lib.fixup(env, .GlobalEnv)
      if (exists(".First.lib", envir = env, inherits = FALSE)) {
	firstlib <- get(".First.lib", envir = env, inherits = FALSE)
	firstlib(which.lib.loc, name)
      }
    }
  } else if (!missing(help)) {
    if (!character.only)
      help <- as.character(substitute(help))
    file <- system.file("INDEX", help, lib.loc)
    if (file == "")
      stop(paste("No documentation for package `",
		 help, "'", sep = ""))
    else
      system(paste("$RHOME/cmd/pager", file))
  } else {
    file <- tempfile("R.")
    on.exit(unlink(file))
    first <- TRUE
    for (lib in lib.loc) {
      cat(paste(ifelse(first, "", "\n"), "Packages in library `",
		lib, "':\n\n", sep = ""), file = file,
	  append = TRUE)
      INDEX <- paste(lib, "LibIndex", sep = "/")
      system(paste("cat", INDEX, ">>", file,
		   "2>/dev/null"))
      first <- FALSE
    }
    system(paste("$RHOME/cmd/pager", file))
  }
  if (logical.return)
    TRUE
  else invisible(.packages())
}
library.dynam <-
function(chname, package = .packages(), lib.loc = .lib.loc) {
  if (!exists(".Dyn.libs"))
    assign(".Dyn.libs", character(0), envir = .AutoloadEnv)
  if(missing(chname) || (LEN <- nchar(chname)) == 0)
    return(.Dyn.libs)
  if (substr(chname, LEN - 2, LEN) == ".so") {
    chname <- substr(chname, 1, LEN - 3)
  }
  if (is.na(match(chname, .Dyn.libs))) {
    file <- system.file(paste("libs", "/", chname, ".", "so", sep = ""),
			package, lib.loc)
    if (file == "") {
      stop(paste("dynamic library `", chname, "' not found", sep = ""))
    }
    .Internal(dyn.load(file))
    assign(".Dyn.libs", c(.Dyn.libs, chname), envir = .AutoloadEnv)
  }
  invisible(.Dyn.libs)
}
system <- function(call, intern = FALSE) .Internal(system(call, intern))
unix <- function(call, intern = FALSE) {
	.Deprecated("system"); system(call,intern)
}
system.file <- function(file = "", pkg = .packages(), lib = .lib.loc) {
	FILES <- paste(t(outer(lib, pkg, paste, sep = "/")),
		       file, sep = "/", collapse = " ")
	system(paste("${RHOME}/cmd/filename", FILES), intern = TRUE)
}
system.time <- function(expr) {
	## Purpose: Return CPU (and other) times that `expr' used ..
	## Modelled after S "unix.time"
	## -----------------------------------------------------------------
	## Arguments: expr: `any' valid R expression
	## -----------------------------------------------------------------
	loc.frame <- sys.frame(sys.parent(1))
	on.exit(cat("Timing stopped at:", proc.time() - time, "\n"))
	expr <- substitute(expr)
	time <- proc.time()
	eval(expr, envir = loc.frame)
	new.time <- proc.time()
	on.exit()
	if(length(new.time) == 3)	new.time <- c(new.time, 0, 0)
	if(length(time) == 3)		time	 <- c(	  time, 0, 0)
	new.time - time
}
unix.time <- system.time
tempfile <- function(pattern = "file") {
  system(paste("for p in", paste(pattern, collapse = " "), ";",
	       "do echo /tmp/$p$$; done"),
	 intern = TRUE)
}
unlink <- function(x) {
  system(paste("rm -rf ", paste(x, collapse = " ")))
}
