gammaCody <- function(x) .Internal(gammaCody(x))

besselI <- function(x, nu, expon.scaled = FALSE)
{
    .Internal(besselI(x,nu, 1+ as.logical(expon.scaled)))
}
besselK <- function(x, nu, expon.scaled = FALSE)
{
    .Internal(besselK(x,nu, 1+ as.logical(expon.scaled)))
}
besselJ <- function(x, nu) .Internal(besselJ(x,nu))
besselY <- function(x, nu) .Internal(besselY(x,nu))
#### copyright (C) 1998 B. D. Ripley
C <- function(object, contr, how.many, ...)
{
    if(!nlevels(object)) stop("object not interpretable as a factor")
    if(!missing(contr) && is.name(Xcontr <- substitute(contr)))
	contr <- switch(as.character(Xcontr),
			poly =	"contr.poly",
			helmert = "contr.helmert",
			sum = "contr.sum",
			treatment = "contr.treatment",
			contr
			)
    if(missing(contr)) {
	oc <- .Options$contrasts
	contr <-
	    if(length(oc) < 2) # should not happen
		if(is.ordered(object)) contr.poly else contr.treatment
	    else oc[1 + is.ordered(object)]
    }
    if(missing(how.many) && !length(list(...)))
	contrasts(object) <- contr
    else {
	if(is.character(contr)) contr <- get(contr, mode = "function")
	if(is.function(contr)) contr <- contr(nlevels(object), ...)
	contrasts(object, how.many) <- contr
    }
    object
}
.Defunct <- function() {
    stop(paste("`", as.character(sys.call(sys.parent())[[1]]), "' ",
	       "is defunct.\n",
	       "See ?Defunct.",
	       sep = ""))
}
dnchisq <- function(x, df, lambda) .Defunct()
pnchisq <- function(q, df, lambda) .Defunct()
qnchisq <- function(p, df, lambda) .Defunct()
#rnchisq <- function(...) .NotYetImplemented()

print.plot <- function() .Defunct()
save.plot <- function(file = "Rplots.ps") .Defunct()

## From print.R :
## This is not used anymore [replaced by  print.anova() -> ./anova.R ]
##- print.tabular <-
##-	function(x, digits = max(3, .Options$digits - 3), na.print = "")
##- {
##-	cat("\n", if(!is.null(x$title))
##-	x$title else "Analysis of Variance:", "\n\n", sep="")
##-	if(!is.null(x$topnote))
##-	cat(paste(x$topnote, collapse="\n"), "\n\n", sep="")
##-	print.default(x$table, digits=digits, na = "", print.gap = 2)
##-	if(!is.null(x$botnote))
##-	cat("\n", paste(x$botnote, collapse="\n"), sep="")
##-	cat("\n")
##- }
print.tabular <-
    function(table, digits = max(3, .Options$digits - 3), na.print = "", ...)
	.Defunct()

## From lm.R :
## Unused (0.63, Sept.25 1998) --- print.anova()  now in ./print.R
##- print.anova.lm <- function(x, digits = max(3, .Options$digits - 3), ...)
##- {
##-	cat("\nAnalysis of Variance:\n\n")
##-	print.default(round(unclass(x), digits), na="", print.gap=2)
##-	cat("\n")
##-	invisible(x)
##- }
print.anova.lm <- function(x, digits = max(3, .Options$digits - 3), ...)
    .Defunct()

## From glm.R :
## Not used anymore..
##- print.anova.glm <- function(x, digits = max(3, .Options$digits - 3),
##-			    na.print = "", ...)
##- {
##-	cat("\n", x$title, sep="")
##-	print.default(x$table, digits=digits, na = "", print.gap = 2)
##-	cat("\n")
##- }
print.anova.glm <- .Alias(print.anova.lm)

system.test <- function(...)
  .Defunct()
###----- NOTE:	../man/Deprecated.Rd   must be synchronized with this!
###		--------------------
.Deprecated <- function(new) {
    warning(paste("`", as.character(sys.call(sys.parent())[[1]]), "' ",
		  "is deprecated.\n",
		  if (!missing(new))
		  paste("Use `", new, "' instead.\n", sep = ""),
		  "See ?Deprecated.",
		  sep = ""))
}
##vector <- function(mode = "logical", length = 0).Internal(vector(mode,length))

stop <- function(message = NULL).Internal(stop(message))
warning <- function(message = NULL).Internal(warning(message))
restart <- function(on = TRUE).Internal(restart(on))

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())
R.Version <- function().Internal(Version())
Version <- function() { .Deprecated("R.Version"); R.Version() }
machine <- function().Internal(machine())
colors <- function().Internal(colors())
colours <- .Alias(colors)
commandArgs <- function() .Internal(commandArgs())

args <- function(name).Internal(args(name))

##=== Problems here [[	attr(f, "class") <- "factor"  fails in factor(..)  ]]:
##- attr <- function(x, which).Internal(attr(x, which))
##- "attr<-" <- function(x, which, value).Internal("attr<-"(x, which, value))

cbind <- function(..., deparse.level=1) {
    if(deparse.level != 1) stop("cbind(.) does not accept deparse.level in R.")
    .Internal(cbind(...))
}
rbind <- function(..., deparse.level=1) {
    if(deparse.level != 1) stop("rbind(.) does not accept deparse.level in R.")
    .Internal(rbind(...))
}

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


do.call <- function(what,args).Internal(do.call(what,args))
drop <- function(x).Internal(drop(x))
duplicated <- function(x, incomparables = FALSE) {
    if(!is.logical(incomparables) || incomparables)
	stop("duplicated(.. incomparables != FALSE) not yet available in R.")
    .Internal(duplicated(x))
}
format.info <- function(x).Internal(format.info(x))
gc <- function(verbose = .Options$verbose)
    matrix(.Internal(gc(verbose))/c(1,1,1,1,10,10),2,3,
           dimnames = list(c("Ncells","Vcells"),c("free","total", "(Mb)")))
gcinfo <- function(verbose).Internal(gcinfo(verbose))
gctorture <- function(on=TRUE)invisible(.Internal(gctorture(on)))
gray <- function(level).Internal(gray(level))

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

plot.window <- function(xlim, ylim, log = "", asp = NA, ...)
    .Internal(plot.window(xlim, ylim, log, asp, ...))
polyroot <- function(z).Internal(polyroot(z))
rank <- function(x, na.last = TRUE) {
    if(!is.logical(na.last) || !na.last)
	stop("rank(.., na.last != TRUE) does not yet work in R.")
    .Internal(rank(x))
}
readline <- function(prompt="").Internal(readline(prompt))
search <- function().Internal(search())

sink <- function(file=NULL, append = FALSE)
    .Internal(sink(file, append))

##-- DANGER ! ---   substitute(list(...))  inside functions !!!
##substitute <- function(expr, env=NULL).Internal(substitute(expr, env))

t.default <- function(x).Internal(t.default(x))
typeof <- function(x).Internal(typeof(x))

unique <- function(x){
    z<-.Internal(unique(x))
    if (is.factor(x))
	z <- factor(z,levels=1:nlevels(x),labels=levels(x))
    z
}

memory.profile <- function().Internal(memory.profile())
## Random Number Generator[s]

## The available kinds are in
## ../../../include/Random.h  and ../../../nmath/sunif.c [RNG_Table]
RNGkind <- function(kind = NULL) 
{
    kinds <- c("Wichmann-Hill", "Marsaglia-Multicarry", "Super-Duper",
               ## NOT yet: "Mersenne-Twister",
               ##BUG "Rand"
               )
    do.set <- length(kind) > 0
    if(do.set) {
	if(!is.character(kind) || length(kind) > 1)
	    stop("'kind' must be a character of length 1 (RNG to be used).")
	if(is.na(i.knd <- pmatch(kind, kinds) - 1))
	    stop(paste("'",kind,"' is not a valid abbrevation of an RNG",
		       sep=""))
    } else i.knd <- NULL
    
    r <- kinds[1 + .Internal(RNGkind(i.knd))]
    if(do.set) invisible(r) else r
}

abline <-
    function(a=NULL, b=NULL, h=NULL, v=NULL, reg=NULL, coef=NULL,
	     untf=FALSE, col=par("col"), lty=par("lty"), lwd=NULL, ...)
{
    if(!is.null(reg)) a <- reg
    if(!is.null(a) && is.list(a)) {
	temp <- as.vector(coefficients(a))
	if(length(temp) == 1) {
	    a <- 0
	    b <- temp
	}
	else {
	    a <- temp[1]
	    b <- temp[2]
	}
    }
    if(!is.null(coef)) {
	a <- coef[1]
	b <- coef[2]
    }
    .Internal(abline(a, b, h, v, untf, col, lty, lwd, ...))
    invisible()
}
#### copyright (C) 1998 B. D. Ripley
add1 <- function(object, ...) UseMethod("add1")

add1.default <- function(object, scope, scale = 0, test=c("none", "Chisq"),
			 k = 2, trace = FALSE, ...)
{
    if(missing(scope) || is.null(scope)) stop("no terms in scope")
    if(!is.character(scope))
	scope <- add.scope(object, update.formula(object, scope))
    if(!length(scope))
	stop("no terms in scope for adding to object")
    ns <- length(scope)
    ans <- matrix(nrow = ns + 1, ncol = 2)
    dimnames(ans) <- list(c("<none>", scope), c("df", "AIC"))
    ans[1, ] <- extractAIC(object, scale, k = k, ...)
    for(i in seq(ns)) {
	tt <- scope[i]
	if(trace > 1) cat("trying +", tt, "\n")
	nfit <- update(object, as.formula(paste("~ . +", tt)))
	ans[i+1, ] <- extractAIC(nfit, scale, k = k, ...)
    }
    dfs <- ans[,1] - ans[1,1]
    dfs[1] <- NA
    aod <- data.frame(Df = dfs, AIC = ans[,2])
    test <- match.arg(test)
    if(test == "Chisq") {
	dev <- ans[,2] - k*ans[, 1]
	dev <- dev[1] - dev; dev[1] <- NA
	nas <- !is.na(dev)
	P <- dev
	P[nas] <- 1 - pchisq(dev[nas], dfs[nas])
	aod[, c("LRT", "Pr(Chi)")] <- list(dev, P)
    }
    head <- c("Single term additions", "\nModel:",
	      deparse(as.vector(formula(object))),
	      if(scale > 0) paste("\nscale: ", format(scale), "\n"))
    class(aod) <- c("anova", "data.frame")
    attr(aod, "heading") <- head
    aod
}

add1.lm <- function(object, scope, scale = 0, test=c("none", "Chisq", "F"),
		    x = NULL, k = 2,...)
{
    Fstat <- function(table, RSS, rdf) {
	dev <- table$"Sum of Sq"
	df <- table$Df
	rms <- (RSS - dev)/(rdf - df)
	Fs <- (dev/df)/rms
	Fs[df < .Machine$double.eps] <- NA
	P <- Fs
	nnas <- !is.na(Fs)
	P[nnas] <- 1 - pf(Fs[nnas], df[nnas], rdf - df[nnas])
	list(Fs=Fs, P=P)
    }

    if(missing(scope) || is.null(scope)) stop("no terms in scope")
    if(!is.character(scope))
	scope <- add.scope(object, update.formula(object, scope))
    if(!length(scope))
	stop("no terms in scope for adding to object")
    oTerms <- attr(object$terms, "term.labels")
    int <- attr(object$terms, "intercept")
    ns <- length(scope)
    y <- object$residuals + predict(object)
    dfs <- numeric(ns+1)
    RSS <- numeric(ns+1)
    names(dfs) <- names(RSS) <- c("<none>", scope)
    dfs[1] <- object$rank
    RSS[1] <- deviance.lm(object)
    add.rhs <- paste(scope, collapse = "+")
    add.rhs <- eval(parse(text = paste("~ . +", add.rhs)))
    new.form <- update.formula(object, add.rhs)
    Terms <- terms(new.form)
    if(is.null(x)) {
	fc <- object$call
	fc$formula <- Terms
	fob <- list(call = fc)
	class(fob) <- class(object)
	m <- model.frame(fob, xlev = object$xlevels)
	x <- model.matrix(Terms, m, contrasts = object$contrasts)
    }
    n <- nrow(x)
    Terms <- attr(Terms, "term.labels")
    asgn <- attr(x, "assign")
    ousex <- match(asgn, match(oTerms, Terms), 0) > 0
    if(int) ousex[1] <- TRUE
    iswt <- !is.null(wt <- object$weights)
    for(tt in scope) {
	usex <- match(asgn, match(tt, Terms), 0) > 0
	X <- x[, usex|ousex, drop = FALSE]
	z <- if(iswt) lm.wfit(X, y, wt) else lm.fit(X, y)
	dfs[tt] <- z$rank
	RSS[tt] <- deviance.lm(z)
    }
    if(scale > 0) aic <- RSS/scale - n + k*dfs
    else aic <- n * log(RSS/n) + k*dfs
    dfs <- dfs - dfs[1]
    dfs[1] <- NA
    aod <- data.frame(Df = dfs, "Sum of Sq" = c(NA, RSS[1] - RSS[-1]),
		      RSS = RSS, AIC = aic,
                      row.names = names(dfs), check.names = FALSE)
    if(scale > 0) names(aod) <- c("Df", "Sum of Sq", "RSS", "Cp")
    test <- match.arg(test)
    if(test == "Chisq") {
	dev <- aod$"Sum of Sq"
	nas <- !is.na(dev)
	dev[nas] <- 1 - pchisq(dev[nas]/scale, aod$Df[nas])
	aod[, "Pr(Chi)"] <- dev
    } else if(test == "F") {
	rdf <- object$df.resid
	aod[, c("F value", "Pr(F)")] <- Fstat(aod, aod$RSS[1], rdf)
    }
    head <- c("Single term additions", "\nModel:",
	      deparse(as.vector(formula(object))),
	      if(scale > 0) paste("\nscale: ", format(scale), "\n"))
    class(aod) <- c("anova", "data.frame")
    attr(aod, "heading") <- head
    aod
}

add1.glm <- function(object, scope, scale = 0, test=c("none", "Chisq"),
		     x = NULL, k = 2, ...)
{
    if(!is.character(scope))
	scope <- add.scope(object, update.formula(object, scope))
    if(!length(scope))
	stop("no terms in scope for adding to object")
    oTerms <- attr(object$terms, "term.labels")
    int <- attr(object$terms, "intercept")
    ns <- length(scope)
    dfs <- dev <- numeric(ns+1)
    names(dfs) <- names(dev) <- c("<none>", scope)
    dfs[1] <- object$rank
    dev[1] <- object$deviance
    add.rhs <- paste(scope, collapse = "+")
    add.rhs <- eval(parse(text = paste("~ . +", add.rhs)))
    new.form <- update.formula(object, add.rhs)
    Terms <- terms(new.form)
    if(is.null(x)) {
	fc <- object$call
	fc$formula <- Terms
	fob <- list(call = fc)
	class(fob) <- class(object)
	m <- model.frame(fob, xlev = object$xlevels)
	x <- model.matrix(Terms, m, contrasts = object$contrasts)
    }
    n <- nrow(x)
    y <- object$y
    if(is.null(y)) y <- model.response(model.frame(object), "numeric")
    wt <- object$prior.weights
    if(is.null(wt)) wt <- rep(1, n)
    Terms <- attr(Terms, "term.labels")
    asgn <- attr(x, "assign")
    ousex <- match(asgn, match(oTerms, Terms), 0) > 0
    if(int) ousex[1] <- TRUE
    for(tt in scope) {
	usex <- match(asgn, match(tt, Terms), 0) > 0
	X <- x[, usex|ousex, drop = FALSE]
	z <-  glm.fit(X, y, wt, offset=object$offset,
		      family=object$family, control=object$control)
	dfs[tt] <- z$rank
	dev[tt] <- z$deviance
    }
    if (is.null(scale) || scale == 0)
	dispersion <- summary(object, dispersion = NULL)$dispersion
    else dispersion <- scale
    if(object$family$family == "gaussian") {
	if(scale > 0) loglik <- dev/scale - n
	else loglik <- n * log(dev/n)
    } else loglik <- dev/dispersion
    aic <- loglik + k * dfs
    dfs <- dfs - dfs[1]
    dfs[1] <- NA
    aod <- data.frame(Df = dfs, Deviance = dev, AIC = aic,
		      row.names = names(dfs), check.names = FALSE)
    test <- match.arg(test)
    if(test == "Chisq") {
	dev <- loglik[1] - loglik
	dev[1] <- NA
	aod[, "LRT"] <- dev
	nas <- !is.na(dev)
	dev[nas] <- 1 - pchisq(dev[nas]/dispersion, aod$Df[nas])
	aod[, "Pr(Chi)"] <- dev
    }
    head <- c("Single term additions", "\nModel:",
	      deparse(as.vector(formula(object))),
	      if(scale > 0) paste("\nscale: ", format(scale), "\n"))
    class(aod) <- c("anova", "data.frame")
    attr(aod, "heading") <- head
    aod
}

add1.mlm <- function(...)
    stop("no add1 method implemented for mlm models")

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

drop1.default <- function(object, scope, scale = 0, test=c("none", "Chisq"),
			  k = 2, trace = FALSE, ...)
{
    tl <- attr(object$terms, "term.labels")
    if(missing(scope)) scope <- drop.scope(object)
    else {
	if(!is.character(scope))
	    scope <- attr(terms(update.formula(object, scope)), "term.labels")
	if(!all(match(scope, tl, FALSE)))
	    stop("scope is not a subset of term labels")
    }
    ns <- length(scope)
    ans <- matrix(nrow = ns + 1, ncol = 2)
    dimnames(ans) <- list(c("<none>", scope), c("df", "AIC"))
    ans[1, ] <- extractAIC(object, scale, k = k, ...)
    for(i in seq(ns)) {
	tt <- scope[i]
	if(trace > 1) cat("trying -", tt, "\n")
	nfit <- update(object, as.formula(paste("~ . -", tt)))
	ans[i+1, ] <- extractAIC(nfit, scale, k = k, ...)
    }
    dfs <- ans[1,1] - ans[,1]
    dfs[1] <- NA
    aod <- data.frame(Df = dfs, AIC = ans[,2])
    if(test == "Chisq") {
	dev <- ans[, 2] - k*ans[, 1]
	dev <- dev - dev[1] ; dev[1] <- NA
	nas <- !is.na(dev)
	P <- dev
	P[nas] <- 1 - pchisq(dev[nas], dfs[nas])
	aod[, c("LRT", "Pr(Chi)")] <- list(dev, P)
    }
    head <- c("Single term deletions", "\nModel:",
	      deparse(as.vector(formula(object))),
	      if(scale > 0) paste("\nscale: ", format(scale), "\n"))
    class(aod) <- c("anova", "data.frame")
    attr(aod, "heading") <- head
    aod
}

drop1.lm <- function(object, scope, scale = 0, all.cols = TRUE,
		     test=c("none", "Chisq", "F"), k = 2, ...)
{
    x <- model.matrix(object)
    iswt <- !is.null(wt <- object$weights)
    n <- nrow(x)
    asgn <- attr(x, "assign")
    tl <- attr(object$terms, "term.labels")
    if(missing(scope)) scope <- drop.scope(object)
    else {
	if(!is.character(scope))
	    scope <- attr(terms(update.formula(object, scope)), "term.labels")
	if(!all(match(scope, tl, FALSE)))
	    stop("scope is not a subset of term labels")
    }
    ndrop <- match(scope, tl)
    ns <- length(scope)
    rdf <- object$df.resid
    chisq <- deviance.lm(object)
    dfs <- numeric(ns)
    RSS <- numeric(ns)
    y <- object$residuals + predict(object)
    rank <- object$rank
    for(i in 1:ns) {
	ii <- seq(along=asgn)[asgn == ndrop[i]]
	if(all.cols) jj <- setdiff(seq(ncol(x)), ii)
	else jj <- setdiff(na.coef, ii)
	z <- if(iswt) lm.wfit(x[, jj, drop = FALSE], y, wt)
	else lm.fit(x[, jj, drop = FALSE], y)
	dfs[i] <- z$rank
	RSS[i] <- deviance.lm(z)
    }
    scope <- c("<none>", scope)
    dfs <- c(object$rank, dfs)
    RSS <- c(chisq, RSS)
    if(scale > 0) aic <- RSS/scale - n + k*dfs
    else aic <- n * log(RSS/n) + k*dfs
    dfs <- dfs[1] - dfs
    dfs[1] <- NA
    aod <- data.frame(Df = dfs, "Sum of Sq" = c(NA, RSS[-1] - RSS[1]),
		      RSS = RSS, AIC = aic,
                      row.names = scope, check.names = FALSE)
    if(scale > 0) names(aod) <- c("Df", "Sum of Sq", "RSS", "Cp")
    test <- match.arg(test)
    if(test == "Chisq") {
	dev <- aod$"Sum of Sq"
	nas <- !is.na(dev)
	dev[nas] <- 1 - pchisq(dev[nas]/scale, aod$Df[nas])
	aod[, "Pr(Chi)"] <- dev
    } else if(test == "F") {
	dev <- aod$"Sum of Sq"
	dfs <- aod$Df
	rdf <- object$df.resid
	rms <- aod$RSS[1]/rdf
	Fs <- (dev/dfs)/rms
	Fs[dfs < 1e-4] <- NA
	P <- Fs
	nas <- !is.na(Fs)
	P[nas] <- 1 - pf(Fs[nas], dfs[nas], rdf)
	aod[, c("F value", "Pr(F)")] <- list(Fs, P)
    }
    head <- c("Single term deletions", "\nModel:",
	      deparse(as.vector(formula(object))),
	      if(scale > 0) paste("\nscale: ", format(scale), "\n"))
    class(aod) <- c("anova", "data.frame")
    attr(aod, "heading") <- head
    aod
}

drop1.mlm <- function(object, ...)
    stop("drop1 not implemented for mlm models")

drop1.glm <- function(object, scope, scale = 0, test=c("none", "Chisq"),
		      k = 2, ...)
{
    x <- model.matrix(object)
    iswt <- !is.null(wt <- object$weights)
    n <- nrow(x)
    asgn <- attr(x, "assign")
    tl <- attr(object$terms, "term.labels")
    if(missing(scope)) scope <- drop.scope(object)
    else {
	if(!is.character(scope))
	    scope <- attr(terms(update.formula(object, scope)), "term.labels")
	if(!all(match(scope, tl, FALSE)))
	    stop("scope is not a subset of term labels")
    }
    ndrop <- match(scope, tl)
    ns <- length(scope)
    rdf <- object$df.resid
    chisq <- object$deviance
    dfs <- numeric(ns)
    dev <- numeric(ns)
    y <- object$y
    if(is.null(y)) y <- model.response(model.frame(object), "numeric")
    na.coef <- (1:length(object$coefficients))[!is.na(object$coefficients)]
    wt <- object$prior.weights
    if(is.null(wt)) wt <- rep(1, n)
    rank <- object$rank
    for(i in 1:ns) {
	ii <- seq(along=asgn)[asgn == ndrop[i]]
	jj <- setdiff(seq(ncol(x)), ii)
	z <-  glm.fit(x[, jj, drop = FALSE], y, wt, offset=object$offset,
		      family=object$family, control=object$control)
	dfs[i] <- z$rank
	dev[i] <- z$deviance
    }
    scope <- c("<none>", scope)
    dfs <- c(object$rank, dfs)
    dev <- c(chisq, dev)
    if (is.null(scale) || scale == 0)
	dispersion <- summary(object, dispersion = NULL)$dispersion
    else dispersion <- scale
    if(object$family$family == "gaussian") {
	if(scale > 0) loglik <- dev/scale - n
	else loglik <- n * log(dev/n)
    } else loglik <- dev/dispersion
    aic <- loglik + k * dfs
    dfs <- dfs[1] - dfs
    dfs[1] <- NA
    aod <- data.frame(Df = dfs, Deviance = dev, AIC = aic,
		      row.names = scope, check.names = FALSE)
    test <- match.arg(test)
    if(test == "Chisq") {
	dev <- loglik - loglik[1]
	dev[1] <- NA
	nas <- !is.na(dev)
	aod[, "LRT"] <- dev
	dev[nas] <- 1 - pchisq(dev[nas]/dispersion, aod$Df[nas])
	aod[, "Pr(Chi)"] <- dev
    }
    head <- c("Single term deletions", "\nModel:",
	      deparse(as.vector(formula(object))),
	      if(scale > 0) paste("\nscale: ", format(scale), "\n"))
    class(aod) <- c("anova", "data.frame")
    attr(aod, "heading") <- head
    aod
}

add.scope <- function(terms1, terms2)
{
    terms1 <- terms(as.formula(terms1))
    terms2 <- terms(as.formula(terms2))
    factor.scope(attr(terms1, "factor"),
		 list(add = attr(terms2, "factor")))$add
}

drop.scope <- function(terms1, terms2)
{
    terms1 <- terms(as.formula(terms1))
    f2 <- if(missing(terms2)) numeric(0)
    else attr(terms(as.formula(terms2)), "factor")
    factor.scope(attr(terms1, "factor"), list(drop = f2))$drop
}

factor.scope <- function(factor, scope)
{
    drop <- scope$drop
    add <- scope$add

    if(length(factor) && !is.null(drop)) {# have base model
	nmdrop <- colnames(drop)
	facs <- factor
	if(length(drop)) {
	    nmfac <- colnames(factor)
	    where <- match(nmdrop, nmfac, 0)
	    if(any(!where)) stop("lower scope is not included in model")
	    nmdrop <- nmfac[-where]
	    facs <- factor[, -where, drop = FALSE]
	} else nmdrop <- colnames(factor)
	if(ncol(facs) > 1) {
					# now check no interactions will be left without margins.
	    keep <- rep(TRUE, ncol(facs))
	    f <- crossprod(facs > 0)
	    for(i in seq(keep)) keep[i] <- max(f[i, - i]) != f[i, i]
	    nmdrop <- nmdrop[keep]
	}
    } else nmdrop <- character(0)

    if(is.null(add)) nmadd <- character(0)
    else {
	nmfac <- colnames(factor)
	nmadd <- colnames(add)
	if(!is.null(nmfac)) {
	    where <- match(nmfac, nmadd, 0)
	    if(any(!where)) stop("upper scope does not include model")
	    nmadd <- nmadd[-where]
	    add <- add[, -where, drop = FALSE]
	}
	if(ncol(add) > 1) {
					# now check marginality:
	    keep <- rep(TRUE, ncol(add))
	    f <- crossprod(add > 0)
	    for(i in seq(keep)) keep[-i] <- keep[-i] & (f[i, -i] < f[i, i])
	    nmadd <- nmadd[keep]
	}
    }
    list(drop = nmdrop, add = nmadd)
}

step <- function(object, scope, scale = 0,
		 direction = c("both", "backward", "forward"),
		 trace = 1, keep = NULL, steps = 1000, k = 2, ...)
{
    fixFormulaObject <- function(object) {
	tt <- terms(object)
	tmp <- attr(tt, "term.labels")
	if (!attr(tt, "intercept"))
	    tmp <- c(tmp, "0")
	if (!length(tmp))
	    tmp <- "1"
	tmp <- paste(deparse(formula(object)[[2]]), "~",
		     paste(tmp, collapse = " + "))
	if (length(offset <- attr(tt, "offset")))
	    tmp <- paste(tmp, deparse(attr(tt, "variables")[offset + 1]),
			 sep = " + ")
	formula(tmp)
    }

    cut.string <- function(string)
    {
	if(length(string) > 1)
	    string[-1] <- paste("\n", string[-1], sep = "")
	string
    }
    re.arrange <- function(keep)
    {
	namr <- names(k1 <- keep[[1]])
	namc <- names(keep)
	nc <- length(keep)
	nr <- length(k1)
	array(unlist(keep, recursive = FALSE), c(nr, nc), list(namr, namc))
    }

    step.results <- function(models, fit, object, usingCp=FALSE)
    {
	change <- sapply(models, "[[", "change")
	rd <- sapply(models, "[[", "deviance")
	dd <- c(NA, diff(rd))
	rdf <- sapply(models, "[[", "df.resid")
	ddf <- c(NA, diff(rdf))
	AIC <- sapply(models, "[[", "AIC")
	heading <- c("Stepwise Model Path \nAnalysis of Deviance Table",
		     "\nInitial Model:", deparse(as.vector(formula(object))),
		     "\nFinal Model:", deparse(as.vector(formula(fit))),
		     "\n")
	aod <- data.frame(Step = I(change), Df = ddf, Deviance = dd,
                          "Resid. Df" = rdf, "Resid. Dev" = rd, AIC = AIC,
                          check.names = FALSE)
        if(usingCp) {
            cn <- colnames(aod); cn[cn == "AIC"] <- "Cp"; colnames(aod) <- cn
        }
	attr(aod, "heading") <- heading
        ##stop gap attr(aod, "class") <- c("anova", "data.frame")
	fit$anova <- aod
	fit
    }

    ## need to fix up . in formulae in R
    object$formula <- fixFormulaObject(object)
    Terms <- object$formula
    object$call$formula <- object$formula
    attributes(Terms) <- attributes(object$terms)
    object$terms <- Terms
    if(missing(direction)) direction <- "both"
    else direction <- match.arg(direction)
    backward <- direction == "both" | direction == "backward"
    forward <- direction == "both" | direction == "forward"
    if(missing(scope)) {
	fdrop <- numeric(0)
	fadd <- NULL
    } else {
	if(is.list(scope)) {
	    fdrop <- if(!is.null(fdrop <- scope$lower))
		attr(terms(update.formula(object, fdrop)), "factors")
	    else numeric(0)
	    fadd <- if(!is.null(fadd <- scope$upper))
		attr(terms(update.formula(object, fadd)), "factors")
	} else {
	    fadd <- if(!is.null(fadd <- scope))
		attr(terms(update.formula(object, scope)), "factors")
	    fdrop <- numeric(0)
	}
    }
    if(is.null(fadd)) {
	backward <- TRUE
	forward <- FALSE
    }
    models <- vector("list", steps)
    if(!is.null(keep)) {
	keep.list <- vector("list", steps)
	nv <- 1
    }
    n <- length(object$residuals)
    fit <- object
    bAIC <- extractAIC(fit, scale, k = k, ...)
    edf <- bAIC[1]
    bAIC <- bAIC[2]
    nm <- 1
    Terms <- fit$terms
    if(trace)
	cat("Start:  AIC=", format(round(bAIC, 2)), "\n",
	    cut.string(deparse(as.vector(formula(fit)))), "\n\n")

    models[[nm]] <- list(deviance = deviance(fit), df.resid = n - edf,
			 change = "", AIC = bAIC)
    if(!is.null(keep)) keep.list[[nm]] <- keep(fit, bAIC)
    usingCp <- FALSE
    while(steps > 0) {
	steps <- steps - 1
	AIC <- bAIC
	bfit <- fit
	ffac <- attr(Terms, "factors")
	scope <- factor.scope(ffac, list(add = fadd, drop = fdrop))
	aod <- NULL
	change <- NULL
	if(backward && length(scope$drop)) {
	    aod <- drop1(fit, scope$drop, scale = scale,
                         trace = trace, k = k, ...)
	    rn <- row.names(aod)
	    row.names(aod) <- c(rn[1], paste("-", rn[-1], sep=" "))
            ## drop all zero df terms first.
	    if(any(aod$Df == 0, na.rm=TRUE)) {
		zdf <- aod$Df == 0 & !is.na(aod$Df)
		change <- paste(rownames(aod)[zdf])
	    }
	}
	if(is.null(change)) {
	    if(forward && length(scope$add)) {
		aodf <- add1(fit, scope$add, scale = scale,
                             trace = trace, k = k, ...)
		rn <- row.names(aodf)
		row.names(aodf) <- c(rn[1], paste("+", rn[-1], sep=" "))
		aod <-
                    if(is.null(aod)) aodf
                    else rbind(aod, aodf[-1, , drop = FALSE])
	    }
	    attr(aod, "heading") <- NULL
					# need to remove any terms with zero df from consideration
	    nzdf <- if( !is.null(aod$Df) )
		aod$Df != 0 | is.na(aod$Df)
	    aod <- aod[nzdf, ]
	    if(is.null(aod) || ncol(aod) == 0) break
	    nc <- match(c("Cp", "AIC"), names(aod))
	    nc <- nc[!is.na(nc)][1]
	    o <- order(aod[, nc])
	    if(trace) print(aod[o, ])
	    if(o[1] == 1) break
	    change <- rownames(aod)[o[1]]
	}
	usingCp <- match("Cp", names(aod), 0) > 0
	fit <- update(fit, paste("~ .", change))
	fit$formula <- fixFormulaObject(fit)
	Terms <- fit$formula
	attributes(Terms) <- attributes(fit$terms)
	fit$terms <- Terms
	bAIC <- extractAIC(fit, scale, k = k, ...)
	edf <- bAIC[1]
	bAIC <- bAIC[2]
	if(trace)
	    cat("\nStep:  AIC=", format(round(bAIC, 2)), "\n",
		cut.string(deparse(as.vector(formula(fit)))), "\n\n")
	if(bAIC >= AIC) break
	nm <- nm + 1
	edf <- models[[nm]] <-
	    list(deviance = deviance(fit), df.resid = n - edf,
		 change = change, AIC = bAIC)
	if(!is.null(keep)) keep.list[[nm]] <- keep(fit, bAIC)
    }
    if(!is.null(keep)) fit$keep <- re.arrange(keep.list[seq(nm)])
    step.results(models = models[seq(nm)], fit, object, usingCp)
}

extractAIC <- function(fit, scale, k = 2, ...) UseMethod("extractAIC")

extractAIC.coxph <- function(fit, scale, k = 2, ...)
{
    edf <- length(fit$coef)
    if(edf > 0)
        c(edf, -2 * fit$loglik[2] + k * edf)
    else
        c(0, -2 * fit$loglik)
}

extractAIC.survreg <- function(fit, scale, k = 2, ...)
{
    n <- length(fit$residuals)
    edf <- n  - fit$df.residual
    c(edf, -2 * fit$loglik[2] + k * edf)
}

extractAIC.glm <- function(fit, scale = 0, k = 2, ...)
{
    n <- length(fit$residuals)
    edf <- n  - fit$df.residual
    dev <- fit$deviance
    if(scale > 0) dev <- dev/scale
    if(scale == 0 && fit$family$family == "Gaussian") dev <- n * log(dev/n)
    c(edf, dev + k * edf)
}

extractAIC.lm <- function(fit, scale = 0, k = 2, ...)
{
    n <- length(fit$residuals)
    edf <- n  - fit$df.residual
    RSS <- deviance.lm(fit)
    dev <- if(scale > 0) RSS/scale - n else n * log(RSS/n)
    c(edf, dev + k * edf)
}
extractAIC.aov <- .Alias(extractAIC.lm)

extractAIC.negbin <- function(fit, scale, k = 2, ...)
{
    n <- length(fit$residuals)
    edf <- n - fit$df.residual
    c(edf, -fit$twologlik + k * edf)
}
aggregate <- function(x, ...) UseMethod("aggregate")

aggregate.default <- function(x, ...) {
    if (is.ts(x))
        aggregate.ts(as.ts(x), ...)
    else
        aggregate.data.frame(as.data.frame(x), ...)
}

aggregate.data.frame <- function(x, by, FUN, ...) {
    if (!is.data.frame(x))
        x <- as.data.frame(x)
    if (!is.list(by))
        stop("`by' must be a list")
    if (is.null(names(by)))
        names(by) <- paste("Group", seq(along = by), sep = ".")
    else {
        nam <- names(by)
        ind <- which(nchar(nam) == 0)
        names(by)[ind] <- paste("Group", ind, sep = ".")
    }
    y <- lapply(x, tapply, by, FUN, ..., simplify = FALSE)
    if (any(sapply(unlist(y, recursive = FALSE), length) > 1))
        stop("`FUN' must always return a scalar")
    z <- y[[1]]
    d <- dim(z)
    w <- NULL    
    for (i in seq(along = d)) {
        j <- rep(rep(seq(1 : d[i]),
                     prod(d[seq(length = i - 1)]) * rep(1, d[i])),
                 prod(d[seq(from = i + 1, length = length(d) - i)]))
        w <- cbind(w, dimnames(z)[[i]][j])
    }
    w <- w[which(!unlist(lapply(z, is.null))), ]
    y <- data.frame(w, lapply(y, unlist, use.names = FALSE))
    names(y) <- c(names(by), names(x))
    y
}

aggregate.ts <- function(x, nfrequency = 1, FUN = sum, ndeltat = 1,
                         ts.eps = .Options$ts.eps) {
    x <- as.ts(x)
    ofrequency <- tsp(x)[3]
    ## Set up the new frequency, and make sure it is an integer.
    if (missing(nfrequency))
        nfrequency <- 1 / ndeltat
    if ((nfrequency > 1) &&
        (abs(nfrequency - round(nfrequency)) < ts.eps))
        nfrequency <- round(nfrequency)
    
    if (nfrequency == ofrequency)
        return(x)
    if ((ofrequency %% nfrequency) != 0)
        stop(paste("cannot change frequency from",
                   ofrequency, "to", nfrequency))
    ## The desired result is obtained by applying FUN to blocks of
    ## length ofrequency/nfrequency, for each of the variables in x.
    ## We first get the new start and end right, and then break x into
    ## such blocks by reshaping it into an array and setting dim.
    len <- ofrequency %/% nfrequency
    mat <- is.matrix(x)
    nstart <- ceiling(tsp(x)[1] * nfrequency) / nfrequency
    x <- as.matrix(window(x, start = nstart))
    nend <- floor(nrow(x) / len) * len
    x <- apply(array(c(x[1 : nend, ]),
                     dim = c(len, nend / len, ncol(x))),
               MARGIN = c(2, 3),
               FUN = FUN)
    if (!mat)
        x <- as.vector(x)
    ts(x, start = nstart, frequency = nfrequency)
}
all.equal <- function(target, current, ...) UseMethod("all.equal")

all.equal.default <- function(target, current, ...)
{
    ## Really a dispatcher given mode() of args :
    if(is.language(target) || is.function(target))
	return(all.equal.language(target, current, ...))
    if(is.recursive(target))
	return(all.equal.list(target, current, ...))
    msg <- c(attr.all.equal(target, current, ...),
	     if(data.class(target) != data.class(current))
		paste("target is ", data.class(target), ", current is ",
		      data.class(current), sep = "") else
		switch (mode(target),
			logical = ,
                        complex = ,
			numeric	  = all.equal.numeric(target, current, ...),
			character = all.equal.character(target, current, ...),
			NULL))
    if(is.null(msg)) TRUE else msg
}

all.equal.numeric <- function(target, current,
			      tolerance = .Machine$double.eps ^ .5, scale=NULL)
{
    lt <- length(target)
    lc <- length(current)
    cplx <- is.complex(target)
    if(lt != lc)
	return(paste(if(cplx)"Complex" else "Numeric",
                     ": lengths (", lt, ", ", lc, ") differ"), sep = "")
    else msg <- NULL
    target <- as.vector(target)
    current <- as.vector(current)
    out <- is.na(target)
    if(any(out != is.na(current)))
	return(paste("`is.NA' value mismatches:", sum(is.na(current)),
		     "in current,", sum(out), " in target"))
    out <- out | target == current
    if(all(out)) return(TRUE)
    target <- target[!out]
    current <- current[!out]
    xy <- mean((if(cplx)Mod else abs)(target - current))
    what <-
	if(is.null(scale)) {
	    xn <- mean(abs(target))
	    if(xn > tolerance) {
		xy <- xy/xn
		"relative"
	    } else "absolute"
	} else {
	    xy <- xy/scale
	    "scaled"
	}
    if(is.na(xy) || xy > tolerance)
	paste("Mean", what, if(cplx)"Mod", "difference:", format(xy)) else TRUE
}

all.equal.character <- function(target, current, ...)
{
    lt <- length(target)
    lc <- length(current)
    if(lt != lc) {
	msg <- paste("Lengths (", lt, ", ", lc,
		     ") differ (string compare on first ", ll <- min(lt, lc),
		     ")", sep = "")
	ll <- seq(length = ll)
	target <- target[ll]
	current <- current[ll]
    } else msg <- NULL
    ne <- target != current
    if(!any(ne) && is.null(msg)) TRUE
    else if(any(ne)) c(msg, paste(sum(ne), "string mismatches"))
    else msg
}

all.equal.factor <- function(target, current, ...)
{
    if(!inherits(current, "factor"))
	return("`current' is not a factor")
    msg <- attr.all.equal(target, current)
    class(target) <- class(current) <- NULL
    nax <- is.na(target)
    nay <- is.na(current)
    if(n <- sum(nax != nay))
	msg <- c(msg, paste("NA mismatches:", n))
    else {
	target <- levels(target)[target[!nax]]
	current <- levels(current)[current[!nay]]
	if(is.character(n <- all.equal(target, current)))
	    msg <- c(msg, n)
    }
    if(is.null(msg)) TRUE else msg
}

all.equal.formula <- function(target, current, ...)
{
    if(length(target) != length(current))
	return(paste("target, current differ in having response: ",
		     length(target) == 3, ", ", length(current) == 3))
    if(all(deparse(target) != deparse(current)))
	"formulas differ in contents"
    else TRUE
}

all.equal.language <- function(target, current, ...)
{
    mt <- mode(target)
    mc <- mode(current)
    if(mt == "expression" && mc == "expression")
	return(all.equal.list(target, current, ...))
    ttxt <- paste(deparse(target), collapse = "\n")
    ctxt <- paste(deparse(current), collapse = "\n")
    msg <- c(if(mt != mc)
	     paste("Modes of target, current: ", mt, ", ", mc, sep = ""),
	     if(ttxt != ctxt) {
		 if(pmatch(ttxt, ctxt, FALSE))
		     "target a subset of current"
		 else if(pmatch(ctxt, ttxt, FALSE))
		     "current a subset of target"
		 else	"target, current don't match when deparsed"
	     })
    if(is.null(msg)) TRUE else msg
}

all.equal.list <- function(target, current, ...)
{
    msg <- attr.all.equal(target, current, ...)
    nt <- names(target)
    nc <- names(current)
    iseq <-
	if(length(nt) && length(nc)) {
	    if(any(not.in <- (c.in.t <- match(nc, nt, 0)) == 0))
		msg <- c(msg, paste("Components not in target:",
				    paste(nc[not.in], collapse = ", ")))
	    if(any(not.in <- match(nt, nc, 0) == 0))
		msg <- c(msg, paste("Components not in current:",
				    paste(nt[not.in], collapse = ", ")))
	    nt[c.in.t]
	} else if(length(target) == length(current)) {
	    seq(along = target)
	} else {
	    nc <- min(length(target), length(current))
	    msg <- c(msg, paste("Length mismatch: comparison on first",
				nc, "components"))
	    seq(length = nc)
	}
    for(i in iseq) {
	mi <- all.equal(target[[i]], current[[i]], ...)
	if(is.character(mi))
	    msg <- c(msg, paste("Component ", i, ": ", mi, sep=""))
    }
    if(is.null(msg)) TRUE else msg
}


attr.all.equal <- function(target, current, ...)
{
    ##--- "all.equal(.)" for attributes ---
    ##---  Auxiliary in all.equal(.) methods --- return NULL or character()
    msg <- NULL
    if(mode(target) != mode(current))
	msg <- paste("Modes: ", mode(target), ", ", mode(current), sep = "")
    if(length(target) != length(current))
	msg <- c(msg, paste("Lengths: ", length(target), ", ",
			    length(current), sep = ""))
    ax <- attributes(target)
    ay <- attributes(current)
    nx <- names(target)
    ny <- names(current)
    if((lx <- length(nx)) | (ly <- length(ny))) {
	## names() treated now; hence NOT with attributes()
	ax$names <- ay$names <- NULL
	if(lx && ly) {
	    if(is.character(m <- all.equal.character(nx, ny)))
		msg <- c(msg, paste("Names:", m))
	} else if(lx)
	    msg <- c(msg, "names for target but not for current")
	else msg <- c(msg, "names for current but not for target")
    }
    if(length(ax) || length(ay)) {# some (more) attributes
	## order by names before comparison:
	nx <- names(ax)
	ny <- names(ay)
	if(length(nx))	    ax <- ax[order(nx)]
	if(length(ny))	    ay <- ay[order(ny)]
	tt <- all.equal(ax, ay, ...)
	if(is.character(tt)) msg <- c(msg, paste("Attributes: <", tt, ">"))
    }
    msg # NULL or character
}

all.names <- function(expr, functions = TRUE, max.names = 200, unique = FALSE)
    .Internal(all.names(expr, functions, max.names, unique))

all.vars <- function(expr, functions = FALSE, max.names = 200, unique = TRUE)
    .Internal(all.names(expr, functions, max.names, unique))
## *ANY* print method should return its argument invisibly!


##-     nn <- names(x)
##-
##-     for (i in 1:NCOL(x)) {
##- 	xr <- x[[i]]
##- 	if (substr(nn[i],1,2) == "Pr") {
##- 	    x[[i]] <- format.pval(xr, digits = max(1, min(5, digits - 1)), na="")
##- 	    if(signif.stars)
##- 		x$Signif <- c(symnum(xr[!is.na(xr)], corr = FALSE,
##- 				     cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1),
##- 				     symbols = c("***", "**", "*", ".", " ")),
##- 			      "") ## 'nterms' ~= 'Residuals' have no P-value
##-
##- 	} else if (!is.factor(xr) && is.numeric(xr)) {
##- 	    cxr <- format(zapsmall(xr, digits=digits), digits=digits)
##- 	    cxr[is.na(xr)] <- ""
##- 	    x[[i]] <- cxr
##- 	}
##-     }
##-     print.data.frame(x)


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

aov <- function(formula, data = NULL, projections = FALSE, qr = TRUE,
                contrasts = NULL, ...)
{
    Terms <- if(missing(data)) terms(formula, "Error")
    else terms(formula, "Error", data = data)
    indError <- attr(Terms, "specials")$Error
    if(length(indError) > 1)
        stop(paste("There are", length(indError),
                   "Error terms: only 1 is allowed"))
    lmcall <- Call <- match.call()
    lmcall[[1]] <- as.name("lm")
    lmcall$singular.ok <- TRUE          # not currently used in R
    if(projections) qr <- lmcall$qr <- TRUE
    lmcall$projections <- NULL
    if(is.null(indError)) {
        ## no Error term
        fit <- eval(lmcall, sys.frame(sys.parent()))
        if(projections) fit$projections <- proj(fit)
        class(fit) <- if(inherits(fit, "mlm"))
            c("maov", "aov", class(fit)) else c("aov", class(fit))
        fit$call <- Call
        return(fit)
    } else {
        ##  helmert contrasts can be helpful: do we want to force them?
        ##  this version does for the Error model.
        cons <- options("contrasts")
        options(contrasts=c("contr.helmert", "contr.poly"))
        on.exit(options(cons))
        allTerms <- Terms
        errorterm <-  attr(Terms, "variables")[[1 + indError]]
        eTerm <- deparse(errorterm[[2]])
        intercept <- attr(Terms, "intercept")
        ecall <- lmcall
        ecall$formula <- as.formula(paste(deparse(formula[[2]]), "~", eTerm,
                                          if(!intercept) "- 1"))
        ecall$method <- "qr"
        ecall$qr <- TRUE
        ecall$contrasts <- NULL
        er.fit <- eval(ecall, sys.frame(sys.parent()))
        options(cons)
        nmstrata <- attr(terms(er.fit),"term.labels")
        if(intercept) nmstrata <- c("(Intercept)", nmstrata)
        qr.e <- er.fit$qr
        rank.e <- er.fit$rank
        qty <- er.fit$resid
        maov <- is.matrix(qty)
        asgn.e <- er.fit$assign[qr.e$piv[1:rank.e]]
        ## we want this to label the rows of qtx, not cols of x.
        nobs <- NROW(qty)
        if(nobs > rank.e) {
            result <- vector("list", max(asgn.e) + 2)
            asgn.e[(rank.e+1):nobs] <- max(asgn.e) + 1
            nmstrata <- c(nmstrata, "Within")
        } else result <- vector("list", max(asgn.e) + 1)
        names(result) <- nmstrata
        lmcall$formula <- form <-
            update(formula, paste(". ~ .-", deparse(errorterm)))
        Terms <- terms(form)
        lmcall$method <- "model.frame"
        mf <- eval(lmcall, sys.frame(sys.parent()))
        xvars <- as.character(attr(Terms, "variables"))[-1]
        if ((yvar <- attr(Terms, "response")) > 0)
            xvars <- xvars[-yvar]
        if (length(xvars) > 0) {
            xlev <- lapply(mf[xvars], levels)
            xlev <- xlev[!sapply(xlev, is.null)]
        } else xlev <- NULL
        resp <- model.response(mf)
        qtx <- model.matrix(Terms, mf, contrasts)
        cons <- attr(qtx, "contrasts")
        dnx <- colnames(qtx)
        asgn.t <- attr(qtx, "assign")
        if(length(wts <- model.extract(mf, weights))) {
            wts <- sqrt(wts)
            resp <- resp * wts
            qtx <- qtx * wts
        }
        qty <- as.matrix(qr.qty(qr.e, resp))
        if((nc <- ncol(qty)) > 1) {
            dny <- colnames(resp)
            if(is.null(dny)) dny <- paste("Y", 1:nc, sep="")
            dimnames(qty) <- list(seq(nrow(qty)), dny)
        } else dimnames(qty) <- list(seq(nrow(qty)), NULL)
        qtx <- qr.qty(qr.e, qtx)
        dimnames(qtx) <- list(seq(nrow(qtx)) , dnx)
        for(i in seq(along=nmstrata)) {
            select <- asgn.e==(i-1)
            ni <- sum(select)
            if(!ni) next
            ## helpful to drop constant columns.
            xi <- qtx[select, , drop = FALSE]
            cols <- apply(xi^2, 2, sum) > 1e-5
            if(any(cols)) {
                xi <- xi[, cols, drop = FALSE]
                attr(xi, "assign") <- asgn.t[cols]
                fiti <- lm.fit(xi, qty[select,,drop=FALSE])
                fiti$terms <- Terms
            } else {
                y <- qty[select,,drop=FALSE]
                fiti <- list(coefficients = numeric(0), residuals = y,
                             fitted.values = 0 * y, weights = wts, rank = 0,
                             df.residual = NROW(y))
            }
            if(projections) fiti$projections <- proj(fiti)
            class(fiti) <- c(if(maov) "maov", "aov", class(er.fit))
            result[[i]] <- fiti
        }
        class(result) <- c("aovlist", "listof")
        if(qr) attr(result, "error.qr") <- qr.e
        attr(result, "call") <- Call
        if(length(wts)) attr(result, "weights") <- wts
        attr(result, "terms") <- allTerms
        attr(result, "contrasts") <- cons
        attr(result, "xlevels") <- xlev
        result
    }
}

print.aov <-
function(x, intercept = FALSE, tol = .Machine$double.eps^0.5, ...)
{
    if(!is.null(cl <- x$call)) {
        cat("Call:\n   ")
        dput(cl)
    }
    asgn <- x$assign[x$qr$pivot[1:x$rank]]
    effects <- x$effects
    if(!is.null(effects))
        effects <- as.matrix(effects)[seq(along=asgn),,drop=FALSE]
    rdf <- x$df.resid
    uasgn <- unique(asgn)
    nmeffect <- c("(Intercept)", attr(x$terms, "term.labels"))[1+uasgn]
    nterms <- length(uasgn)
    nresp <- NCOL(effects)
    df <- numeric(nterms)
    ss <- matrix(NA, nterms, nresp)
    if(nterms) {
        for(i in seq(nterms)) {
            ai <- asgn==uasgn[i]
            df[i] <- sum(ai)
            ef <- effects[ai,, drop=FALSE]
            ss[i,] <- if(sum(ai) > 1) apply(ef^2, 2, sum) else ef^2
        }
        keep <- df > 0
        if(!intercept && uasgn[1] == 0) keep[1] <- FALSE
        nmeffect <- nmeffect[keep]
        df <- df[keep]
        ss <- ss[keep,,drop=FALSE]
        nterms <- length(df)
    }
    cat("\nTerms:\n")
    if(nterms == 0) {
        ## empty model
        if(rdf > 0) {
            ss <- apply(as.matrix(x$residuals)^2,2,sum)
            ssp <- sapply(ss, format)
            tmp <- as.matrix(c(ssp, format(rdf)))
            rn <- if(length(ss) > 1) colnames(x$fitted) else "Sum of Squares"
            dimnames(tmp) <- list(c(rn, "Deg. of Freedom"), "Residuals")
            print.matrix(tmp, quote = FALSE, right = TRUE)
            cat("\n")
            cat("Residual standard error:", sapply(sqrt(ss/rdf), format), "\n")
        } else
        print.matrix(matrix(0, 2, 1, dimnames=
                            list(c("Sum of Squares", "Deg. of Freedom"),
                                 "<empty>")))
    } else {
        if(rdf > 0) {
            resid <- as.matrix(x$residuals)
            nterms <- nterms + 1
            df <- c(df, rdf)
            ss <- rbind(ss, apply(resid^2, 2, sum))
            nmeffect <- c(nmeffect, "Residuals")
        }
        ssp <- apply(zapsmall(ss), 2, format)
        tmp <- t(cbind(ssp, format(df)))
        if(ncol(effects) > 1) {
            rn <- colnames(x$coef)
            if(is.null(rn)) rn <- paste("resp", seq(ncol(effects)))
        } else rn <- "Sum of Squares"
        dimnames(tmp) <- list(c(rn, "Deg. of Freedom"), nmeffect)
        print.matrix(tmp, quote = FALSE, right = TRUE)
        rank <- x$rank
        int <- attr(x$terms, "intercept")
        nobs <- NROW(x$residuals) - !(is.null(int) || int == 0)
        cat("\n")
        if(rdf > 0) {
            rs <- sqrt(apply(as.matrix(x$residuals)^2,2,sum)/rdf)
            cat("Residual standard error:", sapply(rs, format), "\n")
        }
        coef <- as.matrix(x$coef)[,1]
        R <- x$qr$qr
        R <- R[1:min(dim(R)), ,drop=FALSE]
        R[lower.tri(R)] <- 0
        if(rank < (nc <- length(coef))) {
            cat(paste(nc - rank, "out of", nc, "effects not estimable\n"))
            R <- R[, 1:rank, drop = FALSE]
        }
        d2 <- sum(abs(diag(R)))
        diag(R) <- 0
        if(sum(abs(R))/d2 > tol)
            cat("Estimated effects may be unbalanced\n")
        else cat("Estimated effects are balanced\n")
    }
    invisible(x)
}

summary.aov <- function(object, intercept = FALSE, keep.zero.df = TRUE, ...)
{
    asgn <- object$assign[object$qr$pivot[1:object$rank]]
    uasgn <- unique(asgn)
    nterms <- length(uasgn)
    effects <- object$effects
    if(!is.null(effects))
        effects <- as.matrix(effects)[seq(along=asgn),,drop=FALSE]
    rdf <- object$df.resid
    nmeffect <- c("(Intercept)", attr(object$terms, "term.labels"))
    coef <- as.matrix(object$coef)
    resid <- as.matrix(object$residuals)
    wt <- object$weights
    if(!is.null(wt)) resid <- resid * wt^0.5
    nresp <- NCOL(resid)
    ans <- vector("list", nresp)
    if(nresp > 1) {
        names(ans) <- character(nresp)
        for (y in 1:nresp) {
            cn <- colnames(resid)[y]
            if(is.null(cn) || cn == "") cn <- y
            names(ans)[y] <- paste(" Response", cn)
        }
    }
    for (y in 1:nresp) {
        if(is.null(effects)) {
            df <- nterms <- neff <- 0
            ss <- ms <- numeric(0)
            nmrows <- character(0)
        } else {
            nobs <- length(resid[, y])
            df <- ss <- numeric(nterms)
            nmrows <- character(nterms)
            for(i in seq(nterms)) {
                ai <- (asgn == uasgn[i])
                df[i] <- sum(ai)
                ss[i] <- sum(effects[ai, y]^2)
                nmrows[i] <- nmeffect[1 + uasgn[i]]
            }
        }
        nt <- nterms
        if(rdf > 0) {
            nt <- nterms + 1
            df[nt] <- rdf
            ss[nt] <- sum(resid[,y]^2)
            nmrows[nt] <- "Residuals"
        }
        ms <- ifelse(df > 0, ss/df, NA)
        x <- list(Df = df, "Sum Sq" = ss, "Mean Sq" = ms)
        if(rdf > 0) {
            TT <- ms/ms[nt]
            TP <- 1 - pf(TT, df, rdf)
            TT[nt] <- TP[nt] <- NA
            x$"F value" <- TT
            x$"Pr(>F)" <- TP
            ## 'nterms' ~= 'Residuals' have no P-value
        }
        class(x) <- c("anova", "data.frame")
        row.names(x) <- format(nmrows)
        if(!keep.zero.df) x <- x[df > 0, ]
        pm <- pmatch("(Intercept)", row.names(x), 0)
        if(!intercept && pm > 0) x <- x[-pm ,]
        ans[[y]] <- x
    }
    class(ans) <- c("summary.aov", "listof")
    ans
}

print.summary.aov <- function(x, digits = max(3, .Options$digits - 3),
                              symbolic.cor = p > 4,
                              signif.stars= .Options$show.signif.stars,	...)
{
    if (length(x) == 1)  print(x[[1]], ...)
    else NextMethod()
    invisible(x)
}

coef.aov <- function(object, ...)
{
    z <- object$coef
    z[!is.na(z)]
}

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

alias.formula <- function(object, data, ...)
{
    lm.obj <- if(missing(data)) aov(object) else aov(object, data)
    alias(lm.obj, ...)
}

alias.lm <- function(object, complete = TRUE, partial = FALSE,
                     partial.pattern = FALSE, ...)
{
    CompPatt <- function(x, ...) {
        x[abs(x) < 1e-6] <- 0
        if(exists("fractions", mode="function")) fractions(x)
        else {
            class(x) <- "mtable"
            x[abs(x) < 1e-6] <- NA
            x
        }
    }
    PartPatt <- function(x) {
        z <- zapsmall(x) != 0
        if(any(z)) {
            xx <- abs(signif(x[z], 2))
            ll <- length(unique(xx))
            if(ll > 10) xx <- cut(xx, 9) else if(ll == 1) x[] <- 1
            x[z] <- paste(ifelse(x[z] > 0, " ", "-"), xx, sep = "")
        }
        x[!z] <- ""
        collabs <- colnames(x)
        if(length(collabs)) {
            collabs <- abbreviate(sub("\\.", "", collabs), 3)
        } else  collabs <-1:ncol(x)
        colnames(x) <- collabs
        class(x) <- "mtable"
        x
    }
    Model <- object$terms
    attributes(Model) <- NULL
    value <- list(Model = Model)
    R <- object$qr$qr
    R <- R[1:min(dim(R)),, drop=FALSE]
    R[lower.tri(R)] <- 0
    d <- dim(R)
    rank <- object$rank
    p <- d[2]
    if(complete) {                      # full rank, no aliasing
        value$Complete <-
            if(is.null(p) || rank == p) NULL else {
                p1 <- 1:rank
                dn <- colnames(R)
                X <- R[p1, p1]
                Y <-  R[p1, -p1, drop = FALSE]
                beta12 <- as.matrix(qr.coef(qr(X), Y))
                dimnames(beta12) <- list(dn[p1], dn[ -p1])
                CompPatt(t(beta12))
            }
    }
    if(partial) {
        tmp <- summary.lm(object)$cov.unscaled
        ses <- sqrt(diag(tmp))
        beta11 <- tmp /outer(ses, ses)
        beta11[row(beta11) >= col(beta11)] <- 0
        beta11[abs(beta11) < 1e-6] <- 0
        if(all(beta11 == 0)) beta11 <- NULL
        else if(partial.pattern) beta11 <- PartPatt(beta11)
        value$Partial <- beta11
    }
    class(value) <- "listof"
    value
}

print.aovlist <- function(x, ...)
{
    cl <- attr(x, "call")
    if(!is.null(cl)) {
        cat("\nCall:\n")
        dput(cl)
    }
    if(!is.null(attr(x, "weights")))
        cat("Note: The results below are on the weighted scale\n")
    nx <- names(x)
    if(nx[1] == "(Intercept)") {
        mn <- x[[1]]$coef
        if(is.matrix(mn)) {
            cat("\nGrand Means:\n")
            print(format(mn[1,]), quote=FALSE)
        } else cat("\nGrand Mean:", format(mn[1]), "\n")
        nx <- nx[-1]
    }
    for(ii in seq(along = nx)) {
        i <- nx[ii]
        cat("\nStratum ", ii, ": ", i, "\n", sep = "")
        xi <- x[[i]]
        print(xi, ...)
    }
    invisible(x)
}

summary.aovlist <- function(object, ...)
{
    if(!is.null(attr(object, "weights")))
        cat("Note: The results below are on the weighted scale\n")
    dots <- list(...)
    strata <- names(object)
    if(strata[1] == "(Intercept)") {
        strata <- strata[-1]
        object <- object[-1]
    }
    x <- vector(length = length(strata), mode = "list")
    names(x) <- paste("Error:", strata)
    for(i in seq(along = strata)) {
        x[[i]] <- do.call("summary", append(list(object = object[[i]]), dots))
    }
    class(x) <- "summary.aovlist"
    x
}

print.summary.aovlist <- function(x, ...)
{
    nn <- names(x)
    for (i in nn) {
        cat("\n", i, "\n", sep="")
        print(x[[i]], ...)
    }
    invisible(x)
}

coef.listof <- function(object, ...)
{
    val <- vector("list", length(object))
    names(val) <- names(object)
    for(i in seq(along=object)) val[[i]] <- coef(object[[i]])
    class(val) <- "listof"
    val
}

se.contrast <- function(object, ...) UseMethod("se.contrast")

se.contrast.aov <-
    function(object, contrast.obj, coef = contr.helmert(ncol(contrast))[, 1],
             data = NULL, ...)
{
    contrast.weight.aov <- function(object, contrast)
    {
        asgn <- object$assign[object$qr$pivot[1:object$rank]]
        uasgn <- unique(asgn)
        nterms <- length(uasgn)
        nmeffect <- c("(Intercept)",
                      attr(object$terms, "term.labels"))[1 + uasgn]
        effects <- as.matrix(qr.qty(object$qr, contrast))
        effect.sq <- effects[seq(along=asgn), , drop = FALSE]^2
        res <- matrix(0, nrow = nterms, ncol = ncol(effects),
                      dimnames = list(nmeffect, colnames(contrast)))
        for(i in seq(nterms)) {
            select <- (asgn == uasgn[i])
            res[i,] <- rep(1, sum(select)) %*% effect.sq[select, , drop = FALSE]
        }
        res
    }
    if(is.null(data)) contrast.obj <- eval(contrast.obj)
    else contrast.obj <- eval(substitute(contrast.obj), data, sys.frame(sys.parent()))
    if(!missing(coef)) {
        if(sum(coef) != 0)
            stop("coef must define a contrast, i.e., sum to 0")
        if(length(coef) != length(contrast.obj))
            stop("coef must have same length as contrast.obj")
    }
    if(!is.matrix(contrast.obj)) {
        contrast <-
            sapply(contrast.obj, function(x)
               {
                   if(!is.logical(x))
                       stop(paste("Each element of", substitute(contrasts.list),
                                  " must be\nlogical"))
                   x/sum(x)
               })
        contrast <- contrast %*% coef
        if(!any(contrast) || all(is.na(contrast)))
            stop("The contrast defined is empty (has no TRUE elements)")
    } else {
        contrast <- contrast.obj
        if(any(round(rep(1, nrow(contrast)) %*% contrast, 8) != 0))
            stop("Columns of contrast.obj must define a contrast (sum to zero)")
        if(length(colnames(contrast)) == 0)
            colnames(contrast) <- paste("Contrast", seq(ncol(contrast)))
    }
    weights <- contrast.weight.aov(object, contrast)
    rdf <- object$df.resid
    rse <- sum(object$residuals^2)/rdf
    if(!is.matrix(contrast.obj)) sqrt(sum(weights) * rse)
    else sqrt(rse * (rep(1, nrow(weights)) %*% weights))
}

se.contrast.aovlist <-
    function(object, contrast.obj, coef = contr.helmert(ncol(contrast))[, 1],
             data = NULL, ...)
{
    contrast.weight.aovlist <- function(object, contrast, onedf = TRUE)
    {
        e.qr <- attr(object, "error.qr")
        if(!is.qr(e.qr))
            stop("Argument does not include an error qr component")
        c.qr <- qr.qty(e.qr, contrast)
        e.assign <- attr(e.qr$qr, "assign")
        n.object <- length(object)
        if(length(e.assign) < n.object)
            e.assign[[names(object)[n.object]]] <-
                attr(e.qr$qr, "assign.residual")
        res <- vector(length = n.object, mode = "list")
        names(res) <- names(object)
        for(strata.nm in names(object)) {
            strata <- object[[strata.nm]]
            if(is.qr(strata$qr)) {
                scontrast <- c.qr[e.assign[[strata.nm]], , drop = FALSE]
                effects <- as.matrix(qr.qty(strata$qr, scontrast))
                asgn <- strata$assign
                asgn <- strata$assign[strata$qr$pivot[1:strata$rank]]
                uasgn <- unique(asgn)
                res.i <- matrix(0, nrow = length(asgn), ncol = ncol(effects),
                                dimnames= list(names(asgn), colnames(contrast)))
                for(i in seq(along = asgn)) {
                    select <- (asgn == uasgn[i])
                    res.i[i, ] <- rep(1, length(select)) %*%
                        effect[select, , drop = FALSE]^2
                }
                res[[strata.nm]] <- res.i
            }
        }
        res
    }
    SS <- function(aov.object)
    {
        rdf <- aov.object$df.resid
        if(is.null(rdf)) {
            nobs <- length(aov.object$residuals)
            rank <- aov.object$rank
            rdf <- nobs - rank
        }
        sum(aov.object$residuals^2)/rdf
    }
    if(is.null(attr(object, "error.qr"))) {
        cat("Refitting model to allow projection\n")
        object <- update(object, qr = TRUE)
    }
    contrast.obj <-
        if(is.null(data)) eval(contrast.obj)
        else eval(substitute(contrast.obj), data, sys.frame(sys.parent()))
    if(!missing(coef)) {
        if(sum(coef) != 0)
            stop("coef must define a contrast, i.e., sum to 0")
        if(length(coef) != length(contrast.obj))
            stop("coef must have same length as contrast.obj")
    }
    if(!is.matrix(contrast.obj)) {
        contrast <-
            sapply(contrast.obj,
                   function(x) {
                       if(!is.logical(x))
                           stop(paste("Each element of",
                                      substitute(contrast.obj),
                                      " must be\n logical"))
                       x/sum(x)
                   })
        contrast <- contrast %*% coef
        if(!any(contrast))
            stop("The contrast defined is empty (has no TRUE elements)")
    }
    else {
        contrast <- contrast.obj
        if(any(round(rep(1, nrow(contrast)) %*% contrast, 8) != 0))
            stop("Columns of contrast.obj must define a contrast(sum to zero)")
        if(length(colnames(contrast)) == 0)
            colnames(contrast) <- paste("Contrast", seq(ncol(contrast)))
    }
    weights <- contrast.weight.aovlist(object, contrast, onedf = FALSE)
    weights <- weights[-match("(Intercept)", names(weights))]
    effic <- eff.aovlist(object)
    ## Need to identify the lowest stratum where each nonzero term appears
    eff.used <- apply(effic, 2, function(x, ind = seq(length(x)))
                  {
                      temp <- (x > 0)
                      if(sum(temp) == 1) temp
                      else max(ind[temp]) == ind
                  }
                      )
    strata.nms <- rownames(effic)[row(eff.used)[eff.used]]
    var.nms <- colnames(effic)[col(eff.used)[eff.used]]
    rse.list <- sapply(object[unique(strata.nms)], SS)
    wgt <- matrix(0, nrow = length(var.nms), ncol = ncol(contrast),
                  dimnames = list(var.nms, colnames(contrast)))
    for(i in seq(length(var.nms)))
        wgt[i, ] <- weights[[strata.nms[i]]][var.nms[i], , drop = FALSE]
    rse <- rse.list[strata.nms]
    eff <- effic[eff.used]
    sqrt((rse/eff^2) %*% wgt)
}
aperm <- function(a, perm, resize=TRUE) {
    if (missing(perm))
	perm<-(length(dim(a)):1)
    else {
	if(length(perm) != length(dim(a)))
	    stop("perm has incorrect length")
	if(!all(sort(perm)==1:length(perm)))
	    stop("perm is not a permutation")
    }
    r <- .Internal(aperm(a, perm, resize))
    if(!is.null(dn <- dimnames(a))) dimnames(r) <- dn[perm]
    r
}
append <- function (x, values, after = length(x))
{
    lengx <- length(x)
    if (after <= 0)
	c(values, x)
    else if (after >= lengx)
	c(x, values)
    else c(x[1:after], values, x[(after + 1):lengx])
}
apply <- function(X, MARGIN, FUN, ...)
{
    FUN <- match.fun(FUN)

    ## Ensure that X is an array object
    d <- dim(X)
    dl <- length(d)
    if(dl == 0)
	stop("dim(X) must have a positive length")
    ds <- 1:dl
    if(length(class(X)) > 0)
	X <- if(dl == 2) as.matrix(X) else as.array(X)
    dn <- dimnames(X)

    ## Extract the margins and associated dimnames

    s.call <- ds[-MARGIN]
    s.ans  <- ds[MARGIN]
    d.call <- d[-MARGIN]
    d.ans  <- d[MARGIN]
    dn.call<- dn[-MARGIN]
    dn.ans <- dn[MARGIN]
    ## dimnames(X) <- NULL

    ## do the calls

    newX <- aperm(X, c(s.call, s.ans))
    dim(newX) <- c(prod(d.call), d2 <- prod(d.ans))

    ans <- vector("list", d2)
    if((i.vec <- length(d.call) < 2)) # vector
	for(i in 1:d2){
	    xi <- newX[,i]
	    if (length(dn.call))
		names(xi) <- dn.call[[1]]
	    ans[[i]] <- FUN(xi, ...)
	}
    else
	for(i in 1:d2) ans[[i]] <- FUN(array(newX[,i], d.call, dn.call), ...)

    ## answer dims and dimnames

    ans.list <- is.recursive(ans[[1]])
    l.ans <- length(ans[[1]])

    ans.names <- names(ans[[1]])
    if(i.vec && is.null(ans.names) && length(dn.call) &&
       l.ans == length(an <- dn.call[[1]]))
	ans.names <- an
    if(!ans.list)
	ans.list <- any(unlist(lapply(ans, length)) != l.ans)
    len.a <- if(ans.list) d2 else length(ans <- unlist(ans, recursive = FALSE))
    if(length(MARGIN) == 1 && len.a == d2) {
	names(ans) <- if(length(dn.ans[[1]])) dn.ans[[1]] # else NULL
	return(ans)
    }
    if(len.a == d2)
	return(array(ans, d.ans, dn.ans))
    if(len.a > 0 && len.a %% d2 == 0)
	return(array(ans, c(len.a %/% d2, d.ans),
                     if(is.null(dn.ans)) {
                         if(!is.null(ans.names)) list(ans.names,NULL)
                     } else c(list(ans.names), dn.ans)))
    return(ans)
}
approx <- function (x, y=NULL, xout, method = "linear", n = 50,
		    yleft, yright, rule = 1, f = 0)
{
    x <- xy.coords(x, y)
    y <- x$y
    x <- x$x
    if (!is.numeric(x) || !is.numeric(y))
	stop("approx: x and y must be numeric")
    nx <- length(x)
    if (nx != length(y))
	stop("x and y must have equal lengths")
    if (nx < 2)
	stop("approx requires at least two values to interpolate")
    method <- pmatch(method, c("linear", "constant"))
    if (is.na(method))
	stop("approx: invalid interpolation method")
    ok <- !(is.na(x) | is.na(y))
    x <- x[ok]
    y <- y[ok]
    nx <-length(x)
    if (nx < 2)
	stop("approx requires at least two non-missing values to interpolate")
    o <- order(x)
    x <- x[o]
    y <- y[o]
    if (missing(yleft))
	yleft <- if(rule == 1) NA else y[1]
    if (missing(yright))
	yright <- if(rule == 1) NA else y[length(y)]
    if (missing(xout)) {
	if (n <= 0) stop("approx requires n >= 1")
	xout <- seq(x[1], x[nx], length = n)
    }
    y <- .C("approx", as.double(x), as.double(y), nx, xout=as.double(xout),
	    length(xout), as.integer(method),
	    as.double(yleft), as.double(yright), as.double(f),
	    NAOK=TRUE, PACKAGE="base")$xout
    list(x = xout, y = y)
}
approxfun <- function (x, y=NULL, method = "linear", yleft, yright, rule=1, f=0)
{
    x <- xy.coords(x, y)
    y <- x$y
    x <- x$x
    if (!is.numeric(x) || !is.numeric(y))
	stop("approx: x and y must be numeric")
    n <- length(x)
    if (n != length(y))
	stop("x and y must have equal lengths")
    if (n < 2)
	stop("approx requires at least two values to interpolate")
    method <- pmatch(method, c("linear", "constant"))
    if (is.na(method))
	stop("Invalid interpolation method")
    ok <- !(is.na(x) | is.na(y))
    x <- x[ok]
    y <- y[ok]
    o <- order(x)
    x <- x[o]
    y <- y[o]
    if (missing(yleft))
	yleft <- if(rule == 1) NA else y[1]
    if (missing(yright))
	yright <- if(rule == 1) NA else y[length(y)]
    rm(o, ok, rule)
    function(v) .C("approx", as.double(x), as.double(y),
		   n, xout = as.double(v), length(v), as.integer(method),
		   as.double(yleft), as.double(yright),
		   as.double(f), NAOK=TRUE, PACKAGE="base")$xout
}
apropos <- function (what, where = FALSE, mode = "any")
{
    if(!is.character(what))
	what <- as.character(substitute(what))
    x <- character(0)
    check.mode <- mode != "any"
    for (i in seq(search())) {
	ll <- length(li <- ls(pos = i, pattern = what, all.names = TRUE))
	if (ll) {
	    if(check.mode)
		ll <- length(li <- li[sapply(li, function(x)
					     exists(x, where = i,
						    mode = mode, inherits=FALSE))])
	    x <- c(x, if (where) structure(li, names = rep(i, ll)) else li)
	}
    }
    x
}

find <- function(what, mode = "any", numeric. = FALSE, simple.words=TRUE) {
    if(!is.character(what))
	what <- as.character(substitute(what))
    if(simple.words)
	what <- gsub("([.[])", "\\\\\\1", paste("^",what,"$", sep=""))
    len.s <- length(sp <- search())
    ind <- logical(len.s)
    if((check.mode <- mode != "any"))
	nam <- character(len.s)
    for (i in 1:len.s) {
	ll <- length(li <- ls(pos = i, pattern = what, all.names = TRUE))
	ind[i] <- ll > 0
	if(ll >= 2) warning(paste(ll, "occurrences in", sp[i]))
	if(check.mode && ind[i]) nam[i] <- li[1]
    }
    ## found name in  search()[ ind ]

    ii <- which(ind)
    if(check.mode && any(ind)) {
	mode.ok <- sapply(ii, function(i) exists(nam[i], where = i,
						 mode = mode, inherits=FALSE))
	ii <- ii[mode.ok]
    }
    if(numeric.) structure(ii, names=sp[ii]) else sp[ii]
}

array <- function(data = NA, dim = length(data), dimnames = NULL)
{
    data <- as.vector(data)
    vl <- prod(dim)
    if( length(data) != vl  ) {
	t1 <- ceiling(vl/length(data))
	data <- rep(data,t1)
	if( length(data) != vl )
	    data <- data[1:vl]
    }
    if(length(dim))
	dim(data) <- dim
    if(is.list(dimnames) && length(dimnames))
	dimnames(data) <- dimnames
    data
}
arrows <- function(x0, y0, x1, y1, length=0.25, angle=30, code=2,
		   col=par("fg"), lty=NULL, lwd=par("lwd"), xpd=FALSE)
{
 .Internal(arrows(x0, y0,
		  x1, y1,
		  length=length,
		  angle=angle,
		  code=code,
		  col=col,
		  lty=lty,
		  lwd=lwd,
		  xpd=xpd))
}
as.logical <- function(x,...) UseMethod("as.logical")
as.logical.default<-function(x) .Internal(as.vector(x,"logical"))

as.integer <- function(x,...) UseMethod("as.integer")
as.integer.default <- function(x) .Internal(as.vector(x,"integer"))

as.double <- function(x,...) UseMethod("as.double")
as.double.default <- function(x) .Internal(as.vector(x,"double"))
as.real <- .Alias(as.double)

as.complex <- function(x,...) UseMethod("as.complex")
as.complex.default <- function(x) .Internal(as.vector(x, "complex"))

as.single <- function(x,...) UseMethod("as.single")
as.single.default <- function(x) {
    structure(.Internal(as.vector(x,"double")), Csingle=TRUE)
}
as.character<- function(x,...) UseMethod("as.character")
as.character.default <- function(x) .Internal(as.vector(x,"character"))

as.expression <- function(x,...) UseMethod("as.expression")
as.expression.default <- function(x) .Internal(as.vector(x,"expression"))

as.list <- function(x,...) UseMethod("as.list")
as.list.default <- function (x)
{
    if (is.function(x))
	return(c(formals(x), body(x)))
    if (is.expression(x)) {
	n <- length(x)
	l <- vector("list", n)
	i <- 0
	for (sub in x) l[[i <- i + 1]] <- sub
	return(l)
    }
    .Internal(as.vector(x, "list"))
}
## FIXME:  Really the above  as.vector(x, "list")  should work for data.frames!
as.list.data.frame <- function(x) {
    x <- unclass(x)
    attr(x,"row.names") <- NULL
    x
}

##as.vector dispatches internally so no need for a generic
as.vector <- function(x, mode="any") .Internal(as.vector(x,mode))
as.matrix <- function(x) UseMethod("as.matrix")
as.matrix.default <- function(x) {
    if (is.matrix(x))
	x
    else
	array(x, c(length(x),1),
	      if(!is.null(names(x))) list(names(x), NULL) else NULL)
}
as.null <- function(x,...) UseMethod("as.null")
as.null.default <- function(x) NULL

as.function <- function(x,...) UseMethod("as.function")
as.function.default <- function (l, envir = sys.frame(sys.parent()))
if (is.function(l)) l else .Internal(as.function.default(l, envir))

as.array <- function(x)
{
    if(is.array(x))
	return(x)
    n <- names(x)
    dim(x) <- length(x)
    if(length(n)) dimnames(x) <- list(n)
    return(x)
}
as.name <- function(x) .Internal(as.vector(x, "name"))
## as.call <- function(x) stop("type call cannot be assigned")
as.numeric <- as.double
as.qr <- function(x) stop("you cannot be serious")
## as.ts <- function(x) if(is.ts(x)) x else ts(x) # in ts.R
as.formula <- function(object)
    if(inherits(object, "formula")) object else formula(object)
assign <-
    function(x, value, pos=-1, envir=pos.to.env(pos), inherits=FALSE,
	     immediate=TRUE)
    {
	if ( is.character(pos) )
	    pos <- match(pos,search())
    	.Internal(assign(x, value, envir, inherits))
    }
attach <- function(what, pos=2, name=deparse(substitute(what)))
    .Internal(attach(what, pos, name))

detach <- function(name, pos=2)
{
    if(!missing(name)) {
	name <- substitute(name)# when a name..
	pos <-
	    if(is.numeric(name)) name
	    else match(if(!is.character(name))deparse(name) else name,
		       search())
	if(is.na(pos))
	    stop("invalid name")
    }
    .Internal(detach(pos))
}

objects <-
    function (name, pos = -1, envir=pos.to.env(pos), all.names = FALSE, pattern)
{
    if (!missing(name)) {
	if(!is.numeric(name) || name != (pos <- as.integer(name))) {
	    name <- substitute(name)
	    if (!is.character(name))
		name <- deparse(name)
	    pos <- match(name, search())
	}
	envir <- pos.to.env(pos)
    }
    all.names <- .Internal(ls(envir, all.names))
    if(!missing(pattern)) {
	if((ll <- length(grep("\\[", pattern))) > 0
	   && ll != (lr <- length(grep("\\]", pattern)))) {
	    ## fix forgotten "\\" for simple cases:
	    if(pattern == "[") {
		pattern <- "\\["
		warning("replaced regular expression pattern `[' by `\\\\['")
	    } else if(length(grep("[^\\\\]\\[<-",pattern)>0)) {
		pattern <- sub("\\[<-","\\\\\\[<-",pattern)
		warning("replaced `[<-' by `\\\\[<-' in regular expression pattern")
	    }
	}
	grep(pattern, all.names, value = TRUE)
    } else all.names
}

ls <- .Alias(objects)
attr <- function(x, which) {
    if (!is.character(which))
	stop("attribute name must be of mode character")
    if (length(which) != 1)
	stop("exactly one attribute name must be given")
    attributes(x)[[which]]
}
autoload <- function (name, file)
{
    if (exists(name,envir=.GlobalEnv,inherits=FALSE))
	stop("Object already exists")
    newcall <- paste("delay(autoloader(\"", name, "\",\"", file, "\"))",
		     sep = "")
    if (is.na(match(file,.Autoloaded)))
	assign(".Autoloaded",c(file,.Autoloaded),env=.AutoloadEnv)
    assign(name, eval(parse(text = newcall)), env = .AutoloadEnv)
}
autoloader <- function (name, file)
{
    name<-paste(name,"",sep="")
    rm(list=name,envir=.AutoloadEnv,inherits=FALSE)
    where <- length(search)
    eval(parse(text = paste("library(\"", file, "\")", sep = "")),
	 .GlobalEnv)
    autoload(name,file)
    where <- length(search) - where + 2
    if (exists(name,where=where,inherits=FALSE))
	eval(as.name(name), pos.to.env(where))
    else
	stop(paste("autoloader didn't find `",name,"' in `",file,"'.",sep=""))
}


ave <- function (x, ..., FUN = mean)
{
    l <- list(...)
    if (is.null(l)) {
	x[] <- FUN(x)
    }
    else {
	g <- 1
	nlv <- 1
	for (i in 1:length(l)) {
	    l[[i]] <- li <- as.factor(l[[i]])
	    g <- g + nlv * (as.numeric(li) - 1)
	    nlv <- nlv * length(levels(li))
	}
	x[] <- unlist(lapply(split(x, g), FUN))[g]
    }
    x
}
axis <- function(side, at=NULL, labels=NULL, ...)
    .Internal(axis(side, at, labels,...))
forwardsolve <- function(l, x, k=ncol(l), upper.tri = FALSE, transpose = FALSE)
    backsolve(l,x, k=k, upper.tri= upper.tri, transpose= transpose)

backsolve <- function(r, x, k=ncol(r), upper.tri = TRUE, transpose = FALSE)
{
    r <- as.matrix(r)# nr  x  k
    storage.mode(r) <- "double"
    x.mat <- is.matrix(x)
    if(!x.mat) x <- as.matrix(x)# k  x	nb
    storage.mode(x) <- "double"
    k <- as.integer(k)
    if(k <= 0 || nrow(x) != k) stop("invalid parameters in backsolve")
    nb <- ncol(x)
    upper.tri <- as.logical(upper.tri)
    transpose <- as.logical(transpose)
    job <- as.integer((upper.tri) + 10*(transpose))
    z <- .C("bakslv",
	    t  = r, ldt= nrow(r), n  = k,
	    b  = x, ldb= k,	  nb = nb,
	    x  = matrix(0, k, nb),
	    job = job,
	    info = integer(1),
	    DUP = FALSE, PACKAGE = "base")[c("x","info")]
    if(z$info != 0)
	stop(paste("singular matrix in backsolve. First zero in diagonal [",
		   z$info,"].",sep=""))
    if(x.mat) z$x else drop(z$x)
}
barplot <- function(height, ...) UseMethod("barplot")

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

    if (missing(space))
	space <- if (is.matrix(height) && beside) c(0, 1) else 0.2
    space <- space * mean(width)

    if (plot && axisnames && missing(names.arg))
	names.arg <-
	    if(is.matrix(height)) colnames(height) else names(height)

    if (is.vector(height)) {
	height <- cbind(height)
	beside <- TRUE
    } else if (is.array(height) && (length(dim(height)) == 1)) {
	height <- rbind(height)
	beside <- TRUE
    } else if (!is.matrix(height))
	stop("`height' must be a vector or a matrix")

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

    if (beside) {
	if (length(space) == 2)
	    space <- rep(c(space[2], rep(space[1], NR - 1)), NC)
	width <- rep(width, length = NR * NC)
    } else {
	width <- rep(width, length = NC)
	height <- rbind(0, apply(height, 2, cumsum))
    }
    delta <- width / 2
    w.r <- cumsum(space + width)
    w.m <- w.r - delta
    w.l <- w.m - delta
    if (horiz) {
	if (missing(xlim)) xlim <- range(-0.01 * height, height)
	if (missing(ylim)) ylim <- c(min(w.l), max(w.r))
    } else {
	if (missing(xlim)) xlim <- c(min(w.l), max(w.r))
	if (missing(ylim)) ylim <- range(-0.01 * height, height)
    }
    if (beside)
	w.m <- matrix(w.m, nc = NC)
    if(plot) { ##-------- Plotting :
	opar <-
	    if (horiz)	par(xaxs = "i", xpd = TRUE)
	    else	par(yaxs = "i", xpd = TRUE)
	on.exit(par(opar))

	plot.new()
	plot.window(xlim, ylim, log = "")
	xyrect <- function(x1,y1, x2,y2, horizontal=TRUE, ...) {
	    if(horizontal)
		rect(x1,y1, x2,y2, ...)
	    else
		rect(y1,x1, y2,x2, ...)
	}
	if (beside)
	    xyrect(0, w.l, c(height), w.r, horizontal=horiz, col = col)
	else {
	    for (i in 1:NC) {
		xyrect(height[1:NR, i], w.l[i], height[-1, i], w.r[i],
		       horizontal=horiz, col = col)
	    }
	}
	if (axisnames && !is.null(names.arg)) { # specified or from {col}names
	    at.l <- if (length(names.arg) != length(w.m)) {
		if (length(names.arg) == NC) # i.e. beside (!)
		    apply(w.m, 2, mean)
		else
		    stop("incorrect number of names")
	    } else w.m
	    axis(if(horiz) 2 else 1, at = at.l, labels = names.arg, lty = 0)
	}
	if (!is.null(legend.text)) {
	    legend.col <- col
	    if((horiz & beside) | (!horiz & !beside)){
		legend.text <- rev(legend.text)
		legend.col <- rev(legend.col)
	    }
	    xy <- par("usr")
	    legend(xy[2] - xinch(0.1), xy[4] - yinch(0.1),
		   legend = legend.text, fill = legend.col,
		   xjust = 1, yjust = 1)
	}
	title(main = main, sub = sub, xlab = xlab, ylab = ylab, ...)
	if (axes) axis(if(horiz) 1 else 2)
	invisible(w.m)
    } else w.m
}
box <- function(which="plot", lty="solid", ...)
{
    which <- pmatch(which[1], c("plot", "figure", "inner", "outer"))
    .Internal(box(which=which, lty=lty, ...))
}
boxplot <- function(x, ...) UseMethod("boxplot")

boxplot.default <-
function(x, ..., range = 1.5, width = NULL, varwidth = FALSE, notch =
         FALSE, names, data = sys.frame(sys.parent()), plot = TRUE,
         border = par("fg"), col = NULL, log = "", pars = NULL)
{
    args <- list(x, ...)
    namedargs <-
	if(!is.null(attributes(args)$names))
	    attributes(args)$names != ""
	else
	    rep(FALSE, length = length(args))
    pars <- c(args[namedargs], pars)
    groups <-
	if(is.language(x)) {
	    if(inherits(x, "formula") && length(x) == 3) {
		groups <- eval(x[[3]], data, sys.frame(sys.parent()))
		x <- eval(x[[2]], data, sys.frame(sys.parent()))
		split(x, groups)
	    }
	}
	else {
	    groups <- args[!namedargs]
	    if(length(groups) == 1 && is.list(x)) x else groups
	}
    if(0 == (n <- length(groups)))
	stop("invalid first argument")
    if(length(class(groups)))
	groups <- unclass(groups)
    if(!missing(names))
	attr(groups, "names") <- names
    else {
	if(is.null(attr(groups, "names")))
	    attr(groups, "names") <- 1:n
        names <- attr(groups, "names") 
    }
    for(i in 1:n)
	groups[i] <- list(boxplot.stats(groups[[i]], range)) # do.conf=notch)
    if(plot) {
	bxp(groups, width, varwidth = varwidth, notch = notch, border =
            border, col = col, log = log, pars = pars, znames = names) 
	invisible(groups)
    }
    else groups
}

boxplot.formula <- function(formula, data = NULL, subset, na.action, ...)
{
    if(missing(formula) || (length(formula) != 3))
        stop("formula missing or incorrect")
    if(missing(na.action))
        na.action <- options()$na.action
    m <- match.call(expand.dots = FALSE)
    if(is.matrix(eval(m$data, sys.frame(sys.parent()))))
        m$data <- as.data.frame(data)
    m$... <- NULL
    m[[1]] <- as.name("model.frame")
    mf <- eval(m, sys.frame(sys.parent()))
    response <- attr(attr(mf, "terms"), "response")
    boxplot(split(mf[[response]], mf[[-response]]), ...)
}

boxplot.stats <- function(x, coef = 1.5, do.conf=TRUE, do.out=TRUE)
{
    nna <- !is.na(x)
    n <- length(nna)                    # including +/- Inf
    stats <- fivenum(x, na.rm = TRUE)
    iqr <- diff(stats[c(2, 4)])
    out <- x < (stats[2] - coef * iqr) | x > (stats[4] + coef * iqr)
    if(coef > 0) stats[c(1, 5)] <- range(x[!out], na.rm = TRUE)
    conf <- if(do.conf)
        stats[3] + c(-1.58, 1.58) * diff(stats[c(2, 4)]) / sqrt(n)
    list(stats = stats, n = n, conf = conf,
         out = if(do.out) x[out & nna] else numeric(0))
}

bxp <- function(z, notch=FALSE, width=NULL, varwidth=FALSE,
		notch.frac = 0.5,
		border=par("fg"), col=NULL, log="", pars=NULL,
		znames=names(z), ...)
{
    bplt <- function(x, wid, stats, out, conf, notch, border, col)
    {
	## Draw single box plot.
	pars <- c(pars, list(...))# from bxp(...).

	if(!any(is.na(stats))) {
	    ## stats = +/- Inf:	 polygon & segments should handle
	    wid <- wid/2
	    if(notch) {
		xx <- x+wid*c(-1,1, 1, notch.frac, 1,
			      1,-1,-1,-notch.frac,-1)
		yy <- c(stats[c(2,2)],conf[1],stats[3],conf[2],
			stats[c(4,4)],conf[2],stats[3],conf[1])
		polygon(xx, yy, col=col, border=border)
		segments(x-wid/2,stats[3], x+wid/2,stats[3], col=border)
	    }
	    else {
		xx <- x+wid*c(-1,1,1,-1)
		yy <- stats[c(2,2,4,4)]
		polygon(xx, yy, col=col, border=border)
		segments(x-wid,stats[3],x+wid,stats[3],col=border)
	    }
	    segments(rep(x,2),stats[c(1,5)], rep(x,2),
		     stats[c(2,4)], lty="dashed",col=border)
	    segments(rep(x-wid/2,2),stats[c(1,5)],rep(x+wid/2,2),
		     stats[c(1,5)],col=border)
	    points(rep(x,length(out)), out, col=border)
	    if(any(inf <- !is.finite(out))) {
		## FIXME: should MARK on plot !! (S-plus doesn't either)
		warning(paste("Outlier (",
			      paste(unique(out[inf]),collapse=", "),
			      ") in ", paste(x,c("st","nd","rd","th")
					     [pmin(4,x)], sep=""),
			      " boxplot are NOT drawn", sep=""))
	    }
	}
    }## bplt

    if(!is.list(z) || 0 == (n <- length(z)))
	stop("invalid first argument")
    limits <- numeric(0)
    nmax <- 0
    for(i in 1:n) {
	nmax <- max(nmax,z[[i]]$n)
	limits <- range(limits,
                        z[[i]]$stats[is.finite(z[[i]]$stats)],
                        z[[i]]$out[is.finite(z[[i]]$out)])
    }
    width <- if(!is.null(width)) {
	if(length(width) != n | any(is.na(width)) | any(width <= 0))
	    stop("invalid boxplot widths")
	0.8 * width/max(width)
    }
    else if(varwidth) 0.8 * sqrt(unlist(lapply(z, "[[", "n"))/nmax)
    else if(n == 1) 0.4
    else rep(0.8, n)

    if(is.null(pars$ylim)) ylim <- limits
    else { ylim <- pars$ylim; pars$ylim <- NULL }
    if(missing(border) || length(border)==0)
	border <- par("fg")

    plot.new()
    plot.window(xlim=c(0.5,n+0.5), ylim=ylim, log=log)

    for(i in 1:n)
	bplt(i, wid=width[i],
	     stats= z[[i]]$stats,
	     out  = z[[i]]$out,
	     conf = z[[i]]$conf,
	     notch= notch,
	     border=border[(i-1)%%length(border)+1],
	     col=if(is.null(col)) col else col[(i-1)%%length(col)+1])

    axes <- is.null(pars$axes)
    if(!axes) { axes <- pars$axes; pars$axes <- NULL }
    if(axes) {
	if(n > 1) axis(1, at=1:n, labels=znames)
	axis(2)
    }
    do.call("title", pars)
    box()
    invisible(1:n)
}
bug.report <- function(subject="", ccaddress=getenv("USER"),
                       method=.Options$mailer,
                       address="r-bugs@biostat.ku.dk",
                       file="R.bug.report")
{
    methods <- c("mailx", "gnudoit", "none", "ess")

    method <-
	if(is.null(method)) "none"
	else methods[pmatch(method, methods)]

    body <- paste("\\n<<insert bug report here>>\\n\\n\\n\\n",
		  "--please do not edit the information below--\\n\\n",
		  "Version:\\n ",
		  paste(names(R.version),R.version, sep=" = ",collapse="\\n "),
		  "\\n\\n",
		  "Search Path:\\n ",
		  paste(search(), collapse=", "),
		  "\\n", sep="", collapse="")

    if(method == "gnudoit") {
	cmd <- paste("gnudoit -q '",
		     "(mail nil \"", address, "\")",
		     "(insert \"", body, "\")",
		     "(search-backward \"Subject:\")",
		     "(end-of-line)'",
		     sep="")
	system(cmd)
    }
    else if(method=="none"){

        disclaimer <- 
            paste("# Your mailer is set to \"none\" (default on Windows),\n",
                  "# hence we cannot send the bug report directly from R.\n",
                  "# Please copy the bug report (after finishing it) to\n",
                  "# your favorite email program and send it to\n#\n",
                  "#       ", address, "\n#\n",
                  "######################################################\n",
                  "\n\n", sep = "")
                  

        cat(disclaimer, file=file)        
	body <- gsub("\\\\n", "\n", body)
	cat(body, file=file, append=TRUE)
	system(paste(.Options$editor, file))
        cat("The unsent bug report can be found in file", file, "\n")
    }
    else if(method == "mailx"){

        if(missing(subject))
            stop("Subject missing")

	body <- gsub("\\\\n", "\n", body)
	cat(body, file=file, append=FALSE)
	system(paste(.Options$editor, file))

        if(is.character(ccaddress) && nchar(ccaddress)>0) {
            cmdargs <- paste("-s '", subject, "' -c", ccaddress,
                             address, "<", file, "2>/dev/null")
        }
        else
            cmdargs <- paste("-s '", subject, "'", address, "<",
                             file, "2>/dev/null")
        
        status <- 1
            
        cat("Submit the bug report? ")
        answer <- readline()
        answer <- grep("y", answer, ignore.case=TRUE)
        if(length(answer)>0){
            cat("Sending email ...\n")
            status <- system(paste("mailx", cmdargs))
            if(status > 0)
                status <- system(paste("Mail", cmdargs))
            if(status > 0)
                status <- system(paste("/usr/ucb/mail", cmdargs))
            
            if(status==0) unlink(file)
            else{
                cat("Sending email failed!\n")
                cat("The unsent bug report can be found in file",
                    file, "\n")
            }
            
        }
        else
            cat("The unsent bug report can be found in file",
                file, "\n")

    }
    else if(method=="ess"){
	body <- gsub("\\\\n", "\n", body)
	cat(body)
    }
}
builtins <- function(internal=FALSE)
    .Internal(builtins(internal))
cat <- function(...,file="",sep=" ", fill=FALSE, labels=NULL,append=FALSE)
    .Internal(cat(list(...),file,sep,fill,labels,append))
strsplit <- function(x,split)
  .Internal(strsplit(as.character(x),as.character(split)))

substr <- function(x,start,stop)
  .Internal(substr(x,as.integer(start),as.integer(stop)))
substring <- function(text,first,last=1000000)
{
    storage.mode(text) <- "character"
    n <- max(lt <- length(text), length(first), length(last))
    if(lt < n) text <- rep(text, length = n)
    substr(text, first, last)
}

abbreviate <-
    function(names.arg, minlength = 4, use.classes = TRUE, dot = FALSE)
{
    ## we just ignore use.classes
    if(minlength<=0)
	return(rep("",length(names.arg)))
    names.arg <- as.character(names.arg)
    dups <- duplicated(names.arg)
    old <- names.arg
    if(any(dups))
	names.arg <- names.arg[!dups]
    dup2 <- rep(TRUE, length(names.arg))
    x <- these <- names.arg
    repeat {
	ans <- .Internal(abbreviate(these,minlength,use.classes))
	x[dup2] <- ans
	dup2 <- duplicated(x)
	if(!any(dup2))
	    break
	minlength <- minlength+1
	dup2 <- dup2 | match(x, x[duplicated(x)], 0)
	these <- names.arg[dup2]
    }
    if(any(dups))
	x <- x[match(old,names.arg)]
    if(dot)
	x <- paste(x,".",sep="")
    names(x) <- old
    x
}

make.names <- function(names, unique=FALSE)
{
    names <- .Internal(make.names(as.character(names)))
    if(unique) {
	while(any(dups <- duplicated(names))) {
	    names[dups] <- paste(names[dups],
				 seq(length = sum(dups)), sep = "")
	}
    }
    names
}
chisq.test <-
function(x, y = NULL, correct = TRUE, p = rep(1 / length(x), length(x)),
         simulate.p.value = FALSE, B = 2000)
{
    DNAME <- deparse(substitute(x))
    if (is.data.frame(x))
        x <- as.matrix(x)
    if (is.matrix(x)) {
	if (min(dim(x)) == 1)
	    x <- as.vector(x)
    }
    if (!is.matrix(x) && !is.null(y)) {
	if (length(x) != length(y))
	    stop("x and y must have the same length")
	DNAME <- paste(DNAME, "and", deparse(substitute(y)))
	OK <- complete.cases(x, y)
	x <- as.factor(x[OK])
	y <- as.factor(y[OK])
	if ((nlevels(x) < 2) || (nlevels(y) < 2))
	    stop("x and y must have at least 2 levels")
	x <- table(x, y)
    }

    if (any(x < 0) || any(is.na(x)))
	stop("all entries of x must be nonnegative and finite")
    if ((n <- sum(x)) == 0)
        stop("at least one entry of x must be positive")

    if (is.matrix(x)) {
	METHOD <- "Pearson's Chi-square test"
        nr <- nrow(x)
        nc <- ncol(x)
        sr <- apply(x, 1, sum)
        sc <- apply(x, 2, sum)
	E <- outer(sr, sc, "*") / n
	dimnames(E) <- dimnames(x)
        if (simulate.p.value && all(sr > 0) && all(sc > 0)) {
            METHOD <- paste(METHOD,
                            "with simulated p-value\n\t (based on", B,
                            "replicates)")
            tmp <- .C("chisqsim",
                      as.integer(nr),
                      as.integer(nc),
                      as.integer(sr),
                      as.integer(sc),
                      as.integer(n),
                      as.integer(B),
                      as.double(E),
                      integer(nr * nc),
                      double(n + 1),
                      integer(nc),
                      results = double(B),
                      PACKAGE = "base")
            STATISTIC <- sum((x - E) ^ 2 / E)
            PARAMETER <- NA
            PVAL <- sum(tmp$results >= STATISTIC) / B
        }
        else {
            if (simulate.p.value)
                warning(paste("Cannot compute simulated p-value",
                              "with zero marginals"))
            if (correct && nrow(x) == 2 && ncol(x) == 2) {
                YATES <- .5
                METHOD <- paste(METHOD, "with Yates' continuity correction")
            }
            else
                YATES <- 0
            STATISTIC <- sum((abs(x - E) - YATES)^2 / E)
            PARAMETER <- (nr - 1) * (nc - 1)
            PVAL <- 1 - pchisq(STATISTIC, PARAMETER)
        }
    }
    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 <- n * p
	names(E) <- names(x)
	STATISTIC <- sum((x - E) ^ 2 / E)
	PARAMETER <- length(x) - 1
        PVAL <- 1 - pchisq(STATISTIC, PARAMETER)
    }

    names(STATISTIC) <- "X-squared"
    names(PARAMETER) <- "df"
    if (any(E < 5) && is.finite(PARAMETER))
	warning("Chi-square approximation may be incorrect")

    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, PACKAGE="base")
    if(z$info)
	stop("singular matrix in chol")
    z$v
}

chol2inv <- function(x, size=ncol(x))
{
    if(!is.numeric(x))
	stop("non-numeric argument to chol2inv")
    if(is.matrix(x)) {
	nr <- nrow(x)
	nc <- ncol(x)
    }
    else {
	nr <- length(x)
	nc <- as.integer(1)
    }
    size <- as.integer(size)
    if(size <= 0 || size > nr || size > nc)
	stop("invalid size argument in chol2inv")
    if(!is.double(x)) storage.mode(x) <- "double"
    z <- .Fortran("ch2inv",
		  x=x,
		  nr,
		  size,
		  v=matrix(0, nr=size, nc=size),
		  info=integer(1),
		  DUP=FALSE, PACKAGE="base")
    if(z$info)
	stop("singular matrix in chol2inv")
    z$v
}
chull <- function(x, y=NULL)
{
    X <- xy.coords(x, y, recycle = TRUE)
    x <- cbind(X$x, X$y)
    n <- nrow(x)
    if(n == 0) return(integer(0))
    z <- .C("chull",
	    n=as.integer(n),
	    as.double(x),
	    as.integer(n),
	    as.integer(1:n),
	    integer(n),
	    integer(n),
	    ih=integer(n),
	    nh=integer(1),
	    il=integer(n),
	    PACKAGE="base")
    rev(z$ih[1:z$nh])
}
rgb <- function(red, green, blue, names=NULL)
    .Internal(rgb(red, green, blue, names))

hsv <- function(h=1,s=1,v=1,gamma=1)
    .Internal(hsv(h,s,v,gamma))

palette <- function(value)
{
    if(missing(value)) .Internal(palette(character()))
    else invisible(.Internal(palette(value)))
}

## A quick little ``rainbow'' function -- improved by MM
## doc in	../man/palettes.Rd
rainbow <-
    function (n, s = 1, v = 1, start = 0, end = max(1,n - 1)/n, gamma = 1)
{
    if ((n <- as.integer(n[1])) > 0) {
	if(start == end || any(c(start,end) < 0)|| any(c(start,end) > 1))
	    stop("`start' and `end' must be distinct and in [0,1].")
	hsv(h = seq(start, ifelse(start > end, 1, 0) + end, length= n) %% 1,
	    s, v, gamma)
    } else character(0)
}

topo.colors <- function (n)
{
    if ((n <- as.integer(n[1])) > 0) {
	j <- n %/% 3
	k <- n %/% 3
	i <- n - j - k
	c(if(i > 0) hsv(h= seq(from = 43/60, to = 31/60, length = i)),
	  if(j > 0) hsv(h= seq(from = 23/60, to = 11/60, length = j)),
	  if(k > 0) hsv(h= seq(from = 10/60, to =  6/60, length = k),
			s= seq(from = 1,     to = 0.3,	 length = k), v = 1))
    } else character(0)
}

terrain.colors <- function (n)
{
    if ((n <- as.integer(n[1])) > 0) {
	k <- n%/%2
	h <- c(4/12, 2/12, 0/12)
	s <- c(1, 1, 0)
	v <- c(0.65, 0.9, 0.95)
	c(hsv(h = seq(h[1], h[2], length = k),
	      s = seq(s[1], s[2], length = k),
	      v = seq(v[1], v[2], length = k)),
	  hsv(h = seq(h[2], h[3], length = n - k + 1)[-1],
	      s = seq(s[2], s[3], length = n - k + 1)[-1],
	      v = seq(v[2], v[3], length = n - k + 1)[-1]))
    } else character(0)
}

heat.colors <- function (n)
{
    if ((n <- as.integer(n[1])) > 0) {
	j <- n %/% 4
	i <- n - j
	c(rainbow(i, start = 0, end = 1/6),
	  if (j > 0)
	  hsv(h = 1/6, s = seq(from= 1-1/(2*j), to= 1/(2*j), length = j),
	      v = 1))
    } else character(0)
}

cm.colors <- function (n)
{
    if ((n <- as.integer(n[1])) > 0) {
	even.n <- n %% 2 == 0
	k <- n%/%2
	l1 <- k + 1 - even.n
	l2 <- n - k + even.n
	c(if(l1 > 0)
	  hsv(h =  6/12, s= seq(.5, ifelse(even.n,.5/k,0), length = l1), v = 1),
	  if(l2 > 1)
	  hsv(h = 10/12, s= seq(0, 0.5, length = l2)[-1], v = 1))
    } else character(0)
}
complete.cases <- function(...) .Internal(complete.cases(...))
conflicts <- function(where=search(), detail = FALSE)
{
    if(length(where) < 1) stop("argument where of length 0")
    z <- vector(length(where), mode="list")
    names(z) <- where
    for(i in seq(along=where))
	z[[i]] <- objects(pos=i)
    all <- unlist(z, use.names=FALSE)
    dups <- duplicated(all)
    dups <- all[dups]
    if(detail) {
	for(i in where)
	    z[[i]] <- z[[i]][match(dups, z[[i]], 0)]
	z[sapply(z, function(x) length(x)==0)] <- NULL
	z
    } else dups
}
pi <- 4*atan(1)

letters <- c("a","b","c","d","e","f","g","h","i","j","k","l", "m",
	     "n","o","p","q","r","s","t","u","v","w","x","y","z")

LETTERS <- c("A","B","C","D","E","F","G","H","I","J","K","L", "M",
	     "N","O","P","Q","R","S","T","U","V","W","X","Y","Z")

month.name <-
    c("January", "February", "March", "April", "May", "June",
      "July", "August", "September", "October", "November", "December")

month.abb <- c("Jan", "Feb", "Mar", "Apr", "May", "Jun",
	       "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
contour <-
function (x = seq(0, 1, len = nrow(z)), y = seq(0, 1, len = ncol(z)),
	  z,
	  nlevels = 10, levels = pretty(zlim, nlevels),
	  xlim = range(x, finite = TRUE),
	      ylim = range(y, finite = TRUE),
	  zlim = range(z, finite = TRUE),
	  labcex = 0,
	  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 (!is.matrix(z) || nrow(z) <= 1 || ncol(z) <= 1)
	stop("no proper `z' matrix specified")
    if (!add) {
	plot.new()
	plot.window(xlim, ylim, "")
	title(...)
    }
    ##- don't lose  dim(.)
    if (!is.double(z)) storage.mode(z) <- "double"
    .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.

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

contr.poly <- function (n, contrasts = TRUE)
{
    make.poly <- function(n)
    {
	y <- seq(length=n) - n %/% 2 - 1
	X <- outer(y, seq(length=n) - 1, "^")
	QR <- qr(X)
	z <- QR$qr
	z <- z *(row(z) == col(z))
	raw <- qr.qy(QR, z)
	Z <- sweep(raw, 2, apply(raw, 2, function(x) sqrt(sum(x^2))), "/")
	colnames(Z) <- paste("^", 1:n - 1, sep="")
	Z
    }
    if (is.numeric(n) && length(n) == 1) levs <- 1:n
    else {
	levs <- n
	n <- length(levs)
    }
    if (n < 2)
	stop(paste("Contrasts not defined for", n - 1, "degrees of freedom"))
    contr <- make.poly(n)
    if (contrasts) {
	dn <- dimnames(contr)[[2]]
	dn[2:min(4,n)] <- c(".L", ".Q", ".C")[1:min(3, n-1)]
	colnames(contr) <- dn
	contr[, -1, drop = FALSE]
    }
    else {
	contr[, 1] <- 1
	contr
    }
}

## implemented by BDR 29 May 1998
## `coefs' code added by KH
poly <- function(x, degree=1)
{
    if(is.matrix(x)) stop("poly is only implemented for vectors")
    n <- degree + 1
    xbar <- mean(x)
    x <- x - xbar
    X <- outer(x, seq(length = n) - 1, "^")
    QR <- qr(X)
    z <- QR$qr
    z <- z * (row(z) == col(z))
    raw <- qr.qy(QR, z)
    norm2 <- diag(crossprod(raw))
    alpha <- (diag(crossprod(raw, x * raw))/norm2 + xbar)[1:degree]
    Z <- raw/rep(sqrt(norm2), rep(length(x), n))
    colnames(Z) <- 1:n - 1
    Z <- Z[, -1]
    attr(Z, "degree") <- 1:degree
    attr(Z, "coefs") <- list(alpha = alpha, norm2 = c(1, norm2))
    Z
}
contrasts <-
    function (x, contrasts = TRUE)
{
    if (!is.factor(x))
	stop("contrasts apply only to factors")
    ctr <- attr(x, "contrasts")
    if (is.null(ctr)) {
	ctr <- get(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, base = 1, contrasts = TRUE)
{
    if(is.numeric(n) && length(n) == 1)
	levs <- 1:n
    else {
	levs <- n
	n <- length(n)
    }
    contr <- array(0, c(n, n), list(levs, levs))
    diag(contr) <- 1
    if(contrasts) {
	if(n < 2)
	    stop(paste("Contrasts not defined for", n - 1,
		       "degrees of freedom"))
	if (base < 1 | base > n)
	    stop("Baseline group number out of range")
	contr <- contr[, -base, drop = FALSE]
    }
    contr
}

contr.sum <-
    function (n, contrasts=TRUE)
{
    if (length(n) <= 1) {
	if (is.numeric(n) && length(n) == 1 && n > 1)
	    levels <- 1:n
	else stop("Not enough degrees of freedom to define contrasts")
    } else levels <- n
    lenglev <- length(levels)
    if (contrasts) {
	cont <- array(0, c(lenglev, lenglev - 1), list(levels, NULL))
	cont[col(cont) == row(cont)] <- 1
	cont[lenglev, ] <- -1
    } else {
	cont <- array(0, c(lenglev, lenglev), list(levels, levels))
	cont[col(cont) == row(cont)] <- 1
    }
    cont
}
co.intervals <- function (x, number = 6, overlap = 0.5)
{
    x <- sort(x[!is.na(x)])
    n <- length(x)
    ## "from the record"
    r <- n/(number * (1 - overlap) + overlap)
    ii <- round(0:(number - 1) * (1 - overlap) * r)
    x1 <- x[1 + ii]
    xr <- x[r + ii]
    ## Omit any range of values identical with the previous range;
    ## happens e.g. when `number' is less than the number of distinct x values.
    keep <- c(TRUE, diff(x1) > 0 | diff(xr) > 0)
    ## Set eps > 0 to ensure that the endpoints of a range are never
    ## identical, allowing display of a given.values bar
    j.gt.0 <- 0 < (jump <- diff(x))
    eps <- 0.5 * if(any(j.gt.0)) min(jump[j.gt.0]) else 0
    cbind(x1[keep] - eps, xr[keep] + eps)
}

panel.smooth <- function(x, y, col = par("col"), pch = par("pch"),
			 col.smooth = "red", span = 2/3, iter = 3, ...)
{
    points(x, y, pch=pch, col=col)
    ok <- is.finite(x) & is.finite(y)
    if (any(ok)) {
        lines(lowess(x[ok], y[ok], f=span, iter=iter), col = col.smooth, ...)
    }
}

coplot <-
    function(formula, data, given.values, panel=points, rows, columns,
             show.given = TRUE, col = par("fg"), pch=par("pch"),
             xlab = paste("Given :", a.name),
             ylab = paste("Given :", b.name),
             number = 6, overlap = 0.5, ...)
{
    deparen <- function(expr) {
	while (is.language(expr) && !is.name(expr) && deparse(expr[[1]])== "(")
	    expr <- expr[[2]]
	expr
    }
    bad.formula <- function() stop("invalid conditioning formula")
    bad.lengths <- function() stop("incompatible variable lengths")

    ## parse and check the formula

    formula <- deparen(formula)
    if (!inherits(formula, "formula"))
	bad.formula()
    y <- deparen(formula[[2]])
    rhs <- deparen(formula[[3]])
    if (deparse(rhs[[1]]) != "|")
	bad.formula()
    x <- deparen(rhs[[2]])
    rhs <- deparen(rhs[[3]])
    if (is.language(rhs) && !is.name(rhs)
	&& (deparse(rhs[[1]]) == "*" || deparse(rhs[[1]]) == "+")) {
	have.b <- TRUE
	a <- deparen(rhs[[2]])
	b <- deparen(rhs[[3]])
    } else {
	have.b <- FALSE
	a <- rhs
    }

    ## evaluate the formulae components to get the data values

    if (missing(data))
	data <- sys.frame(sys.parent())
    x.name <- deparse(x)
    x <- eval(x, data, sys.frame(sys.parent()))
    nobs <- length(x)
    y.name <- deparse(y)
    y <- eval(y, data, sys.frame(sys.parent()))
    if(length(y) != nobs) bad.lengths()
    a.name <- deparse(a)
    a <- eval(a, data, sys.frame(sys.parent()))
    if(length(a) != nobs) bad.lengths()
    if(is.character(a)) a <- as.factor(a)
    a.levels <- NULL
    if (have.b) {
        b.levels <- NULL
	b.name <- deparse(b)
	b <- eval(b, data, sys.frame(sys.parent()))
	if(length(b) != nobs) bad.lengths()
        if(is.character(b)) b <- as.factor(b)
        missingrows <- which(is.na(x) | is.na(y) | is.na(a) | is.na(b))
    }
    else {
        missingrows <- which(is.na(x) | is.na(y) | is.na(a))
        b <- NULL
    }

    ## generate the given value intervals

    number <- as.integer(number)
    if(length(number)==0 || any(number < 1)) stop("number must be integer >= 1")
    if(any(overlap >= 1)) stop("overlap must be < 1 (and typically >= 0).")

    bad.givens <- function() stop("invalid given.values")
    if(missing(given.values)) {
	a.intervals <-
            if(is.factor(a)) {
                i <- 1:nlevels(a)
                a.levels <- levels(a)
                a <- as.numeric(a)
                cbind(i - 0.5, i + 0.5)
            } else co.intervals(a,number=number[1],overlap=overlap[1])
	b.intervals <-
            if (have.b) {
                if(is.factor(b)) {
                    i <- 1:nlevels(b)
                    b.levels <- levels(b)
                    b <- as.numeric(b)
                    cbind(i - 0.5, i + 0.5)
                }
                else {
                    if(length(number)==1) number  <- rep(number,2)
                    if(length(overlap)==1)overlap <- rep(overlap,2)
                    co.intervals(b,number=number[2],overlap=overlap[2])
                }
            }
    } else {
	if(!is.list(given.values))
	    given.values <- list(given.values)
	if(length(given.values) != (if(have.b) 2 else 1))
	    bad.givens()
	a.intervals <- given.values[[1]]
	if(is.factor(a)) {
            if (is.character(a.intervals)) 
                a.intervals <- match(a.intervals, levels(a))
            a.intervals <- cbind(a.intervals - 0.5, a.intervals + 0.5)
            a.levels <- levels(a)
	    a <- as.numeric(a)
	}
        else if(is.numeric(a)) {
	    if(!is.numeric(a.intervals)) bad.givens()
	    if(!is.matrix(a.intervals) || ncol(a.intervals) != 2)
		a.intervals <- cbind(a.intervals - 0.5, a.intervals + 0.5)
	}
	if(have.b) {
	    b.intervals <- given.values[[2]]
	    if(is.factor(b)) {
                if (is.character(b.intervals)) 
                    b.intervals <- match(b.intervals, levels(b))
                b.intervals <- cbind(b.intervals - 0.5, b.intervals + 0.5)
                b.levels <- levels(b)
		b <- as.numeric(b)
	    }
            else if(is.numeric(b)) {
		if(!is.numeric(b.intervals)) bad.givens()
		if(!is.matrix(b.intervals) || ncol(b.intervals) != 2)
                    b.intervals <- cbind(b.intervals - 0.5, b.intervals + 0.5)
	    }
	}
    }
    if(any(is.na(a.intervals)) || (have.b && any(is.na(b.intervals))))
        bad.givens()

    ## compute the page layout

    if (have.b) {
	rows    <- nrow(b.intervals)
	columns <- nrow(a.intervals)
	nplots <- rows * columns
        if(length(show.given) < 2) show.given <- rep(show.given, 2)
    } else {
	nplots <- nrow(a.intervals)
	if (missing(rows)) {
	    if (missing(columns)) {
		rows <- ceiling(round(sqrt(nplots)))
		columns <- ceiling(nplots/rows)
	    }
	    else rows <- ceiling(nplots/columns)
	}
	else if (missing(columns))
	    columns <- ceiling(nplots/rows)
	if (rows * columns < nplots)
	    stop("rows * columns too small")
    }
    total.columns <- columns
    total.rows <- rows
    f.col <- f.row <- 1
    if(show.given[1]) {
        total.rows <- rows + 1
        f.row <- rows/total.rows
    }
    if(have.b && show.given[2]) {
        total.columns <- columns + 1
        f.col <- columns/total.columns
    }

    ## Start Plotting only now

    opar <- par(mfrow = c(total.rows, total.columns),
		oma = if(have.b) rep(5, 4) else c(5, 6, 5, 4),
		mar = if(have.b) rep(0, 4) else c(0.5, 0, 0.5, 0),
		new = FALSE)
    on.exit(par(opar))
    plot.new()
    xlim <- range(x[is.finite(x)])
    ylim <- range(y[is.finite(y)])
    pch <- rep(pch, length=nobs)
    col <- rep(col, length=nobs)
    do.panel <- function(index) {
        ## Use `global' variables
        ##	id;     rows, columns,  total.rows, total.columns, nplots
        ##		xlim, ylim
	istart <- (total.rows - rows) + 1
	i <- total.rows - ((index - 1)%/%columns)
	j <- (index - 1)%%columns + 1
	par(mfg = c(i, j, total.rows, total.columns))
	plot.new()
	plot.window(xlim, ylim, log = "")
        if(any(is.na(id))) id[is.na(id)] <- FALSE
	if(any(id)) {
	    grid(lty="solid")
	    panel(x[id], y[id], col = col[id], pch=pch[id], ...)
	}
	if((i == total.rows) && (j%%2 == 0))
	    axis(1, xpd=NA)
	else if((i == istart || index + columns > nplots) && (j%%2 == 1))
	    axis(3, xpd=NA)
	if((j == 1) && ((total.rows - i)%%2 == 0))
	    axis(2, xpd=NA)
	else if((j == columns || index == nplots) && ((total.rows - i)%%2 == 1))
	    axis(4, xpd=NA)
	## if(i == total.rows)
	##	axis(1, labels = (j%%2 == 0))
	## if(i == istart || index + columns > nplots)
	##	axis(3, labels = (j%%2 == 1))
	## if(j == 1)
	##	axis(2, labels = ((total.rows - i)%%2 == 0))
	## if(j == columns || index == nplots)
	##	axis(4, labels = ((total.rows - i)%%2 == 1))
	box()
    }## END function do.panel()

    if(have.b) {
	count <- 1
	for(i in 1:rows) {
	    for(j in 1:columns) {
		id <- ((a.intervals[j,1] <= a) & (a <= a.intervals[j,2]) &
		       (b.intervals[i,1] <= b) & (b <= b.intervals[i,2]))
		do.panel(count)
		count <- count + 1
	    }
	}
    } else {
	for (i in 1:nplots) {
	    id <- ((a.intervals[i,1] <= a) & (a <= a.intervals[i,2]))
	    do.panel(i)
	}
    }
    mtext(x.name, side=1, at=0.5*f.col, outer=TRUE, line=3.5, xpd=NA)
    mtext(y.name, side=2, at=0.5*f.row, outer=TRUE, line=3.5, xpd=NA)

    if(show.given[1]) {
	mar <- par("mar")
	nmar <- mar + c(4,0,0,0)
	par(fig = c(0, f.col, f.row, 1), mar = nmar, new=TRUE)
	plot.new()
	nint <- nrow(a.intervals)
	plot.window(range(a.intervals[is.finite(a.intervals)]),
                    0.5 + c(0, nint), log="")
        bg <-
            if (is.null(a.levels))
                gray(0.9)
            else {
                mid <- apply(a.intervals, 1, mean)
                text(mid, 1:nint, a.levels)
                NULL
            }
        rect(a.intervals[, 1], 1:nint - 0.3,
             a.intervals[, 2], 1:nint + 0.3, col = bg)

	axis(3, xpd=NA)
	axis(1, labels=FALSE)
	box()
	mtext(xlab, side=3, at=mean(par("usr")[1:2]), line=3, xpd=NA)
    }
    else { ## i. e. !show.given
        mtext(xlab, side=3, at= 0.5*f.col, line= 3.25, outer= TRUE, xpd=NA)
    }
    if(have.b) {
        if(show.given[2]) {
            nmar <- mar + c(0, 4, 0, 0)
	    par(fig = c(f.col, 1, 0, f.row), mar = nmar, new=TRUE)
	    plot.new()
	    nint <- nrow(b.intervals)
	    plot.window(0.5+c(0, nint),
			range(b.intervals, finite=TRUE), log="")
            bg <-
                if (is.null(b.levels)) 
                    gray(0.9)
                else {
                    mid <- apply(b.intervals, 1, mean)
                    text(1:nint, mid, b.levels, srt = 90)
                    NULL
                }
            rect(1:nint - 0.3, b.intervals[, 1],
                 1:nint + 0.3, b.intervals[, 2], col = bg)
	    axis(4, xpd=NA)
	    axis(2, labels=FALSE)
	    box()
	    mtext(ylab, side=4, at=mean(par("usr")[3:4]), line=3, xpd=NA)
	}
        else {
            mtext(ylab, side=4, at=0.5*f.row, line= 3.25, outer=TRUE, xpd=NA)
        }
    }
    if (length(missingrows) > 0) {
        cat("\nMissing rows:",missingrows,"\n")
        invisible(missingrows)
    }
}
cor <- function (x, y=NULL, use="all.obs")
{
    na.method <- pmatch(use, c("all.obs", "complete.obs", "pairwise.complete.obs"))
    if(is.data.frame(x)) x <- as.matrix(x)
    if(is.data.frame(y)) y <- as.matrix(y)
    .Internal(cor(x, y, na.method))
}
cov <- function (x, y=NULL, use="all.obs")
{
    na.method <- pmatch(use, c("all.obs", "complete.obs",
			       "pairwise.complete.obs"))
    if(is.data.frame(x)) x <- as.matrix(x)
    if(is.data.frame(y)) y <- as.matrix(y)
    .Internal(cov(x, y, na.method))
}
cov.wt <- function(x, wt = rep(1/nrow(x), nrow(x)), cor = FALSE,
		   center = TRUE)
{
    if (is.data.frame(x))
	x <- as.matrix(x)
    else if (!is.matrix(x))
	stop("x must be a matrix or a data frame")
    if (!all(is.finite(x)))
	stop("x must contain finite values only")
    n <- nrow(x)
    if (with.wt <- !missing(wt)) {
	if (length(wt) != n)
	    stop("length of wt must equal the number of rows in x")
	if (any(wt < 0) || (s <- sum(wt)) == 0)
	    stop("weights must be non-negative and not all zero")
	wt <- wt / s
    }
    if (is.logical(center)) {
	center <- if (center)
	    apply(wt * x, 2, sum)
	else 0
    } else {
	if (length(center) != ncol(x))
	    stop("length of center must equal the number of columns in x")
    }
    x <- sqrt(wt) * sweep(x, 2, center)
    cov <- (t(x) %*% x) / (1 - sum(wt^2))
    y <- list(cov = cov, center = center, n.obs = n)
    if (with.wt)
	y <- c(y, wt = wt)
    if (cor) {
	sdinv <- diag(1 / sqrt(diag(cov)))
	y <- c(y, cor = sdinv %*% cov %*% sdinv)
    }
    y
}
curve <- function(expr, from, to, n=101, add=FALSE, type="l",
		  ylab = NULL, log=NULL, ...)
{
    sexpr <- substitute(expr)
    if(is.name(sexpr)) {
	fcall <- paste(sexpr, "(x)")
	expr <- parse(text=fcall)
	if(is.null(ylab)) ylab <- fcall
    } else {
	if(!(is.call(sexpr) && match("x", all.vars(sexpr), nomatch=0)))
	    stop("'expr' must be a function or an expression containing 'x'")
	expr <- sexpr
	if(is.null(ylab)) ylab <- deparse(sexpr)
    }
    lims <- delay(par("usr"))
    if(missing(from)) from <- lims[1]
    if(missing(to)) to <- lims[2]
    lg <- if(length(log)) log else ""
    x <-
	if(lg != "" && "x" %in% strsplit(lg, NULL)[[1]]) {
	    ## unneeded now: rm(list="log",envir=sys.frame(1))# else: warning
	    if(any(c(from,to)<=0))
		stop("`from' & `to' must be > 0	 with  log=\"x\"")
	    exp(seq(log(from), log(to), length=n))
	} else seq(from,to,length=n)
    y <- eval(expr, envir=list(x = x), enclos=sys.frame(sys.parent(1)))
    if(add)
	lines(x, y, type=type, ...)
    else
	plot(x, y, type=type, ylab = ylab, log=lg, ...)
}
cut <- function(x, ...) UseMethod("cut")

cut.default <- function (x, breaks, labels=NULL, include.lowest = FALSE,
			 right=TRUE, dig.lab=3)
{
    if (!is.numeric(x)) stop("cut: x must be numeric")
    if (length(breaks) == 1) {
	if (is.na(breaks) | breaks < 2)
	    stop("invalid number of intervals")
	nb <- as.integer(breaks + 1)# one more than #{intervals}
	dx <- diff(rx <- range(x,na.rm=TRUE))
	if(dx==0) dx <- rx[1]
	breaks <- seq(rx[1] - dx/1000,
		      rx[2] + dx/1000, len=nb)
    } else nb <- length(breaks <- sort(breaks))
    if (any(duplicated(breaks))) stop("cut: breaks are not unique")
    codes.only <- FALSE
    if (is.null(labels)) {#- try to construct nice ones ..
	for(dig in dig.lab:12) {
	    ch.br <- formatC(breaks, dig=dig, wid=1)
	    if(ok <- all(ch.br[-1]!=ch.br[-nb])) break
	}
	labels <-
	    if(ok) paste(if(right)"(" else "[",
			 ch.br[-nb], ",", ch.br[-1],
			 if(right)"]" else ")", sep='')
	    else paste("Range", 1:(nb - 1),sep="_")
    } else if (is.logical(labels) && !labels)
        codes.only <- TRUE
    else if (length(labels) != nb-1)
        stop("labels/breaks length conflict")
    code <- .C("bincode",
	       x =     	as.double(x),
	       n =	length(x),
	       breaks =	as.double(breaks),
               nb,
	       code= 	integer(length(x)),
               right=	as.logical(right),
	       include= as.logical(include.lowest),
	       NAOK= TRUE, DUP = FALSE, PACKAGE = "base") $code
    ## NB this relies on passing NAOK in that position!
    if(codes.only) code
    else factor(code, seq(labels), labels)
}
## Was in `system.unix.R'.  Now system-independent, thanks to Guido's
## .Platform$show.data() idea.
data <-
function (..., list = character(0),
          package = c(.packages(), .Autoloaded),
          lib.loc = .lib.loc, verbose = .Options$verbose)
{
    names <- c(as.character(substitute(list(...))[-1]), list)
    if (!missing(package))
        if (is.name(y <- substitute(package)))
            package <- as.character(y)
    found <- FALSE
    fsep <- .Platform$file.sep
    if (length(names) == 0) {
        if(!missing(package))
            show.data(package, lib.loc)
        else
            show.data(lib.loc = lib.loc)
    } else for (name in names) {
        ## don't make this a single call: list.files() sorts all the
        ## entries. 
        paths <- system.file("data", pkg = package, lib = lib.loc)
        files <- unlist(lapply(paths, FUN = list.files, full = TRUE))
        files <- files[grep(name, files)]
        found <- FALSE
        if (length(files) > 0) {
            subpre <- paste(".*", fsep, sep = "")
            for (file in files) {
                if (verbose)
                    cat("name=", name, ":\t file= ...", fsep,
                        sub(subpre, "", file), "::\t", sep = "")
                if (found)
                    break
                found <- TRUE
                ext <- sub(".*\\.", "", file)
                ## make sure the match is really for `name.ext'
                ## otherwise
                if (sub(subpre, "", file) != paste(name, ".", ext, sep = ""))
                    found <- FALSE
                else switch(ext,
                            R = ,
                            r = source(file, chdir = TRUE),
                            RData = ,
                            rdata = ,
                            rda = load(file, envir = .GlobalEnv),
                            TXT = ,
                            txt = ,
                            tab = assign(name, read.table(file, header = TRUE),
                            env = .GlobalEnv), CSV = ,
                            csv = assign(name,
                            read.table(file, header = TRUE, sep = ";"),
                            env = .GlobalEnv), found <- FALSE)
                if (verbose)
                    cat(if (!found)
                        "*NOT* ", "found\n")
            }
        }
        if (!found)
            warning(paste("Data set `", name, "' not found", sep = ""))
    }
    invisible(names)
}

show.data <-
  function (package = c(.packages(), .Autoloaded), lib.loc = .lib.loc)
{
    ## give `index' of all possible data sets
    file <- tempfile("R.")
    file.create(file)
    first <- TRUE
    nodata <- noindex <- character(0)
    for (lib in lib.loc) for (pkg in package) {
        if(!file.exists(file.path(lib, pkg))) next
        if(!file.exists(file.path(lib, pkg, "data"))) {
            nodata <- c(nodata, pkg)
            next
        }
        INDEX <- system.file("data", "00Index", pkg = pkg, lib = lib)
        if(INDEX == "")
            INDEX <- system.file("data", "index.doc", pkg = pkg, lib = lib)
        if (INDEX != "") {
            cat(paste(ifelse(first, "", "\n"), "Data sets in package `",
                      pkg, "':\n\n", sep = ""), file = file, append = TRUE)
            file.append(file, INDEX)
            first <- FALSE
        } else {
            ## no index: check for datasets
            files <- list.files(system.file("data", pkg = pkg, lib = lib))
            if(length(files) > 0) noindex <- c(noindex, pkg)
        }
    }
    if (first) {
        unlink(file)
        warning("no data listings found")
    } else file.show(file, delete.file = TRUE, title = "R data sets")
    if(!missing(package)) {
        if(length(nodata) > 1)
            warning(paste("packages `", paste(nodata, collapse=", "),
                          "' contain no datasets", sep=""))
        else if(length(nodata) == 1)
            warning(paste("package `", nodata,
                          "' contains no datasets", sep=""))
    }
    if(length(noindex) > 1)
        warning(paste("packages `", paste(noindex, collapse=", "),
                      "' contain datasets but no index", sep=""))
    else if(length(noindex) == 1)
        warning(paste("package `", noindex,
                      "' contains datasets but no index", sep=""))
    invisible(character(0))
}
data.matrix <-
    function(frame)
{
    if(!is.data.frame(frame))
	return(as.matrix(frame))
    log <- unlist(lapply(frame, is.logical))
    num <- unlist(lapply(frame, is.numeric))
    fac <- unlist(lapply(frame, is.factor))

    if(!all(log|fac|num))
	stop("non-numeric data type in frame")

    d <- dim(frame)
    x <- matrix(nr=d[1],nc=d[2],dimnames=dimnames(frame))
    for(i in 1:length(frame)) {
	xi <- frame[[i]]
	if(is.logical(xi)) x[,i] <- as.numeric(xi)
	else if(is.numeric(xi)) x[,i] <- xi
	else x[,i] <- codes(xi)
    }
    x
}
row.names <- function(x) attr(x, "row.names")

"row.names<-" <- function(x, value) {
    if (!is.data.frame(x))
	x <- as.data.frame(x)
    old <- attr(x, "row.names")
    if (!is.null(old) && length(value) != length(old))
	stop("invalid row.names length")
    value <- as.character(value)
    if (any(duplicated(value)))
	stop("duplicate row.names are not allowed")
    attr(x, "row.names") <- value
    x
}

is.na.data.frame <- function (x) {
    y <- do.call("cbind", lapply(x, "is.na"))
    rownames(y) <- row.names(x)
    y
}

is.data.frame <- function(x) inherits(x, "data.frame")

I <- function(x) { structure(x, class = unique(c("AsIs", class(x)))) }

plot.data.frame <- function (x, ...) {
    if(!is.data.frame(x))
	stop("plot.data.frame applied to non data frame")
    x <- data.matrix(x)
    if(ncol(x) == 1) {
	stripplot(x, ...)
    }
    else if(ncol(x) == 2) {
	plot(x, ...)
    }
    else {
	pairs(x, ...)
    }
}

t.data.frame <- function(x) {
    x <- as.matrix(x)
    NextMethod("t")
}

dim.data.frame <- function(x) c(length(attr(x,"row.names")), length(x))

dimnames.data.frame <- function(x) list(attr(x,"row.names"), names(x))

"dimnames<-.data.frame" <- function(x, value) {
    d <- dim(x)
    if(!is.list(value) || length(value) != 2
       || d[[1]] != length(value[[1]])
       || d[[2]] != length(value[[2]]))
	stop("invalid dimnames given for data frame")
    attr(x, "row.names") <- as.character(value[[1]])
    attr(x, "names") <- as.character(value[[2]])
    x
}

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


###  Here are methods ensuring that the arguments to "data.frame"
###  are in a form suitable for combining into a data frame.

as.data.frame.data.frame <- function(x, row.names = NULL, optional = FALSE)
{
    cl <- class(x)
    i <- match("data.frame", cl)
    if(i > 1)
	class(x) <- cl[ - (1:(i-1))]
    if(is.character(row.names)){
	if(length(row.names) == length(attr(x, "row.names")))
	    attr(x, "row.names") <- row.names
	else stop(paste("invalid row.names, length", length(row.names),
			"for a data frame with", length(attr(x, "row.names")),
			"rows"))
    }
    x
}

as.data.frame.list <- function(x, row.names = NULL, optional = FALSE)
{
    x <- eval(as.call(c(expression(data.frame), x)))
    if(!is.null(row.names)) {
	row.names <- as.character(row.names)
	if(length(row.names) != dim(x)[[1]]) stop(paste(
		 "supplied", length(row.names), "row names for",
		 dim(x)[[1]], "rows"))
	attr(x, "row.names") <- row.names
    }
    x
}

as.data.frame.vector <- function(x, row.names = NULL, optional = FALSE)
{
    nrows <- length(x)
    if(is.null(row.names)) {
        if (nrows == 0)
            row.names <- character(0)
        else if(length(row.names <- names(x)) == nrows &&
                !any(duplicated(row.names))) {}
	else if(optional) row.names <- character(nrows)
	else row.names <- as.character(1:nrows)
    }
    value <- list(x)
    if(!optional) names(value) <- deparse(substitute(x))[[1]]
    attr(value, "row.names") <- row.names
    class(value) <- "data.frame"
    value
}

as.data.frame.ts <- function(x, row.names=NULL, optional=FALSE)
{
    if(is.matrix(x))
        as.data.frame.matrix(x, row.names, optional)
    else
        as.data.frame.vector(x, row.names, optional)
}

as.data.frame.factor  <- .Alias(as.data.frame.vector)
as.data.frame.ordered <- .Alias(as.data.frame.vector)
as.data.frame.integer <- .Alias(as.data.frame.vector)
as.data.frame.numeric <- .Alias(as.data.frame.vector)
as.data.frame.complex <- .Alias(as.data.frame.vector)

as.data.frame.character <- function(x, row.names = NULL, optional = FALSE)
    as.data.frame.vector(factor(x), row.names, optional)

as.data.frame.logical <- .Alias(as.data.frame.character)

as.data.frame.matrix <- function(x, row.names = NULL, optional = FALSE)
{
    d <- dim(x)
    nrows <- d[[1]]
    ncols <- d[[2]]
    dn <- dimnames(x)
    row.names <- dn[[1]]
    collabs <- dn[[2]]
    value <- vector("list", ncols)
    for(i in 1:ncols)
	value[[i]] <- as.vector(x[,i])
    if(length(row.names)==nrows) {}
    else if(optional) row.names <- character(nrows)
    else row.names <- as.character(1:nrows)
    if(length(collabs) == ncols) names(value) <- collabs
    else if(!optional) names(value) <- paste("V", 1:ncols, sep="")
    attr(value, "row.names") <- row.names
    class(value) <- "data.frame"
    value
}

as.data.frame.model.matrix <- function(x, row.names = NULL, optional = FALSE)
{
    d <- dim(x)
    nrows <- d[[1]]
    dn <- dimnames(x)
    row.names <- dn[[1]]
    value <- list(x)
    if(!is.null(row.names)) {
	row.names <- as.character(row.names)
	if(length(row.names) != nrows) stop(paste("supplied",
		 length(row.names), "names for a data frame with",
		 nrows, "rows"))
    }
    else if(optional) row.names <- character(nrows)
    else row.names <- as.character(1:nrows)
    if(!optional) names(value) <- deparse(substitute(x))[[1]]
    attr(value, "row.names") <- row.names
    class(value) <- "data.frame"
    value
}

as.data.frame.AsIs <- function(x, row.names = NULL, optional = FALSE)
{
    if(length(dim(x))==2)
        as.data.frame.model.matrix(x, row.names, optional)
    else
        as.data.frame.vector(x, row.names, optional)
}

###  This is the real "data.frame".
###  It does everything by calling the methods presented above.

data.frame <-
function(..., row.names = NULL, check.rows = FALSE, check.names = TRUE) {
    data.row.names <-
	if(check.rows && missing(row.names))
	    function(current, new, i) {
		new <- as.character(new)
		if(any(duplicated(new)))
		    return(current)
		if(is.null(current))
		    return(new)
		if(all(current == new) || all(current == ""))
		    return(new)
		stop(paste("mismatch of row names in elements of",
			   "\"data.frame\", item", i))
	    }
	else function(current, new, i) {
	    if(is.null(current)) {
		if(adup <- any(dup <- duplicated(new <- as.character(new)))) {
		    warning(paste("some row.names duplicated:",
				  paste(which(dup),collapse=","),
				  " --> row.names NOT used."))
		    current
		} else new
	    } else current
	}
    object <- as.list(substitute(list(...)))[-1]
    x <- list(...)
    n <- length(x)
    if(n < 1)
	return(structure(list(), row.names = character(0),
                         class = "data.frame"))
    vnames <- names(x)
    if(length(vnames) != n)
	vnames <- character(n)
    no.vn <- nchar(vnames) == 0
    value <- vnames <- as.list(vnames)
    nrows <- numeric(n)
    for(i in 1:n) {
	xi <- as.data.frame(x[[i]], optional=TRUE)
	rowsi <- attr(xi, "row.names")
	nnew <- length(xi)
	namesi <- names(xi)
	if(nnew>1) {
	    if(length(namesi) == 0) namesi <- 1:nnew
	    if(no.vn[i]) vnames[[i]] <- namesi
	    else vnames[[i]] <- paste(vnames[[i]], namesi, sep=".")
	}
	else if(length(namesi) > 0) vnames[[i]] <- namesi
	else if(no.vn[[i]]) vnames[[i]] <- deparse(object[[i]])[1]
	nrows[[i]] <- length(rowsi)
	if(missing(row.names) && (nrows[[i]] > 0) && (rowsi[[1]] != ""))
	    row.names <- data.row.names(row.names, rowsi, i)
	value[[i]] <- xi
    }
    nr <- max(nrows)
    for(i in (1:n)[nrows < nr]) {
	xi <- value[[i]]
	if(length(xi)==1 && nr%%nrows[[i]]==0 && is.vector(xi[[1]]))
	    value[[i]] <- list(rep(xi[[1]], length=nr))
	else stop(paste("arguments imply differing number of rows:",
			paste(unique(nrows), collapse = ", ")))
    }
    value <- unlist(value, recursive=FALSE, use.names=FALSE)
    vnames <- unlist(vnames)
    noname <- nchar(vnames) == 0
    if(any(noname))
	vnames[noname] <- paste("Var", 1:length(vnames), sep = ".")[noname]
    if(check.names)
	vnames <- make.names(vnames)
    names(value) <- vnames
    if(length(row.names) == 0)
	row.names <- seq(length = nr)
    else if(length(row.names) != nr) {
	if(is.character(row.names))
	    row.names <- match(row.names, vnames, 0)
	if(length(row.names)!=1 ||
	   row.names < 1 || row.names > length(vnames))
	    stop("row.names should specify one of the variables")
	i <- row.names
	row.names <- value[[i]]
	value <- value[ - i]
    }
    row.names <- as.character(row.names)
    if(any(duplicated(row.names)))
	stop(paste("duplicate row.names:",
		   paste(unique(row.names[duplicated(row.names)]),
			 collapse = ", ")))
    attr(value, "row.names") <- row.names
    attr(value, "class") <- "data.frame"
    value
}


###  Subsetting and mutation methods
###  These are a little less general than S

"[.data.frame" <-
    function(x, i, j, drop = if(missing(i)) TRUE else length(cols) == 1)
{
    if(nargs() < 3) {
	if(missing(i))
	    return(x)
	if(is.matrix(i))
	    return(as.matrix(x)[i])
	return(structure(NextMethod("["), class = class(x),
			 row.names = row.names(x)))
    }

    ## preserve the attributes for later use ...

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

    ## handle the column only subsetting ...

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

"[[.data.frame" <- function(x, ...)
{
    ## use in-line functions to refer to the 1st and 2nd ... arguments
    ## explicitly. Also will check for wrong number or empty args
    if(nargs() < 3)
	(function(x, i)
	 if(is.matrix(i))
	 as.matrix(x)[[i]]
	 else unclass(x)[[i]])(x, ...)
    else (function(x, i, j)
	  x[[j]][[i]])(unclass(x), ...)
}

"[<-.data.frame" <- function(x, i, j, value)
{
    if((nA <- nargs()) == 4) {
	has.i <- !missing(i)
	has.j <- !missing(j)
    }
    else if(nA == 3) {
	## really ambiguous, but follow common use as if list
	if(is.matrix(i))
	    stop("matrix subscripts not allowed in replacement")
	j <- i
	i <- NULL
	has.i <- FALSE
	has.j <- TRUE
    }
    else if(nA == 2) {
	value <- i
	i <- j <- NULL
	has.i <- has.j <- FALSE
    }
    else {
	stop("Need 0, 1, or 2 subscripts")
    }
    cl <- class(x)
    ## delete class: Version 3 idiom
    ## to avoid any special methods for [[, etc
    class(x) <- NULL
    rows <- attr(x, "row.names")
    new.cols <- NULL
    nvars <- length(x)
    nrows <- length(rows)
    if(has.i) {
	if(char.i <- is.character(i)) {
	    ii <- match(i, rows)
	    nextra <- sum(new.rows <- is.na(ii))
	    if(nextra > 0) {
		ii[new.rows] <- seq(from = nrows + 1, length = nextra)
		new.rows <- i[new.rows]
	    }
	    i <- ii
	}
	if(all(i >= 0) && (nn <- max(i)) > nrows) {
	    ## expand
	    if(!char.i) {
		nrr <- as.character((nrows + 1):nn)
		if(inherits(value, "data.frame") &&
		   (nrv <- dim(value)[1]) >= length(nrr)) {
		    new.rows <- attr(value, "row.names")[1:length(nrr)]
		    repl <- duplicated(new.rows) | match(new.rows, rows, 0)
		    if(any(repl))
			new.rows[repl] <- nrr[repl]
		}
		else new.rows <- nrr
	    }
	    x <- xpdrows.data.frame(x, rows, new.rows)
	    rows <- attr(x, "row.names")
	    nrows <- length(rows)
	}
	iseq <- seq(along = rows)[i]
	if(any(is.na(iseq)))
	    stop("non-existent rows not allowed")
    }
    else iseq <- NULL
    if(has.j) {
	if(is.character(j)) {
	    jj <- match(j, names(x))
	    nnew <- sum(is.na(jj))
	    if(nnew > 0) {
		n <- is.na(jj)
		jj[n] <- nvars + 1:nnew
		new.cols <- c(names(x), j[n])
	    }
	    jseq <- jj
	}
	else if(is.logical(j) || min(j) < 0)
	    jseq <- seq(along = x)[j]
	else {
	    jseq <- j
	    if(max(jseq) > nvars) {
		new.cols <- c(names(x),
			      paste("V", seq(from = nvars + 1,
					     to = max(jseq)),
				    sep = ""))
		if(length(new.cols) - nvars != sum(jseq > nvars))
		    stop(paste("new columns would leave holes",
			       "after existing columns"))
	    }
	}
    }
    else jseq <- seq(along = x)
    n <- length(iseq)
    if(n == 0)
	n <- nrows
    p <- length(jseq)
    m <- length(value)
    value <- as.data.frame(value)
    dimv <- dim(value)
    nrowv <- dimv[[1]]
    if(nrowv < n) {
	if(n %% nrowv == 0)
	    value <- value[rep(1:nrowv, length=n),,drop = FALSE]
	else stop(paste(nrowv, "rows in value to replace", n, "rows"))
    }
    else if(nrowv > n)
	warning(paste("replacement data has", nrowv, "rows to replace",
		      n, "rows"))
    vseq <- 1:n
    ncolv <- dimv[[2]]
    jvseq <- 1:p
    if(ncolv < p) jvseq <- rep(1:ncolv, length=p)
    else if(ncolv > p)
	warning(paste("provided", ncolv, "variables to replace", p,
		      "variables"))
    if(has.i)
	for(jjj in 1:p) {
	    jj <- jseq[jjj]
	    vjj <- value[[jvseq[[jjj]] ]]
	    xj <- x[[jj]]
	    if(length(dim(xj)) != 2)
		xj[iseq] <- vjj
	    else xj[iseq,  ] <- vjj
	    x[[jj]] <- xj
	}
    else for(jjj in 1:p) {
	jj <- jseq[jjj]
	x[[jj]] <- value[[jvseq[[jjj]] ]]
    }
    if(length(new.cols) > 0)
	names(x) <- new.cols
    class(x) <- cl
    x
}

"[[<-.data.frame"<- function(x, i, j, value)
{
    cl <- class(x)
    ## delete class: Version 3 idiom
    ## to avoid any special methods for [[, etc
    class(x) <- NULL
    rows <- attr(x, "row.names")
    nrows <- length(rows)
    if(nargs() < 4) {
	## really ambiguous, but follow common use as if list
	## el(x,i) <- value is the preferred approach
	if(is.null(value)) {}
	else {
	    if(!inherits(value, "data.frame"))
		value <- as.data.frame(value)
	    if(length(value) != 1)
		stop(paste("trying to replace one column with",
			   length(value)))
	    if(length(row.names(value)) != nrows)
		stop(paste("replacement has", length(value),
			   "rows, data has", nrows))
	    class(value) <- NULL
	    value <- value[[1]]
	}
	x[[i]] <- value
	class(x) <- cl
	return(x)
    }
    if(missing(i) || missing(j))
	stop("only valid calls are x[[j]] <- value or x[[i,j]] <- value")
    nvars <- length(x)
    if(n <- is.character(i)) {
	ii <- match(i, rows)
	n <- sum(new.rows <- is.na(ii))
	if(any(n > 0)) {# drop any(.)?
	    ii[new.rows] <- seq(from = nrows + 1, length = n)
	    new.rows <- i[new.rows]
	}
	i <- ii
    }
    if(all(i >= 0) && (nn <- max(i)) > nrows) {
	## expand
	if(n==0) {
	    nrr <- as.character((nrows + 1):nn)
	    if(inherits(value, "data.frame") &&
	       (nrv <- dim(value)[1]) >= length(nrr)) {
		new.rows <- attr(value, "row.names")[1:length(nrr)]
		repl <- duplicated(new.rows) | match(new.rows, rows, 0)
		if(any(repl))
		    new.rows[repl] <- nrr[repl]
	    }
	    else new.rows <- nrr
	}
	x <- xpdrows.data.frame(x, rows, new.rows)
	rows <- attr(x, "row.names")
	nrows <- length(rows)
    }
    iseq <- seq(along = rows)[i]
    if(any(is.na(iseq)))
	stop("non-existent rows not allowed")
    if(is.character(j)) {
	jseq <- match(j, names(x))
	if(any(is.na(jseq)))
	    stop(paste("replacing element in non-existent column:",
		       j[is.na(jseq)]))
    }
    else if(is.logical(j) || min(j) < 0)
	jseq <- seq(along = x)[j]
    else {
	jseq <- j
	if(max(jseq) > nvars)
	    stop(paste("replacing element in non-existent column:",
		       jseq[jseq>nvars]))
    }
    if(length(iseq) > 1 || length(jseq) > 1)
	stop("only a single element should be replaced")
    x[[jseq]][[iseq]] <- value
    class(x) <- cl
    x
}

xpdrows.data.frame <-
function(x, old.rows, new.rows) {
    nc <- length(x)
    nro <- length(old.rows)
    nrn <- length(new.rows)
    nr <- nro + nrn
    for (i in 1:nc) {
	y <- x[[i]]
	dy <- dim(y)
	cy <- class(y)
	class(y) <- NULL
	if (length(dy) == 2) {
	    dny <- dimnames(y)
	    if (length(dny[[1]]) > 0)
		dny[[1]] <- c(dny[[1]], new.rows)
	    z <- array(y[1], dim = c(nr, nc), dimnames = dny)
	    z[1 : nro, ] <- y
	    class(z) <- cy
	    x[[i]] <- z
	}
	else {
	    ay <- attributes(y)
	    if (length(names(y)) > 0)
		ay$names <- c(ay$names, new.rows)
	    length(y) <- nr
	    attributes(y) <- ay
	    class(y) <- cy
	    x[[i]] <- y
	}
    }
    attr(x, "row.names") <- as.character(c(old.rows, new.rows))
    x
}


### Here are the methods for rbind and cbind.

cbind.data.frame <- function(..., deparse.level = 1)
    data.frame(..., check.names = FALSE)

rbind.data.frame <- function(..., deparse.level = 1)
{
    match.names <- function(clabs, nmi)
    {
	if(all(clabs == nmi))
	    NULL
	else if(all(nii <- match(nmi, clabs, 0)))
	    nii
	else stop(paste("names don't match previous names:\n\t",
			paste(nmi[nii == 0], collapse = ", ")))
    }
    Make.row.names <- function(nmi, ri, ni, nrow)
    {
	if(nchar(nmi) > 0) {
	    if(ni > 1)
		paste(nmi, ri, sep = ".")
	    else nmi
	}
	else if(nrow > 0 && all(ri == 1:ni))
	    seq(from = nrow + 1, length = ni)
	else ri
    }
    allargs <- list(...)
    n <- length(allargs)
    if(n == 0)
	return(structure(list(),
			 class = "data.frame",
			 row.names = character()))
    nms <- names(allargs)
    if(is.null(nms))
	nms <- character(length(allargs))
    cl <- NULL
    perm <- rows <- rlabs <- vector("list", n)
    nrow <- 0
    value <- clabs <- NULL
    all.levs <- list()
    for(i in 1:n) {
	## check the arguments, develop row and column labels
	xi <- allargs[[i]]
	nmi <- nms[i]
	if(inherits(xi, "data.frame")) {
	    if(is.null(cl))
		cl <- class(xi)
	    ri <- row.names(xi)
	    ni <- length(ri)
	    if(is.null(clabs))
		clabs <- names(xi)
	    else {
		pi <- match.names(clabs, names(xi))
		if( !is.null(pi) )
		    perm[[i]] <- pi
	    }
	    rows[[i]] <- nii <- seq(from = nrow + 1, length = ni)
	    rlabs[[i]] <- Make.row.names(nmi, ri, ni, nrow)
	    nrow <- nrow + ni
	    if(is.null(value)) {
		value <- unclass(xi)
		nvar <- length(value)
		all.levs <- vector("list", nvar)
		has.dim <- logical(nvar)
		for(j in 1:nvar) {
		    xj <- value[[j]]
		    if( !is.null(levels(xj)) )
			all.levs[[j]] <- levels(xj)
		    has.dim[j] <- length(dim(xj)) == 2
		}
	    }
	    else for(j in 1:nvar)
		if(length(lij <- levels(xi[[j]])) > 0) {
		    if(is.null(pi) || is.na(jj <- pi[[j]]))
			jj <- j
		    all.levs[[jj]] <- unique(c(all.levs[[jj]],
					       lij))
		}
	}
	else if(is.list(xi)) {
	    ni <- range(sapply(xi, length))
	    if(ni[1] == ni[2])
		ni <- ni[1]
	    else stop("invalid list argument: all variables should have the same length")
	    rows[[i]] <- ri <- seq(from = nrow + 1, length = ni)
	    nrow <- nrow + ni
	    rlabs[[i]] <- Make.row.names(nmi, ri, ni, nrow)
	    if(length(nmi <- names(xi)) > 0) {
		if(is.null(clabs))
		    clabs <- nmi
		else {
		    tmp<-match.names(clabs, nmi)
		    if( !is.null(tmp) )
			perm[[i]] <- tmp
		}
	    }
	}
	else if(length(xi) > 0) {
	    rows[[i]] <- nrow <- nrow + 1
	    rlabs[[i]] <- if(nchar(nmi) > 0) nmi else nrow
	}
    }
    nvar <- length(clabs)
    if(nvar == 0)
	nvar <- max(sapply(allargs, length))	# only vector args
    if(nvar == 0)
	return(structure(list(), class = "data.frame",
			 row.names = character()))
    pseq <- 1:nvar
    if(is.null(value)) {
	value <- list()
	value[pseq] <- list(logical(nrow))
    }
    names(value) <- clabs
    for(j in 1:nvar)
	if(length(lij <- all.levs[[j]]) > 0)
	    value[[j]] <- factor(as.vector(value[[j]]), lij)
    if(any(has.dim)) {
	rmax <- max(unlist(rows))
	for(i in (1:nvar)[has.dim])
	    if(!inherits(xi <- value[[i]], "data.frame")) {
		dn <- dimnames(xi)
		row.names <- dn[[1]]
		if(length(row.names) > 0)
		    length(row.names) <- rmax
		pi <- dim(xi)[2]
		length(xi) <- rmax * pi
		value[[i]] <- array(xi, c(rmax, pi), list(row.names, dn[[2]]))
	    }
    }
    for(i in 1:n) {
	xi <- unclass(allargs[[i]])
	if(!is.list(xi))
	    if(length(xi) != nvar)
		xi <- rep(xi, length = nvar)
	ri <- rows[[i]]
	pi <- perm[[i]]
	if(is.null(pi))
	    pi <- pseq
	for(j in 1:nvar) {
	    jj <- pi[j]
	    if(has.dim[jj])
		value[[jj]][ri,	 ] <- xi[[j]]
	    else value[[jj]][ri] <- xi[[j]]
	}
    }
    for(j in 1:nvar) {
	xj <- value[[j]]
	if(!has.dim[j] && !inherits(xj, "AsIs") &&
		(is.character(xj) || is.logical(xj)))
	    value[[j]] <- factor(xj)
    }
    rlabs <- unlist(rlabs)
    while(any(xj <- duplicated(rlabs)))
	rlabs[xj] <- paste(rlabs[xj], 1:sum(xj), sep = "")
    if(is.null(cl)) {
	as.data.frame(value, row.names = rlabs)
    }
    else {
	class(value) <- cl
	## ensure that row names are ok.  Similar to row.names<-
	rlabs <- as.character(rlabs)
	if(any(duplicated(rlabs)))
	    rlabs <- make.names(rlabs, uniq = TRUE)
	attr(value, "row.names") <- rlabs
	value
    }
}


### coercion and print methods

print.data.frame <-
    function(x, ..., digits = NULL, quote = FALSE, right = TRUE)
{
    if(length(x) == 0) {
	cat("NULL data frame with", length(row.names(x)), "rows\n")
    } else if(length(row.names(x)) == 0) {
	print.default(names(x), quote = FALSE)
	cat("<0 rows> (or 0-length row.names)\n")
    } else {
	if(!is.null(digits)) {
	    ## if 'x' has factors & numeric, as.matrix(x) will apply format(.)
	    ## to the numbers -- set options(.) for the following print(.):
	    op <- options(digits = digits)
	    on.exit(options(op))
	}
	print.matrix(as.matrix(x), ..., quote = quote, right = right)
    }
    invisible(x)
}

as.matrix.data.frame <- function (x)
{
    X <- x
    dm <- dim(X)
    p <- dm[2]
    n <- dm[1]
    dn <- dimnames(X)
    collabs <- as.list(dn[[2]])
    class(X) <- NULL
    non.numeric <- non.atomic <- FALSE
    for (j in 1:p) {
	xj <- X[[j]]
	if(length(dj <- dim(xj)) == 2 && dj[2] > 1) {
	    if(inherits(xj, "data.frame"))
		xj <- X[[j]] <- as.matrix(X[[j]])
	    dnj <- dimnames(xj)[[2]]
	    collabs[[j]] <- paste(collabs[[j]],
				  if(length(dnj) > 0) dnj else 1:dj[2],
				  sep = ".")
	}
	if(length(levels(xj)) > 0 || !(is.numeric(xj) || is.complex(xj)))
	    non.numeric <- TRUE
	if(!is.atomic(xj))
	    non.atomic <- TRUE
    }
    if(non.atomic) {
	for (j in 1:p) {
	    xj <- X[[j]]
	    if(is.recursive(xj)) {
	    }
	    else X[[j]] <- as.list(as.vector(xj))
	}
    } else if(non.numeric) {
	for (j in 1:p) {
	    xj <- X[[j]]
	    if(length(levels(xj)) > 0) {
		X[[j]] <- as.vector(xj)
	    }
	    else X[[j]] <- format(xj)
	}
    }
    X <- unlist(X, recursive = FALSE, use.names = FALSE)
    dim(X) <- c(n, length(X)/n)
    dimnames(X) <- list(dn[[1]], unlist(collabs, use.names = FALSE))
    ##NO! don't copy buggy S-plus!  either all matrices have class or none!!
    ##NO class(X) <- "matrix"
    X
}

if(FALSE)
Math.data.frame <- function(x, ...)
{
    X <- x
    class(X) <- NULL
    f <- get(.Generic, mode = "function")
    call <- match.call(f, sys.call())
    call[[1]] <- as.name(.Generic)
    arg <- names(formals(f))[[1]]
    call[[arg]] <- as.name("xx")
    for(j in names(X)) {
	xx <- X[[j]]
	if(!is.numeric(xx) && mode(xx) != "complex")
	    stop(paste("Non-numeric variable:", j))
	X[[j]] <- eval(call)
    }
    attr(X, "class") <- class(x)
    X
}

Math.data.frame <- function (x, ...)
{
    f <- get(.Generic, mode = "function")
    if (is.null(formals(f)))
	f <- function(x, ...) {
	}
    call <- match.call(f, sys.call())
    call[[1]] <- as.name(.Generic)
    arg <- names(formals(f))[1]
    call[[arg]] <- as.name("xx")
    encl <- sys.frame(sys.parent())
    var.f <- function(x) eval(call, list(xx = x), encl)
    mode.ok <- sapply(x, is.numeric) & !sapply(x, is.factor) |
	sapply(x, is.complex)
    if (all(mode.ok)) {
	r <- lapply(x, var.f)
	class(r) <- class(x)
	row.names(r) <- row.names(x)
	return(r)
    }
    else {
	vnames <- names(x)
	if (is.null(vnames)) vnames <- seq(along=x)
	stop(paste("Non-numeric variable in dataframe:",vnames[!mode.ok]))
    }
}

Ops.data.frame <- function(e1, e2 = NULL)
{
    isList <- function(x) !is.null(x) && is.list(x)
    unary <- nargs() == 1
    lclass <- nchar(.Method[1]) > 0
    rclass <- !unary && (nchar(.Method[2]) > 0)
    value <- list()
    ## set up call as op(left, right)
    FUN <- get(.Generic, envir = sys.frame(sys.parent()),mode="function")
    f <- if (unary)
	quote(FUN(left))
    else quote(FUN(left, right))
    lscalar <- rscalar <- FALSE
    if(lclass && rclass) {
	rn <- row.names(e1)
	cn <- names(e1)
	if(any(dim(e2) != dim(e1)))
	    stop(paste(.Generic, "only defined for equally-sized data frames"))
    } else if(lclass) {
	## e2 is not a data frame, but e1 is.
	rn <- row.names(e1)
	cn <- names(e1)
	rscalar <- length(e2) <= 1 # e2 might be null
	if(isList(e2)) {
	    if(scalar) e2 <- e2[[1]]
	    else if(length(e2) != ncol(e1))
		stop(paste("list of length", length(e2), "not meaningful"))
	} else {
	    if(!rscalar)
		e2 <- split(rep(as.vector(e2), length = prod(dim(e1))),
			    rep(1:ncol(e1), rep(nrow(e1), ncol(e1))))
	}
    } else {
	## e1 is not a data frame, but e2 is.
	rn <- row.names(e2)
	cn <- names(e2)
	lscalar <- length(e1) <= 1
	if(isList(e1)) {
	    if(lscalar) e1 <- e1[[1]]
	    else if(length(e1) != ncol(e2))
		stop(paste("list of length", length(e1), "not meaningful"))
	} else {
	    if(!lscalar)
		e1 <- split(rep(as.vector(e1), length = prod(dim(e2))),
			    rep(1:ncol(e2), rep(nrow(e2), ncol(e2))))
	}
    }
    for(j in seq(along=cn)) {
	left <- if(!lscalar) e1[[j]] else e1
	right <-if(!rscalar) e2[[j]] else e2
	value[[j]] <- eval(f)
    }
    if(any(.Generic == c("+","-","*","/","%%","%/%"))) {
	names(value) <- cn
	data.frame(value, row.names=rn)
    }
    else matrix(unlist(value,recursive = FALSE, use.names=FALSE),
		nrow=length(rn), dimnames=list(rn,cn))
}

Summary.data.frame <- function(x, ...)
{
    x <- as.matrix(x)
    if(!is.numeric(x) && mode(x) != "complex")
	stop("only defined on a data frame with all numeric or complex variables")
    NextMethod(.Generic)
}
de.ncols <- function(inlist)
{
    ncols <- matrix(0, nrow=length(inlist), ncol=2)
    i <- 1
    for( telt in inlist ) {
	if( is.matrix(telt) ) {
	    ncols[i, 1] <- ncol(telt)
	    ncols[i, 2] <- 2
	}
	else if( is.list(telt) ) {
	    for( telt2 in telt )
		if( !is.vector(telt2) ) stop("wrong argument to dataentry")
	    ncols[i, 1] <- length(telt)
	    ncols[i, 2] <- 3
	}
	else if( is.vector(telt) ) {
	    ncols[i, 1] <- 1
	    ncols[i, 2] <- 1
	}
	else stop("wrong argument to dataentry")
	i <- i+1
    }
    return(ncols)
}

de.setup <- function(ilist, list.names, incols)
{
    ilen <- sum(incols)
    ivec <- vector("list", ilen)
    inames <- vector("list", ilen)
    i <- 1
    k <- 0
    for( telt in ilist ) {
	k <- k+1
	if( is.list(telt) ) {
	    y <- names(telt)
	    for( j in 1:length(telt) ) {
		ivec[[i]] <- telt[[j]]
		if( is.null(y) || y[j]=="" )
		    inames[[i]] <- paste("var", i, sep="")
		else inames[[i]] <- y[j]
		i <- i+1
	    }
	}
	else if( is.vector(telt) ) {
	    ivec[[i]] <- telt
	    inames[[i]] <- list.names[[k]]
	    i <- i+1
	}
	else if( is.matrix(telt) ) {
	    y <- dimnames(telt)[[2]]
	    for( j in 1:ncol(telt) ) {
		ivec[[i]] <- telt[, j]
		if( is.null(y) || y[j]=="" )
		    inames[[i]] <- paste("var", i, sep="")
		else inames[[i]] <- y[j]
		i <- i+1
	    }
	}
	else stop("de.setup: wrong argument to dataentry")
    }
    names(ivec) <- inames
    return(ivec)
}

de.restore <- function(inlist, ncols, coltypes, argnames, args)
{
    ## take the data in inlist and restore it
    ## to the format described by ncols and coltypes
    p <- length(ncols)
    rlist <- vector("list", length=p)
    rnames <- vector("character", length=p)
    j <- 1
    lnames <- names(inlist)
    if(p) for(i in 1:p) {
	if(coltypes[i]==2) {
	    tlen <- length(inlist[[j]])
	    x <- matrix(0, nrow=tlen, ncol=ncols[i])
	    cnames <- vector("character", ncol(x))
	    for( ind1 in 1:ncols[i]) {
		if(tlen != length(inlist[[j]]) ) {
		    warning("could not restore type information")
		    return(inlist)
		}
		x[, ind1] <- inlist[[j]]
		cnames[ind1] <- lnames[j]
		j <- j+1
	    }
	    if( dim(x) == dim(args[[i]]) )
		rn <- dimnames(args[[i]])[[1]]
	    else rn <- NULL
	    if( any(cnames!="") )
		dimnames(x) <- list(rn, cnames)
	    rlist[[i]] <- x
	    rnames[i] <- argnames[i]
	}
	else if(coltypes[i]==3) {
	    x <- vector("list", length=ncols[i])
	    cnames <- vector("character", ncols[i])
	    for( ind1 in 1:ncols[i]) {
		x[[ind1]] <- inlist[[j]]
		cnames[ind1] <- lnames[j]
		j <- j+1
	    }
	    if( any(cnames!="") )
		names(x) <- cnames
	    rlist[[i]] <- x
	    rnames[i] <- argnames[i]
	}
	else {
	    rlist[[i]] <- inlist[[j]]
	    j <- j+1
	    rnames[i] <- argnames[i]
	}
    }
    names(rlist) <- rnames
    return(rlist)
}

de <- function(..., Modes=list(), Names=NULL)
{
    sdata <- list(...)
    snames <- as.character(substitute(list(...))[-1])
    if( is.null(sdata) ) {
	if( is.null(Names) ) {
	    odata <- vector("list", length=max(1,length(Modes)))
	}
	else {
	    if( (length(Names) != length(Modes)) && length(Modes) ) {
		warning("modes argument ignored")
		Modes <- list()
	    }
	    odata <- vector("list", length=length(Names))
	    names(odata) <- Names
	}
	ncols <- rep(1, length(odata))
	coltypes <- rep(1, length(odata))
    }
    else {
	ncols <- de.ncols(sdata)
	coltypes <- ncols[, 2]
	ncols <- ncols[, 1]
	odata <- de.setup(sdata, snames, ncols)
	if(length(Names))
	    if( length(Names) != length(odata) )
		warning("names argument ignored")
	    else names(odata) <- Names
	if(length(Modes))
	    if(length(Modes) != length(odata)) {
		warning("modes argument ignored")
		Modes <- list()
	    }
    }
    rdata <- dataentry(odata, as.list(Modes))

    if(any(coltypes != 1)) {
	if(length(rdata) == sum(ncols))
	    rdata <- de.restore(rdata, ncols, coltypes, snames, sdata)
	else warning("could not restore data types properly")
    }
    return(rdata)
}

data.entry <- function(..., Modes=NULL, Names=NULL)
{
    tmp1 <- de(..., Modes=Modes, Names=Names)
    j <- 1
    nn <- names(tmp1)
    for(i in nn) {
	assign(i, tmp1[[j]], env=.GlobalEnv)
	j <- j+1
    }
    if(j==1) warning("not assigned anything!")
    invisible(nn)
}
delay <- function(x, env=.GlobalEnv)
    .Internal(delay(substitute(x), env))
density <-
    function(x, bw, adjust = 1,
             kernel=c("gaussian", "epanechnikov", "rectangular", "triangular",
               "biweight", "cosine", "optcosine"),
             window = kernel, width,
             give.Rkern = FALSE,
             n = 512, from, to, cut = 3, na.rm = FALSE)
{
    if(!missing(window) && missing(kernel))
        kernel <- window
    kernel <- match.arg(kernel)
    if(give.Rkern)
        ##-- sigma(K) * R(K), the scale invariant canonical bandwidth:
        return(switch(kernel,
                      gaussian = 1/(2*sqrt(pi)),
                      rectangular = sqrt(3)/6,
                      triangular  = sqrt(6)/9,
                      epanechnikov= 3/(5*sqrt(5)),
                      biweight    = 5*sqrt(7)/49,
                      cosine      = 3/4*sqrt(1/3 - 2/pi^2),
                      optcosine   = sqrt(1-8/pi^2)*pi^2/16
                      ))

    if (!is.numeric(x))
        stop("argument must be numeric")
    name <- deparse(substitute(x))
    x.na <- is.na(x)
    if (any(x.na)) {
        if (na.rm) x <- x[!x.na]
        else stop("x contains missing values")
    }
    N <- nx <- length(x)
    x.finite <- is.finite(x)
    if(any(!x.finite)) {
        x <- x[x.finite]
        nx <- sum(x.finite)
    }
    n.user <- n
    n <- max(n, 512)
    if (n > 512) n <- 2^ceiling(log2(n)) #- to be fast with FFT

    if (missing(bw))
      bw <-
        if(missing(width)) {
            hi <- sd(x)
            if(!(lo <- min(hi, IQR(x)/1.34)))# qnorm(.75) - qnorm(.25) = 1.34898
                (lo <- hi) || (lo <- abs(x[1])) || (lo <- 1.)
            adjust * 0.9 * lo * N^(-0.2)
        } else 0.25 * width
    if (!is.finite(bw)) stop("non-finite `bw'")
    if (bw <= 0) stop("`bw' is not positive.")

    if (missing(from))
        from <- min(x) - cut * bw
    if (missing(to))
	to   <- max(x) + cut * bw
    if (!is.finite(from)) stop("non-finite `from'")
    if (!is.finite(to)) stop("non-finite `to'")
    lo <- from - 4 * bw
    up <- to + 4 * bw
    y <- .C("massdist",
	    x = as.double(x),
	    nx = nx,
	    xlo = as.double(lo),
	    xhi = as.double(up),
	    y = double(2 * n),
	    ny = as.integer(n),
	    PACKAGE = "base")$y * (nx/N)
    kords <- seq(0, 2*(up-lo), length = 2 * n)
    kords[(n + 2):(2 * n)] <- -kords[n:2]
    kords <- switch(kernel,
		    gaussian = dnorm(kords, sd = bw),
                    ## In the following, a := bw / sigma(K0), where
                    ##	K0() is the unscaled kernel below
		    rectangular = {
                        a <- bw*sqrt(3)
                        ifelse(abs(kords) < a, .5/a, 0) },
		    triangular = {
                        a <- bw*sqrt(6) ; ax <- abs(kords)
                        ifelse(ax < a, (1 - ax/a)/a, 0) },
		    epanechnikov = {
                        a <- bw*sqrt(5) ; ax <- abs(kords)
                        ifelse(ax < a, 3/4*(1 - (ax/a)^2)/a, 0) },
		    biweight = { ## aka quartic
                        a <- bw*sqrt(7) ; ax <- abs(kords)
                        ifelse(ax < a, 15/16*(1 - (ax/a)^2)^2/a, 0) },
		    cosine = {
                        a <- bw/sqrt(1/3 - 2/pi^2)
                        ifelse(abs(kords) < a, (1+cos(pi*kords/a))/(2*a),0)},
		    optcosine = {
                        a <- bw/sqrt(1-8/pi^2)
                        ifelse(abs(kords) < a, pi/4*cos(pi*kords/(2*a))/a, 0)}
                    )
    kords <- convolve(y, kords, type = "circular", conj = TRUE)[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 = FALSE),
	      class="density")
}

plot.density <- function(s, main=NULL, xlab=NULL, ylab="Density", type="l",
			 zero.line = TRUE, ...)
{
    if(is.null(xlab))
	xlab <- paste("N =", s$n, "  Bandwidth =", formatC(s$bw))
    if(is.null(main)) main <- deparse(s$call)
    plot.default(s, main=main, xlab=xlab, ylab=ylab, type=type, ...)
    if(zero.line) abline(h=0, lwd=0.1, col = "gray")
}

print.density <- function(x, digits=NULL, ...)
{
    cat("\nCall:\n\t",deparse(x$call),
	"\n\nData: ",x$data.name," (",x$n," obs.);",
	"\tBandwidth 'bw' = ",formatC(x$bw,digits=digits), "\n\n",sep="")
    print(summary(as.data.frame(x[c("x","y")])), digits=digits, ...)
    invisible(x)
}
dev.list <-
    function()
{
    if(exists(".Devices")) {
	n <- get(".Devices")
    }
    else {
	n <- list("null device")
    }
    n <- unlist(n)
    i <- seq(along = n)[n != ""]
    names(i) <- n[i]
    i <- i[-1]
    if(length(i) == 0)
	return(NULL)
    else i
}

dev.cur <-
    function()
{
    if(!exists(".Devices")) {
	.Devices <- list("null device")
    }
    num.device <- .Internal(dev.cur())
    names(num.device) <- .Devices[[num.device]]
    num.device
}

dev.set <-
    function(which = dev.next())
{
    which <- .Internal(dev.set(as.integer(which)))
    if(exists(".Devices")) {
	assign(".Device", get(".Devices")[[which]])
    }
    else {
	.Devices <- list("null device")
    }
    names(which) <- .Devices[[which]]
    which
}

dev.next <-
    function(which = dev.cur())
{
    if(!exists(".Devices"))
	.Devices <- list("null.device")
    num.device <- .Internal(dev.next(as.integer(which)))
    names(num.device) <- .Devices[[num.device]]
    num.device
}

dev.prev <-
    function(which = dev.cur())
{
    if(!exists(".Devices"))
	.Devices <- list("null device")
    num.device <- .Internal(dev.prev(as.integer(which)))
    names(num.device) <- .Devices[[num.device]]
    num.device
}

dev.off <-
    function(which = dev.cur())
{
    if(which == 1)
	stop("Cannot shut down device 1 (the null device)")
    if(exists(".Devices")) {
	.Devices <- get(".Devices")
    }
    else {
	.Devices <- list("null device")
    }
    .Devices[[which]] <- ""
    assign(".Devices", .Devices)
    .Internal(dev.off(as.integer(which)))
    assign(".Device", .Devices[[dev.cur()]])
    dev.cur()
}

dev.copy <- function(device, ..., which = dev.next())
{
    if(!missing(which) & !missing(device))
	stop("Cannot supply which and device at the same time.")
    old.device <- dev.cur()
    if(old.device == 1)
	stop("Cannot copy the null device.")
    if(missing(device)) {
	if(which == 1)
	    stop("Cannot copy to the null device.")
	else if(which == dev.cur())
	    stop("Cannot copy device to itself")
	dev.set(which)
    }
    else {
	if(!is.function(device))
	    stop("Argument 'device' should be a function")
	else device(...)
    }
    .Internal(dev.copy(old.device))
    dev.cur()
}

dev.print <- function(device = postscript, ...)
{
    current.device <- dev.cur()
    dev.off(dev.copy(device = device, ...)) # user must still print this
    dev.set(current.device)
}

dev.control <- function(displaylist)
{
    if(!missing(displaylist)) {
	if(displaylist == "inhibit")
	    .Internal(dev.control())
	else stop(paste("displaylist should be inhibit"))
    }
    invisible()
}

graphics.off <- function ()
{
    while ((which <- dev.cur()) != 1)
	dev.off(which)
}
diag <- function(x = 1, nrow, ncol = n)
{
    if (is.matrix(x) && nargs() == 1) {
        if((m <- min(dim(x))) == 0)
            return(numeric(0))

        y <- c(x)[1 + 0:(m - 1) * (dim(x)[1] + 1)]
        nms <- dimnames(x)
        if (is.list(nms) && !any(sapply(nms, is.null)) &&
            all((nm <- nms[[1]][1:m]) == nms[[2]][1:m]))
            names(y) <- nm
        return(y)
    }
    if(is.array(x) && length(dim(x)) != 1)
        stop("first argument is array, but not matrix.")

    if(missing(x))
	n <- nrow
    else if(length(x) == 1 && missing(nrow) && missing(ncol)) {
	n <- as.integer(x)
	x <- 1
    }
    else n <- length(x)
    if(!missing(nrow))
	n <- nrow
    p <- ncol
    y <- array(0, c(n, p))
    if((m <- min(n, p)) > 0) y[1 + 0:(m - 1) * (n + 1)] <- x
    y
}

"diag<-" <- function(x, value)
{
    dx <- dim(x)
    if(length(dx) != 2 || prod(dx) != length(x))
	stop("only matrix diagonals can be replaced")
    i <- seq(length=min(dx))
    if(length(value) != 1 && length(value) != length(i))
	stop("replacement diagonal has wrong length")
    x[cbind(i, i)] <- value
    x
}
diff <- function(x, ...) UseMethod("diff")

diff.default <- function(x, lag = 1, differences = 1, ...)
{
    ismat <- is.matrix(x)
    if (ismat)
	xlen <- dim(x)[1]
    else xlen <- length(x)
    if (lag < 1 | differences < 1)
	stop("Bad value for lag or differences")
    if (lag * differences >= xlen)
	return(x[0])
    r <- x
    class(r) <- NULL # don't want class-specific subset methods
    s <- 1:lag
    if (is.matrix(r)) {
	for (i in 1:differences)
	    r <- r[-s, , drop = FALSE] - r[-(nrow(r) + 1 - s), , drop = FALSE]
    }
    else for (i in 1:differences)
	r <- r[-s] - r[-(length(r) + 1 - s)]
    xtsp <- attr(x, "tsp")
    if (!is.null(xtsp))
        tsp(r) <- c(xtsp[1] + lag*differences*xtsp[3], xtsp[2], xtsp[3])
    class(r) <- class(x)
    r
}
dexp <- function(x, rate=1) .Internal(dexp(x, 1/rate))
pexp <- function(q, rate=1) .Internal(pexp(q, 1/rate))
qexp <- function(p, rate=1) .Internal(qexp(p, 1/rate))
rexp <- function(n, rate=1) .Internal(rexp(n, 1/rate))

dunif <- function(x, min=0, max=1) .Internal(dunif(x, min, max))
punif <- function(q, min=0, max=1) .Internal(punif(q, min, max))
qunif <- function(p, min=0, max=1) .Internal(qunif(p, min, max))
runif <- function(n, min=0, max=1) .Internal(runif(n, min, max))

dnorm <- function(x, mean=0, sd=1) .Internal(dnorm(x, mean, sd))
pnorm <- function(q, mean=0, sd=1) .Internal(pnorm(q, mean, sd))
qnorm <- function(p, mean=0, sd=1) .Internal(qnorm(p, mean, sd))
rnorm <- function(n, mean=0, sd=1) .Internal(rnorm(n, mean, sd))

dcauchy <-
    function(x, location=0, scale=1) .Internal(dcauchy(x, location, scale))
pcauchy <-
    function(q, location=0, scale=1) .Internal(pcauchy(q, location, scale))
qcauchy <-
    function(p, location=0, scale=1) .Internal(qcauchy(p, location, scale))
rcauchy <-
    function(n, location=0, scale=1) .Internal(rcauchy(n, location, scale))

dgamma <- function(x, shape, scale=1) .Internal(dgamma(x, shape, scale))
pgamma <- function(q, shape, scale=1) .Internal(pgamma(q, shape, scale))
qgamma <- function(p, shape, scale=1) .Internal(qgamma(p, shape, scale))
rgamma <- function(n, shape, scale=1) .Internal(rgamma(n, shape, scale))

dlnorm <- function(x, meanlog=0, sdlog=1) .Internal(dlnorm(x, meanlog, sdlog))
plnorm <- function(q, meanlog=0, sdlog=1) .Internal(plnorm(q, meanlog, sdlog))
qlnorm <- function(p, meanlog=0, sdlog=1) .Internal(qlnorm(p, meanlog, sdlog))
rlnorm <- function(n, meanlog=0, sdlog=1) .Internal(rlnorm(n, meanlog, sdlog))

dlogis <- function(x, location=0, scale=1) .Internal(dlogis(x, location, scale))
plogis <- function(q, location=0, scale=1) .Internal(plogis(q, location, scale))
qlogis <- function(p, location=0, scale=1) .Internal(qlogis(p, location, scale))
rlogis <- function(n, location=0, scale=1) .Internal(rlogis(n, location, scale))

dweibull <- function(x, shape, scale=1) .Internal(dweibull(x, shape, scale))
pweibull <- function(q, shape, scale=1) .Internal(pweibull(q, shape, scale))
qweibull <- function(p, shape, scale=1) .Internal(qweibull(p, shape, scale))
rweibull <- function(n, shape, scale=1) .Internal(rweibull(n, shape, scale))

dbeta <- function(x, shape1, shape2, ncp=0) {
    if(missing(ncp)) .Internal(dbeta(x, shape1, shape2))
    else .Internal(dnbeta(x, shape1, shape2, ncp))
}
pbeta <- function(q, shape1, shape2, ncp=0) {
    if(missing(ncp)) .Internal(pbeta(q, shape1, shape2))
    else .Internal(pnbeta(q, shape1, shape2, ncp))
}
qbeta <- function(p, shape1, shape2) .Internal(qbeta(p, shape1, shape2))
rbeta <- function(n, shape1, shape2) .Internal(rbeta(n, shape1, shape2))

dbinom <- function(x, size, prob) .Internal(dbinom(x, size, prob))
pbinom <- function(q, size, prob) .Internal(pbinom(q, size, prob))
qbinom <- function(p, size, prob) .Internal(qbinom(p, size, prob))
rbinom <- function(n, size, prob) .Internal(rbinom(n, size, prob))

dchisq <- function(x, df, ncp=0) {
    if(missing(ncp)) .Internal(dchisq(x, df))
    else .Internal(dnchisq(x, df, ncp))
}
pchisq <- function(q, df, ncp=0) {
    if(missing(ncp)) .Internal(pchisq(q, df))
    else .Internal(pnchisq(q, df, ncp))
}
qchisq <- function(p, df, ncp=0) {
    if(missing(ncp)) .Internal(qchisq(p, df))
    else .Internal(qnchisq(p, df, ncp))
}
rchisq <- function(n, df, ncp=0) {
    if(missing(ncp)) .Internal(rchisq(n, df))
    else .not.yet.implemented()
}

df <- function(x, df1, df2) .Internal(df(x, df1, df2))
pf <- function(q, df1, df2, ncp=0) {
    if(missing(ncp)) .Internal(pf(q, df1, df2))
    else .Internal(pnf(q, df1, df2, ncp))
}
qf <- function(p, df1, df2) .Internal(qf(p, df1, df2))
rf <- function(n, df1, df2) .Internal(rf(n, df1, df2))

dgeom <- function(x, prob) .Internal(dgeom(x, prob))
pgeom <- function(q, prob) .Internal(pgeom(q, prob))
qgeom <- function(p, prob) .Internal(qgeom(p, prob))
rgeom <- function(n, prob) .Internal(rgeom(n, prob))

dhyper <- function(x, m, n, k) .Internal(dhyper(x, m, n, k))
phyper <- function(q, m, n, k) .Internal(phyper(q, m, n, k))
qhyper <- function(p, m, n, k) .Internal(qhyper(p, m, n, k))
rhyper <- function(nn, m, n, k) .Internal(rhyper(nn, m, n, k))

dnbinom <- function(x, size, prob) .Internal(dnbinom(x, size, prob))
pnbinom <- function(q, size, prob) .Internal(pnbinom(q, size, prob))
qnbinom <- function(p, size, prob) .Internal(qnbinom(p, size, prob))
rnbinom <- function(n, size, prob) .Internal(rnbinom(n, size, prob))

dpois <- function(x, lambda) .Internal(dpois(x, lambda))
ppois <- function(q, lambda) .Internal(ppois(q, lambda))
qpois <- function(p, lambda) .Internal(qpois(p, lambda))
rpois <- function(n, lambda) .Internal(rpois(n, lambda))

dt <- function(x, df) .Internal(dt(x, df))
pt <- function(q, df, ncp) {
    if(missing(ncp))
	.Internal(pt(q, df))
    else
	.Internal(pnt(q, df, ncp))
}
qt <- function(p, df) .Internal(qt(p, df))
rt <- function(n, df) .Internal(rt(n, df))

ptukey <- function(q, nmeans, df, nranges=1)
    .Internal(ptukey(q, nranges, nmeans, df))
qtukey <- function(p, nmeans, df, nranges=1)
    .Internal(qtukey(p, nranges, nmeans, df))

dwilcox <- function(x, m, n) .Internal(dwilcox(x, m, n))
pwilcox <- function(q, m, n) .Internal(pwilcox(q, m, n))
qwilcox <- function(p, m, n) .Internal(qwilcox(p, m, n))
rwilcox <- function(nn, m, n) .Internal(rwilcox(nn, m, n))

dsignrank <- function(x, n) .Internal(dsignrank(x, n))
psignrank <- function(q, n) .Internal(psignrank(q, n))
qsignrank <- function(p, n) .Internal(qsignrank(p, n))
rsignrank <- function(nn, n) .Internal(rsignrank(nn, n))
"dotplot" <-
    function (x, labels = NULL, groups = NULL, gdata = NULL, cex = par("cex"),
	      pch = 21, gpch = 21, bg = par("bg"), color = par("fg"),
	      gcolor = par("fg"), lcolor = "gray", main = NULL,
	      xlab = NULL, ylab = NULL, ...)
{
    opar <- par("mar", "cex", "yaxs")
    on.exit(par(opar))
    par(cex = cex, yaxs = "i")

    n <- length(x)
    if (is.matrix(x)) {
	if (is.null(labels))
	    labels <- rownames(x)
	if (is.null(labels))
	    labels <- as.character(1:nrow(x))
	labels <- rep(labels, length = n)
	if (is.null(groups))
	    groups <- col(x, as.factor = TRUE)
	glabels <- levels(groups)
    }
    else {
	if (is.null(labels))
	    labels <- names(x)
	if (!is.null(groups))
	    glabels <- levels(groups)
	else glabels <- NULL
    }

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

    lheight <- strheight("M", "inch")
    if (!(is.null(labels) && is.null(glabels))) {
	nmar <- mar <- par("mar")
	nmar[2] <- nmar[4] + (max(linch + goffset, ginch) +
			      0.1)/lheight
	par(mar = nmar)
    }

    if (is.null(groups)) {
	o <- 1:n
	y <- o
	ylim <- c(0, n + 1)
    }
    else {
	o <- rev(order(as.numeric(groups)))
	x <- x[o]
	groups <- groups[o]
	offset <- cumsum(c(0, diff(as.numeric(groups)) != 0))
	y <- 1:n + 2 * offset
	ylim <- range(0, y + 2)
    }

    plot.window(xlim = range(x[is.finite(x)]), ylim = ylim, log = "")
    xmin <- par("usr")[1]
    if (!is.null(labels)) {
	linch <- max(strwidth(labels, "inch"), na.rm = TRUE)
	loffset <- (linch + 0.1)/lheight
	labs <- labels[o]
	for(i in 1:n)
	    mtext(labs[i], side=2, line=loffset, at=y[i], adj = 0,
		  col = color, las=2, ...)
    }
    abline(h = y, lty = "dotted", col = lcolor)
    points(x, y, pch = pch, col = color, bg = bg)
    if (!is.null(groups)) {
	gpos <- rev(cumsum(rev(tapply(groups, groups, length)) + 2) - 1)
	ginch <- max(strwidth(glabels, "inch"), na.rm = TRUE)
	goffset <- (max(linch+0.2, ginch, na.rm = TRUE) + 0.1)/lheight
	for(i in 1:nlevels(groups))
	    mtext(glabels[i], side=2, line=goffset, at=gpos[i],
		  adj = 0, col = gcolor, las=2, ...)
	if (!is.null(gdata)) {
	    abline(h = gpos, lty = "dotted")
	    points(gdata, gpos, pch = gpch, col = gcolor,
		   bg = bg, ...)
	}
    }
    axis(1)
    box()
    title(main=main, xlab=xlab, ylab=ylab, ...)
    invisible()
}
dput <- function(x, file = "")
    .Internal(dput(x, file))

dget <- function(file)
    eval(parse(file = file))
#### copyright (C) 1998 B. D. Ripley
dummy.coef <- function(object, ...) UseMethod("dummy.coef")

dummy.coef.lm <- function(object, use.na=FALSE)
{
    Terms <- terms(object)
    tl <- attr(Terms, "term.labels")
    int <- attr(Terms, "intercept")
    facs <- attr(Terms, "factors")[-1, , drop=FALSE]
    vars <- rownames(facs)
    xl <- object$xlevels
    if(!length(xl)) {			# no factors in model
	return(as.list(coef(object)))
    }
    nxl <- rep(1, length(vars))
    names(nxl) <- vars
    tmp <- unlist(lapply(xl, length))
    nxl[names(tmp)] <- tmp
    lterms <- apply(facs, 2, function(x) prod(nxl[x > 0]))
    nl <- sum(lterms)
    args <- vector("list", length(vars))
    names(args) <- vars
    for(i in vars)
	args[[i]] <- if(nxl[[i]] == 1) rep(1, nl)
	else factor(rep(xl[[i]][1], nl), levels = xl[[i]])
    dummy <- do.call("data.frame", args)
    pos <- 0
    rn <- rep(tl, lterms)
    rnn <- rep("", nl)
    for(j in tl) {
	i <- vars[facs[, j] > 0]
	ifac <- i[nxl[i] > 1]
	if(length(ifac) == 0) {		# quantitative factor
	    rnn[pos+1] <- j
	} else if(length(ifac) == 1) {	# main effect
	    dummy[ pos+1:lterms[j], ifac ] <- xl[[ifac]]
	    rnn[ pos+1:lterms[j] ] <- as.character(xl[[ifac]])
	} else {			# interaction
	    tmp <- expand.grid(xl[ifac])
	    dummy[ pos+1:lterms[j], ifac ] <- tmp
	    rnn[ pos+1:lterms[j] ] <-
		apply(as.matrix(tmp), 1, function(x) paste(x, collapse=":"))
	}
	pos <- pos + lterms[j]
    }
    mm <- model.matrix(delete.response(Terms), dummy, object$contrasts, xl)
    coef <- object$coef
    if(!use.na) coef[is.na(coef)] <- 0
    asgn <- attr(mm,"assign")
    res <- vector("list", length(tl))
    names(res) <- tl
    for(j in seq(along=tl)) {
	keep <- asgn == j
	ans <- drop(mm[rn == tl[j], keep, drop=FALSE] %*% coef[keep])
	names(ans) <- rnn[rn == tl[j]]
	res[[j]] <- ans
    }
    if(int > 0) {
	res <- c(list(coef[int]), res)
	names(res)[1] <- "(Intercept)"
    }
    class(res) <- "dummy.coef"
    res
}

dummy.coef.aovlist <- function(object, use.na = FALSE)
{
    Terms <- terms(object, specials="Error")
    err <- attr(Terms,"specials")$Error - 1
    tl <- attr(Terms, "term.labels")[-err]
    int <- attr(Terms, "intercept")
    facs <- attr(Terms, "factors")[-c(1,1+err), -err, drop=FALSE]
    vars <- rownames(facs)
    xl <- attr(object, "xlevels")
    if(!length(xl)) {			# no factors in model
	return(as.list(coef(object)))
    }
    nxl <- rep(1, length(vars))
    names(nxl) <- vars
    tmp <- unlist(lapply(xl, length))
    nxl[names(tmp)] <- tmp
    lterms <- apply(facs, 2, function(x) prod(nxl[x > 0]))
    nl <- sum(lterms)
    args <- vector("list", length(vars))
    names(args) <- vars
    for(i in vars)
	args[[i]] <- if(nxl[[i]] == 1) rep(1, nl)
	else factor(rep(xl[[i]][1], nl), levels = xl[[i]])
    dummy <- do.call("data.frame", args)
    pos <- 0
    rn <- rep(tl, lterms)
    rnn <- rep("", nl)
    for(j in tl) {
	i <- vars[facs[, j] > 0]
	ifac <- i[nxl[i] > 1]
	if(length(ifac) == 0) {		# quantitative factor
	    rnn[pos + 1] <- j
	} else if(length(ifac) == 1) {	# main effect
	    dummy[ pos+1:lterms[j], ifac ] <- xl[[ifac]]
	    rnn[ pos+1:lterms[j] ] <- as.character(xl[[ifac]])
	} else {			# interaction
	    tmp <- expand.grid(xl[ifac])
	    dummy[ pos+1:lterms[j], ifac ] <- tmp
	    rnn[ pos+1:lterms[j] ] <-
		apply(as.matrix(tmp), 1, function(x) paste(x, collapse=":"))
	}
	pos <- pos + lterms[j]
    }
    form <- paste("~", paste(tl, collapse = " + "))
    if (!int) form <- paste(form, "- 1")
    mm <- model.matrix(terms(formula(form)), dummy,
		       attr(object, "contrasts"), xl)
    res <- vector("list", length(object))
    names(res) <- names(object)
    tl <- c("(Intercept)", tl)
    allasgn <- attr(mm, "assign")
    for(i in names(object)) {
	coef <- object[[i]]$coef
	if(!use.na) coef[is.na(coef)] <- 0
	asgn <- object[[i]]$assign
	uasgn <- unique(asgn)
	tll <- tl[1 + uasgn]
	mod <- vector("list", length(tll))
	names(mod) <- tll
	for(j in uasgn) {
	    if(j == 0) {
		ans <- structure(coef[asgn == j], names="(Intercept)")
	    } else {
		ans <- drop(mm[rn == tl[1+j], allasgn == j, drop=FALSE] %*%
			    coef[asgn == j])
		names(ans) <- rnn[rn == tl[1+j]]
	    }
	    mod[[tl[1+j]]] <- ans
	}
	res[[i]] <- mod
    }
    class(res) <- "dummy.coef.list"
    res
}

print.dummy.coef <- function(x, ..., title)
{
    terms <- names(x)
    n <- length(x)
    nm <- max(sapply(x, length))
    ans <- matrix("", 2*n, nm)
    rn <- rep("", 2*n)
    line <- 0
    for (j in seq(n)) {
	this <- x[[j]]
	n1 <- length(this)
	if(n1 > 1) {
	    line <- line + 2
	    ans[line-1, 1:n1] <- names(this)
	    ans[line, 1:n1] <- format(this, ...)
	    rn[line-1] <- paste(terms[j], ":   ", sep="")
	} else {
	    line <- line + 1
	    ans[line, 1:n1] <- format(this, ...)
	    rn[line] <- paste(terms[j], ":   ", sep="")
	}
    }
    rownames(ans) <- rn
    colnames(ans) <- rep("", nm)
    cat(if(missing(title)) "Full coefficients are" else title, "\n")
    print.matrix(ans[1:line, , drop=FALSE], quote=FALSE, right=TRUE)
    invisible(x)
}

print.dummy.coef.list <- function(x, ...)
{
    for(strata in names(x))
	print.dummy.coef(x[[strata]], ..., title=paste("\n     Error:", strata))
    invisible(x)
}
dump <-
function (list, fileout = "dumpdata")
{
    digits <- options("digits")
    on.exit(options(digits))
    options(digits = 12)
    .Internal(dump(list, fileout))
}

##dump <- function (list, fileout = "dumpdata") { .Internal(dump(list, fileout)) }

##dyn.load <- function(x)
##{
##	x <- as.character(x)
##	y <- substr(x, 1, 1)
##	if (y == "/") {
##		.Internal(dyn.load(x))
##	}
##	else {
##		.Internal(dyn.load(
##		paste(system("pwd", intern = TRUE), x, sep = "/", collapse="")))
##	}
##}
dyn.load <- function(x, local=TRUE, now=TRUE)
    .Internal(dyn.load(x, as.logical(local), as.logical(now)))

dyn.unload <- function(x)
    .Internal(dyn.unload(x))
edit <- function(name=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),
                          PACKAGE="base")
	    if (z$ierr)
		stop(paste("ch returned code ", z$ierr, " in eigen"))
	    if(!only.values)
		z$vectors <- matrix(complex(re=z$vectors,
					    im=z$ivectors), nc=n)
	}
	else {
	    z <- .Fortran("rs",
			  n,
			  n,
			  x,
			  values = dbl.n,
			  !only.values,
			  vectors = x,
			  dbl.n,
			  dbl.n,
			  ierr = integer(1),
                          PACKAGE="base")
	    if (z$ierr)
		stop(paste("rs returned code ", z$ierr, " in eigen"))
	}
	ord <- rev(order(z$values))
    }
    else {##- Asymmetric :
	if(complex.x) {
	    xr <- Re(x)
	    xi <- Im(x)
	    z <- .Fortran("cg",
			  n,
			  n,
			  xr,
			  xi,
			  values = dbl.n,
			  ivalues = dbl.n,
			  !only.values,
			  vectors = xr,
			  ivectors = xi,
			  dbl.n,
			  dbl.n,
			  dbl.n,
			  ierr = integer(1),
                          PACKAGE="base")
	    if (z$ierr)
		stop(paste("cg returned code ", z$ierr, " in eigen"))
	    z$values <- complex(re=z$values,im=z$ivalues)
	    if(!only.values)
		z$vectors <- matrix(complex(re=z$vectors,
					    im=z$ivectors), nc=n)
	}
	else {
	    z <- .Fortran("rg",
			  n,
			  n,
			  x,
			  values = dbl.n,
			  ivalues = dbl.n,
			  !only.values,
			  vectors = x,
			  integer(n),
			  dbl.n,
			  ierr = integer(1),
                          PACKAGE="base")
	    if (z$ierr)
		stop(paste("rg returned code ", z$ierr, " in eigen"))
	    ind <- z$ivalues > 0
	    if(any(ind)) {#- have complex (conjugated) values
		ind <- seq(n)[ind]
		z$values <- complex(re=z$values,im=z$ivalues)
		if(!only.values) {
		    z$vectors[, ind] <- complex(re=z$vectors[,ind],
						im=z$vectors[,ind+1])
		    z$vectors[, ind+1] <- Conj(z$vectors[,ind])
		}
	    }
	}
	ord <- rev(order(Mod(z$values)))
    }
    list(values = z$values[ord],
	 vectors = if(!only.values) z$vectors[,ord])
}
environment <- function(fun=NULL) .Internal(environment(fun))
.GlobalEnv <- environment()
parent.frame <- function(n = 1) sys.frame(sys.parent(n + 1))

eval <-
    function(expr, envir = parent.frame(),
	     enclos = if(is.list(envir) || is.pairlist(envir))
                       parent.frame())
    .Internal(eval(expr, envir,enclos))

quote <- function(x) substitute(x)


eval.parent <- function(expr, n = 1){
    p <- parent.frame(n + 1)
    eval(expr , p)
}

evalq <-
    function (expr, envir, enclos) 
    eval.parent(substitute(eval(quote(expr), envir, enclos))) 

new.env <- function ()
  eval.parent(quote((function() environment())()))

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

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


exists <-
    function(x, where=-1, envir=pos.to.env(where), frame,
	     mode="any", inherits=TRUE)
{
    if(!missing(frame))
	envir <- sys.frame(frame)
    .Internal(exists(x, envir, mode, inherits))
}
## file expand.grid.R
## copyright (C) 1998 W. N. Venables and B. D. Ripley
##
expand.grid <- function(...) {
    ## x should either be a list or a set of vectors or factors
    nargs <- length(args <- list(...))
    if(! nargs) return(as.data.frame(list()))
    if(nargs == 1 && is.list(a1 <- args[[1]]))
        nargs <- length(args <- a1)
    if(nargs <= 1)
        return(as.data.frame(if(nargs==0||is.null(args[[1]])) list() else args,
                             optional = TRUE))
    cargs <- args
    nmc <- paste("Var", 1:nargs, sep="")
    nm <- names(args)
    if(is.null(nm)) nm <- nmc
    if(any(ng0 <- nchar(nm) > 0)) nmc[ng0] <- nm[ng0]
    names(cargs) <- nmc
    rep.fac <- 1
    orep <- final.len <- prod(sapply(args, length))
    for(i in 1:nargs) {
	x <- args[[i]]
	## avoid sorting the levels of character variates
	nx <- length(x)
	orep <- orep/nx
	x <- rep(rep(x, rep(rep.fac, nx)), orep)
	## avoid sorting the levels of character variates
	if(!is.factor(x) && is.character(x)) x <- factor(x, levels = unique(x))
	cargs[[i]] <- x
	rep.fac <- rep.fac * nx
    }
    do.call("cbind.data.frame", cargs)
}
factor <- function (x, levels = sort(unique(x), na.last = TRUE),
		    labels=levels, exclude = NA, ordered = is.ordered(x))
{
    if(is.null(x))
	x <- list()
    exclude <- as.vector(exclude, typeof(x))
    levels <- levels[is.na(match(levels, exclude))]
    f <- match(x, levels)
    names(f) <- names(x)
    nl <- length(labels)
    attr(f, "levels") <-
	if (nl == length(levels))
	    as.character(labels)
	else if(nl == 1)
	    paste(labels, seq(along = levels), sep = "")
	else
	    stop(paste("invalid labels; length", nl,
		       "should be 1 or",length(levels)))
    class(f) <- c(if(ordered)"ordered", "factor")
    f
}

is.factor <- function(x) inherits(x, "factor")
as.factor <- function (x) if (is.factor(x)) x else factor(x)

## Help old S users:
category <- function(...) .Defunct()

levels <- function(x) attr(x, "levels")
nlevels <- function(x) length(levels(x))

"levels<-" <- function(x, value) UseMethod("levels<-")

"levels<-.default" <- function(x, value)
{
  attr(x, "levels") <- value
  x
}

"levels<-.factor" <- function(x, value)
{
  xlevs <- levels(x)
  if (is.list(value)) {
      nlevs <- rep(names(value), lapply(value, length))
      value <- unlist(value)
      m <- match(value, xlevs, nomatch=0)
      xlevs[m] <- nlevs
  }
  else {
    if (length(xlevs) > length(value))
      stop("number of levels differs")
    xlevs <- as.character(value)
  }
  factor(xlevs[x], levels=unique(xlevs))
}

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

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

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

"codes<-" <- function(x, value)
{
    if ( length(value) == 1 )
	value <- rep(value, length(x))
    else if ( length(x) != length(value) )
	stop("Length mismatch in \"codes<-\"")
    ## S-plus again...
    if ( !is.ordered(x) ) value <- order(levels(x))[value]
    attributes(value) <- attributes(x)
    value
}

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


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


Math.factor <- function(x, ...) {
    stop(paste('"',.Generic,'"', " not meaningful for factors", sep=""))
}
Summary.factor <- function(x, ...) {
    stop(paste('"',.Generic,'"', " not meaningful for factors", sep=""))
}
Ops.factor <- function(e1, e2)
{
    ok <- switch(.Generic, "=="=, "!="=TRUE, FALSE)
    if(!ok) {
	warning(paste('"',.Generic,'"', " not meaningful for factors", sep=""))
	return(rep(NA, max(length(e1),if(!missing(e2))length(e2))))
    }
    nas <- is.na(e1) | is.na(e2)
    if (nchar(.Method[1])) {
	l1 <- levels(e1)
	e1 <- l1[e1]
    }
    if (nchar(.Method[2])) {
	l2 <- levels(e2)
	e2 <- l2[e2]
    }
    if (all(nchar(.Method)) && (length(l1) != length(l2) ||
				!all(sort(l2) == sort(l1))))
	stop("Level sets of factors are different")
    value <- NextMethod(.Generic)
    value[nas] <- NA
    value
}

"[.factor" <- function(x, i, drop=FALSE)
{
    y <- NextMethod("[")
    class(y)<-class(x)
    attr(y,"contrasts")<-attr(x,"contrasts")
    attr(y,"levels")<-attr(x,"levels")
    if ( drop ) factor(y) else y
}

"[<-.factor" <- function(x, i, value)
{
    lx <- levels(x)
    cx <- class(x)
    nas <- is.na(x)
    if (is.factor(value))
	value <- levels(value)[value]
    m <- match(value, lx)
    if (any(is.na(m) & !is.na(value)))
	warning("invalid factor level, NAs generated")
    class(x) <- NULL
    x[i] <- m
    attr(x,"levels") <- lx
    class(x) <- cx
    x
}

## ordered factors ...

ordered <- function(x, ...) factor(x, ..., ordered=TRUE)

is.ordered <- function(x) inherits(x, "ordered")
as.ordered <- function(x) if(is.ordered(x)) x else ordered(x)

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

Ops.ordered <-
function (e1, e2)
{
    ok <- switch(.Generic,
		 "<" = , ">" = , "<=" = , ">=" = ,"=="=, "!=" =TRUE,
		 FALSE)
    if(!ok) {
	warning(paste('"',.Generic,'"', " not meaningful for ordered factors", sep=""))
	return(rep(NA, max(length(e1),if(!missing(e2))length(e2))))
    }
    nas <- is.na(e1) | is.na(e2)
    ord1 <- FALSE
    ord2 <- FALSE
    if (nchar(.Method[1])) {
	l1 <- levels(e1)
	ord1 <- TRUE
    }
    if (nchar(.Method[2])) {
	l2 <- levels(e2)
	ord2 <- TRUE
    }
    if (all(nchar(.Method)) && (length(l1) != length(l2) || !all(l2 == l1)))
	stop("Level sets of factors are different")
    if (ord1 && ord2) {
	e1 <- codes(e1)
	e2 <- codes(e2)
    }
    else if (!ord1) {
	e1 <- match(e1, l2)
	e2 <- codes(e2)
    }
    else if (!ord2) {
	e2 <- match(e2, l1)
	e1 <- codes(e1)
    }
    value <- get(.Generic, mode = "function")(e1, e2)
    value[nas] <- NA
    value
}
family <- function(object, ...) UseMethod("family")

print.family <- function(x, ...)
{
    cat("\nFamily:", x$family, "\n")
    cat("Link function:", x$link, "\n\n")
}

power <- function(lambda = 1) {
    if(lambda <= 0)
	make.link("log")
    else if(lambda == 1)
        make.link("identity")
    else
        make.link(lambda)
}

## Written by Simon Davies Dec 1995
## Modified by Thomas Lumley 26 Apr 97
## added valideta(eta) function..
make.link <- function (link)
{
    if (is.character(link) && length(grep("^power", link) > 0))
        return(eval(parse(text = link)))
    else if(!is.character(link) && !is.na(lambda <- as.numeric(link))) {
        linkfun <- function(mu) mu^lambda
        linkinv <- function(eta) eta^(1/lambda)
        mu.eta <- function(eta) (1/lambda) * eta^(1/lambda - 1)
        valideta <- function(eta) all(eta>0)
    }
    else
        switch(link,
               "logit" = {
                   linkfun <- function(mu) log(mu/(1 - mu))
                   linkinv <- function(eta) 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 :
               stop(paste(link, "link not recognised"))
               )# end switch(.)
    list(linkfun = linkfun, linkinv = linkinv,
	 mu.eta = mu.eta, valideta = valideta)
}

poisson <- function (link = "log")
{
    linktemp <- substitute(link)
    ## this is a function used in  glm().
    ## It holds everything personal to the family,
    ## converts link into character string
    if (!is.character(linktemp)) {
	linktemp <- deparse(linktemp)
	if (linktemp == "link")
	    linktemp <- eval(link)
    }
    if (any(linktemp == c("log", "identity", "sqrt")))
	stats <- make.link(linktemp)
    else stop(paste(linktemp, "link not available for poisson",
		    "family; available links are",
		    '"identity", "log" and "sqrt"'))
    variance <- function(mu) mu
    validmu <- function(mu) all(mu>0)
    dev.resids <- function(y, mu, wt)
	2 * wt * (y * log(ifelse(y == 0, 1, y/mu)) - (y - mu))
    aic <- function(y, n, mu, wt, dev)
	2*sum((mu-y*log(mu)+lgamma(y+1))*wt)
    initialize <- expression({
	if (any(y < 0))
	    stop(paste("Negative values not allowed for",
		       "the Poisson family"))
	n <- rep(1, nobs)
	mustart <- y + 0.1
    })
    structure(list(family = "poisson",
		   link = linktemp,
		   linkfun = stats$linkfun,
		   linkinv = stats$linkinv,
		   variance = variance,
		   dev.resids = dev.resids,
		   aic = aic,
		   mu.eta = stats$mu.eta,
		   initialize = initialize,
		   validmu = validmu,
		   valideta = stats$valideta),
	      class = "family")
}

gaussian <- function (link = "identity")
{
    linktemp <- substitute(link)
    ## This is a function used in  glm();
    ## it holds everything personal to the family
    ## converts link into character string
    if (!is.character(linktemp)) {
	linktemp <- deparse(linktemp)
	if (linktemp == "link")
	    linktemp <- eval(link)
    }
    if (any(linktemp == c("inverse", "log", "identity")))
	stats <- make.link(linktemp)
    else stop(paste(linktemp, "link not available for gaussian",
		    "family, available links are \"inverse\", ",
		    "\"log\" and \"identity\""))
    structure(list(family = "gaussian",
		   link = linktemp,
		   linkfun = stats$linkfun,
		   linkinv = stats$linkinv,
		   variance = function(mu) rep(1, length(mu)),
		   dev.resids = function(y, mu, wt) wt * ((y - mu)^2),
		   aic =	function(y, n, mu, wt, dev)
		   sum(wt)*(log(dev/sum(wt)*2*pi)+1)+2,
		   mu.eta = stats$mu.eta,
		   initialize = expression({
		       n <- rep(1, nobs)
		       mustart <- y }),
		   validmu = function(mu) TRUE
		   ),
	      class = "family")
}

binomial <- function (link = "logit")
{
    linktemp <- substitute(link)
    ## this is a function used in  glm();
    ## it holds everything personal to the family
    ## converts link into character string
    if (!is.character(linktemp)) {
	linktemp <- deparse(linktemp)
	if (linktemp == "link")
	    linktemp <- eval(link)
    }
    if (any(linktemp == c("logit", "probit", "cloglog", "log")))
	stats <- make.link(linktemp)
    else stop(paste(linktemp, "link not available for binomial",
		    "family, available links are \"logit\", ",
		    "\"probit\" and \"cloglog\""))
    variance <- function(mu) mu * (1 - mu)
    validmu <- function(mu) all(mu>0) && all(mu<1)
    dev.resids <- function(y, mu, wt)
	2 * wt * (y * log(ifelse(y == 0, 1, y/mu)) +
		  (1 - y) * log(ifelse(y == 1, 1, (1 - y)/(1 - mu))))
    aic <- function(y, n, mu, wt, dev)
	-2*sum((lchoose(n,n*y)+n*(y*log(mu)+(1-y)*log(1-mu)))*wt/n)
    initialize <- expression({
	if (NCOL(y) == 1) {
	    ## allow factors as responses
	    ## added BDR 29/5/98
	    if (is.factor(y)) y <- y != levels(y)[1]
	    n <- rep(1, nobs)
	    if (any(y < 0 | y > 1))
		stop("y values must be 0 <= y <= 1")
	}
	else if (NCOL(y) == 2) {
	    n <- y[, 1] + y[, 2]
	    y <- ifelse(n == 0, 0, y[, 1]/n)
	    weights <- weights * n
	}
	else stop(paste("For the binomial family, y must be",
			"a vector of 0 and 1\'s or a 2 column",
			"matrix where col 1 is no. successes",
			"and col 2 is no. failures"))
	mustart <- (n * y + 0.5)/(n + 1)
    })
    structure(list(family = "binomial",
		   link = linktemp,
		   linkfun = stats$linkfun,
		   linkinv = stats$linkinv,
		   variance = variance,
		   dev.resids = dev.resids,
		   aic = aic,
		   mu.eta = stats$mu.eta,
		   initialize = initialize,
		   validmu = validmu,
		   valideta = stats$valideta),
	      class = "family")
}

Gamma <- function (link = "inverse")
{
    linktemp <- substitute(link)
    ## This is a function used in  glm();
    ## it holds everything personal to the family
    ## converts link into character string
    if (!is.character(linktemp)) {
	linktemp <- deparse(linktemp)
	if (linktemp == "link")
	    linktemp <- eval(link)
    }
    if (any(linktemp == c("inverse", "log", "identity")))
	stats <- make.link(linktemp)
    else stop(paste(linktemp, "link not available for gamma",
		    "family, available links are \"inverse\", ",
		    "\"log\" and \"identity\""))
    variance <- function(mu) mu^2
    validmu <- function(mu) all(mu>0)
    dev.resids <- function(y, mu, wt)
	-2 * wt * (log(ifelse(y == 0, 1, y/mu)) - (y - mu)/mu)
    aic <- function(y, n, mu, wt, dev){
	n <- sum(wt)
	disp <- dev/n
	2*((sum(wt*(y/mu+log(mu)-log(y)))+n*log(disp))/disp+
	   n*lgamma(1/disp)+sum(log(y)*wt)+1)}
    initialize <- expression({
	if (any(y <= 0))
	    stop(paste("Non-positive values not",
		       "allowed for the gamma family"))
	n <- rep(1, nobs)
	mustart <- y
    })
    structure(list(family = "Gamma",
		   link = linktemp,
		   linkfun = stats$linkfun,
		   linkinv = stats$linkinv,
		   variance = variance,
		   dev.resids = dev.resids,
		   aic = aic,
		   mu.eta = stats$mu.eta,
		   initialize = initialize,
		   validmu = validmu,
		   valideta = stats$valideta),
	      class = "family")
}

inverse.gaussian <- function(link = "1/mu^2")
{
    linktemp <- substitute(link)
    ## This is a function used in  glm();
    ## it holds everything personal to the family
    ## converts link into character string
    if (!is.character(linktemp)) {
	linktemp <- deparse(linktemp)
	if (linktemp == "link")
	    linktemp <- eval(link)
    }
    if (any(linktemp == c("inverse", "log", "identity", "1/mu^2")))
	stats <- make.link(linktemp)
    else stop(paste(linktemp, "link not available for inverse gauss",
		    "family, available links are \"inverse\", ",
		    "\"1/mu^2\" \"log\" and \"identity\""))
    ##	stats <- make.link("1/mu^2")
    variance <- function(mu) mu^3
    dev.resids <- function(y, mu, wt)  wt*((y - mu)^2)/(y*mu^2)
    aic <- function(y, n, mu, wt, dev)
	sum(wt)*(log(dev/sum(wt)*2*pi)+1)+3*sum(log(y)*wt)+2
    initialize <- expression({
	if(any(y <= 0))
	    stop(paste("Positive values only allowed for",
		       "the inverse.gaussian family"))
	n <- rep(1, nobs)
	mustart <- y
    })
    validmu <- function(mu) TRUE

    structure(list(family = "inverse.gaussian",
		   link = "1/mu^2",
		   linkfun = stats$linkfun,
		   linkinv = stats$linkinv,
		   variance = variance,
		   dev.resids = dev.resids,
		   aic = aic,
		   mu.eta = stats$mu.eta,
		   initialize = initialize,
		   validmu = validmu,
		   valideta = stats$valideta),
	      class = "family")
}

quasi <- function (link = "identity", variance = "constant")
{
    linktemp <- substitute(link)
    ##this is a function used in  glm()
    ##it holds everything personal to the family
    ##converts link into character string
    if (is.expression(linktemp))
	linktemp <- eval(linktemp)
    if (!is.character(linktemp)) {
	linktemp <- deparse(linktemp)
	if (linktemp == "link")
	    linktemp <- eval(link)
    }
    stats <- make.link(linktemp)
    ##converts variance into character string
    variancetemp <- substitute(variance)
    if (!is.character(variancetemp)) {
	variancetemp <- deparse(variancetemp)
	if (linktemp == "variance")
	    variancetemp <- eval(variance)
    }
    switch(variancetemp,
	   "constant" = {
	       variance <- function(mu) rep(1, length(mu))
	       dev.resids <- function(y, mu, wt) wt * ((y - mu)^2)
	       validmu <-function(mu) TRUE
	   },
	   "mu(1-mu)" = {
	       variance <- function(mu) mu * (1 - mu)
	       validmu <- function(mu) all(mu>0) && all(mu<1)
	       dev.resids <- function(y, mu, wt)
		   2 * wt * (y * log(ifelse(y == 0, 1, y/mu)) +
			     (1 - y) * log(ifelse(y == 1, 1, (1 - y)/(1 - mu))))
	   },
	   "mu" = {
	       variance <- function(mu) mu
	       validmu <- function(mu) all(mu>0)
	       dev.resids <- function(y, mu, wt)
		   2 * wt * (y * log(ifelse(y == 0, 1, y/mu)) - (y - mu))
	   },
	   "mu^2" = {
	       variance <- function(mu) mu^2
	       validmu <- function(mu) all(mu>0)
	       dev.resids <- function(y, mu, wt)
		   pmax(-2 * wt * (log(ifelse(y == 0, 1, y)/mu) - (y - mu)/mu), 0)
	   },
	   "mu^3" = {
	       variance <- function(mu) mu^3
	       validmu <-function(mu) all(mu>0)
	       dev.resids <- function(y, mu, wt)
		   wt * ((y - mu)^2)/(y * mu^2)
	   },
	   stop(paste(variancetemp, "not recognised, possible variances",
		      'are "mu(1-mu)", "mu", "mu^2", "mu^3" and "constant"'))
	   )# end switch(.)
# 0.1 fudge here matches poisson: S has 1/6.
    initialize <- expression({ n <- rep(1, nobs); mustart <- y + 0.1 *(y == 0)})
    aic <- function(y, n, mu, wt, dev) NA
    structure(list(family = "quasi",
		   link = linktemp,
		   linkfun = stats$linkfun,
		   linkinv = stats$linkinv,
		   variance = variance,
		   dev.resids = dev.resids,
		   aic = aic,
		   mu.eta = stats$mu.eta,
		   initialize = initialize,
		   validmu = validmu,
		   valideta = stats$valideta),
	      class = "family")
}
fft <- function(z, inverse=FALSE)
    .Internal(fft(z, inverse))

mvfft <- function(z, inverse=FALSE)
    .Internal(mvfft(z, inverse))

nextn <- function(n, factors=c(2,3,5))
    .Internal(nextn(n, factors))

convolve <- function(x, y, conj=TRUE, type=c("circular","open","filter")) {
    type <- match.arg(type)
    n <- length(x)
    ny <- length(y)
    Real <- is.numeric(x) && is.numeric(y)
    ## switch(type, circular = ..., )
    if(type == "circular") {
        if(ny != n)
            stop("length mismatch in convolution")
    }
    else { ## "open" or "filter": Pad with zeros
        n1 <- ny - 1
        x <- c(rep(0, n1), x)
        n <- length(y <- c(y, rep(0, n - 1)))# n = nx+ny-1
    }
    x <- fft(fft(x)* (if(conj)Conj(fft(y)) else fft(y)), inv=TRUE)
    if(type == "filter")
        (if(Real) Re(x) else x)[-c(1:n1, (n-n1+1):n)]/n
    else
        (if(Real) Re(x) else x)/n
}

Platform <- function()
.Internal(Platform())

R.home <- function()
.Internal(R.home())

file.show <-
function (..., header=rep("", nfiles), title="R Information",
          delete.file=FALSE, pager=options()$pager)
{
    file <- c(...)
    nfiles <- length(file)
    .Internal(file.show(file, header, title, delete.file, pager))
}

file.append <- function(file1, file2)
.Internal(file.append(file1, file2))

file.remove <- function(...)
.Internal(file.remove(c(...)))


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

file.path <- function(..., fsep=.Platform$file.sep)
paste(..., sep=fsep)

file.exists <- function(...)
.Internal(file.exists(c(...)))


file.create <- function(...)
.Internal(file.create(c(...)))

file.choose <- function(new=FALSE)
.Internal(file.choose(new))


system.file <- function (..., pkg = .packages(), lib = .lib.loc)
{
    flist <- list(...)
    if(length(flist) > 1 || (length(flist) == 1 && nchar(flist[[1]]) > 0)) {
        FILES <- file.path(t(outer(lib, pkg, paste, sep = .Platform$file.sep)),
                           file.path(...))
    } else {
        if(missing(pkg)) pkg <- "base"
        FILES <- outer(lib, pkg, paste, sep = .Platform$file.sep)
    }
    present <- file.exists(FILES)
    if (any(present)) FILES[present]
    else ""
}

getwd <- function()
    .Internal(getwd())
setwd <- function(dir)
    .Internal(setwd(dir))
basename <- function(path)
    .Internal(basename(path))
dirname <- function(path)
    .Internal(dirname(path))
filled.contour <-
function (x = seq(0, 1, len = nrow(z)),
          y = seq(0, 1, len = ncol(z)),
          z,
          xlim = range(x, finite=TRUE),
          ylim = range(y, finite=TRUE),
          zlim = range(z, finite=TRUE),
          levels = pretty(zlim, nlevels), nlevels = 20,
          color.palette = cm.colors,
          col = color.palette(length(levels) - 1),
          plot.title, plot.axes, key.title, key.axes,
          asp = NA, xaxs="i", yaxs="i", las = 1, axes = TRUE, ...)
{
    if (missing(z)) {
        if (!missing(x)) {
            if (is.list(x)) {
                z <- x$z
                y <- x$y
                x <- x$x
            }
            else {
                z <- x
                x <- seq(0, 1, len = nrow(z))
            }
        }
        else stop("no `z' matrix specified")
    }
    else if (is.list(x)) {
        y <- x$y
        x <- x$x
    }
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
        stop("increasing x and y values expected")

    mar.orig <- (par.orig <- par(c("mar","las","mfrow")))$mar
    on.exit(par(par.orig))

    w <- (3 + mar.orig[2]) * par('csi') * 2.54
    layout(matrix(c(2, 1), nc=2), widths=c(1, lcm(w)))
    par(las = las)

    ## Plot the `plot key' (scale):
    mar <- mar.orig
    mar[4] <- mar[2]
    mar[2] <- 1
    par(mar = mar)
    plot.new()
    plot.window(xlim=c(0,1), ylim=range(levels), xaxs="i", yaxs="i")
    rect(0, levels[-length(levels)], 1, levels[-1], col = col)
    if (missing(key.axes)) {
        if (axes)
            axis(4)
    }
    else key.axes
    box()
    if (!missing(key.title))
	key.title

    ## Plot contour-image::
    mar <- mar.orig
    mar[4] <- 1
    par(mar=mar)
    plot.new()
    plot.window(xlim, ylim, "", xaxs=xaxs, yaxs=yaxs, asp=asp)

    if (!is.matrix(z) || nrow(z) <= 1 || ncol(z) <= 1)
        stop("no proper `z' matrix specified")
    if (!is.double(z))
        storage.mode(z) <- "double"
    .Internal(filledcontour(as.double(x),
                            as.double(y),
                            z,
                            as.double(levels),
                            col = col))
    if (missing(plot.axes)) {
        if (axes) {
            title(main="", xlab="", ylab="")
            axis(1)
            axis(2)
        }
    }
    else plot.axes
    box()
    if (missing(plot.title))
        title(...)
    else
	plot.title
    invisible()
}
fivenum <- function(x, na.rm=TRUE)
{
    xna <- is.na(x)
    if(na.rm) x <- x[!xna]
    else if(any(xna)) return(rep(NA,5))
    x <- sort(x)
    n <- length(x)
    if(n == 0) rep(NA,5)
    else {
	d <- c(1, 0.5*floor(0.5*(n+3)), 0.5*(n+1),
	       n+1-0.5*floor(0.5*(n+3)), n)
	0.5*(x[floor(d)]+x[ceiling(d)])
    }
}
fix <- function(x) {
    subx <- substitute(x)
    if( is.name(subx) )
	subx<-deparse(subx)
    if (!is.character(subx) || length(subx) != 1)
	stop("fix requires a name")
    if(exists(subx, inherits=TRUE))
	x <- edit(get(subx))
    else
	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", envir = sys.frame(sys.parent()))
    .Internal(formals(fun))
}
body <- function(fun=sys.function(sys.parent())) {
    if(is.character(fun))
	fun <- get(fun, mode = "function")
    .Internal(body(fun))
}
alist <- function (...) as.list(sys.call())[-1]
"body<-" <- function (f, value, envir = sys.frame(sys.parent())) {
    if (is.expression(value))
	value <- value[[1]]
    f <- as.function(c(formals(f), value), envir)
}
"formals<-" <- function (f, value, envir = sys.frame(sys.parent())) {
    f <- as.function(c(value, body(f)), envir)
}
format <- function(x, ...) UseMethod("format")

###	 -----
###----- FIXME ----- the digits handling should rather happen in
###	 -----	     in .Internal(format(...))	 in  ../../main/paste.c !
###--- also the 'names' should be kept INTERNALLY !
format.default <- function(x, trim=FALSE, digits=NULL)
{
    if(!is.null(digits)) {
	op <- options(digits=digits)
	on.exit(options(op))
    }
    switch(mode(x),
	   NULL = "NULL",
	   list = sapply(
	   lapply(x, function(x)
		  .Internal(format(unlist(x),trim=trim))),
	   paste, collapse=", "),
	   ##else: numeric, complex, character, ??? :
	   structure(.Internal(format(x, trim = trim)), names=names(x)))
}

## Martin Maechler <maechler@stat.math.ethz.ch>
##-- this should also happen in	C(.) :
##	.Internal(format(..) should work  with	'width =' and 'flag=.."
##		at least for the case of character arguments.
format.char <- function(x, width = NULL, flag = "-")
{
    ## Character formatting, flag: if "-" LEFT-justify
    if (is.null(x)) return("")
    if(!is.character(x)) {
	warning("format.char: coercing 'x' to 'character'")
	x <- as.character(x)
    }
    if(is.null(width) && flag == "-")
	return(format(x))		# Left justified; width= max.width

    at <- attributes(x)
    nc <- nchar(x)			#-- string lengths
    if(is.null(width)) width <- max(nc)
    else if(width<0) { flag <- "-"; width <- -width }
    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")))  {
      ## for .C call later on
        if(mode=="real") mode <- "double"
	storage.mode(x) <- mode
    }
    else stop("\"mode\" must be \"double\" (\"real\") or \"integer\"")
    if (mode == "character" || (!is.null(format) && format == "s")) {
	if (mode != "character") {
	    warning('formatC: Coercing argument to "character" for format="s"')
	    x <- as.character(x)
	}
	return(format.char(x, width=width, flag=flag))
    }
    some.special <- !all(Ok <- is.finite(x))
    if (some.special) {
	rQ <- as.character(x[!Ok])
	x[!Ok] <- 0
    }
    if (missing(format) || is.null(format))
	format <- if (mode == "integer") "d" else "g"
    else {
	if (any(format == c("f", "e", "E", "g", "G", "fg"))) {
	    if (mode == "integer") mode <- storage.mode(x) <- "double"
	}
	else if (format == "d") {
	    if (mode != "integer") mode <- storage.mode(x) <- "integer"
	}
	else stop('"format" must be in {"f","e","E","g","G", "fg", "s"}')
    }
    if(is.null(width) && is.null(digits))
        width <- 1
    if (is.null(digits))
	digits <- if (mode == "integer") 2 else 4
    else if(digits < 0)
	digits <- 6
    if(is.null(width))  width <- digits + 1
    else if (width == 0)width <- digits
    i.strlen <-
	pmax(abs(width),
	     if(format == "fg"||format == "f") {
		 xEx <- as.integer(floor(log10(abs(x+ifelse(x==0,1,0)))))
		 as.integer(x < 0 | flag!="") + digits +
		     if(format == "f") {
			 2 + pmax(xEx,0)
		     } else {# format == "fg"
			 pmax(xEx, digits,digits+(-xEx)+1) +
			     ifelse(flag!="",nchar(flag),0) + 1
		     }
	     } else # format == "g" or "e":
	     rep(digits+8, n)
	     )
    ##Dbg if(format=="fg"||format == "f")
    ##Dbg   cat("formatC(,.): xEx=",xEx,"\n\t==> i.strlen=",i.strlen,"\n")
    r <- .C("str_signif",
	    x = x,
	    n = n,
	    mode   = as.character(mode),
	    width  = as.integer(width),
	    digits = as.integer(digits),
	    format = as.character(format),
	    flag   = as.character(flag),
	    result = blank.chars(i.strlen),
            PACKAGE = "base")$result
    ##Dbg if(any(ii <- (nc.res <- nchar(r)) > i.strlen)) {
    ##Dbg  cat("formatC: some  i.strlen[.] were too small:\n")
    ##Dbg  print(cbind(ii=which(ii), strlen=i.strlen[ii], nchar=nc.res[ii]))
    ##Dbg }
    if (some.special)
	r[!Ok] <- format.char(rQ, width=width, flag=flag)
    if (!is.null(x.atr <- attributes(x)))
	attributes(r) <- x.atr
    r
}
subset.data.frame <-
    function (dfr, subset, select)
{
    if(missing(subset))
	r <- TRUE
    else {
	e <- substitute(subset)
	r <- eval(e, dfr, sys.frame(sys.parent()))
	r <- r & !is.na(r)
    }
    if(missing(select))
	vars <- TRUE
    else {
	nl <- as.list(1:ncol(dfr))
	names(nl) <- names(dfr)
	vars <- eval(substitute(select),nl, sys.frame(sys.parent()))
    }
    dfr[r,vars,drop=FALSE]
}

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

subset.default <-
    function(x,subset)
    x[subset & !is.na(subset)]

transform.data.frame <-
    function (dfr, ...)
{
    e <- eval(substitute(list(...)), dfr, sys.frame(sys.parent()))
    tags <- names(e)
    inx <- match(tags, names(dfr))
    matched <- !is.na(inx)
    if (any(matched)) {
	dfr[inx[matched]] <- e[matched]
	dfr <- data.frame(dfr)
    }
    if (!all(matched))
	data.frame(dfr, e[!matched])
    else dfr
}

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

## Actually, I have no idea what to transform(), except dataframes.
## The default converts its argument to a dataframe and transforms
## that. This is probably marginally useful at best. --pd
transform.default <-
    function(x,...)
    transform.data.frame(data.frame(x),...)
get <-
    function(x, pos=-1, envir=pos.to.env(pos), mode="any", inherits=TRUE)
    {
	if (is.character(pos)) 
	    pos<-match(pos,search()) 
	.Internal(get(x, envir, mode, inherits))
    }
## gl function of GLIM
gl <- function (n, k, length = n*k, labels=1:n, ordered=FALSE)
    factor(rep(rep(1:n,rep(k,n)), length=length),
	   levels=1:n, labels=labels, ordered=ordered)
### This function fits a generalized linear model via
### iteratively reweighted least squares for any family.
### Written by Simon Davies, Dec 1995
### glm.fit modified by Thomas Lumley, Apr 1997, and then others..

glm <- function(formula, family=gaussian, data=list(), weights=NULL,
		subset=NULL, na.action=na.fail, start=NULL, offset=NULL,
		control=glm.control(...), model=TRUE, method="glm.fit",
                x=FALSE, y=TRUE, contrasts = NULL, ...)
{
    call <- match.call()

    ## family
    if(is.character(family)) family <- get(family)
    if(is.function(family)) family <- family()
    if(is.null(family$family)) {
	print(family)
	stop("`family' not recognized")
    }

    ## extract x, y, etc from the model formula and frame
    mt <- terms(formula, data=data)
    if(missing(data)) data <- sys.frame(sys.parent())
    mf <- match.call(expand.dots = FALSE)
    mf$family <- mf$start <- mf$control <- mf$maxit <- NULL
    mf$model <- mf$method <- mf$x <- mf$y <- mf$contrasts <- NULL
    mf$... <- NULL
    ##	      mf$drop.unused.levels <- TRUE
    mf[[1]] <- as.name("model.frame")
    mf <- eval(mf, sys.frame(sys.parent()))
    switch(method,
	   "model.frame" = return(mf),
	   "glm.fit"= 1,
	   "glm.fit.null"= 1,
	   ## else
	   stop(paste("invalid `method':", method)))
    xvars <- as.character(attr(mt, "variables"))[-1]
    if((yvar <- attr(mt, "response")) > 0) xvars <- xvars[-yvar]
    xlev <- if(length(xvars) > 0) {
	xlev <- lapply(mf[xvars], levels)
	xlev[!sapply(xlev, is.null)]
    } # else NULL

    ## null model support
    X <- if (!is.empty.model(mt)) model.matrix(mt, mf, contrasts)# else NULL
    Y <- model.response(mf, "numeric")
    weights <- model.weights(mf)
    offset <- model.offset(mf)
    ## check weights and offset
    if( !is.null(weights) && any(weights<0) )
	stop("Negative wts not allowed")
    if(!is.null(offset) && length(offset) != NROW(Y))
	stop(paste("Number of offsets is", length(offset),
		   ", should equal", NROW(Y), "(number of observations)"))

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

    if(any(offset) && attr(mt, "intercept") > 0) {
	fit$null.deviance <-
	    if(is.empty.model(mt)) fit$deviance
	    else glm.fit(x=X[,"(Intercept)",drop=FALSE], y=Y, weights=weights,
			 start=start, offset=offset, family=family,
			 control=control, intercept=TRUE)$deviance
    }
    if(model) fit$model <- mf
    if(x) fit$x <- X
    if(!y) fit$y <- NULL
    fit <- c(fit, list(call=call, formula=formula,
		       terms=mt, data=data,
		       offset=offset, control=control, method=method,
		       contrasts = attr(X, "contrasts"), xlevels = xlev))
    class(fit) <- c(if(is.empty.model(mt)) "glm.null", "glm", "lm")
    fit
}


glm.control <- function(epsilon = 0.0001, maxit = 10, trace = FALSE)
{
    if(!is.numeric(epsilon) || epsilon <= 0)
	stop("value of epsilon must be > 0")
    if(!is.numeric(maxit) || maxit <= 0)
	stop("maximum number of iterations must be > 0")
    list(epsilon = epsilon, maxit = maxit, trace = trace)
}

## Modified by Thomas Lumley 26 Apr 97
## Added boundary checks and step halving
## Modified detection of fitted 0/1 in binomial
## Updated by KH as suggested by BDR on 1998/06/16

glm.fit <-
    function (x, y, weights = rep(1, nobs), start = NULL,
	      etastart = NULL, mustart = NULL, offset = rep(0, nobs),
	      family = gaussian(), control = glm.control(), intercept = TRUE)
{
    x <- as.matrix(x)
    xnames <- dimnames(x)[[2]]
    ynames <- names(y)
    conv <- FALSE
    nobs <- NROW(y)
    nvars <- NCOL(x)
    if (nvars == 0) {
        ## oops, you'd want glm.fit.null, then
        cc <- match.call()
        cc[[1]] <- as.name("glm.fit.null")
        return(eval(cc, sys.frame(sys.parent())))
    }
    ## define weights and offset if needed
    if (is.null(weights))
	weights <- rep(1, nobs)
    if (is.null(offset))
	offset <- rep(0, nobs)
    ## get family functions:
    variance <- family$variance
    dev.resids <- family$dev.resids
    aic <- family$aic
    linkinv <- family$linkinv
    mu.eta <- family$mu.eta
    if (!is.function(variance) || !is.function(linkinv) )
	stop("illegal `family' argument")
    valideta <- family$valideta
    if (is.null(valideta))
	valideta <- function(eta) TRUE
    validmu <- family$validmu
    if (is.null(validmu))
	validmu <- function(mu) TRUE
    if(is.null(mustart))
	## next line calculates mustart and may change y and weights
	eval(family$initialize, sys.frame(sys.nframe()))
    if (NCOL(y) > 1)
	stop("y must be univariate unless binomial")
    eta <-
	if(!is.null(etastart) && valideta(etastart))
	    etastart
	else if(!is.null(start))
	    if (length(start) != nvars)
		stop(paste("Length of start should equal", nvars,
			   "and correspond to initial coefs for",
			   deparse(xnames)))
	    else as.vector(if (NCOL(x) == 1) x * start else x %*% start)
	else family$linkfun(mustart)
    mu <- linkinv(eta)
    if (!(validmu(mu) && valideta(eta)))
	stop("Can't find valid starting values: please specify some")
    ## calculate initial deviance and coefficient
    devold <- sum(dev.resids(y, mu, weights))
    coefold <- start
    boundary <- FALSE

    ##------------- THE Iteratively Reweighting L.S. iteration -----------
    for (iter in 1:control$maxit) {
	mu.eta.val <- mu.eta(eta)
	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-offset)[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),
                        PACKAGE = "base")
	## stop if not enough parameters
	if (nobs < fit$rank)
	    stop(paste("X matrix has rank", fit$rank, "but only",
		       nobs, "observations"))
	## calculate updated values of eta and mu with the new coef:
	start <- coef <- fit$coefficients
	start[fit$pivot] <- coef
	eta[good] <-
	    if (nvars == 1) x[good] * start else as.vector(x[good, ] %*% start)
	mu <- linkinv(eta <- 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 <- 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 <- 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-offset)[good] # z does not have offset in.
    fit$qr <- as.matrix(fit$qr)
    nr <- min(sum(good), nvars)
    if (nr < nvars) {
	Rmat <- diag(nvars)
	Rmat[1:nr,1:nvars] <- fit$qr[1:nr,1:nvars]
    }
    else Rmat <- fit$qr[1:nvars, 1:nvars]
    Rmat <- as.matrix(Rmat)
    Rmat[row(Rmat) > col(Rmat)] <- 0
    names(coef) <- xnames
    colnames(fit$qr) <- xxnames
    dimnames(Rmat) <- list(xxnames, xxnames)
    names(residuals) <- ynames
    names(mu) <- ynames
    names(eta) <- ynames
    names(w) <- ynames
    names(weights) <- ynames
    names(y) <- ynames
    names(fit$effects) <-
	c(xxnames[seq(fit$rank)], rep("", nobs - fit$rank))
    ## calculate null deviance
    wtdmu <-
	if (intercept) sum(weights * y)/sum(weights) else linkinv(offset)
    nulldev <- sum(dev.resids(y, wtdmu, weights))
    ## calculate df
    n.ok <- nobs - sum(weights==0)
    nulldf <- n.ok - as.integer(intercept)
    resdf  <- n.ok - fit$rank
    ## calculate AIC
    aic.model <-
	##Should not be necessary: --pd
	##if(resdf>0) aic(y, n, mu, weights, dev) + 2*fit$rank else -Inf
	aic(y, n, mu, weights, dev) + 2*fit$rank
    list(coefficients = coef, residuals = residuals, fitted.values = mu,
	 effects = fit$effects, R = Rmat, rank = fit$rank,
	 qr = fit[c("qr", "rank", "qraux", "pivot", "tol")], family = family,
	 linear.predictors = eta, deviance = dev, aic = aic.model,
	 null.deviance = nulldev, iter = iter, weights = w^2,
	 prior.weights = weights, df.residual = resdf, df.null = nulldf,
	 y = y, converged = conv, boundary = boundary)
}


print.glm <- function (x, digits= max(3, .Options$digits - 3), na.print="", ...)
{
    cat("\nCall: ", deparse(x$call), "\n\n")
    cat("Coefficients")
    if(is.character(co <- x$contrasts))
	cat("  [contrasts: ",
	    apply(cbind(names(co),co), 1, paste, collapse="="), "]")
    cat(":\n")
    print.default(format(x$coefficients, digits=digits),
		  print.gap = 2, quote = FALSE)
    cat("\nDegrees of Freedom:", x$df.null, "Total (i.e. Null); ",
	x$df.residual, "Residual\n")
    cat("Null Deviance:	   ",   format(signif(x$null.deviance, digits)),
        "\nResidual Deviance:", format(signif(x$deviance, digits)),
        "\tAIC:", format(signif(x$aic, digits)), "\n")
    invisible(x)
}


anova.glm <- function(object, ..., test=NULL, na.action=na.omit)
{
    ## check for multiple objects
    dotargs <- list(...)
    named <- if (is.null(names(dotargs)))
	rep(FALSE,length(dotargs)) else (names(dotargs) != "")
    if(any(named))
	warning(paste("The following arguments to anova.glm(..)",
		      "are invalid and dropped:",
		      paste(deparse(dotargs[named]), collapse=", ")))
    dotargs <- dotargs[!named]
    is.glm <- unlist(lapply(dotargs,function(x) inherits(x,"glm")))
    dotargs <- dotargs[is.glm]
    if (length(dotargs)>0)
	return(anova.glmlist(c(list(object),dotargs),test=test,
			     na.action=na.action))
    ##args <- function(...) nargs()
    ##if(args(...)) return(anova.glmlist(list(object, ...), test=test))

    ## extract variables from model

    varlist <- attr(object$terms, "variables")
    ## must avoid partial matching here.
    x <-
	if (n <- match("x", names(object), 0))
	    object[[n]]
	else model.matrix(object)
    varseq <- attr(x, "assign")
    nvars <- max(varseq)
    resdev <- resdf <- NULL

    ## if there is more than one explanatory variable then
    ## recall glm.fit to fit variables sequentially

    if(nvars > 1) {
	method <- object$method
	if(!is.function(method))
	    method <- get(method, mode = "function")
	for(i in 1:(nvars-1)) {
	    ## explanatory variables up to i are kept in the model
	    ## use method from glm to find residual deviance
	    ## and df for each sequential fit
	    fit <- method(x=x[, varseq <= i],
			  y=object$y,
			  weights=object$prior.weights,
			  start	 =object$start,
			  offset =object$offset,
			  family =object$family,
			  control=object$control)
	    resdev <- c(resdev, fit$deviance)
	    resdf <- c(resdf, fit$df.residual)
	}
    }

    ## add values from null and full model

    resdf <- c(object$df.null, resdf, object$df.residual)
    resdev <- c(object$null.deviance, resdev, object$deviance)

    ## construct table and title

    table <- data.frame(c(NA, -diff(resdf)), c(NA, -diff(resdev)), resdf, resdev)
    if (nvars == 0) table <- table[1,,drop=FALSE] # kludge for null model
    dimnames(table) <- list(c("NULL", attr(object$terms, "term.labels")),
			    c("Df", "Deviance", "Resid. Df", "Resid. Dev"))
    title <- paste("Analysis of Deviance Table", "\n\nModel: ",
		   object$family$family, ", link: ", object$family$link,
		   "\n\nResponse: ", as.character(varlist[-1])[1],
		   "\n\nTerms added sequentially (first to last)\n\n", sep="")

    ## calculate test statistics if needed

    if(!is.null(test))
	table <- stat.anova(table=table, test=test,
                            scale=sum(object$weights*object$residuals^2)/
                            object$df.residual,
			    df.scale=object$df.residual, n=NROW(x))
    structure(table, heading = title, class= c("anova", "data.frame"))
}


anova.glmlist <- function(object, test=NULL, na.action=na.omit)
{

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

    responses <- as.character(lapply(object, function(x) {
	deparse(formula(x)[[2]])} ))
    sameresp <- responses==responses[1]
    if(!all(sameresp)) {
	object <- object[sameresp]
	warning(paste("Models with response", deparse(responses[!sameresp]),
                      "removed because response differs from",
		      "model 1"))
    }

    ## calculate the number of models

    nmodels <- length(object)
    if(nmodels==1)
        return(anova.glm(object[[1]], na.action=na.action, test=test))

    ## extract statistics

    resdf  <- as.numeric(lapply(object, function(x) x$df.residual))
    resdev <- as.numeric(lapply(object, function(x) x$deviance))

    ## construct table and title

    table <- data.frame(resdf, resdev, c(NA, -diff(resdf)), c(NA, -diff(resdev)))
    variables <- as.character(lapply(object, function(x) {
	deparse(formula(x)[[3]])} ))
    dimnames(table) <- list(variables, c("Resid. Df", "Resid. Dev", "Df",
					 "Deviance"))
    title <- paste("Analysis of Deviance Table \n\nResponse: ", responses[1],
		   "\n\n", sep="")

    ## calculate test statistic if needed

    if(!is.null(test)) {
	bigmodel <- object[[(order(resdf)[1])]]
	table <- stat.anova(table=table, test=test,
                            scale=sum(bigmodel$weights * bigmodel$residuals^2)/
			    bigmodel$df.residual, df.scale=min(resdf),
			    n=length(bigmodel$residuals))
    }
    structure(table, heading = title, class= c("anova", "data.frame"))
}


stat.anova <- function(table, test=c("Chisq", "F", "Cp"), scale, df.scale, n)
{
    test <- match.arg(test)
    dev.col <- match("Deviance", colnames(table))
    if(is.na(dev.col)) dev.col <- match("Sum of Sq", colnames(table))
    switch(test,
	   "Chisq" = {
	       cbind(table,"P(>|Chi|)"= 1-pchisq(abs(table[, dev.col]),
                             abs(table[, "Df"])))
	   },
	   "F" = {
	       Fvalue <- abs((table[, dev.col]/table[, "Df"])/scale)
	       cbind(table, F = Fvalue,
		     "Pr(>F)" = 1-pf(Fvalue, abs(table[, "Df"]), abs(df.scale)))
	   },
	   "Cp" = {
	       cbind(table, Cp = table[,"Resid. Dev"] +
                     2*scale*(n - table[,"Resid. Df"]))
	   })
}

summary.glm <- function(object, dispersion = NULL,
			correlation = FALSE, na.action=na.omit, ...)
{
    Qr <- .Alias(object$qr)
    est.disp <- FALSE
    df.r <- object$df.residual
    if(is.null(dispersion))	# calculate dispersion if needed
	dispersion <-
	    if(any(object$family$family == c("poisson", "binomial")))
		1
	    else if(df.r > 0) {
		est.disp <- TRUE
		if(any(object$weights==0))
		    warning(paste("observations with zero weight",
				  "not used for calculating dispersion"))
		sum(object$weights*object$residuals^2)/ df.r
	    } else Inf

    ## calculate scaled and unscaled covariance matrix

    p <- object$rank
    p1 <- 1:p

    ## WATCHIT! doesn't this rely on pivoting not permuting 1:p?
    coef.p <- object$coefficients[Qr$pivot[p1]]
    covmat.unscaled <- chol2inv(Qr$qr[p1,p1,drop=FALSE])
    dimnames(covmat.unscaled) <- list(names(coef.p),names(coef.p))
    covmat <- dispersion*covmat.unscaled
    var.cf <- diag(covmat)

    ## calculate coef table

    s.err <- sqrt(var.cf)
    tvalue <- coef.p/s.err

    dn <- c("Estimate", "Std. Error")
    if(!est.disp) {
	pvalue <- 2*pnorm(-abs(tvalue))
	coef.table <- cbind(coef.p, s.err, tvalue, pvalue)
	dimnames(coef.table) <- list(names(coef.p),
				     c(dn, "z value","Pr(>|z|)"))
    } else if(df.r > 0) {
	pvalue <- 2*pt(-abs(tvalue), df.r)
	coef.table <- cbind(coef.p, s.err, tvalue, pvalue)
	dimnames(coef.table) <- list(names(coef.p),
				     c(dn, "t value","Pr(>|t|)"))
    } else { ## df.r == 0
	coef.table <- cbind(coef.p, Inf)
	dimnames(coef.table) <- list(names(coef.p), dn)
    }
    ## return answer

    ans <- c(object[c("call","terms","family","deviance", "aic",
		      "contrasts",
		      "df.residual","null.deviance","df.null","iter")],
	     list(deviance.resid= residuals(object, type = "deviance"),
		  aic = object$aic,
		  coefficients=coef.table,
		  dispersion=dispersion,
		  df=c(object$rank, df.r),
		  cov.unscaled=covmat.unscaled,
		  cov.scaled=covmat))

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

print.summary.glm <- function (x, digits = max(3, .Options$digits - 3),
			       na.print = "", symbolic.cor = p > 4,
			       signif.stars= .Options$show.signif.stars, ...)
{
    cat("\nCall:\n")
    cat(paste(deparse(x$call), sep="\n", collapse="\n"), "\n\n", sep="")
    cat("Deviance Residuals: \n")
    if(x$df.residual > 5) {
	x$deviance.resid <- quantile(x$deviance.resid,na.rm=TRUE)
	names(x$deviance.resid) <- c("Min", "1Q", "Median", "3Q", "Max")
    }
    print.default(x$deviance.resid, digits=digits, na = "", print.gap = 2)

    cat("\nCoefficients:\n")
    print.coefmat(x$coef, digits=digits, signif.stars=signif.stars, ...)
    ##
    cat("\n(Dispersion parameter for ", x$family$family,
	" family taken to be ", format(x$dispersion), ")\n\n",
	apply(cbind(paste(format.char(c("Null","Residual"),width=8,flag=""),
			  "deviance:"),
		    format(unlist(x[c("null.deviance","deviance")]),
			   digits= max(5, digits+1)), " on",
		    format(unlist(x[c("df.null","df.residual")])),
		    " degrees of freedom\n"),
	      1, paste, collapse=" "),
	"AIC: ", format(x$aic, digits= max(4, digits+1)),"\n\n",
	"Number of Fisher Scoring iterations: ", x$iter,
	"\n\n", sep="")

    correl <- x$correlation
    if(!is.null(correl)) {
	p <- dim(correl)[2]
	if(p > 1) {
	    cat("Correlation of Coefficients:\n")
	    correl[!lower.tri(correl)] <- NA
	    print(correl[-1, -NCOL(correl), drop=FALSE],
		  digits=digits, na="")
	}
	cat("\n")
    }
    invisible(x)
}


## GLM Methods for Generic Functions :

coef.glm <- function(object, ...) object$coefficients
deviance.glm <- function(object, ...) object$deviance
effects.glm <- function(object, ...) object$effects
fitted.glm <- function(object, ...) object$fitted.values

family.glm <- function(object, ...) object$family

residuals.glm <- function(object, type="deviance", ...)
{
    ntyp <- match(type, c("deviance", "pearson", "working", "response", "partial"))
    if(is.na(ntyp))
	stop(paste("invalid `type':", type))
    y  <- object$y
    mu <- object$fitted.values
    wts <- object$prior.weights
    switch(ntyp,
	   deviance = if(object$df.res > 0) {
	       d.res <- sqrt((object$family$dev.resids)(y, mu, wts))
	       ifelse(y > mu, d.res, -d.res)
	   } else rep(0, length(mu)),
	   pearson	 = object$residuals * sqrt(object$weights),
	   working	 = object$residuals,
	   response = y - mu,
           partial=object$residuals+predict(object,type="terms")
	   )
}

## Commented by KH on 1998/06/22
## update.default() should be more general now ...
##update.glm <- function (glm.obj, formula, data, weights, subset, na.action,
##			offset, family, x)
##{
##	call <- glm.obj$call
##	if (!missing(formula))
##	  call$formula <- update.formula(call$formula, formula)
##	if (!missing(data))	call$data <- substitute(data)
##	if (!missing(subset))	call$subset <- substitute(subset)
##	if (!missing(na.action))call$na.action <- substitute(na.action)
##	if (!missing(weights))	call$weights <- substitute(weights)
##	if (!missing(offset))	call$offset <- substitute(offset)
##	if (!missing(family))	call$family <- substitute(family)
##	if (!missing(x))	call$x <- substitute(x)
####	notparent <- c("NextMethod", "update", methods(update))
####	for (i in 1:(1+sys.parent())) {
####		parent <- sys.call(-i)[[1]]
####		if (is.null(parent))
####		break
####	if (is.na(match(as.character(parent), notparent)))
####			break
####	}
####	eval(call, sys.frame(-i))
##	eval(call, sys.frame(sys.parent()))
##}

model.frame.glm <-
    function (formula, data, na.action, ...)
{
    if (is.null(formula$model)) {
	fcall <- formula$call
	fcall$method <- "model.frame"
	fcall[[1]] <- as.name("glm")
	eval(fcall, sys.frame(sys.parent()))
    }
    else formula$model
}
###- FIXME --- This is UGLY :  a lot of coding is just doubled from  ./glm.R --

anova.glm.null <- function (object, ..., test = NULL, na.action = na.omit)
{
    ## check for multiple objects
    if (length(list(object, ...)) > 1)
	return(anova.glmlist(list(object, ...), test = test))
    ## extract variables from model
    varlist <- attr(object$terms, "variables")
    nvars <- 0
    resdev <- resdf <- NULL
    ## if there is more than one explanatory variable then
    ## recall glm.fit to fit variables sequentially
    ## add values from null and full model
    resdf <- c(object$df.null)
    resdev <- c(object$null.deviance)
    ## construct table and title
    table <- data.frame(c(NA), c(NA), resdf, resdev)
    dimnames(table) <- list(c("NULL", attr(object$terms, "term.labels")),
                            c("Df", "Deviance", "Resid. Df", "Resid. Dev"))
    title <- paste("Analysis of Deviance Table", "\n\nModel: ",
		   object$family$family, ", link: ", object$family$link,
		   "\n\nResponse: ", as.character(varlist[-1])[1],
		   "\n\nTerms added sequentially (first to last)\n\n",
		   sep = "")
    ## calculate test statistics if needed
    ## return output
    if (!is.null(test))
	table <- stat.anova(table = table, test = test,
			    scale = sum(object$weights * object$residuals^2)/
                            	object$df.residual,
			    df.scale = object$df.residual, n = NROW(x))
    output <- list(title = title, table = table)
    class(output) <- c("anova.glm.null", "anova.glm")
    return(output)
}
print.glm.null <- function(x, digits = max(3, .Options$digits - 3),
                           na.print = "", ...)
{
    cat("\nCall: ", deparse(x$call), "\n\n")
    cat("No coefficients\n")
    cat("\nDegrees of Freedom:", length(x$residuals), "Total;",
	x$df.residual, "Residual\n")
    cat("Null Deviance:", format(signif(x$null.deviance, digits)), "\n")
    cat("Residual Deviance:", format(signif(x$deviance, digits)), "\t")
    cat("AIC:", format(signif(x$aic, digits)), "\n")
    invisible(x)
}
print.summary.glm.null <- function (x, digits = max(3, .Options$digits - 3),
                                    na.print = "", ...)
{
    cat("\nCall:\n")
    cat(paste(deparse(x$call), sep = "\n", collapse = "\n"),
	"\n\n", sep = "")
    cat("Deviance Residuals: \n")
    if (x$df.residual > 5) {
	x$deviance.resid <- quantile(x$deviance.resid)
	names(x$deviance.resid) <- c("Min", "1Q", "Median",
				     "3Q", "Max")
    }
    print.default(x$deviance.resid, digits = digits, na = "", print.gap = 2)
    cat("\nNo coefficients\n")
    cat(paste("\n(Dispersion parameter for ", x$family$family,
	      " family taken to be ", x$dispersion, ")\n\n    Null deviance: ",
	      x$null.deviance, " on ", x$df.null, " degrees of freedom\n\n",
	      "Residual deviance: ", x$deviance, " on ", x$df.residual,
	      " degrees of freedom\n\n", "Number of Fisher Scoring iterations: ",
	      x$iter, "\n\n", sep = ""))
    invisible(x)
}
summary.glm.null <- function (object, dispersion = NULL, correlation = TRUE,
                              na.action = na.omit, ...)
{
    ## calculate dispersion if needed
    ## extract x to get column names
    ## calculate scaled and unscaled covariance matrix
    if (is.null(dispersion)) {
	if (any(object$family$family == c("poisson",
		"binomial")))
	    dispersion <- 1
	else {
	    if (any(object$weights == 0))
		warning(paste("observations with zero weight",
			      "not used for calculating dispersion"))
	    dispersion <- sum(object$weights * object$residuals^2)/
                object$df.residual
	}
    }
    p <- 0
    ## return answer
    ans <- list(call = object$call, terms = object$terms,
		family = object$family,
                deviance.resid = residuals(object, type = "deviance"),
                dispersion= dispersion, df = c(object$rank,object$df.residual),
                deviance = object$deviance, df.residual = object$df.residual,
                null.deviance = object$null.deviance,
		df.null = object$df.null, iter = object$iter,
		)
    class(ans) <- c("summary.glm.null", "summary.glm")
    return(ans)
}
glm.fit.null <- function (x, y, weights = rep(1, nobs), start = NULL,
                          offset = rep(0, nobs), family = gaussian(),
                          control = glm.control(), intercept = FALSE)
{
    if(intercept) stop("null models have no intercept")
    ynames <- names(y)
    conv <- TRUE
    nobs <- NROW(y)
    nvars <- NCOL(x)
    ## define weights and offset if needed
    ## get family functions
    if (is.null(weights))
	weights <- rep(1, nobs)
    if (is.null(offset))
	offset <- rep(0, nobs)
    variance <- family$variance
    dev.resids <- family$dev.resids
    linkinv <- family$linkinv
    mu.eta <- family$mu.eta
    valideta <- family$valideta
    if (is.null(valideta))
	valideta <- function(eta) TRUE
    validmu <- family$validmu
    if (is.null(validmu))
	validmu <- function(mu) TRUE
    eta <- rep(0, nobs)
    if (!valideta(eta + offset))
	stop("Invalid linear predictor values in empty model")
    mu <- linkinv(eta + offset)
    ## calculate initial deviance and coefficient
    if (!validmu(mu))
	stop("Invalid fitted means in empty model")
    dev <- sum(dev.resids(y, mu, weights))
    w <- ((weights * mu.eta(eta + offset)^2)/variance(mu))^0.5
    ##	residuals[good] <- z - eta
    residuals <- (y - mu)/mu.eta(eta + offset)
    ## name output
    names(residuals) <- ynames
    names(mu) <- ynames
    names(eta) <- ynames
    names(w) <- ynames
    names(weights) <- ynames
    names(y) <- ynames
    ## calculate null deviance
    wtdmu <- linkinv(offset)
    nulldev <- sum(dev.resids(y, wtdmu, weights))
    ## calculate df
    resdf <- nulldf <- n.ok <- nobs - sum(weights==0)
    aic.model <- family$aic(y, n, mu, weights, dev)
    return(list(coefficients = numeric(0), residuals = residuals,
		fitted.values = mu, rank = 0, family = family,
		linear.predictors = eta + offset, deviance = dev,
		aic = aic.model,
		null.deviance = nulldev, iter = 0, weights = w^2,
		prior.weights = weights, df.residual = resdf,
		df.null = nulldf, y = y, converged = conv, boundary = FALSE))
}
model.matrix.glm.null<-function(x,...){
  rval<-matrix(ncol=0,nrow=length(object$y))
  attr(rval,"assign")<-integer(0)
}
grep <-
    function(pattern, x, ignore.case=FALSE, extended=TRUE, value=FALSE)
{
    .Internal(grep(pattern, x, ignore.case, extended, value))
}

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

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

regexpr <- function(pattern, text, extended=TRUE)
{
    .Internal(regexpr(pattern, text, extended))
}
grid <- function (nx=NULL, ny=NULL, col="lightgray", lty="dotted")
{
    if (is.null(nx)|| nx >= 1) {
        axp <- par("xaxp")
        if(is.null(nx)) nx <- axp[3]
	abline(v = seq(axp[1],axp[2],len=1+nx), col = col, lty = lty)
    }
    if (is.null(ny)|| ny >= 1) {
        axp <- par("yaxp")
        if(is.null(ny)) ny <- axp[3]
	abline(h = seq(axp[1],axp[2],len=1+ny), col = col, lty = lty)
    }
}
###-- NOTE: This is for  NON-Windows only  (cf. windows/help.R )

index.search <- function(topic, path, file="AnIndex", type="help")
    .Internal(index.search(topic, path, file, .Platform$file.sep, type))

help <-
    function (topic, offline = FALSE, package = c(.packages(), .Autoloaded),
              lib.loc = .lib.loc, verbose = .Options$verbose,
              htmlhelp = .Options$htmlhelp)
{
    htmlhelp <- is.logical(htmlhelp) && htmlhelp
    if (!missing(package))
        if (is.name(y <- substitute(package)))
            package <- as.character(y)
    if (!missing(topic)) {
        topic <- substitute(topic)
        if (is.name(topic))
            topic <- as.character(topic)
        else if (!is.character(topic))
            stop("Unimplemented help feature")
        # for cmd/help ..
        if (!is.na(match(topic, c("+", "-", "*", "/", "^", "%%"))))
            topic <- "Arithmetic"
        else if (!is.na(match(topic, c("<", ">", "<=", ">=", "==", "!="))))
            topic <- "Comparison"
        else if (!is.na(match(topic, c("[", "[[", "$"))))
            topic <- "Extract"
        else if (!is.na(match(topic, c("&", "&&", "|", "||", "!"))))
            topic <- "Logic"
        else if (!is.na(match(topic, c("%*%"))))
            topic <- "matmult"
        type <- if(offline) "latex" else if (htmlhelp) "html" else "help"
        INDICES <- system.file(pkg=package, lib=lib.loc)
        file <- index.search(topic, INDICES, "AnIndex", type)
        if (length(file) && file != "") {
            if (verbose)
                cat("\t\t\t\t\t\tHelp file name `", sub(".*/", "", file),
                    ".Rd'\n", sep = "")
            if (!offline) {
                if (htmlhelp) {
                    if(file.exists(file)) {
                        file <- paste("file:", file, sep="")
                        if (is.null(.Options$browser))
                            stop("options(\"browser\") not set")
                        browser <- .Options$browser
                        system(paste(browser, " -remote \"openURL(",
                                     file, ")\" 2>/dev/null || ", browser, " ",
                                     file, " &", sep = ""))
                        cat("help() for",topic, " is shown in browser",browser,
                            "...\nUse\t help(",topic,", htmlhelp=FALSE)\nor\t",
                            "options(htmlhelp = FALSE)\nto revert.\n")
                        return(invisible())
                    } else {
                        if(verbose)
                            cat("no HTML help for `", topic,
                                "' is available\n", sep = "")
                        file <- index.search(topic, INDICES, "AnIndex", "help")
                    }
                }
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                ## end of experimental code
                if(file.exists(zfile))
                    file.show(zfile,
                              ##header= paste("Help for `", topic, "'", sep=""),
                              delete.file = (zfile!=file))
                else
                    stop(paste("The help file for `", topic, "' is missing",
                               sep = ""))
                return(invisible())
            }
            else {
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                if(zfile != file) on.exit(unlink(zfile))
                ## end of experimental code
                if(file.exists(zfile)) {
                    FILE <- tempfile()
                    on.exit(unlink(FILE))
                    cat("\\documentclass[", .Options$papersize, "paper]{article}\n",
                        file = FILE, sep = "")
                    file.append(FILE,
                                file.path(R.home(), "doc", "manual", "Rd.sty"))
                    cat("\\InputIfFileExists{Rhelp.cfg}{}{}\n\\begin{document}\n",
                        file = FILE, append = TRUE)
                    file.append(FILE, zfile)
                    cat("\\end{document}\n", file = FILE, append = TRUE)
                    system(paste(file.path(R.home(), "bin", "help"),
                                 "PRINT", FILE, topic,
                                 .Options$latexcmd, .Options$dvipscmd)
                           )
                    return(invisible())
                }
                else
                    stop(paste("No offline documentation for", topic, "is available"))
            }
        }
        else
            stop(paste("No documentation for `", topic, "'", sep = ""))
    }
    else if (!missing(package))
        library(help = package, lib = lib.loc, character.only = TRUE)
    else if (!missing(lib.loc))
        library(lib = lib.loc)
    else help("help", package = "base", lib.loc = .Library)
}
help.search <- function(topic, fields = c("name", "title"),
                        apropos, keyword, whatis, ignore.case = TRUE,
                        packages = NULL, lib.loc = .lib.loc,
                        help.db = .Options$help.db,
                        verbose = .Options$verbose,
                        rebuild = FALSE) {
    TABLE <- c("name", "alias", "title", "keyword")
    if (!missing(topic)) {
        if (!is.character(topic) || (length(topic) > 1))
            stop("`topic' must be a single character string")
        i <- pmatch(fields, TABLE)
        if (any(is.na(i)))
            stop("incorrect field specification")
        else
            fields <- TABLE[i]
    } else if (!missing(apropos)) {
        if (!is.character(apropos) || (length(apropos) > 1))
            stop("`apropos' must be a single character string")
        else {
            topic <- apropos
            fields <- c("name", "title")
        }
    } else if (!missing(keyword)) {
        if (!is.character(keyword) || (length(keyword) > 1))
            stop("`keyword' must be a single character string")
        else {
            topic <- keyword
            fields <- "keyword"
        }
    } else if (!missing(whatis)) {
        if (!is.character(whatis) || (length(whatis) > 1))
            stop("`whatis' must be a single character string")
        else {
            topic <- whatis
            fields <- "name"
        }
    } else {
        stop("don't know what to search")
    }

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

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

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

    ## Output
    fields <- paste(fields, collapse = " or ")
    if (NROW(db) > 0) {
        FILE <- tempfile()
        cat(paste("Objects with ", fields, " matching `", topic,
                  "':\n\n", sep = ""),
            file = FILE)
        dbnam <- paste(db[ , "name"], "(", db[, "pkg"], ")", sep = "")
        dbtit <- paste(db[ , "title"], sep = "")
        cat(paste(format(dbnam), dbtit, sep = "   "),
            sep = "\n", file = FILE, append = TRUE)
        file.show(FILE, delete.file = TRUE)
    } else {
        cat(paste("No objects found with ", fields, " matching `",
                  topic, "'\n", sep = ""))
    }

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

hist.default <-
    function (x, breaks, freq= NULL, probability = !freq, include.lowest= TRUE,
	      right=TRUE, col = NULL, border = par("fg"),
	      main = paste("Histogram of" , deparse(substitute(x))),
	      xlim = range(breaks), ylim = range(y, 0),
	      xlab = deparse(substitute(x)), ylab,
	      axes = TRUE, plot = TRUE, labels = FALSE, nclass = NULL, ...)
{
    if (!is.numeric(x))
	stop("hist: x must be numeric")
    main # eval() now: defeat lazy eval
    xlab
    n <- length(x <- x[!is.na(x)])
    use.br <- !missing(breaks)
    if(use.br) {
	if(!missing(nclass))
	    warning("`nclass' not used when `breaks' specified")
    }
    else if(!is.null(nclass) && length(nclass) == 1)
	breaks <- nclass
    use.br <- use.br && (nB <- length(breaks)) > 1
    if(use.br)
	breaks <- sort(breaks)
    else { # construct vector of breaks
	rx <- range(x)
	nnb <-
	    if(missing(breaks)) 1 + log2(n)
	    else { # breaks = `nclass'
		if (is.na(breaks) | breaks < 2)
		    stop("invalid number of breaks")
		breaks
	    }
	breaks <- pretty (rx, n = nnb, min.n=1, eps.corr = 2)
	nB <- length(breaks)
	if(nB <= 1) { ##-- Impossible !
	    stop(paste("hist.default: pretty() error, breaks=",format(breaks)))
	}
    }
    storage.mode(x) <- "double"
    storage.mode(breaks) <- "double"
    counts <- .C("bincount",
		 x,
		 n,
		 breaks,
		 nB,
		 counts = integer(nB - 1),
		 right	= as.logical(right),
		 include= as.logical(include.lowest),
		 NAOK = FALSE, DUP = FALSE, PACKAGE = "base") $counts
    if (any(counts < 0))
	stop("negative `counts'. Internal Error in C-code for \"bincount\"")
    if (sum(counts) < n)
	stop("some `x' not counted; maybe `breaks' do not span range of `x'")
    h <- diff(breaks)
    if (!use.br && any(h <= 0))
	stop("not strictly increasing `breaks'.")
    if (is.null(freq)) {
	freq <- if(!missing(probability))
	    !as.logical(probability)
	else if(use.br) {
	    ##-- Do frequencies if breaks are evenly spaced
	    max(h)-min(h) < 1e-7 * mean(h)
	} else TRUE
    } else if(!missing(probability) && any(probability == freq))
	stop("`probability is an alias for `!freq', however they differ.")
    intensities <- counts/(n*h)
    mids <- 0.5 * (breaks[-1] + breaks[-nB])
    y <- if (freq) counts else intensities
    r <- list(breaks = breaks, counts = counts,
	      intensities = intensities, mids = mids)
    if (plot) {
	plot.new()
	plot.window(xlim, ylim, "") #-> ylim's default from 'y'
	if (missing(ylab))
	    ylab <- paste(if(!freq)"Relative ", "Frequency", sep="")
	if(freq && use.br && max(h)-min(h) > 1e-7 * mean(h))
	    warning("the AREAS in the plot are wrong -- maybe use `freq=FALSE'")
	title(main = main, xlab = xlab, ylab = ylab, ...)
	if(axes) {
	    axis(1, ...)
	    axis(2, ...)
	}
	rect(breaks[-nB], 0, breaks[-1], y,
	     col = col, border = border)
	if(labels)
	    text(mids, y,
		 labels = if(freq) counts else round(intensities,3),
		 adj = c(0.5, -0.5))
	invisible(r)
    }
    else r
}
print.htest <- function(x, digits = 4, quote = TRUE, prefix = "", ...)
{
    cat("\n\t", x$method, "\n\n")
    cat("data: ", x$data.name, "\n")
    if(!is.null(x$statistic))
	cat(names(x$statistic), " = ", format(round(x$statistic, 4)),
	    ", ", sep = "")
    if(!is.null (x$parameter))
	cat(paste(names(x$parameter), " = ", format(round(x$parameter, 3)),
                  ",", sep = ""), "")
    cat("p-value =", format.pval(x$p.value, digits= digits), "\n")
    if(!is.null(x$alternative)) {
	if(!is.null(x$null.value)) {
	    if(length(x$null.value) == 1) {
		if (x$alternative == "two.sided" )
		    alt.char <- "not equal to"
		else if( x$alternative == "less" )
		    alt.char <- "less than"
		else if( x$alternative == "greater" )
		    alt.char <- "greater than"
		cat("alternative hypothesis:", "true", names(x$null.value),
                    "is", alt.char, x$null.value, "\n")
	    }
	    else {
		cat("alternative hypothesis:", x$alternative, "\n")
		cat("null values:\n")
		print(x$null.value, ...)
	    }
	}
	else cat("alternative hypothesis:", x$alternative, "\n")
    }
    if(!is.null(x$conf.int)) {
	cat(format(100 * attr(x$conf.int, "conf.level")),
	    "percent confidence interval:\n",
            format(c(x$conf.int[1], x$conf.int[2])), "\n")
    }
    if(!is.null(x$estimate)) {
	cat("sample estimates:\n")
	print(x$estimate, ...)
    }
    cat("\n")
    invisible(x)
}
identify <- function(x, ...) UseMethod("identify")

identify.default <- function(x, y=NULL, labels=seq(along=x), pos=FALSE,
			     n=length(x), plot=TRUE, offset=0.5, ...)
{
    opar <- par(list(...))
    on.exit(par(opar))
    xy <- xy.coords(x, y)
    z <- .Internal(identify(xy$x, xy$y, as.character(labels),
			    n, plot, offset))
    i <- seq(z[[1]])[z[[1]]]
    if(pos) list(ind= i, pos= z[[2]][z[[1]]]) else i
}
ifelse <-
    function (test, yes, no)
{
    ans <- test
    test <- as.logical(test)
    nas <- is.na(test)
    if (any(test[!nas])) {
        ans[test] <- rep(yes, length = length(ans))[test]
    }
    if (any(!test[!nas])) {
        ans[!test] <- rep(no, length = length(ans))[!test]
    }
    ans[nas] <- NA
    ans
}
image <- function (x = seq(0, 1, len = nrow(z)),
		   y = seq(0, 1, len = ncol(z)),
		   z,
		   zlim = range(z[is.finite(z)]),
		   xlim = range(x[is.finite(x)]),
		   ylim = range(y[is.finite(y)]),
		   col = heat.colors(12), add = FALSE,
		   xaxs = "i", yaxs = "i", xlab, ylab, ...)
{
    if (missing(z)) {
	if (!missing(x)) {
	    if (is.list(x)) {
		z <- x$z; y <- x$y; x <- x$x
	    } else {
		if(is.null(dim(x)))
		   stop("argument must be matrix alike")
		z <- x
		x <- seq(0, 1, len = nrow(z))
	    }
	    if (missing(xlab)) xlab <- ""
	    if (missing(ylab)) ylab <- ""
	} else stop("no `z' matrix specified")
    } else if (is.list(x)) {
	xn <- deparse(substitute(x))
	if (missing(xlab)) xlab <- paste(xn, "x", sep = "$")
	if (missing(ylab)) ylab <- paste(xn, "y", sep = "$")
	y <- x$y
	x <- x$x
    } else {
	if (missing(xlab))
	    xlab <- if (missing(x)) "" else deparse(substitute(x))
	if (missing(ylab))
	    ylab <- if (missing(y)) "" else deparse(substitute(y))
    }
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
	stop("increasing x and y values expected")
    if (!is.matrix(z))
        stop("`z' must be a matrix")
    if(length(x) > 1 && length(x) == e(substi, ny=NULL, col="lightgray", lty="dotted")
{
    if (is.null(nx)|| nx >= 1) {
        axp <- par("xaxp")
        if(is.null(nx)) nx <- axp[3]
	abline(v = seq(axp[1],axp[2],len=1+nx), col = col, lty = lty)
    }
    if (is.null(ny)|| ny >= 1) {
        axp <- par("yaxp")
        if(is.null(ny)) ny <- axp[3]
	abline(h = seq(axp[1],axp[2],len=1+ny), col = col, lty = lty)
    }
}
###-- NOTE: This is for  NON-Windows only  (cf. windows/help.R )

index.search <- function(topic, path, file="AnIndex", type="help")
    .Internal(index.search(topic, path, file, .Platform$file.sep, type))

help <-
    function (topic, offline = FALSE, package = c(.packages(), .Autoloaded),
              lib.loc = .lib.loc, verbose = .Options$verbose,
              htmlhelp = .Options$htmlhelp)
{
    htmlhelp <- is.logical(htmlhelp) && htmlhelp
    if (!missing(package))
        if (is.name(y <- substitute(package)))
            package <- as.character(y)
    if (!missing(topic)) {
        topic <- substitute(topic)
        if (is.name(topic))
            topic <- as.character(topic)
        else if (!is.character(topic))
            stop("Unimplemented help feature")
        # for cmd/help ..
        if (!is.na(match(topic, c("+", "-", "*", "/", "^", "%%"))))
            topic <- "Arithmetic"
        else if (!is.na(match(topic, c("<", ">", "<=", ">=", "==", "!="))))
            topic <- "Comparison"
        else if (!is.na(match(topic, c("[", "[[", "$"))))
            topic <- "Extract"
        else if (!is.na(match(topic, c("&", "&&", "|", "||", "!"))))
            topic <- "Logic"
        else if (!is.na(match(topic, c("%*%"))))
            topic <- "matmult"
        type <- if(offline) "latex" else if (htmlhelp) "html" else "help"
        INDICES <- system.file(pkg=package, lib=lib.loc)
        file <- index.search(topic, INDICES, "AnIndex", type)
        if (length(file) && file != "") {
            if (verbose)
                cat("\t\t\t\t\t\tHelp file name `", sub(".*/", "", file),
                    ".Rd'\n", sep = "")
            if (!offline) {
                if (htmlhelp) {
                    if(file.exists(file)) {
                        file <- paste("file:", file, sep="")
                        if (is.null(.Options$browser))
                            stop("options(\"browser\") not set")
                        browser <- .Options$browser
                        system(paste(browser, " -remote \"openURL(",
                                     file, ")\" 2>/dev/null || ", browser, " ",
                                     file, " &", sep = ""))
                        cat("help() for",topic, " is shown in browser",browser,
                            "...\nUse\t help(",topic,", htmlhelp=FALSE)\nor\t",
                            "options(htmlhelp = FALSE)\nto revert.\n")
                        return(invisible())
                    } else {
                        if(verbose)
                            cat("no HTML help for `", topic,
                                "' is available\n", sep = "")
                        file <- index.search(topic, INDICES, "AnIndex", "help")
                    }
                }
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                ## end of experimental code
                if(file.exists(zfile))
                    file.show(zfile,
                              ##header= paste("Help for `", topic, "'", sep=""),
                              delete.file = (zfile!=file))
                else
                    stop(paste("The help file for `", topic, "' is missing",
                               sep = ""))
                return(invisible())
            }
            else {
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                if(zfile != file) on.exit(unlink(zfile))
                ## end of experimental code
                if(file.exists(zfile)) {
                    FILE <- tempfile()
                    on.exit(unlink(FILE))
                    cat("\\documentclass[", .Options$papersize, "paper]{article}\n",
                        file = FILE, sep = "")
                    file.append(FILE,
                                file.path(R.home(), "doc", "manual", "Rd.sty"))
                    cat("\\InputIfFileExists{Rhelp.cfg}{}{}\n\\begin{document}\n",
                        file = FILE, append = TRUE)
                    file.append(FILE, zfile)
                    cat("\\end{document}\n", file = FILE, append = TRUE)
                    system(paste(file.path(R.home(), "bin", "help"),
                                 "PRINT", FILE, topic,
                                 .Options$latexcmd, .Options$dvipscmd)
                           )
                    return(invisible())
                }
                else
                    stop(paste("No offline documentation for", topic, "is available"))
            }
        }
        else
            stop(paste("No documentation for `", topic, "'", sep = ""))
    }
    else if (!missing(package))
        library(help = package, lib = lib.loc, character.only = TRUE)
    else if (!missing(lib.loc))
        library(lib = lib.loc)
    else help("help", package = "base", lib.loc = .Library)
}
help.search <- function(topic, fields = c("name", "title"),
                        apropos, keyword, whatis, ignore.case = TRUE,
                        packages = NULL, lib.loc = .lib.loc,
                        help.db = .Options$help.db,
                        verbose = .Options$verbose,
                        rebuild = FALSE) {
    TABLE <- c("name", "alias", "title", "keyword")
    if (!missing(topic)) {
        if (!is.character(topic) || (length(topic) > 1))
            stop("`topic' must be a single character string")
        i <- pmatch(fields, TABLE)
        if (any(is.na(i)))
            stop("incorrect field specification")
        else
            fields <- TABLE[i]
    } else if (!missing(apropos)) {
        if (!is.character(apropos) || (length(apropos) > 1))
            stop("`apropos' must be a single character string")
        else {
            topic <- apropos
            fields <- c("name", "title")
        }
    } else if (!missing(keyword)) {
        if (!is.character(keyword) || (length(keyword) > 1))
            stop("`keyword' must be a single character string")
        else {
            topic <- keyword
            fields <- "keyword"
        }
    } else if (!missing(whatis)) {
        if (!is.character(whatis) || (length(whatis) > 1))
            stop("`whatis' must be a single character string")
        else {
            topic <- whatis
            fields <- "name"
        }
    } else {
        stop("don't know what to search")
    }

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

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

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

    ## Output
    fields <- paste(fields, collapse = " or ")
    if (NROW(db) > 0) {
        FILE <- tempfile()
        cat(paste("Objects with ", fields, " matching `", topic,
                  "':\n\n", sep = ""),
            file = FILE)
        dbnam <- paste(db[ , "name"], "(", db[, "pkg"], ")", sep = "")
        dbtit <- paste(db[ , "title"], sep = "")
        cat(paste(format(dbnam), dbtit, sep = "   "),
            sep = "\n", file = FILE, append = TRUE)
        file.show(FILE, delete.file = TRUE)
    } else {
        cat(paste("No objects found with ", fields, " matching `",
                  topic, "'\n", sep = ""))
    }

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

hist.default <-
    function (x, breaks, freq= NULL, probability = !freq, include.lowest= TRUE,
	      right=TRUE, col = NULL, border = par("fg"),
	      main = paste("Histogram of" , deparse(substitute(x))),
	      xlim = range(breaks), ylim = range(y, 0),
	      xlab = deparse(substitute(x)), ylab,
	      axes = TRUE, plot = TRUE, labels = FALSE, nclass = NULL, ...)
{
    if (!is.numeric(x))
	stop("hist: x must be numeric")
    main # eval() now: defeat lazy eval
    xlab
    n <- length(x <- x[!is.na(x)])
    use.br <- !missing(breaks)
    if(use.br) {
	if(!missing(nclass))
	    warning("`nclass' not used when `breaks' specified")
    }
    else if(!is.null(nclass) && length(nclass) == 1)
	breaks <- nclass
    use.br <- use.br && (nB <- length(breaks)) > 1
    if(use.br)
	breaks <- sort(breaks)
    else { # construct vector of breaks
	rx <- range(x)
	nnb <-
	    if(missing(breaks)) 1 + log2(n)
	    else { # breaks = `nclass'
		if (is.na(breaks) | breaks < 2)
		    stop("invalid number of breaks")
		breaks
	    }
	breaks <- pretty (rx, n = nnb, min.n=1, eps.corr = 2)
	nB <- length(breaks)
	if(nB <= 1) { ##-- Impossible !
	    stop(paste("hist.default: pretty() error, breaks=",format(breaks)))
	}
    }
    storage.mode(x) <- "double"
    storage.mode(breaks) <- "double"
    counts <- .C("bincount",
		 x,
		 n,
		 breaks,
		 nB,
		 counts = integer(nB - 1),
		 right	= as.logical(right),
		 include= as.logical(include.lowest),
		 NAOK = FALSE, DUP = FALSE, PACKAGE = "base") $counts
    if (any(counts < 0))
	stop("negative `counts'. Internal Error in C-code for \"bincount\"")
    if (sum(counts) < n)
	stop("some `x' not counted; maybe `breaks' do not span range of `x'")
    h <- diff(breaks)
    if (!use.br && any(h <= 0))
	stop("not strictly increasing `breaks'.")
    if (is.null(freq)) {
	freq <- if(!missing(probability))
	    !as.logical(probability)
	else if(use.br) {
	    ##-- Do frequencies if breaks are evenly spaced
	    max(h)-min(h) < 1e-7 * mean(h)
	} else TRUE
    } else if(!missing(probability) && any(probability == freq))
	stop("`probability is an alias for `!freq', however they differ.")
    intensities <- counts/(n*h)
    mids <- 0.5 * (breaks[-1] + breaks[-nB])
    y <- if (freq) counts else intensities
    r <- list(breaks = breaks, counts = counts,
	      intensities = intensities, mids = mids)
    if (plot) {
	plot.new()
	plot.window(xlim, ylim, "") #-> ylim's default from 'y'
	if (missing(ylab))
	    ylab <- paste(if(!freq)"Relative ", "Frequency", sep="")
	if(freq && use.br && max(h)-min(h) > 1e-7 * mean(h))
	    warning("the AREAS in the plot are wrong -- maybe use `freq=FALSE'")
	title(main = main, xlab = xlab, ylab = ylab, ...)
	if(axes) {
	    axis(1, ...)
	    axis(2, ...)
	}
	rect(breaks[-nB], 0, breaks[-1], y,
	     col = col, border = border)
	if(labels)
	    text(mids, y,
		 labels = if(freq) counts else round(intensities,3),
		 adj = c(0.5, -0.5))
	invisible(r)
    }
    else r
}
print.htest <- function(x, digits = 4, quote = TRUE, prefix = "", ...)
{
    cat("\n\t", x$method, "\n\n")
    cat("data: ", x$data.name, "\n")
    if(!is.null(x$statistic))
	cat(names(x$statistic), " = ", format(round(x$statistic, 4)),
	    ", ", sep = "")
    if(!is.null (x$parameter))
	cat(paste(names(x$parameter), " = ", format(round(x$parameter, 3)),
                  ",", sep = ""), "")
    cat("p-value =", format.pval(x$p.value, digits= digits), "\n")
    if(!is.null(x$alternative)) {
	if(!is.null(x$null.value)) {
	    if(length(x$null.value) == 1) {
		if (x$alternative == "two.sided" )
		    alt.char <- "not equal to"
		else if( x$alternative == "less" )
		    alt.char <- "less than"
		else if( x$alternative == "greater" )
		    alt.char <- "greater than"
		cat("alternative hypothesis:", "true", names(x$null.value),
                    "is", alt.char, x$null.value, "\n")
	    }
	    else {
		cat("alternative hypothesis:", x$alternative, "\n")
		cat("null values:\n")
		print(x$null.value, ...)
	    }
	}
	else cat("alternative hypothesis:", x$alternative, "\n")
    }
    if(!is.null(x$conf.int)) {
	cat(format(100 * attr(x$conf.int, "conf.level")),
	    "percent confidence interval:\n",
            format(c(x$conf.int[1], x$conf.int[2])), "\n")
    }
    if(!is.null(x$estimate)) {
	cat("sample estimates:\n")
	print(x$estimate, ...)
    }
    cat("\n")
    invisible(x)
}
identify <- function(x, ...) UseMethod("identify")

identify.default <- function(x, y=NULL, labels=seq(along=x), pos=FALSE,
			     n=length(x), plot=TRUE, offset=0.5, ...)
{
    opar <- par(list(...))
    on.exit(par(opar))
    xy <- xy.coords(x, y)
    z <- .Internal(identify(xy$x, xy$y, as.character(labels),
			    n, plot, offset))
    i <- seq(z[[1]])[z[[1]]]
    if(pos) list(ind= i, pos= z[[2]][z[[1]]]) else i
}
ifelse <-
    function (test, yes, no)
{
    ans <- test
    test <- as.logical(test)
    nas <- is.na(test)
    if (any(test[!nas])) {
        ans[test] <- rep(yes, length = length(ans))[test]
    }
    if (any(!test[!nas])) {
        ans[!test] <- rep(no, length = length(ans))[!test]
    }
    ans[nas] <- NA
    ans
}
image <- function (x = seq(0, 1, len = nrow(z)),
		   y = seq(0, 1, len = ncol(z)),
		   z,
		   zlim = range(z[is.finite(z)]),
		   xlim = range(x[is.finite(x)]),
		   ylim = range(y[is.finite(y)]),
		   col = heat.colors(12), add = FALSE,
		   xaxs = "i", yaxs = "i", xlab, ylab, ...)
{
    if (missing(z)) {
	if (!missing(x)) {
	    if (is.list(x)) {
		z <- x$z; y <- x$y; x <- x$x
	    } else {
		if(is.null(dim(x)))
		   stop("argument must be matrix alike")
		z <- x
		x <- seq(0, 1, len = nrow(z))
	    }
	    if (missing(xlab)) xlab <- ""
	    if (missing(ylab)) ylab <- ""
	} else stop("no `z' matrix specified")
    } else if (is.list(x)) {
	xn <- deparse(substitute(x))
	if (missing(xlab)) xlab <- paste(xn, "x", sep = "$")
	if (missing(ylab)) ylab <- paste(xn, "y", sep = "$")
	y <- x$y
	x <- x$x
    } else {
	if (missing(xlab))
	    xlab <- if (missing(x)) "" else deparse(substitute(x))
	if (missing(ylab))
	    ylab <- if (missing(y)) "" else deparse(substitute(y))
    }
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
	stop("increasing x and y values expected")
    if (!is.matrix(z))
        stop("`z' must be a matrix")
    if(length(x) > 1 && length(x) == e(substi, ny=NULL, col="lightgray", lty="dotted")
{
    if (is.null(nx)|| nx >= 1) {
        axp <- par("xaxp")
        if(is.null(nx)) nx <- axp[3]
	abline(v = seq(axp[1],axp[2],len=1+nx), col = col, lty = lty)
    }
    if (is.null(ny)|| ny >= 1) {
        axp <- par("yaxp")
        if(is.null(ny)) ny <- axp[3]
	abline(h = seq(axp[1],axp[2],len=1+ny), col = col, lty = lty)
    }
}
###-- NOTE: This is for  NON-Windows only  (cf. windows/help.R )

index.search <- function(topic, path, file="AnIndex", type="help")
    .Internal(index.search(topic, path, file, .Platform$file.sep, type))

help <-
    function (topic, offline = FALSE, package = c(.packages(), .Autoloaded),
              lib.loc = .lib.loc, verbose = .Options$verbose,
              htmlhelp = .Options$htmlhelp)
{
    htmlhelp <- is.logical(htmlhelp) && htmlhelp
    if (!missing(package))
        if (is.name(y <- substitute(package)))
            package <- as.character(y)
    if (!missing(topic)) {
        topic <- substitute(topic)
        if (is.name(topic))
            topic <- as.character(topic)
        else if (!is.character(topic))
            stop("Unimplemented help feature")
        # for cmd/help ..
        if (!is.na(match(topic, c("+", "-", "*", "/", "^", "%%"))))
            topic <- "Arithmetic"
        else if (!is.na(match(topic, c("<", ">", "<=", ">=", "==", "!="))))
            topic <- "Comparison"
        else if (!is.na(match(topic, c("[", "[[", "$"))))
            topic <- "Extract"
        else if (!is.na(match(topic, c("&", "&&", "|", "||", "!"))))
            topic <- "Logic"
        else if (!is.na(match(topic, c("%*%"))))
            topic <- "matmult"
        type <- if(offline) "latex" else if (htmlhelp) "html" else "help"
        INDICES <- system.file(pkg=package, lib=lib.loc)
        file <- index.search(topic, INDICES, "AnIndex", type)
        if (length(file) && file != "") {
            if (verbose)
                cat("\t\t\t\t\t\tHelp file name `", sub(".*/", "", file),
                    ".Rd'\n", sep = "")
            if (!offline) {
                if (htmlhelp) {
                    if(file.exists(file)) {
                        file <- paste("file:", file, sep="")
                        if (is.null(.Options$browser))
                            stop("options(\"browser\") not set")
                        browser <- .Options$browser
                        system(paste(browser, " -remote \"openURL(",
                                     file, ")\" 2>/dev/null || ", browser, " ",
                                     file, " &", sep = ""))
                        cat("help() for",topic, " is shown in browser",browser,
                            "...\nUse\t help(",topic,", htmlhelp=FALSE)\nor\t",
                            "options(htmlhelp = FALSE)\nto revert.\n")
                        return(invisible())
                    } else {
                        if(verbose)
                            cat("no HTML help for `", topic,
                                "' is available\n", sep = "")
                        file <- index.search(topic, INDICES, "AnIndex", "help")
                    }
                }
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                ## end of experimental code
                if(file.exists(zfile))
                    file.show(zfile,
                              ##header= paste("Help for `", topic, "'", sep=""),
                              delete.file = (zfile!=file))
                else
                    stop(paste("The help file for `", topic, "' is missing",
                               sep = ""))
                return(invisible())
            }
            else {
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                if(zfile != file) on.exit(unlink(zfile))
                ## end of experimental code
                if(file.exists(zfile)) {
                    FILE <- tempfile()
                    on.exit(unlink(FILE))
                    cat("\\documentclass[", .Options$papersize, "paper]{article}\n",
                        file = FILE, sep = "")
                    file.append(FILE,
                                file.path(R.home(), "doc", "manual", "Rd.sty"))
                    cat("\\InputIfFileExists{Rhelp.cfg}{}{}\n\\begin{document}\n",
                        file = FILE, append = TRUE)
                    file.append(FILE, zfile)
                    cat("\\end{document}\n", file = FILE, append = TRUE)
                    system(paste(file.path(R.home(), "bin", "help"),
                                 "PRINT", FILE, topic,
                                 .Options$latexcmd, .Options$dvipscmd)
                           )
                    return(invisible())
                }
                else
                    stop(paste("No offline documentation for", topic, "is available"))
            }
        }
        else
            stop(paste("No documentation for `", topic, "'", sep = ""))
    }
    else if (!missing(package))
        library(help = package, lib = lib.loc, character.only = TRUE)
    else if (!missing(lib.loc))
        library(lib = lib.loc)
    else help("help", package = "base", lib.loc = .Library)
}
help.search <- function(topic, fields = c("name", "title"),
                        apropos, keyword, whatis, ignore.case = TRUE,
                        packages = NULL, lib.loc = .lib.loc,
                        help.db = .Options$help.db,
                        verbose = .Options$verbose,
                        rebuild = FALSE) {
    TABLE <- c("name", "alias", "title", "keyword")
    if (!missing(topic)) {
        if (!is.character(topic) || (length(topic) > 1))
            stop("`topic' must be a single character string")
        i <- pmatch(fields, TABLE)
        if (any(is.na(i)))
            stop("incorrect field specification")
        else
            fields <- TABLE[i]
    } else if (!missing(apropos)) {
        if (!is.character(apropos) || (length(apropos) > 1))
            stop("`apropos' must be a single character string")
        else {
            topic <- apropos
            fields <- c("name", "title")
        }
    } else if (!missing(keyword)) {
        if (!is.character(keyword) || (length(keyword) > 1))
            stop("`keyword' must be a single character string")
        else {
            topic <- keyword
            fields <- "keyword"
        }
    } else if (!missing(whatis)) {
        if (!is.character(whatis) || (length(whatis) > 1))
            stop("`whatis' must be a single character string")
        else {
            topic <- whatis
            fields <- "name"
        }
    } else {
        stop("don't know what to search")
    }

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

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

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

    ## Output
    fields <- paste(fields, collapse = " or ")
    if (NROW(db) > 0) {
        FILE <- tempfile()
        cat(paste("Objects with ", fields, " matching `", topic,
                  "':\n\n", sep = ""),
            file = FILE)
        dbnam <- paste(db[ , "name"], "(", db[, "pkg"], ")", sep = "")
        dbtit <- paste(db[ , "title"], sep = "")
        cat(paste(format(dbnam), dbtit, sep = "   "),
            sep = "\n", file = FILE, append = TRUE)
        file.show(FILE, delete.file = TRUE)
    } else {
        cat(paste("No objects found with ", fields, " matching `",
                  topic, "'\n", sep = ""))
    }

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

hist.default <-
    function (x, breaks, freq= NULL, probability = !freq, include.lowest= TRUE,
	      right=TRUE, col = NULL, border = par("fg"),
	      main = paste("Histogram of" , deparse(substitute(x))),
	      xlim = range(breaks), ylim = range(y, 0),
	      xlab = deparse(substitute(x)), ylab,
	      axes = TRUE, plot = TRUE, labels = FALSE, nclass = NULL, ...)
{
    if (!is.numeric(x))
	stop("hist: x must be numeric")
    main # eval() now: defeat lazy eval
    xlab
    n <- length(x <- x[!is.na(x)])
    use.br <- !missing(breaks)
    if(use.br) {
	if(!missing(nclass))
	    warning("`nclass' not used when `breaks' specified")
    }
    else if(!is.null(nclass) && length(nclass) == 1)
	breaks <- nclass
    use.br <- use.br && (nB <- length(breaks)) > 1
    if(use.br)
	breaks <- sort(breaks)
    else { # construct vector of breaks
	rx <- range(x)
	nnb <-
	    if(missing(breaks)) 1 + log2(n)
	    else { # breaks = `nclass'
		if (is.na(breaks) | breaks < 2)
		    stop("invalid number of breaks")
		breaks
	    }
	breaks <- pretty (rx, n = nnb, min.n=1, eps.corr = 2)
	nB <- length(breaks)
	if(nB <= 1) { ##-- Impossible !
	    stop(paste("hist.default: pretty() error, breaks=",format(breaks)))
	}
    }
    storage.mode(x) <- "double"
    storage.mode(breaks) <- "double"
    counts <- .C("bincount",
		 x,
		 n,
		 breaks,
		 nB,
		 counts = integer(nB - 1),
		 right	= as.logical(right),
		 include= as.logical(include.lowest),
		 NAOK = FALSE, DUP = FALSE, PACKAGE = "base") $counts
    if (any(counts < 0))
	stop("negative `counts'. Internal Error in C-code for \"bincount\"")
    if (sum(counts) < n)
	stop("some `x' not counted; maybe `breaks' do not span range of `x'")
    h <- diff(breaks)
    if (!use.br && any(h <= 0))
	stop("not strictly increasing `breaks'.")
    if (is.null(freq)) {
	freq <- if(!missing(probability))
	    !as.logical(probability)
	else if(use.br) {
	    ##-- Do frequencies if breaks are evenly spaced
	    max(h)-min(h) < 1e-7 * mean(h)
	} else TRUE
    } else if(!missing(probability) && any(probability == freq))
	stop("`probability is an alias for `!freq', however they differ.")
    intensities <- counts/(n*h)
    mids <- 0.5 * (breaks[-1] + breaks[-nB])
    y <- if (freq) counts else intensities
    r <- list(breaks = breaks, counts = counts,
	      intensities = intensities, mids = mids)
    if (plot) {
	plot.new()
	plot.window(xlim, ylim, "") #-> ylim's default from 'y'
	if (missing(ylab))
	    ylab <- paste(if(!freq)"Relative ", "Frequency", sep="")
	if(freq && use.br && max(h)-min(h) > 1e-7 * mean(h))
	    warning("the AREAS in the plot are wrong -- maybe use `freq=FALSE'")
	title(main = main, xlab = xlab, ylab = ylab, ...)
	if(axes) {
	    axis(1, ...)
	    axis(2, ...)
	}
	rect(breaks[-nB], 0, breaks[-1], y,
	     col = col, border = border)
	if(labels)
	    text(mids, y,
		 labels = if(freq) counts else round(intensities,3),
		 adj = c(0.5, -0.5))
	invisible(r)
    }
    else r
}
print.htest <- function(x, digits = 4, quote = TRUE, prefix = "", ...)
{
    cat("\n\t", x$method, "\n\n")
    cat("data: ", x$data.name, "\n")
    if(!is.null(x$statistic))
	cat(names(x$statistic), " = ", format(round(x$statistic, 4)),
	    ", ", sep = "")
    if(!is.null (x$parameter))
	cat(paste(names(x$parameter), " = ", format(round(x$parameter, 3)),
                  ",", sep = ""), "")
    cat("p-value =", format.pval(x$p.value, digits= digits), "\n")
    if(!is.null(x$alternative)) {
	if(!is.null(x$null.value)) {
	    if(length(x$null.value) == 1) {
		if (x$alternative == "two.sided" )
		    alt.char <- "not equal to"
		else if( x$alternative == "less" )
		    alt.char <- "less than"
		else if( x$alternative == "greater" )
		    alt.char <- "greater than"
		cat("alternative hypothesis:", "true", names(x$null.value),
                    "is", alt.char, x$null.value, "\n")
	    }
	    else {
		cat("alternative hypothesis:", x$alternative, "\n")
		cat("null values:\n")
		print(x$null.value, ...)
	    }
	}
	else cat("alternative hypothesis:", x$alternative, "\n")
    }
    if(!is.null(x$conf.int)) {
	cat(format(100 * attr(x$conf.int, "conf.level")),
	    "percent confidence interval:\n",
            format(c(x$conf.int[1], x$conf.int[2])), "\n")
    }
    if(!is.null(x$estimate)) {
	cat("sample estimates:\n")
	print(x$estimate, ...)
    }
    cat("\n")
    invisible(x)
}
identify <- function(x, ...) UseMethod("identify")

identify.default <- function(x, y=NULL, labels=seq(along=x), pos=FALSE,
			     n=length(x), plot=TRUE, offset=0.5, ...)
{
    opar <- par(list(...))
    on.exit(par(opar))
    xy <- xy.coords(x, y)
    z <- .Internal(identify(xy$x, xy$y, as.character(labels),
			    n, plot, offset))
    i <- seq(z[[1]])[z[[1]]]
    if(pos) list(ind= i, pos= z[[2]][z[[1]]]) else i
}
ifelse <-
    function (test, yes, no)
{
    ans <- test
    test <- as.logical(test)
    nas <- is.na(test)
    if (any(test[!nas])) {
        ans[test] <- rep(yes, length = length(ans))[test]
    }
    if (any(!test[!nas])) {
        ans[!test] <- rep(no, length = length(ans))[!test]
    }
    ans[nas] <- NA
    ans
}
image <- function (x = seq(0, 1, len = nrow(z)),
		   y = seq(0, 1, len = ncol(z)),
		   z,
		   zlim = range(z[is.finite(z)]),
		   xlim = range(x[is.finite(x)]),
		   ylim = range(y[is.finite(y)]),
		   col = heat.colors(12), add = FALSE,
		   xaxs = "i", yaxs = "i", xlab, ylab, ...)
{
    if (missing(z)) {
	if (!missing(x)) {
	    if (is.list(x)) {
		z <- x$z; y <- x$y; x <- x$x
	    } else {
		if(is.null(dim(x)))
		   stop("argument must be matrix alike")
		z <- x
		x <- seq(0, 1, len = nrow(z))
	    }
	    if (missing(xlab)) xlab <- ""
	    if (missing(ylab)) ylab <- ""
	} else stop("no `z' matrix specified")
    } else if (is.list(x)) {
	xn <- deparse(substitute(x))
	if (missing(xlab)) xlab <- paste(xn, "x", sep = "$")
	if (missing(ylab)) ylab <- paste(xn, "y", sep = "$")
	y <- x$y
	x <- x$x
    } else {
	if (missing(xlab))
	    xlab <- if (missing(x)) "" else deparse(substitute(x))
	if (missing(ylab))
	    ylab <- if (missing(y)) "" else deparse(substitute(y))
    }
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
	stop("increasing x and y values expected")
    if (!is.matrix(z))
        stop("`z' must be a matrix")
    if(length(x) > 1 && length(x) == e(substi, ny=NULL, col="lightgray", lty="dotted")
{
    if (is.null(nx)|| nx >= 1) {
        axp <- par("xaxp")
        if(is.null(nx)) nx <- axp[3]
	abline(v = seq(axp[1],axp[2],len=1+nx), col = col, lty = lty)
    }
    if (is.null(ny)|| ny >= 1) {
        axp <- par("yaxp")
        if(is.null(ny)) ny <- axp[3]
	abline(h = seq(axp[1],axp[2],len=1+ny), col = col, lty = lty)
    }
}
###-- NOTE: This is for  NON-Windows only  (cf. windows/help.R )

index.search <- function(topic, path, file="AnIndex", type="help")
    .Internal(index.search(topic, path, file, .Platform$file.sep, type))

help <-
    function (topic, offline = FALSE, package = c(.packages(), .Autoloaded),
              lib.loc = .lib.loc, verbose = .Options$verbose,
              htmlhelp = .Options$htmlhelp)
{
    htmlhelp <- is.logical(htmlhelp) && htmlhelp
    if (!missing(package))
        if (is.name(y <- substitute(package)))
            package <- as.character(y)
    if (!missing(topic)) {
        topic <- substitute(topic)
        if (is.name(topic))
            topic <- as.character(topic)
        else if (!is.character(topic))
            stop("Unimplemented help feature")
        # for cmd/help ..
        if (!is.na(match(topic, c("+", "-", "*", "/", "^", "%%"))))
            topic <- "Arithmetic"
        else if (!is.na(match(topic, c("<", ">", "<=", ">=", "==", "!="))))
            topic <- "Comparison"
        else if (!is.na(match(topic, c("[", "[[", "$"))))
            topic <- "Extract"
        else if (!is.na(match(topic, c("&", "&&", "|", "||", "!"))))
            topic <- "Logic"
        else if (!is.na(match(topic, c("%*%"))))
            topic <- "matmult"
        type <- if(offline) "latex" else if (htmlhelp) "html" else "help"
        INDICES <- system.file(pkg=package, lib=lib.loc)
        file <- index.search(topic, INDICES, "AnIndex", type)
        if (length(file) && file != "") {
            if (verbose)
                cat("\t\t\t\t\t\tHelp file name `", sub(".*/", "", file),
                    ".Rd'\n", sep = "")
            if (!offline) {
                if (htmlhelp) {
                    if(file.exists(file)) {
                        file <- paste("file:", file, sep="")
                        if (is.null(.Options$browser))
                            stop("options(\"browser\") not set")
                        browser <- .Options$browser
                        system(paste(browser, " -remote \"openURL(",
                                     file, ")\" 2>/dev/null || ", browser, " ",
                                     file, " &", sep = ""))
                        cat("help() for",topic, " is shown in browser",browser,
                            "...\nUse\t help(",topic,", htmlhelp=FALSE)\nor\t",
                            "options(htmlhelp = FALSE)\nto revert.\n")
                        return(invisible())
                    } else {
                        if(verbose)
                            cat("no HTML help for `", topic,
                                "' is available\n", sep = "")
                        file <- index.search(topic, INDICES, "AnIndex", "help")
                    }
                }
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                ## end of experimental code
                if(file.exists(zfile))
                    file.show(zfile,
                              ##header= paste("Help for `", topic, "'", sep=""),
                              delete.file = (zfile!=file))
                else
                    stop(paste("The help file for `", topic, "' is missing",
                               sep = ""))
                return(invisible())
            }
            else {
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                if(zfile != file) on.exit(unlink(zfile))
                ## end of experimental code
                if(file.exists(zfile)) {
                    FILE <- tempfile()
                    on.exit(unlink(FILE))
                    cat("\\documentclass[", .Options$papersize, "paper]{article}\n",
                        file = FILE, sep = "")
                    file.append(FILE,
                                file.path(R.home(), "doc", "manual", "Rd.sty"))
                    cat("\\InputIfFileExists{Rhelp.cfg}{}{}\n\\begin{document}\n",
                        file = FILE, append = TRUE)
                    file.append(FILE, zfile)
                    cat("\\end{document}\n", file = FILE, append = TRUE)
                    system(paste(file.path(R.home(), "bin", "help"),
                                 "PRINT", FILE, topic,
                                 .Options$latexcmd, .Options$dvipscmd)
                           )
                    return(invisible())
                }
                else
                    stop(paste("No offline documentation for", topic, "is available"))
            }
        }
        else
            stop(paste("No documentation for `", topic, "'", sep = ""))
    }
    else if (!missing(package))
        library(help = package, lib = lib.loc, character.only = TRUE)
    else if (!missing(lib.loc))
        library(lib = lib.loc)
    else help("help", package = "base", lib.loc = .Library)
}
help.search <- function(topic, fields = c("name", "title"),
                        apropos, keyword, whatis, ignore.case = TRUE,
                        packages = NULL, lib.loc = .lib.loc,
                        help.db = .Options$help.db,
                        verbose = .Options$verbose,
                        rebuild = FALSE) {
    TABLE <- c("name", "alias", "title", "keyword")
    if (!missing(topic)) {
        if (!is.character(topic) || (length(topic) > 1))
            stop("`topic' must be a single character string")
        i <- pmatch(fields, TABLE)
        if (any(is.na(i)))
            stop("incorrect field specification")
        else
            fields <- TABLE[i]
    } else if (!missing(apropos)) {
        if (!is.character(apropos) || (length(apropos) > 1))
            stop("`apropos' must be a single character string")
        else {
            topic <- apropos
            fields <- c("name", "title")
        }
    } else if (!missing(keyword)) {
        if (!is.character(keyword) || (length(keyword) > 1))
            stop("`keyword' must be a single character string")
        else {
            topic <- keyword
            fields <- "keyword"
        }
    } else if (!missing(whatis)) {
        if (!is.character(whatis) || (length(whatis) > 1))
            stop("`whatis' must be a single character string")
        else {
            topic <- whatis
            fields <- "name"
        }
    } else {
        stop("don't know what to search")
    }

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

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

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

    ## Output
    fields <- paste(fields, collapse = " or ")
    if (NROW(db) > 0) {
        FILE <- tempfile()
        cat(paste("Objects with ", fields, " matching `", topic,
                  "':\n\n", sep = ""),
            file = FILE)
        dbnam <- paste(db[ , "name"], "(", db[, "pkg"], ")", sep = "")
        dbtit <- paste(db[ , "title"], sep = "")
        cat(paste(format(dbnam), dbtit, sep = "   "),
            sep = "\n", file = FILE, append = TRUE)
        file.show(FILE, delete.file = TRUE)
    } else {
        cat(paste("No objects found with ", fields, " matching `",
                  topic, "'\n", sep = ""))
    }

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

hist.default <-
    function (x, breaks, freq= NULL, probability = !freq, include.lowest= TRUE,
	      right=TRUE, col = NULL, border = par("fg"),
	      main = paste("Histogram of" , deparse(substitute(x))),
	      xlim = range(breaks), ylim = range(y, 0),
	      xlab = deparse(substitute(x)), ylab,
	      axes = TRUE, plot = TRUE, labels = FALSE, nclass = NULL, ...)
{
    if (!is.numeric(x))
	stop("hist: x must be numeric")
    main # eval() now: defeat lazy eval
    xlab
    n <- length(x <- x[!is.na(x)])
    use.br <- !missing(breaks)
    if(use.br) {
	if(!missing(nclass))
	    warning("`nclass' not used when `breaks' specified")
    }
    else if(!is.null(nclass) && length(nclass) == 1)
	breaks <- nclass
    use.br <- use.br && (nB <- length(breaks)) > 1
    if(use.br)
	breaks <- sort(breaks)
    else { # construct vector of breaks
	rx <- range(x)
	nnb <-
	    if(missing(breaks)) 1 + log2(n)
	    else { # breaks = `nclass'
		if (is.na(breaks) | breaks < 2)
		    stop("invalid number of breaks")
		breaks
	    }
	breaks <- pretty (rx, n = nnb, min.n=1, eps.corr = 2)
	nB <- length(breaks)
	if(nB <= 1) { ##-- Impossible !
	    stop(paste("hist.default: pretty() error, breaks=",format(breaks)))
	}
    }
    storage.mode(x) <- "double"
    storage.mode(breaks) <- "double"
    counts <- .C("bincount",
		 x,
		 n,
		 breaks,
		 nB,
		 counts = integer(nB - 1),
		 right	= as.logical(right),
		 include= as.logical(include.lowest),
		 NAOK = FALSE, DUP = FALSE, PACKAGE = "base") $counts
    if (any(counts < 0))
	stop("negative `counts'. Internal Error in C-code for \"bincount\"")
    if (sum(counts) < n)
	stop("some `x' not counted; maybe `breaks' do not span range of `x'")
    h <- diff(breaks)
    if (!use.br && any(h <= 0))
	stop("not strictly increasing `breaks'.")
    if (is.null(freq)) {
	freq <- if(!missing(probability))
	    !as.logical(probability)
	else if(use.br) {
	    ##-- Do frequencies if breaks are evenly spaced
	    max(h)-min(h) < 1e-7 * mean(h)
	} else TRUE
    } else if(!missing(probability) && any(probability == freq))
	stop("`probability is an alias for `!freq', however they differ.")
    intensities <- counts/(n*h)
    mids <- 0.5 * (breaks[-1] + breaks[-nB])
    y <- if (freq) counts else intensities
    r <- list(breaks = breaks, counts = counts,
	      intensities = intensities, mids = mids)
    if (plot) {
	plot.new()
	plot.window(xlim, ylim, "") #-> ylim's default from 'y'
	if (missing(ylab))
	    ylab <- paste(if(!freq)"Relative ", "Frequency", sep="")
	if(freq && use.br && max(h)-min(h) > 1e-7 * mean(h))
	    warning("the AREAS in the plot are wrong -- maybe use `freq=FALSE'")
	title(main = main, xlab = xlab, ylab = ylab, ...)
	if(axes) {
	    axis(1, ...)
	    axis(2, ...)
	}
	rect(breaks[-nB], 0, breaks[-1], y,
	     col = col, border = border)
	if(labels)
	    text(mids, y,
		 labels = if(freq) counts else round(intensities,3),
		 adj = c(0.5, -0.5))
	invisible(r)
    }
    else r
}
print.htest <- function(x, digits = 4, quote = TRUE, prefix = "", ...)
{
    cat("\n\t", x$method, "\n\n")
    cat("data: ", x$data.name, "\n")
    if(!is.null(x$statistic))
	cat(names(x$statistic), " = ", format(round(x$statistic, 4)),
	    ", ", sep = "")
    if(!is.null (x$parameter))
	cat(paste(names(x$parameter), " = ", format(round(x$parameter, 3)),
                  ",", sep = ""), "")
    cat("p-value =", format.pval(x$p.value, digits= digits), "\n")
    if(!is.null(x$alternative)) {
	if(!is.null(x$null.value)) {
	    if(length(x$null.value) == 1) {
		if (x$alternative == "two.sided" )
		    alt.char <- "not equal to"
		else if( x$alternative == "less" )
		    alt.char <- "less than"
		else if( x$alternative == "greater" )
		    alt.char <- "greater than"
		cat("alternative hypothesis:", "true", names(x$null.value),
                    "is", alt.char, x$null.value, "\n")
	    }
	    else {
		cat("alternative hypothesis:", x$alternative, "\n")
		cat("null values:\n")
		print(x$null.value, ...)
	    }
	}
	else cat("alternative hypothesis:", x$alternative, "\n")
    }
    if(!is.null(x$conf.int)) {
	cat(format(100 * attr(x$conf.int, "conf.level")),
	    "percent confidence interval:\n",
            format(c(x$conf.int[1], x$conf.int[2])), "\n")
    }
    if(!is.null(x$estimate)) {
	cat("sample estimates:\n")
	print(x$estimate, ...)
    }
    cat("\n")
    invisible(x)
}
identify <- function(x, ...) UseMethod("identify")

identify.default <- function(x, y=NULL, labels=seq(along=x), pos=FALSE,
			     n=length(x), plot=TRUE, offset=0.5, ...)
{
    opar <- par(list(...))
    on.exit(par(opar))
    xy <- xy.coords(x, y)
    z <- .Internal(identify(xy$x, xy$y, as.character(labels),
			    n, plot, offset))
    i <- seq(z[[1]])[z[[1]]]
    if(pos) list(ind= i, pos= z[[2]][z[[1]]]) else i
}
ifelse <-
    function (test, yes, no)
{
    ans <- test
    test <- as.logical(test)
    nas <- is.na(test)
    if (any(test[!nas])) {
        ans[test] <- rep(yes, length = length(ans))[test]
    }
    if (any(!test[!nas])) {
        ans[!test] <- rep(no, length = length(ans))[!test]
    }
    ans[nas] <- NA
    ans
}
image <- function (x = seq(0, 1, len = nrow(z)),
		   y = seq(0, 1, len = ncol(z)),
		   z,
		   zlim = range(z[is.finite(z)]),
		   xlim = range(x[is.finite(x)]),
		   ylim = range(y[is.finite(y)]),
		   col = heat.colors(12), add = FALSE,
		   xaxs = "i", yaxs = "i", xlab, ylab, ...)
{
    if (missing(z)) {
	if (!missing(x)) {
	    if (is.list(x)) {
		z <- x$z; y <- x$y; x <- x$x
	    } else {
		if(is.null(dim(x)))
		   stop("argument must be matrix alike")
		z <- x
		x <- seq(0, 1, len = nrow(z))
	    }
	    if (missing(xlab)) xlab <- ""
	    if (missing(ylab)) ylab <- ""
	} else stop("no `z' matrix specified")
    } else if (is.list(x)) {
	xn <- deparse(substitute(x))
	if (missing(xlab)) xlab <- paste(xn, "x", sep = "$")
	if (missing(ylab)) ylab <- paste(xn, "y", sep = "$")
	y <- x$y
	x <- x$x
    } else {
	if (missing(xlab))
	    xlab <- if (missing(x)) "" else deparse(substitute(x))
	if (missing(ylab))
	    ylab <- if (missing(y)) "" else deparse(substitute(y))
    }
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
	stop("increasing x and y values expected")
    if (!is.matrix(z))
        stop("`z' must be a matrix")
    if(length(x) > 1 && length(x) == e(substi, ny=NULL, col="lightgray", lty="dotted")
{
    if (is.null(nx)|| nx >= 1) {
        axp <- par("xaxp")
        if(is.null(nx)) nx <- axp[3]
	abline(v = seq(axp[1],axp[2],len=1+nx), col = col, lty = lty)
    }
    if (is.null(ny)|| ny >= 1) {
        axp <- par("yaxp")
        if(is.null(ny)) ny <- axp[3]
	abline(h = seq(axp[1],axp[2],len=1+ny), col = col, lty = lty)
    }
}
###-- NOTE: This is for  NON-Windows only  (cf. windows/help.R )

index.search <- function(topic, path, file="AnIndex", type="help")
    .Internal(index.search(topic, path, file, .Platform$file.sep, type))

help <-
    function (topic, offline = FALSE, package = c(.packages(), .Autoloaded),
              lib.loc = .lib.loc, verbose = .Options$verbose,
              htmlhelp = .Options$htmlhelp)
{
    htmlhelp <- is.logical(htmlhelp) && htmlhelp
    if (!missing(package))
        if (is.name(y <- substitute(package)))
            package <- as.character(y)
    if (!missing(topic)) {
        topic <- substitute(topic)
        if (is.name(topic))
            topic <- as.character(topic)
        else if (!is.character(topic))
            stop("Unimplemented help feature")
        # for cmd/help ..
        if (!is.na(match(topic, c("+", "-", "*", "/", "^", "%%"))))
            topic <- "Arithmetic"
        else if (!is.na(match(topic, c("<", ">", "<=", ">=", "==", "!="))))
            topic <- "Comparison"
        else if (!is.na(match(topic, c("[", "[[", "$"))))
            topic <- "Extract"
        else if (!is.na(match(topic, c("&", "&&", "|", "||", "!"))))
            topic <- "Logic"
        else if (!is.na(match(topic, c("%*%"))))
            topic <- "matmult"
        type <- if(offline) "latex" else if (htmlhelp) "html" else "help"
        INDICES <- system.file(pkg=package, lib=lib.loc)
        file <- index.search(topic, INDICES, "AnIndex", type)
        if (length(file) && file != "") {
            if (verbose)
                cat("\t\t\t\t\t\tHelp file name `", sub(".*/", "", file),
                    ".Rd'\n", sep = "")
            if (!offline) {
                if (htmlhelp) {
                    if(file.exists(file)) {
                        file <- paste("file:", file, sep="")
                        if (is.null(.Options$browser))
                            stop("options(\"browser\") not set")
                        browser <- .Options$browser
                        system(paste(browser, " -remote \"openURL(",
                                     file, ")\" 2>/dev/null || ", browser, " ",
                                     file, " &", sep = ""))
                        cat("help() for",topic, " is shown in browser",browser,
                            "...\nUse\t help(",topic,", htmlhelp=FALSE)\nor\t",
                            "options(htmlhelp = FALSE)\nto revert.\n")
                        return(invisible())
                    } else {
                        if(verbose)
                            cat("no HTML help for `", topic,
                                "' is available\n", sep = "")
                        file <- index.search(topic, INDICES, "AnIndex", "help")
                    }
                }
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                ## end of experimental code
                if(file.exists(zfile))
                    file.show(zfile,
                              ##header= paste("Help for `", topic, "'", sep=""),
                              delete.file = (zfile!=file))
                else
                    stop(paste("The help file for `", topic, "' is missing",
                               sep = ""))
                return(invisible())
            }
            else {
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                if(zfile != file) on.exit(unlink(zfile))
                ## end of experimental code
                if(file.exists(zfile)) {
                    FILE <- tempfile()
                    on.exit(unlink(FILE))
                    cat("\\documentclass[", .Options$papersize, "paper]{article}\n",
                        file = FILE, sep = "")
                    file.append(FILE,
                                file.path(R.home(), "doc", "manual", "Rd.sty"))
                    cat("\\InputIfFileExists{Rhelp.cfg}{}{}\n\\begin{document}\n",
                        file = FILE, append = TRUE)
                    file.append(FILE, zfile)
                    cat("\\end{document}\n", file = FILE, append = TRUE)
                    system(paste(file.path(R.home(), "bin", "help"),
                                 "PRINT", FILE, topic,
                                 .Options$latexcmd, .Options$dvipscmd)
                           )
                    return(invisible())
                }
                else
                    stop(paste("No offline documentation for", topic, "is available"))
            }
        }
        else
            stop(paste("No documentation for `", topic, "'", sep = ""))
    }
    else if (!missing(package))
        library(help = package, lib = lib.loc, character.only = TRUE)
    else if (!missing(lib.loc))
        library(lib = lib.loc)
    else help("help", package = "base", lib.loc = .Library)
}
help.search <- function(topic, fields = c("name", "title"),
                        apropos, keyword, whatis, ignore.case = TRUE,
                        packages = NULL, lib.loc = .lib.loc,
                        help.db = .Options$help.db,
                        verbose = .Options$verbose,
                        rebuild = FALSE) {
    TABLE <- c("name", "alias", "title", "keyword")
    if (!missing(topic)) {
        if (!is.character(topic) || (length(topic) > 1))
            stop("`topic' must be a single character string")
        i <- pmatch(fields, TABLE)
        if (any(is.na(i)))
            stop("incorrect field specification")
        else
            fields <- TABLE[i]
    } else if (!missing(apropos)) {
        if (!is.character(apropos) || (length(apropos) > 1))
            stop("`apropos' must be a single character string")
        else {
            topic <- apropos
            fields <- c("name", "title")
        }
    } else if (!missing(keyword)) {
        if (!is.character(keyword) || (length(keyword) > 1))
            stop("`keyword' must be a single character string")
        else {
            topic <- keyword
            fields <- "keyword"
        }
    } else if (!missing(whatis)) {
        if (!is.character(whatis) || (length(whatis) > 1))
            stop("`whatis' must be a single character string")
        else {
            topic <- whatis
            fields <- "name"
        }
    } else {
        stop("don't know what to search")
    }

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

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

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

    ## Output
    fields <- paste(fields, collapse = " or ")
    if (NROW(db) > 0) {
        FILE <- tempfile()
        cat(paste("Objects with ", fields, " matching `", topic,
                  "':\n\n", sep = ""),
            file = FILE)
        dbnam <- paste(db[ , "name"], "(", db[, "pkg"], ")", sep = "")
        dbtit <- paste(db[ , "title"], sep = "")
        cat(paste(format(dbnam), dbtit, sep = "   "),
            sep = "\n", file = FILE, append = TRUE)
        file.show(FILE, delete.file = TRUE)
    } else {
        cat(paste("No objects found with ", fields, " matching `",
                  topic, "'\n", sep = ""))
    }

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

hist.default <-
    function (x, breaks, freq= NULL, probability = !freq, include.lowest= TRUE,
	      right=TRUE, col = NULL, border = par("fg"),
	      main = paste("Histogram of" , deparse(substitute(x))),
	      xlim = range(breaks), ylim = range(y, 0),
	      xlab = deparse(substitute(x)), ylab,
	      axes = TRUE, plot = TRUE, labels = FALSE, nclass = NULL, ...)
{
    if (!is.numeric(x))
	stop("hist: x must be numeric")
    main # eval() now: defeat lazy eval
    xlab
    n <- length(x <- x[!is.na(x)])
    use.br <- !missing(breaks)
    if(use.br) {
	if(!missing(nclass))
	    warning("`nclass' not used when `breaks' specified")
    }
    else if(!is.null(nclass) && length(nclass) == 1)
	breaks <- nclass
    use.br <- use.br && (nB <- length(breaks)) > 1
    if(use.br)
	breaks <- sort(breaks)
    else { # construct vector of breaks
	rx <- range(x)
	nnb <-
	    if(missing(breaks)) 1 + log2(n)
	    else { # breaks = `nclass'
		if (is.na(breaks) | breaks < 2)
		    stop("invalid number of breaks")
		breaks
	    }
	breaks <- pretty (rx, n = nnb, min.n=1, eps.corr = 2)
	nB <- length(breaks)
	if(nB <= 1) { ##-- Impossible !
	    stop(paste("hist.default: pretty() error, breaks=",format(breaks)))
	}
    }
    storage.mode(x) <- "double"
    storage.mode(breaks) <- "double"
    counts <- .C("bincount",
		 x,
		 n,
		 breaks,
		 nB,
		 counts = integer(nB - 1),
		 right	= as.logical(right),
		 include= as.logical(include.lowest),
		 NAOK = FALSE, DUP = FALSE, PACKAGE = "base") $counts
    if (any(counts < 0))
	stop("negative `counts'. Internal Error in C-code for \"bincount\"")
    if (sum(counts) < n)
	stop("some `x' not counted; maybe `breaks' do not span range of `x'")
    h <- diff(breaks)
    if (!use.br && any(h <= 0))
	stop("not strictly increasing `breaks'.")
    if (is.null(freq)) {
	freq <- if(!missing(probability))
	    !as.logical(probability)
	else if(use.br) {
	    ##-- Do frequencies if breaks are evenly spaced
	    max(h)-min(h) < 1e-7 * mean(h)
	} else TRUE
    } else if(!missing(probability) && any(probability == freq))
	stop("`probability is an alias for `!freq', however they differ.")
    intensities <- counts/(n*h)
    mids <- 0.5 * (breaks[-1] + breaks[-nB])
    y <- if (freq) counts else intensities
    r <- list(breaks = breaks, counts = counts,
	      intensities = intensities, mids = mids)
    if (plot) {
	plot.new()
	plot.window(xlim, ylim, "") #-> ylim's default from 'y'
	if (missing(ylab))
	    ylab <- paste(if(!freq)"Relative ", "Frequency", sep="")
	if(freq && use.br && max(h)-min(h) > 1e-7 * mean(h))
	    warning("the AREAS in the plot are wrong -- maybe use `freq=FALSE'")
	title(main = main, xlab = xlab, ylab = ylab, ...)
	if(axes) {
	    axis(1, ...)
	    axis(2, ...)
	}
	rect(breaks[-nB], 0, breaks[-1], y,
	     col = col, border = border)
	if(labels)
	    text(mids, y,
		 labels = if(freq) counts else round(intensities,3),
		 adj = c(0.5, -0.5))
	invisible(r)
    }
    else r
}
print.htest <- function(x, digits = 4, quote = TRUE, prefix = "", ...)
{
    cat("\n\t", x$method, "\n\n")
    cat("data: ", x$data.name, "\n")
    if(!is.null(x$statistic))
	cat(names(x$statistic), " = ", format(round(x$statistic, 4)),
	    ", ", sep = "")
    if(!is.null (x$parameter))
	cat(paste(names(x$parameter), " = ", format(round(x$parameter, 3)),
                  ",", sep = ""), "")
    cat("p-value =", format.pval(x$p.value, digits= digits), "\n")
    if(!is.null(x$alternative)) {
	if(!is.null(x$null.value)) {
	    if(length(x$null.value) == 1) {
		if (x$alternative == "two.sided" )
		    alt.char <- "not equal to"
		else if( x$alternative == "less" )
		    alt.char <- "less than"
		else if( x$alternative == "greater" )
		    alt.char <- "greater than"
		cat("alternative hypothesis:", "true", names(x$null.value),
                    "is", alt.char, x$null.value, "\n")
	    }
	    else {
		cat("alternative hypothesis:", x$alternative, "\n")
		cat("null values:\n")
		print(x$null.value, ...)
	    }
	}
	else cat("alternative hypothesis:", x$alternative, "\n")
    }
    if(!is.null(x$conf.int)) {
	cat(format(100 * attr(x$conf.int, "conf.level")),
	    "percent confidence interval:\n",
            format(c(x$conf.int[1], x$conf.int[2])), "\n")
    }
    if(!is.null(x$estimate)) {
	cat("sample estimates:\n")
	print(x$estimate, ...)
    }
    cat("\n")
    invisible(x)
}
identify <- function(x, ...) UseMethod("identify")

identify.default <- function(x, y=NULL, labels=seq(along=x), pos=FALSE,
			     n=length(x), plot=TRUE, offset=0.5, ...)
{
    opar <- par(list(...))
    on.exit(par(opar))
    xy <- xy.coords(x, y)
    z <- .Internal(identify(xy$x, xy$y, as.character(labels),
			    n, plot, offset))
    i <- seq(z[[1]])[z[[1]]]
    if(pos) list(ind= i, pos= z[[2]][z[[1]]]) else i
}
ifelse <-
    function (test, yes, no)
{
    ans <- test
    test <- as.logical(test)
    nas <- is.na(test)
    if (any(test[!nas])) {
        ans[test] <- rep(yes, length = length(ans))[test]
    }
    if (any(!test[!nas])) {
        ans[!test] <- rep(no, length = length(ans))[!test]
    }
    ans[nas] <- NA
    ans
}
image <- function (x = seq(0, 1, len = nrow(z)),
		   y = seq(0, 1, len = ncol(z)),
		   z,
		   zlim = range(z[is.finite(z)]),
		   xlim = range(x[is.finite(x)]),
		   ylim = range(y[is.finite(y)]),
		   col = heat.colors(12), add = FALSE,
		   xaxs = "i", yaxs = "i", xlab, ylab, ...)
{
    if (missing(z)) {
	if (!missing(x)) {
	    if (is.list(x)) {
		z <- x$z; y <- x$y; x <- x$x
	    } else {
		if(is.null(dim(x)))
		   stop("argument must be matrix alike")
		z <- x
		x <- seq(0, 1, len = nrow(z))
	    }
	    if (missing(xlab)) xlab <- ""
	    if (missing(ylab)) ylab <- ""
	} else stop("no `z' matrix specified")
    } else if (is.list(x)) {
	xn <- deparse(substitute(x))
	if (missing(xlab)) xlab <- paste(xn, "x", sep = "$")
	if (missing(ylab)) ylab <- paste(xn, "y", sep = "$")
	y <- x$y
	x <- x$x
    } else {
	if (missing(xlab))
	    xlab <- if (missing(x)) "" else deparse(substitute(x))
	if (missing(ylab))
	    ylab <- if (missing(y)) "" else deparse(substitute(y))
    }
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
	stop("increasing x and y values expected")
    if (!is.matrix(z))
        stop("`z' must be a matrix")
    if(length(x) > 1 && length(x) == e(substi, ny=NULL, col="lightgray", lty="dotted")
{
    if (is.null(nx)|| nx >= 1) {
        axp <- par("xaxp")
        if(is.null(nx)) nx <- axp[3]
	abline(v = seq(axp[1],axp[2],len=1+nx), col = col, lty = lty)
    }
    if (is.null(ny)|| ny >= 1) {
        axp <- par("yaxp")
        if(is.null(ny)) ny <- axp[3]
	abline(h = seq(axp[1],axp[2],len=1+ny), col = col, lty = lty)
    }
}
###-- NOTE: This is for  NON-Windows only  (cf. windows/help.R )

index.search <- function(topic, path, file="AnIndex", type="help")
    .Internal(index.search(topic, path, file, .Platform$file.sep, type))

help <-
    function (topic, offline = FALSE, package = c(.packages(), .Autoloaded),
              lib.loc = .lib.loc, verbose = .Options$verbose,
              htmlhelp = .Options$htmlhelp)
{
    htmlhelp <- is.logical(htmlhelp) && htmlhelp
    if (!missing(package))
        if (is.name(y <- substitute(package)))
            package <- as.character(y)
    if (!missing(topic)) {
        topic <- substitute(topic)
        if (is.name(topic))
            topic <- as.character(topic)
        else if (!is.character(topic))
            stop("Unimplemented help feature")
        # for cmd/help ..
        if (!is.na(match(topic, c("+", "-", "*", "/", "^", "%%"))))
            topic <- "Arithmetic"
        else if (!is.na(match(topic, c("<", ">", "<=", ">=", "==", "!="))))
            topic <- "Comparison"
        else if (!is.na(match(topic, c("[", "[[", "$"))))
            topic <- "Extract"
        else if (!is.na(match(topic, c("&", "&&", "|", "||", "!"))))
            topic <- "Logic"
        else if (!is.na(match(topic, c("%*%"))))
            topic <- "matmult"
        type <- if(offline) "latex" else if (htmlhelp) "html" else "help"
        INDICES <- system.file(pkg=package, lib=lib.loc)
        file <- index.search(topic, INDICES, "AnIndex", type)
        if (length(file) && file != "") {
            if (verbose)
                cat("\t\t\t\t\t\tHelp file name `", sub(".*/", "", file),
                    ".Rd'\n", sep = "")
            if (!offline) {
                if (htmlhelp) {
                    if(file.exists(file)) {
                        file <- paste("file:", file, sep="")
                        if (is.null(.Options$browser))
                            stop("options(\"browser\") not set")
                        browser <- .Options$browser
                        system(paste(browser, " -remote \"openURL(",
                                     file, ")\" 2>/dev/null || ", browser, " ",
                                     file, " &", sep = ""))
                        cat("help() for",topic, " is shown in browser",browser,
                            "...\nUse\t help(",topic,", htmlhelp=FALSE)\nor\t",
                            "options(htmlhelp = FALSE)\nto revert.\n")
                        return(invisible())
                    } else {
                        if(verbose)
                            cat("no HTML help for `", topic,
                                "' is available\n", sep = "")
                        file <- index.search(topic, INDICES, "AnIndex", "help")
                    }
                }
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                ## end of experimental code
                if(file.exists(zfile))
                    file.show(zfile,
                              ##header= paste("Help for `", topic, "'", sep=""),
                              delete.file = (zfile!=file))
                else
                    stop(paste("The help file for `", topic, "' is missing",
                               sep = ""))
                return(invisible())
            }
            else {
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                if(zfile != file) on.exit(unlink(zfile))
                ## end of experimental code
                if(file.exists(zfile)) {
                    FILE <- tempfile()
                    on.exit(unlink(FILE))
                    cat("\\documentclass[", .Options$papersize, "paper]{article}\n",
                        file = FILE, sep = "")
                    file.append(FILE,
                                file.path(R.home(), "doc", "manual", "Rd.sty"))
                    cat("\\InputIfFileExists{Rhelp.cfg}{}{}\n\\begin{document}\n",
                        file = FILE, append = TRUE)
                    file.append(FILE, zfile)
                    cat("\\end{document}\n", file = FILE, append = TRUE)
                    system(paste(file.path(R.home(), "bin", "help"),
                                 "PRINT", FILE, topic,
                                 .Options$latexcmd, .Options$dvipscmd)
                           )
                    return(invisible())
                }
                else
                    stop(paste("No offline documentation for", topic, "is available"))
            }
        }
        else
            stop(paste("No documentation for `", topic, "'", sep = ""))
    }
    else if (!missing(package))
        library(help = package, lib = lib.loc, character.only = TRUE)
    else if (!missing(lib.loc))
        library(lib = lib.loc)
    else help("help", package = "base", lib.loc = .Library)
}
help.search <- function(topic, fields = c("name", "title"),
                        apropos, keyword, whatis, ignore.case = TRUE,
                        packages = NULL, lib.loc = .lib.loc,
                        help.db = .Options$help.db,
                        verbose = .Options$verbose,
                        rebuild = FALSE) {
    TABLE <- c("name", "alias", "title", "keyword")
    if (!missing(topic)) {
        if (!is.character(topic) || (length(topic) > 1))
            stop("`topic' must be a single character string")
        i <- pmatch(fields, TABLE)
        if (any(is.na(i)))
            stop("incorrect field specification")
        else
            fields <- TABLE[i]
    } else if (!missing(apropos)) {
        if (!is.character(apropos) || (length(apropos) > 1))
            stop("`apropos' must be a single character string")
        else {
            topic <- apropos
            fields <- c("name", "title")
        }
    } else if (!missing(keyword)) {
        if (!is.character(keyword) || (length(keyword) > 1))
            stop("`keyword' must be a single character string")
        else {
            topic <- keyword
            fields <- "keyword"
        }
    } else if (!missing(whatis)) {
        if (!is.character(whatis) || (length(whatis) > 1))
            stop("`whatis' must be a single character string")
        else {
            topic <- whatis
            fields <- "name"
        }
    } else {
        stop("don't know what to search")
    }

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

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

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

    ## Output
    fields <- paste(fields, collapse = " or ")
    if (NROW(db) > 0) {
        FILE <- tempfile()
        cat(paste("Objects with ", fields, " matching `", topic,
                  "':\n\n", sep = ""),
            file = FILE)
        dbnam <- paste(db[ , "name"], "(", db[, "pkg"], ")", sep = "")
        dbtit <- paste(db[ , "title"], sep = "")
        cat(paste(format(dbnam), dbtit, sep = "   "),
            sep = "\n", file = FILE, append = TRUE)
        file.show(FILE, delete.file = TRUE)
    } else {
        cat(paste("No objects found with ", fields, " matching `",
                  topic, "'\n", sep = ""))
    }

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

hist.default <-
    function (x, breaks, freq= NULL, probability = !freq, include.lowest= TRUE,
	      right=TRUE, col = NULL, border = par("fg"),
	      main = paste("Histogram of" , deparse(substitute(x))),
	      xlim = range(breaks), ylim = range(y, 0),
	      xlab = deparse(substitute(x)), ylab,
	      axes = TRUE, plot = TRUE, labels = FALSE, nclass = NULL, ...)
{
    if (!is.numeric(x))
	stop("hist: x must be numeric")
    main # eval() now: defeat lazy eval
    xlab
    n <- length(x <- x[!is.na(x)])
    use.br <- !missing(breaks)
    if(use.br) {
	if(!missing(nclass))
	    warning("`nclass' not used when `breaks' specified")
    }
    else if(!is.null(nclass) && length(nclass) == 1)
	breaks <- nclass
    use.br <- use.br && (nB <- length(breaks)) > 1
    if(use.br)
	breaks <- sort(breaks)
    else { # construct vector of breaks
	rx <- range(x)
	nnb <-
	    if(missing(breaks)) 1 + log2(n)
	    else { # breaks = `nclass'
		if (is.na(breaks) | breaks < 2)
		    stop("invalid number of breaks")
		breaks
	    }
	breaks <- pretty (rx, n = nnb, min.n=1, eps.corr = 2)
	nB <- length(breaks)
	if(nB <= 1) { ##-- Impossible !
	    stop(paste("hist.default: pretty() error, breaks=",format(breaks)))
	}
    }
    storage.mode(x) <- "double"
    storage.mode(breaks) <- "double"
    counts <- .C("bincount",
		 x,
		 n,
		 breaks,
		 nB,
		 counts = integer(nB - 1),
		 right	= as.logical(right),
		 include= as.logical(include.lowest),
		 NAOK = FALSE, DUP = FALSE, PACKAGE = "base") $counts
    if (any(counts < 0))
	stop("negative `counts'. Internal Error in C-code for \"bincount\"")
    if (sum(counts) < n)
	stop("some `x' not counted; maybe `breaks' do not span range of `x'")
    h <- diff(breaks)
    if (!use.br && any(h <= 0))
	stop("not strictly increasing `breaks'.")
    if (is.null(freq)) {
	freq <- if(!missing(probability))
	    !as.logical(probability)
	else if(use.br) {
	    ##-- Do frequencies if breaks are evenly spaced
	    max(h)-min(h) < 1e-7 * mean(h)
	} else TRUE
    } else if(!missing(probability) && any(probability == freq))
	stop("`probability is an alias for `!freq', however they differ.")
    intensities <- counts/(n*h)
    mids <- 0.5 * (breaks[-1] + breaks[-nB])
    y <- if (freq) counts else intensities
    r <- list(breaks = breaks, counts = counts,
	      intensities = intensities, mids = mids)
    if (plot) {
	plot.new()
	plot.window(xlim, ylim, "") #-> ylim's default from 'y'
	if (missing(ylab))
	    ylab <- paste(if(!freq)"Relative ", "Frequency", sep="")
	if(freq && use.br && max(h)-min(h) > 1e-7 * mean(h))
	    warning("the AREAS in the plot are wrong -- maybe use `freq=FALSE'")
	title(main = main, xlab = xlab, ylab = ylab, ...)
	if(axes) {
	    axis(1, ...)
	    axis(2, ...)
	}
	rect(breaks[-nB], 0, breaks[-1], y,
	     col = col, border = border)
	if(labels)
	    text(mids, y,
		 labels = if(freq) counts else round(intensities,3),
		 adj = c(0.5, -0.5))
	invisible(r)
    }
    else r
}
print.htest <- function(x, digits = 4, quote = TRUE, prefix = "", ...)
{
    cat("\n\t", x$method, "\n\n")
    cat("data: ", x$data.name, "\n")
    if(!is.null(x$statistic))
	cat(names(x$statistic), " = ", format(round(x$statistic, 4)),
	    ", ", sep = "")
    if(!is.null (x$parameter))
	cat(paste(names(x$parameter), " = ", format(round(x$parameter, 3)),
                  ",", sep = ""), "")
    cat("p-value =", format.pval(x$p.value, digits= digits), "\n")
    if(!is.null(x$alternative)) {
	if(!is.null(x$null.value)) {
	    if(length(x$null.value) == 1) {
		if (x$alternative == "two.sided" )
		    alt.char <- "not equal to"
		else if( x$alternative == "less" )
		    alt.char <- "less than"
		else if( x$alternative == "greater" )
		    alt.char <- "greater than"
		cat("alternative hypothesis:", "true", names(x$null.value),
                    "is", alt.char, x$null.value, "\n")
	    }
	    else {
		cat("alternative hypothesis:", x$alternative, "\n")
		cat("null values:\n")
		print(x$null.value, ...)
	    }
	}
	else cat("alternative hypothesis:", x$alternative, "\n")
    }
    if(!is.null(x$conf.int)) {
	cat(format(100 * attr(x$conf.int, "conf.level")),
	    "percent confidence interval:\n",
            format(c(x$conf.int[1], x$conf.int[2])), "\n")
    }
    if(!is.null(x$estimate)) {
	cat("sample estimates:\n")
	print(x$estimate, ...)
    }
    cat("\n")
    invisible(x)
}
identify <- function(x, ...) UseMethod("identify")

identify.default <- function(x, y=NULL, labels=seq(along=x), pos=FALSE,
			     n=length(x), plot=TRUE, offset=0.5, ...)
{
    opar <- par(list(...))
    on.exit(par(opar))
    xy <- xy.coords(x, y)
    z <- .Internal(identify(xy$x, xy$y, as.character(labels),
			    n, plot, offset))
    i <- seq(z[[1]])[z[[1]]]
    if(pos) list(ind= i, pos= z[[2]][z[[1]]]) else i
}
ifelse <-
    function (test, yes, no)
{
    ans <- test
    test <- as.logical(test)
    nas <- is.na(test)
    if (any(test[!nas])) {
        ans[test] <- rep(yes, length = length(ans))[test]
    }
    if (any(!test[!nas])) {
        ans[!test] <- rep(no, length = length(ans))[!test]
    }
    ans[nas] <- NA
    ans
}
image <- function (x = seq(0, 1, len = nrow(z)),
		   y = seq(0, 1, len = ncol(z)),
		   z,
		   zlim = range(z[is.finite(z)]),
		   xlim = range(x[is.finite(x)]),
		   ylim = range(y[is.finite(y)]),
		   col = heat.colors(12), add = FALSE,
		   xaxs = "i", yaxs = "i", xlab, ylab, ...)
{
    if (missing(z)) {
	if (!missing(x)) {
	    if (is.list(x)) {
		z <- x$z; y <- x$y; x <- x$x
	    } else {
		if(is.null(dim(x)))
		   stop("argument must be matrix alike")
		z <- x
		x <- seq(0, 1, len = nrow(z))
	    }
	    if (missing(xlab)) xlab <- ""
	    if (missing(ylab)) ylab <- ""
	} else stop("no `z' matrix specified")
    } else if (is.list(x)) {
	xn <- deparse(substitute(x))
	if (missing(xlab)) xlab <- paste(xn, "x", sep = "$")
	if (missing(ylab)) ylab <- paste(xn, "y", sep = "$")
	y <- x$y
	x <- x$x
    } else {
	if (missing(xlab))
	    xlab <- if (missing(x)) "" else deparse(substitute(x))
	if (missing(ylab))
	    ylab <- if (missing(y)) "" else deparse(substitute(y))
    }
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
	stop("increasing x and y values expected")
    if (!is.matrix(z))
        stop("`z' must be a matrix")
    if(length(x) > 1 && length(x) == e(substi, ny=NULL, col="lightgray", lty="dotted")
{
    if (is.null(nx)|| nx >= 1) {
        axp <- par("xaxp")
        if(is.null(nx)) nx <- axp[3]
	abline(v = seq(axp[1],axp[2],len=1+nx), col = col, lty = lty)
    }
    if (is.null(ny)|| ny >= 1) {
        axp <- par("yaxp")
        if(is.null(ny)) ny <- axp[3]
	abline(h = seq(axp[1],axp[2],len=1+ny), col = col, lty = lty)
    }
}
###-- NOTE: This is for  NON-Windows only  (cf. windows/help.R )

index.search <- function(topic, path, file="AnIndex", type="help")
    .Internal(index.search(topic, path, file, .Platform$file.sep, type))

help <-
    function (topic, offline = FALSE, package = c(.packages(), .Autoloaded),
              lib.loc = .lib.loc, verbose = .Options$verbose,
              htmlhelp = .Options$htmlhelp)
{
    htmlhelp <- is.logical(htmlhelp) && htmlhelp
    if (!missing(package))
        if (is.name(y <- substitute(package)))
            package <- as.character(y)
    if (!missing(topic)) {
        topic <- substitute(topic)
        if (is.name(topic))
            topic <- as.character(topic)
        else if (!is.character(topic))
            stop("Unimplemented help feature")
        # for cmd/help ..
        if (!is.na(match(topic, c("+", "-", "*", "/", "^", "%%"))))
            topic <- "Arithmetic"
        else if (!is.na(match(topic, c("<", ">", "<=", ">=", "==", "!="))))
            topic <- "Comparison"
        else if (!is.na(match(topic, c("[", "[[", "$"))))
            topic <- "Extract"
        else if (!is.na(match(topic, c("&", "&&", "|", "||", "!"))))
            topic <- "Logic"
        else if (!is.na(match(topic, c("%*%"))))
            topic <- "matmult"
        type <- if(offline) "latex" else if (htmlhelp) "html" else "help"
        INDICES <- system.file(pkg=package, lib=lib.loc)
        file <- index.search(topic, INDICES, "AnIndex", type)
        if (length(file) && file != "") {
            if (verbose)
                cat("\t\t\t\t\t\tHelp file name `", sub(".*/", "", file),
                    ".Rd'\n", sep = "")
            if (!offline) {
                if (htmlhelp) {
                    if(file.exists(file)) {
                        file <- paste("file:", file, sep="")
                        if (is.null(.Options$browser))
                            stop("options(\"browser\") not set")
                        browser <- .Options$browser
                        system(paste(browser, " -remote \"openURL(",
                                     file, ")\" 2>/dev/null || ", browser, " ",
                                     file, " &", sep = ""))
                        cat("help() for",topic, " is shown in browser",browser,
                            "...\nUse\t help(",topic,", htmlhelp=FALSE)\nor\t",
                            "options(htmlhelp = FALSE)\nto revert.\n")
                        return(invisible())
                    } else {
                        if(verbose)
                            cat("no HTML help for `", topic,
                                "' is available\n", sep = "")
                        file <- index.search(topic, INDICES, "AnIndex", "help")
                    }
                }
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                ## end of experimental code
                if(file.exists(zfile))
                    file.show(zfile,
                              ##header= paste("Help for `", topic, "'", sep=""),
                              delete.file = (zfile!=file))
                else
                    stop(paste("The help file for `", topic, "' is missing",
                               sep = ""))
                return(invisible())
            }
            else {
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                if(zfile != file) on.exit(unlink(zfile))
                ## end of experimental code
                if(file.exists(zfile)) {
                    FILE <- tempfile()
                    on.exit(unlink(FILE))
                    cat("\\documentclass[", .Options$papersize, "paper]{article}\n",
                        file = FILE, sep = "")
                    file.append(FILE,
                                file.path(R.home(), "doc", "manual", "Rd.sty"))
                    cat("\\InputIfFileExists{Rhelp.cfg}{}{}\n\\begin{document}\n",
                        file = FILE, append = TRUE)
                    file.append(FILE, zfile)
                    cat("\\end{document}\n", file = FILE, append = TRUE)
                    system(paste(file.path(R.home(), "bin", "help"),
                                 "PRINT", FILE, topic,
                                 .Options$latexcmd, .Options$dvipscmd)
                           )
                    return(invisible())
                }
                else
                    stop(paste("No offline documentation for", topic, "is available"))
            }
        }
        else
            stop(paste("No documentation for `", topic, "'", sep = ""))
    }
    else if (!missing(package))
        library(help = package, lib = lib.loc, character.only = TRUE)
    else if (!missing(lib.loc))
        library(lib = lib.loc)
    else help("help", package = "base", lib.loc = .Library)
}
help.search <- function(topic, fields = c("name", "title"),
                        apropos, keyword, whatis, ignore.case = TRUE,
                        packages = NULL, lib.loc = .lib.loc,
                        help.db = .Options$help.db,
                        verbose = .Options$verbose,
                        rebuild = FALSE) {
    TABLE <- c("name", "alias", "title", "keyword")
    if (!missing(topic)) {
        if (!is.character(topic) || (length(topic) > 1))
            stop("`topic' must be a single character string")
        i <- pmatch(fields, TABLE)
        if (any(is.na(i)))
            stop("incorrect field specification")
        else
            fields <- TABLE[i]
    } else if (!missing(apropos)) {
        if (!is.character(apropos) || (length(apropos) > 1))
            stop("`apropos' must be a single character string")
        else {
            topic <- apropos
            fields <- c("name", "title")
        }
    } else if (!missing(keyword)) {
        if (!is.character(keyword) || (length(keyword) > 1))
            stop("`keyword' must be a single character string")
        else {
            topic <- keyword
            fields <- "keyword"
        }
    } else if (!missing(whatis)) {
        if (!is.character(whatis) || (length(whatis) > 1))
            stop("`whatis' must be a single character string")
        else {
            topic <- whatis
            fields <- "name"
        }
    } else {
        stop("don't know what to search")
    }

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

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

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

    ## Output
    fields <- paste(fields, collapse = " or ")
    if (NROW(db) > 0) {
        FILE <- tempfile()
        cat(paste("Objects with ", fields, " matching `", topic,
                  "':\n\n", sep = ""),
            file = FILE)
        dbnam <- paste(db[ , "name"], "(", db[, "pkg"], ")", sep = "")
        dbtit <- paste(db[ , "title"], sep = "")
        cat(paste(format(dbnam), dbtit, sep = "   "),
            sep = "\n", file = FILE, append = TRUE)
        file.show(FILE, delete.file = TRUE)
    } else {
        cat(paste("No objects found with ", fields, " matching `",
                  topic, "'\n", sep = ""))
    }

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

hist.default <-
    function (x, breaks, freq= NULL, probability = !freq, include.lowest= TRUE,
	      right=TRUE, col = NULL, border = par("fg"),
	      main = paste("Histogram of" , deparse(substitute(x))),
	      xlim = range(breaks), ylim = range(y, 0),
	      xlab = deparse(substitute(x)), ylab,
	      axes = TRUE, plot = TRUE, labels = FALSE, nclass = NULL, ...)
{
    if (!is.numeric(x))
	stop("hist: x must be numeric")
    main # eval() now: defeat lazy eval
    xlab
    n <- length(x <- x[!is.na(x)])
    use.br <- !missing(breaks)
    if(use.br) {
	if(!missing(nclass))
	    warning("`nclass' not used when `breaks' specified")
    }
    else if(!is.null(nclass) && length(nclass) == 1)
	breaks <- nclass
    use.br <- use.br && (nB <- length(breaks)) > 1
    if(use.br)
	breaks <- sort(breaks)
    else { # construct vector of breaks
	rx <- range(x)
	nnb <-
	    if(missing(breaks)) 1 + log2(n)
	    else { # breaks = `nclass'
		if (is.na(breaks) | breaks < 2)
		    stop("invalid number of breaks")
		breaks
	    }
	breaks <- pretty (rx, n = nnb, min.n=1, eps.corr = 2)
	nB <- length(breaks)
	if(nB <= 1) { ##-- Impossible !
	    stop(paste("hist.default: pretty() error, breaks=",format(breaks)))
	}
    }
    storage.mode(x) <- "double"
    storage.mode(breaks) <- "double"
    counts <- .C("bincount",
		 x,
		 n,
		 breaks,
		 nB,
		 counts = integer(nB - 1),
		 right	= as.logical(right),
		 include= as.logical(include.lowest),
		 NAOK = FALSE, DUP = FALSE, PACKAGE = "base") $counts
    if (any(counts < 0))
	stop("negative `counts'. Internal Error in C-code for \"bincount\"")
    if (sum(counts) < n)
	stop("some `x' not counted; maybe `breaks' do not span range of `x'")
    h <- diff(breaks)
    if (!use.br && any(h <= 0))
	stop("not strictly increasing `breaks'.")
    if (is.null(freq)) {
	freq <- if(!missing(probability))
	    !as.logical(probability)
	else if(use.br) {
	    ##-- Do frequencies if breaks are evenly spaced
	    max(h)-min(h) < 1e-7 * mean(h)
	} else TRUE
    } else if(!missing(probability) && any(probability == freq))
	stop("`probability is an alias for `!freq', however they differ.")
    intensities <- counts/(n*h)
    mids <- 0.5 * (breaks[-1] + breaks[-nB])
    y <- if (freq) counts else intensities
    r <- list(breaks = breaks, counts = counts,
	      intensities = intensities, mids = mids)
    if (plot) {
	plot.new()
	plot.window(xlim, ylim, "") #-> ylim's default from 'y'
	if (missing(ylab))
	    ylab <- paste(if(!freq)"Relative ", "Frequency", sep="")
	if(freq && use.br && max(h)-min(h) > 1e-7 * mean(h))
	    warning("the AREAS in the plot are wrong -- maybe use `freq=FALSE'")
	title(main = main, xlab = xlab, ylab = ylab, ...)
	if(axes) {
	    axis(1, ...)
	    axis(2, ...)
	}
	rect(breaks[-nB], 0, breaks[-1], y,
	     col = col, border = border)
	if(labels)
	    text(mids, y,
		 labels = if(freq) counts else round(intensities,3),
		 adj = c(0.5, -0.5))
	invisible(r)
    }
    else r
}
print.htest <- function(x, digits = 4, quote = TRUE, prefix = "", ...)
{
    cat("\n\t", x$method, "\n\n")
    cat("data: ", x$data.name, "\n")
    if(!is.null(x$statistic))
	cat(names(x$statistic), " = ", format(round(x$statistic, 4)),
	    ", ", sep = "")
    if(!is.null (x$parameter))
	cat(paste(names(x$parameter), " = ", format(round(x$parameter, 3)),
                  ",", sep = ""), "")
    cat("p-value =", format.pval(x$p.value, digits= digits), "\n")
    if(!is.null(x$alternative)) {
	if(!is.null(x$null.value)) {
	    if(length(x$null.value) == 1) {
		if (x$alternative == "two.sided" )
		    alt.char <- "not equal to"
		else if( x$alternative == "less" )
		    alt.char <- "less than"
		else if( x$alternative == "greater" )
		    alt.char <- "greater than"
		cat("alternative hypothesis:", "true", names(x$null.value),
                    "is", alt.char, x$null.value, "\n")
	    }
	    else {
		cat("alternative hypothesis:", x$alternative, "\n")
		cat("null values:\n")
		print(x$null.value, ...)
	    }
	}
	else cat("alternative hypothesis:", x$alternative, "\n")
    }
    if(!is.null(x$conf.int)) {
	cat(format(100 * attr(x$conf.int, "conf.level")),
	    "percent confidence interval:\n",
            format(c(x$conf.int[1], x$conf.int[2])), "\n")
    }
    if(!is.null(x$estimate)) {
	cat("sample estimates:\n")
	print(x$estimate, ...)
    }
    cat("\n")
    invisible(x)
}
identify <- function(x, ...) UseMethod("identify")

identify.default <- function(x, y=NULL, labels=seq(along=x), pos=FALSE,
			     n=length(x), plot=TRUE, offset=0.5, ...)
{
    opar <- par(list(...))
    on.exit(par(opar))
    xy <- xy.coords(x, y)
    z <- .Internal(identify(xy$x, xy$y, as.character(labels),
			    n, plot, offset))
    i <- seq(z[[1]])[z[[1]]]
    if(pos) list(ind= i, pos= z[[2]][z[[1]]]) else i
}
ifelse <-
    function (test, yes, no)
{
    ans <- test
    test <- as.logical(test)
    nas <- is.na(test)
    if (any(test[!nas])) {
        ans[test] <- rep(yes, length = length(ans))[test]
    }
    if (any(!test[!nas])) {
        ans[!test] <- rep(no, length = length(ans))[!test]
    }
    ans[nas] <- NA
    ans
}
image <- function (x = seq(0, 1, len = nrow(z)),
		   y = seq(0, 1, len = ncol(z)),
		   z,
		   zlim = range(z[is.finite(z)]),
		   xlim = range(x[is.finite(x)]),
		   ylim = range(y[is.finite(y)]),
		   col = heat.colors(12), add = FALSE,
		   xaxs = "i", yaxs = "i", xlab, ylab, ...)
{
    if (missing(z)) {
	if (!missing(x)) {
	    if (is.list(x)) {
		z <- x$z; y <- x$y; x <- x$x
	    } else {
		if(is.null(dim(x)))
		   stop("argument must be matrix alike")
		z <- x
		x <- seq(0, 1, len = nrow(z))
	    }
	    if (missing(xlab)) xlab <- ""
	    if (missing(ylab)) ylab <- ""
	} else stop("no `z' matrix specified")
    } else if (is.list(x)) {
	xn <- deparse(substitute(x))
	if (missing(xlab)) xlab <- paste(xn, "x", sep = "$")
	if (missing(ylab)) ylab <- paste(xn, "y", sep = "$")
	y <- x$y
	x <- x$x
    } else {
	if (missing(xlab))
	    xlab <- if (missing(x)) "" else deparse(substitute(x))
	if (missing(ylab))
	    ylab <- if (missing(y)) "" else deparse(substitute(y))
    }
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
	stop("increasing x and y values expected")
    if (!is.matrix(z))
        stop("`z' must be a matrix")
    if(length(x) > 1 && length(x) == e(substi, ny=NULL, col="lightgray", lty="dotted")
{
    if (is.null(nx)|| nx >= 1) {
        axp <- par("xaxp")
        if(is.null(nx)) nx <- axp[3]
	abline(v = seq(axp[1],axp[2],len=1+nx), col = col, lty = lty)
    }
    if (is.null(ny)|| ny >= 1) {
        axp <- par("yaxp")
        if(is.null(ny)) ny <- axp[3]
	abline(h = seq(axp[1],axp[2],len=1+ny), col = col, lty = lty)
    }
}
###-- NOTE: This is for  NON-Windows only  (cf. windows/help.R )

index.search <- function(topic, path, file="AnIndex", type="help")
    .Internal(index.search(topic, path, file, .Platform$file.sep, type))

help <-
    function (topic, offline = FALSE, package = c(.packages(), .Autoloaded),
              lib.loc = .lib.loc, verbose = .Options$verbose,
              htmlhelp = .Options$htmlhelp)
{
    htmlhelp <- is.logical(htmlhelp) && htmlhelp
    if (!missing(package))
        if (is.name(y <- substitute(package)))
            package <- as.character(y)
    if (!missing(topic)) {
        topic <- substitute(topic)
        if (is.name(topic))
            topic <- as.character(topic)
        else if (!is.character(topic))
            stop("Unimplemented help feature")
        # for cmd/help ..
        if (!is.na(match(topic, c("+", "-", "*", "/", "^", "%%"))))
            topic <- "Arithmetic"
        else if (!is.na(match(topic, c("<", ">", "<=", ">=", "==", "!="))))
            topic <- "Comparison"
        else if (!is.na(match(topic, c("[", "[[", "$"))))
            topic <- "Extract"
        else if (!is.na(match(topic, c("&", "&&", "|", "||", "!"))))
            topic <- "Logic"
        else if (!is.na(match(topic, c("%*%"))))
            topic <- "matmult"
        type <- if(offline) "latex" else if (htmlhelp) "html" else "help"
        INDICES <- system.file(pkg=package, lib=lib.loc)
        file <- index.search(topic, INDICES, "AnIndex", type)
        if (length(file) && file != "") {
            if (verbose)
                cat("\t\t\t\t\t\tHelp file name `", sub(".*/", "", file),
                    ".Rd'\n", sep = "")
            if (!offline) {
                if (htmlhelp) {
                    if(file.exists(file)) {
                        file <- paste("file:", file, sep="")
                        if (is.null(.Options$browser))
                            stop("options(\"browser\") not set")
                        browser <- .Options$browser
                        system(paste(browser, " -remote \"openURL(",
                                     file, ")\" 2>/dev/null || ", browser, " ",
                                     file, " &", sep = ""))
                        cat("help() for",topic, " is shown in browser",browser,
                            "...\nUse\t help(",topic,", htmlhelp=FALSE)\nor\t",
                            "options(htmlhelp = FALSE)\nto revert.\n")
                        return(invisible())
                    } else {
                        if(verbose)
                            cat("no HTML help for `", topic,
                                "' is available\n", sep = "")
                        file <- index.search(topic, INDICES, "AnIndex", "help")
                    }
                }
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                ## end of experimental code
                if(file.exists(zfile))
                    file.show(zfile,
                              ##header= paste("Help for `", topic, "'", sep=""),
                              delete.file = (zfile!=file))
                else
                    stop(paste("The help file for `", topic, "' is missing",
                               sep = ""))
                return(invisible())
            }
            else {
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                if(zfile != file) on.exit(unlink(zfile))
                ## end of experimental code
                if(file.exists(zfile)) {
                    FILE <- tempfile()
                    on.exit(unlink(FILE))
                    cat("\\documentclass[", .Options$papersize, "paper]{article}\n",
                        file = FILE, sep = "")
                    file.append(FILE,
                                file.path(R.home(), "doc", "manual", "Rd.sty"))
                    cat("\\InputIfFileExists{Rhelp.cfg}{}{}\n\\begin{document}\n",
                        file = FILE, append = TRUE)
                    file.append(FILE, zfile)
                    cat("\\end{document}\n", file = FILE, append = TRUE)
                    system(paste(file.path(R.home(), "bin", "help"),
                                 "PRINT", FILE, topic,
                                 .Options$latexcmd, .Options$dvipscmd)
                           )
                    return(invisible())
                }
                else
                    stop(paste("No offline documentation for", topic, "is available"))
            }
        }
        else
            stop(paste("No documentation for `", topic, "'", sep = ""))
    }
    else if (!missing(package))
        library(help = package, lib = lib.loc, character.only = TRUE)
    else if (!missing(lib.loc))
        library(lib = lib.loc)
    else help("help", package = "base", lib.loc = .Library)
}
help.search <- function(topic, fields = c("name", "title"),
                        apropos, keyword, whatis, ignore.case = TRUE,
                        packages = NULL, lib.loc = .lib.loc,
                        help.db = .Options$help.db,
                        verbose = .Options$verbose,
                        rebuild = FALSE) {
    TABLE <- c("name", "alias", "title", "keyword")
    if (!missing(topic)) {
        if (!is.character(topic) || (length(topic) > 1))
            stop("`topic' must be a single character string")
        i <- pmatch(fields, TABLE)
        if (any(is.na(i)))
            stop("incorrect field specification")
        else
            fields <- TABLE[i]
    } else if (!missing(apropos)) {
        if (!is.character(apropos) || (length(apropos) > 1))
            stop("`apropos' must be a single character string")
        else {
            topic <- apropos
            fields <- c("name", "title")
        }
    } else if (!missing(keyword)) {
        if (!is.character(keyword) || (length(keyword) > 1))
            stop("`keyword' must be a single character string")
        else {
            topic <- keyword
            fields <- "keyword"
        }
    } else if (!missing(whatis)) {
        if (!is.character(whatis) || (length(whatis) > 1))
            stop("`whatis' must be a single character string")
        else {
            topic <- whatis
            fields <- "name"
        }
    } else {
        stop("don't know what to search")
    }

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

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

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

    ## Output
    fields <- paste(fields, collapse = " or ")
    if (NROW(db) > 0) {
        FILE <- tempfile()
        cat(paste("Objects with ", fields, " matching `", topic,
                  "':\n\n", sep = ""),
            file = FILE)
        dbnam <- paste(db[ , "name"], "(", db[, "pkg"], ")", sep = "")
        dbtit <- paste(db[ , "title"], sep = "")
        cat(paste(format(dbnam), dbtit, sep = "   "),
            sep = "\n", file = FILE, append = TRUE)
        file.show(FILE, delete.file = TRUE)
    } else {
        cat(paste("No objects found with ", fields, " matching `",
                  topic, "'\n", sep = ""))
    }

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

hist.default <-
    function (x, breaks, freq= NULL, probability = !freq, include.lowest= TRUE,
	      right=TRUE, col = NULL, border = par("fg"),
	      main = paste("Histogram of" , deparse(substitute(x))),
	      xlim = range(breaks), ylim = range(y, 0),
	      xlab = deparse(substitute(x)), ylab,
	      axes = TRUE, plot = TRUE, labels = FALSE, nclass = NULL, ...)
{
    if (!is.numeric(x))
	stop("hist: x must be numeric")
    main # eval() now: defeat lazy eval
    xlab
    n <- length(x <- x[!is.na(x)])
    use.br <- !missing(breaks)
    if(use.br) {
	if(!missing(nclass))
	    warning("`nclass' not used when `breaks' specified")
    }
    else if(!is.null(nclass) && length(nclass) == 1)
	breaks <- nclass
    use.br <- use.br && (nB <- length(breaks)) > 1
    if(use.br)
	breaks <- sort(breaks)
    else { # construct vector of breaks
	rx <- range(x)
	nnb <-
	    if(missing(breaks)) 1 + log2(n)
	    else { # breaks = `nclass'
		if (is.na(breaks) | breaks < 2)
		    stop("invalid number of breaks")
		breaks
	    }
	breaks <- pretty (rx, n = nnb, min.n=1, eps.corr = 2)
	nB <- length(breaks)
	if(nB <= 1) { ##-- Impossible !
	    stop(paste("hist.default: pretty() error, breaks=",format(breaks)))
	}
    }
    storage.mode(x) <- "double"
    storage.mode(breaks) <- "double"
    counts <- .C("bincount",
		 x,
		 n,
		 breaks,
		 nB,
		 counts = integer(nB - 1),
		 right	= as.logical(right),
		 include= as.logical(include.lowest),
		 NAOK = FALSE, DUP = FALSE, PACKAGE = "base") $counts
    if (any(counts < 0))
	stop("negative `counts'. Internal Error in C-code for \"bincount\"")
    if (sum(counts) < n)
	stop("some `x' not counted; maybe `breaks' do not span range of `x'")
    h <- diff(breaks)
    if (!use.br && any(h <= 0))
	stop("not strictly increasing `breaks'.")
    if (is.null(freq)) {
	freq <- if(!missing(probability))
	    !as.logical(probability)
	else if(use.br) {
	    ##-- Do frequencies if breaks are evenly spaced
	    max(h)-min(h) < 1e-7 * mean(h)
	} else TRUE
    } else if(!missing(probability) && any(probability == freq))
	stop("`probability is an alias for `!freq', however they differ.")
    intensities <- counts/(n*h)
    mids <- 0.5 * (breaks[-1] + breaks[-nB])
    y <- if (freq) counts else intensities
    r <- list(breaks = breaks, counts = counts,
	      intensities = intensities, mids = mids)
    if (plot) {
	plot.new()
	plot.window(xlim, ylim, "") #-> ylim's default from 'y'
	if (missing(ylab))
	    ylab <- paste(if(!freq)"Relative ", "Frequency", sep="")
	if(freq && use.br && max(h)-min(h) > 1e-7 * mean(h))
	    warning("the AREAS in the plot are wrong -- maybe use `freq=FALSE'")
	title(main = main, xlab = xlab, ylab = ylab, ...)
	if(axes) {
	    axis(1, ...)
	    axis(2, ...)
	}
	rect(breaks[-nB], 0, breaks[-1], y,
	     col = col, border = border)
	if(labels)
	    text(mids, y,
		 labels = if(freq) counts else round(intensities,3),
		 adj = c(0.5, -0.5))
	invisible(r)
    }
    else r
}
print.htest <- function(x, digits = 4, quote = TRUE, prefix = "", ...)
{
    cat("\n\t", x$method, "\n\n")
    cat("data: ", x$data.name, "\n")
    if(!is.null(x$statistic))
	cat(names(x$statistic), " = ", format(round(x$statistic, 4)),
	    ", ", sep = "")
    if(!is.null (x$parameter))
	cat(paste(names(x$parameter), " = ", format(round(x$parameter, 3)),
                  ",", sep = ""), "")
    cat("p-value =", format.pval(x$p.value, digits= digits), "\n")
    if(!is.null(x$alternative)) {
	if(!is.null(x$null.value)) {
	    if(length(x$null.value) == 1) {
		if (x$alternative == "two.sided" )
		    alt.char <- "not equal to"
		else if( x$alternative == "less" )
		    alt.char <- "less than"
		else if( x$alternative == "greater" )
		    alt.char <- "greater than"
		cat("alternative hypothesis:", "true", names(x$null.value),
                    "is", alt.char, x$null.value, "\n")
	    }
	    else {
		cat("alternative hypothesis:", x$alternative, "\n")
		cat("null values:\n")
		print(x$null.value, ...)
	    }
	}
	else cat("alternative hypothesis:", x$alternative, "\n")
    }
    if(!is.null(x$conf.int)) {
	cat(format(100 * attr(x$conf.int, "conf.level")),
	    "percent confidence interval:\n",
            format(c(x$conf.int[1], x$conf.int[2])), "\n")
    }
    if(!is.null(x$estimate)) {
	cat("sample estimates:\n")
	print(x$estimate, ...)
    }
    cat("\n")
    invisible(x)
}
identify <- function(x, ...) UseMethod("identify")

identify.default <- function(x, y=NULL, labels=seq(along=x), pos=FALSE,
			     n=length(x), plot=TRUE, offset=0.5, ...)
{
    opar <- par(list(...))
    on.exit(par(opar))
    xy <- xy.coords(x, y)
    z <- .Internal(identify(xy$x, xy$y, as.character(labels),
			    n, plot, offset))
    i <- seq(z[[1]])[z[[1]]]
    if(pos) list(ind= i, pos= z[[2]][z[[1]]]) else i
}
ifelse <-
    function (test, yes, no)
{
    ans <- test
    test <- as.logical(test)
    nas <- is.na(test)
    if (any(test[!nas])) {
        ans[test] <- rep(yes, length = length(ans))[test]
    }
    if (any(!test[!nas])) {
        ans[!test] <- rep(no, length = length(ans))[!test]
    }
    ans[nas] <- NA
    ans
}
image <- function (x = seq(0, 1, len = nrow(z)),
		   y = seq(0, 1, len = ncol(z)),
		   z,
		   zlim = range(z[is.finite(z)]),
		   xlim = range(x[is.finite(x)]),
		   ylim = range(y[is.finite(y)]),
		   col = heat.colors(12), add = FALSE,
		   xaxs = "i", yaxs = "i", xlab, ylab, ...)
{
    if (missing(z)) {
	if (!missing(x)) {
	    if (is.list(x)) {
		z <- x$z; y <- x$y; x <- x$x
	    } else {
		if(is.null(dim(x)))
		   stop("argument must be matrix alike")
		z <- x
		x <- seq(0, 1, len = nrow(z))
	    }
	    if (missing(xlab)) xlab <- ""
	    if (missing(ylab)) ylab <- ""
	} else stop("no `z' matrix specified")
    } else if (is.list(x)) {
	xn <- deparse(substitute(x))
	if (missing(xlab)) xlab <- paste(xn, "x", sep = "$")
	if (missing(ylab)) ylab <- paste(xn, "y", sep = "$")
	y <- x$y
	x <- x$x
    } else {
	if (missing(xlab))
	    xlab <- if (missing(x)) "" else deparse(substitute(x))
	if (missing(ylab))
	    ylab <- if (missing(y)) "" else deparse(substitute(y))
    }
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
	stop("increasing x and y values expected")
    if (!is.matrix(z))
        stop("`z' must be a matrix")
    if(length(x) > 1 && length(x) == e(substi, ny=NULL, col="lightgray", lty="dotted")
{
    if (is.null(nx)|| nx >= 1) {
        axp <- par("xaxp")
        if(is.null(nx)) nx <- axp[3]
	abline(v = seq(axp[1],axp[2],len=1+nx), col = col, lty = lty)
    }
    if (is.null(ny)|| ny >= 1) {
        axp <- par("yaxp")
        if(is.null(ny)) ny <- axp[3]
	abline(h = seq(axp[1],axp[2],len=1+ny), col = col, lty = lty)
    }
}
###-- NOTE: This is for  NON-Windows only  (cf. windows/help.R )

index.search <- function(topic, path, file="AnIndex", type="help")
    .Internal(index.search(topic, path, file, .Platform$file.sep, type))

help <-
    function (topic, offline = FALSE, package = c(.packages(), .Autoloaded),
              lib.loc = .lib.loc, verbose = .Options$verbose,
              htmlhelp = .Options$htmlhelp)
{
    htmlhelp <- is.logical(htmlhelp) && htmlhelp
    if (!missing(package))
        if (is.name(y <- substitute(package)))
            package <- as.character(y)
    if (!missing(topic)) {
        topic <- substitute(topic)
        if (is.name(topic))
            topic <- as.character(topic)
        else if (!is.character(topic))
            stop("Unimplemented help feature")
        # for cmd/help ..
        if (!is.na(match(topic, c("+", "-", "*", "/", "^", "%%"))))
            topic <- "Arithmetic"
        else if (!is.na(match(topic, c("<", ">", "<=", ">=", "==", "!="))))
            topic <- "Comparison"
        else if (!is.na(match(topic, c("[", "[[", "$"))))
            topic <- "Extract"
        else if (!is.na(match(topic, c("&", "&&", "|", "||", "!"))))
            topic <- "Logic"
        else if (!is.na(match(topic, c("%*%"))))
            topic <- "matmult"
        type <- if(offline) "latex" else if (htmlhelp) "html" else "help"
        INDICES <- system.file(pkg=package, lib=lib.loc)
        file <- index.search(topic, INDICES, "AnIndex", type)
        if (length(file) && file != "") {
            if (verbose)
                cat("\t\t\t\t\t\tHelp file name `", sub(".*/", "", file),
                    ".Rd'\n", sep = "")
            if (!offline) {
                if (htmlhelp) {
                    if(file.exists(file)) {
                        file <- paste("file:", file, sep="")
                        if (is.null(.Options$browser))
                            stop("options(\"browser\") not set")
                        browser <- .Options$browser
                        system(paste(browser, " -remote \"openURL(",
                                     file, ")\" 2>/dev/null || ", browser, " ",
                                     file, " &", sep = ""))
                        cat("help() for",topic, " is shown in browser",browser,
                            "...\nUse\t help(",topic,", htmlhelp=FALSE)\nor\t",
                            "options(htmlhelp = FALSE)\nto revert.\n")
                        return(invisible())
                    } else {
                        if(verbose)
                            cat("no HTML help for `", topic,
                                "' is available\n", sep = "")
                        file <- index.search(topic, INDICES, "AnIndex", "help")
                    }
                }
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                ## end of experimental code
                if(file.exists(zfile))
                    file.show(zfile,
                              ##header= paste("Help for `", topic, "'", sep=""),
                              delete.file = (zfile!=file))
                else
                    stop(paste("The help file for `", topic, "' is missing",
                               sep = ""))
                return(invisible())
            }
            else {
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                if(zfile != file) on.exit(unlink(zfile))
                ## end of experimental code
                if(file.exists(zfile)) {
                    FILE <- tempfile()
                    on.exit(unlink(FILE))
                    cat("\\documentclass[", .Options$papersize, "paper]{article}\n",
                        file = FILE, sep = "")
                    file.append(FILE,
                                file.path(R.home(), "doc", "manual", "Rd.sty"))
                    cat("\\InputIfFileExists{Rhelp.cfg}{}{}\n\\begin{document}\n",
                        file = FILE, append = TRUE)
                    file.append(FILE, zfile)
                    cat("\\end{document}\n", file = FILE, append = TRUE)
                    system(paste(file.path(R.home(), "bin", "help"),
                                 "PRINT", FILE, topic,
                                 .Options$latexcmd, .Options$dvipscmd)
                           )
                    return(invisible())
                }
                else
                    stop(paste("No offline documentation for", topic, "is available"))
            }
        }
        else
            stop(paste("No documentation for `", topic, "'", sep = ""))
    }
    else if (!missing(package))
        library(help = package, lib = lib.loc, character.only = TRUE)
    else if (!missing(lib.loc))
        library(lib = lib.loc)
    else help("help", package = "base", lib.loc = .Library)
}
help.search <- function(topic, fields = c("name", "title"),
                        apropos, keyword, whatis, ignore.case = TRUE,
                        packages = NULL, lib.loc = .lib.loc,
                        help.db = .Options$help.db,
                        verbose = .Options$verbose,
                        rebuild = FALSE) {
    TABLE <- c("name", "alias", "title", "keyword")
    if (!missing(topic)) {
        if (!is.character(topic) || (length(topic) > 1))
            stop("`topic' must be a single character string")
        i <- pmatch(fields, TABLE)
        if (any(is.na(i)))
            stop("incorrect field specification")
        else
            fields <- TABLE[i]
    } else if (!missing(apropos)) {
        if (!is.character(apropos) || (length(apropos) > 1))
            stop("`apropos' must be a single character string")
        else {
            topic <- apropos
            fields <- c("name", "title")
        }
    } else if (!missing(keyword)) {
        if (!is.character(keyword) || (length(keyword) > 1))
            stop("`keyword' must be a single character string")
        else {
            topic <- keyword
            fields <- "keyword"
        }
    } else if (!missing(whatis)) {
        if (!is.character(whatis) || (length(whatis) > 1))
            stop("`whatis' must be a single character string")
        else {
            topic <- whatis
            fields <- "name"
        }
    } else {
        stop("don't know what to search")
    }

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

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

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

    ## Output
    fields <- paste(fields, collapse = " or ")
    if (NROW(db) > 0) {
        FILE <- tempfile()
        cat(paste("Objects with ", fields, " matching `", topic,
                  "':\n\n", sep = ""),
            file = FILE)
        dbnam <- paste(db[ , "name"], "(", db[, "pkg"], ")", sep = "")
        dbtit <- paste(db[ , "title"], sep = "")
        cat(paste(format(dbnam), dbtit, sep = "   "),
            sep = "\n", file = FILE, append = TRUE)
        file.show(FILE, delete.file = TRUE)
    } else {
        cat(paste("No objects found with ", fields, " matching `",
                  topic, "'\n", sep = ""))
    }

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

hist.default <-
    function (x, breaks, freq= NULL, probability = !freq, include.lowest= TRUE,
	      right=TRUE, col = NULL, border = par("fg"),
	      main = paste("Histogram of" , deparse(substitute(x))),
	      xlim = range(breaks), ylim = range(y, 0),
	      xlab = deparse(substitute(x)), ylab,
	      axes = TRUE, plot = TRUE, labels = FALSE, nclass = NULL, ...)
{
    if (!is.numeric(x))
	stop("hist: x must be numeric")
    main # eval() now: defeat lazy eval
    xlab
    n <- length(x <- x[!is.na(x)])
    use.br <- !missing(breaks)
    if(use.br) {
	if(!missing(nclass))
	    warning("`nclass' not used when `breaks' specified")
    }
    else if(!is.null(nclass) && length(nclass) == 1)
	breaks <- nclass
    use.br <- use.br && (nB <- length(breaks)) > 1
    if(use.br)
	breaks <- sort(breaks)
    else { # construct vector of breaks
	rx <- range(x)
	nnb <-
	    if(missing(breaks)) 1 + log2(n)
	    else { # breaks = `nclass'
		if (is.na(breaks) | breaks < 2)
		    stop("invalid number of breaks")
		breaks
	    }
	breaks <- pretty (rx, n = nnb, min.n=1, eps.corr = 2)
	nB <- length(breaks)
	if(nB <= 1) { ##-- Impossible !
	    stop(paste("hist.default: pretty() error, breaks=",format(breaks)))
	}
    }
    storage.mode(x) <- "double"
    storage.mode(breaks) <- "double"
    counts <- .C("bincount",
		 x,
		 n,
		 breaks,
		 nB,
		 counts = integer(nB - 1),
		 right	= as.logical(right),
		 include= as.logical(include.lowest),
		 NAOK = FALSE, DUP = FALSE, PACKAGE = "base") $counts
    if (any(counts < 0))
	stop("negative `counts'. Internal Error in C-code for \"bincount\"")
    if (sum(counts) < n)
	stop("some `x' not counted; maybe `breaks' do not span range of `x'")
    h <- diff(breaks)
    if (!use.br && any(h <= 0))
	stop("not strictly increasing `breaks'.")
    if (is.null(freq)) {
	freq <- if(!missing(probability))
	    !as.logical(probability)
	else if(use.br) {
	    ##-- Do frequencies if breaks are evenly spaced
	    max(h)-min(h) < 1e-7 * mean(h)
	} else TRUE
    } else if(!missing(probability) && any(probability == freq))
	stop("`probability is an alias for `!freq', however they differ.")
    intensities <- counts/(n*h)
    mids <- 0.5 * (breaks[-1] + breaks[-nB])
    y <- if (freq) counts else intensities
    r <- list(breaks = breaks, counts = counts,
	      intensities = intensities, mids = mids)
    if (plot) {
	plot.new()
	plot.window(xlim, ylim, "") #-> ylim's default from 'y'
	if (missing(ylab))
	    ylab <- paste(if(!freq)"Relative ", "Frequency", sep="")
	if(freq && use.br && max(h)-min(h) > 1e-7 * mean(h))
	    warning("the AREAS in the plot are wrong -- maybe use `freq=FALSE'")
	title(main = main, xlab = xlab, ylab = ylab, ...)
	if(axes) {
	    axis(1, ...)
	    axis(2, ...)
	}
	rect(breaks[-nB], 0, breaks[-1], y,
	     col = col, border = border)
	if(labels)
	    text(mids, y,
		 labels = if(freq) counts else round(intensities,3),
		 adj = c(0.5, -0.5))
	invisible(r)
    }
    else r
}
print.htest <- function(x, digits = 4, quote = TRUE, prefix = "", ...)
{
    cat("\n\t", x$method, "\n\n")
    cat("data: ", x$data.name, "\n")
    if(!is.null(x$statistic))
	cat(names(x$statistic), " = ", format(round(x$statistic, 4)),
	    ", ", sep = "")
    if(!is.null (x$parameter))
	cat(paste(names(x$parameter), " = ", format(round(x$parameter, 3)),
                  ",", sep = ""), "")
    cat("p-value =", format.pval(x$p.value, digits= digits), "\n")
    if(!is.null(x$alternative)) {
	if(!is.null(x$null.value)) {
	    if(length(x$null.value) == 1) {
		if (x$alternative == "two.sided" )
		    alt.char <- "not equal to"
		else if( x$alternative == "less" )
		    alt.char <- "less than"
		else if( x$alternative == "greater" )
		    alt.char <- "greater than"
		cat("alternative hypothesis:", "true", names(x$null.value),
                    "is", alt.char, x$null.value, "\n")
	    }
	    else {
		cat("alternative hypothesis:", x$alternative, "\n")
		cat("null values:\n")
		print(x$null.value, ...)
	    }
	}
	else cat("alternative hypothesis:", x$alternative, "\n")
    }
    if(!is.null(x$conf.int)) {
	cat(format(100 * attr(x$conf.int, "conf.level")),
	    "percent confidence interval:\n",
            format(c(x$conf.int[1], x$conf.int[2])), "\n")
    }
    if(!is.null(x$estimate)) {
	cat("sample estimates:\n")
	print(x$estimate, ...)
    }
    cat("\n")
    invisible(x)
}
identify <- function(x, ...) UseMethod("identify")

identify.default <- function(x, y=NULL, labels=seq(along=x), pos=FALSE,
			     n=length(x), plot=TRUE, offset=0.5, ...)
{
    opar <- par(list(...))
    on.exit(par(opar))
    xy <- xy.coords(x, y)
    z <- .Internal(identify(xy$x, xy$y, as.character(labels),
			    n, plot, offset))
    i <- seq(z[[1]])[z[[1]]]
    if(pos) list(ind= i, pos= z[[2]][z[[1]]]) else i
}
ifelse <-
    function (test, yes, no)
{
    ans <- test
    test <- as.logical(test)
    nas <- is.na(test)
    if (any(test[!nas])) {
        ans[test] <- rep(yes, length = length(ans))[test]
    }
    if (any(!test[!nas])) {
        ans[!test] <- rep(no, length = length(ans))[!test]
    }
    ans[nas] <- NA
    ans
}
image <- function (x = seq(0, 1, len = nrow(z)),
		   y = seq(0, 1, len = ncol(z)),
		   z,
		   zlim = range(z[is.finite(z)]),
		   xlim = range(x[is.finite(x)]),
		   ylim = range(y[is.finite(y)]),
		   col = heat.colors(12), add = FALSE,
		   xaxs = "i", yaxs = "i", xlab, ylab, ...)
{
    if (missing(z)) {
	if (!missing(x)) {
	    if (is.list(x)) {
		z <- x$z; y <- x$y; x <- x$x
	    } else {
		if(is.null(dim(x)))
		   stop("argument must be matrix alike")
		z <- x
		x <- seq(0, 1, len = nrow(z))
	    }
	    if (missing(xlab)) xlab <- ""
	    if (missing(ylab)) ylab <- ""
	} else stop("no `z' matrix specified")
    } else if (is.list(x)) {
	xn <- deparse(substitute(x))
	if (missing(xlab)) xlab <- paste(xn, "x", sep = "$")
	if (missing(ylab)) ylab <- paste(xn, "y", sep = "$")
	y <- x$y
	x <- x$x
    } else {
	if (missing(xlab))
	    xlab <- if (missing(x)) "" else deparse(substitute(x))
	if (missing(ylab))
	    ylab <- if (missing(y)) "" else deparse(substitute(y))
    }
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
	stop("increasing x and y values expected")
    if (!is.matrix(z))
        stop("`z' must be a matrix")
    if(length(x) > 1 && length(x) == e(substi, ny=NULL, col="lightgray", lty="dotted")
{
    if (is.null(nx)|| nx >= 1) {
        axp <- par("xaxp")
        if(is.null(nx)) nx <- axp[3]
	abline(v = seq(axp[1],axp[2],len=1+nx), col = col, lty = lty)
    }
    if (is.null(ny)|| ny >= 1) {
        axp <- par("yaxp")
        if(is.null(ny)) ny <- axp[3]
	abline(h = seq(axp[1],axp[2],len=1+ny), col = col, lty = lty)
    }
}
###-- NOTE: This is for  NON-Windows only  (cf. windows/help.R )

index.search <- function(topic, path, file="AnIndex", type="help")
    .Internal(index.search(topic, path, file, .Platform$file.sep, type))

help <-
    function (topic, offline = FALSE, package = c(.packages(), .Autoloaded),
              lib.loc = .lib.loc, verbose = .Options$verbose,
              htmlhelp = .Options$htmlhelp)
{
    htmlhelp <- is.logical(htmlhelp) && htmlhelp
    if (!missing(package))
        if (is.name(y <- substitute(package)))
            package <- as.character(y)
    if (!missing(topic)) {
        topic <- substitute(topic)
        if (is.name(topic))
            topic <- as.character(topic)
        else if (!is.character(topic))
            stop("Unimplemented help feature")
        # for cmd/help ..
        if (!is.na(match(topic, c("+", "-", "*", "/", "^", "%%"))))
            topic <- "Arithmetic"
        else if (!is.na(match(topic, c("<", ">", "<=", ">=", "==", "!="))))
            topic <- "Comparison"
        else if (!is.na(match(topic, c("[", "[[", "$"))))
            topic <- "Extract"
        else if (!is.na(match(topic, c("&", "&&", "|", "||", "!"))))
            topic <- "Logic"
        else if (!is.na(match(topic, c("%*%"))))
            topic <- "matmult"
        type <- if(offline) "latex" else if (htmlhelp) "html" else "help"
        INDICES <- system.file(pkg=package, lib=lib.loc)
        file <- index.search(topic, INDICES, "AnIndex", type)
        if (length(file) && file != "") {
            if (verbose)
                cat("\t\t\t\t\t\tHelp file name `", sub(".*/", "", file),
                    ".Rd'\n", sep = "")
            if (!offline) {
                if (htmlhelp) {
                    if(file.exists(file)) {
                        file <- paste("file:", file, sep="")
                        if (is.null(.Options$browser))
                            stop("options(\"browser\") not set")
                        browser <- .Options$browser
                        system(paste(browser, " -remote \"openURL(",
                                     file, ")\" 2>/dev/null || ", browser, " ",
                                     file, " &", sep = ""))
                        cat("help() for",topic, " is shown in browser",browser,
                            "...\nUse\t help(",topic,", htmlhelp=FALSE)\nor\t",
                            "options(htmlhelp = FALSE)\nto revert.\n")
                        return(invisible())
                    } else {
                        if(verbose)
                            cat("no HTML help for `", topic,
                                "' is available\n", sep = "")
                        file <- index.search(topic, INDICES, "AnIndex", "help")
                    }
                }
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                ## end of experimental code
                if(file.exists(zfile))
                    file.show(zfile,
                              ##header= paste("Help for `", topic, "'", sep=""),
                              delete.file = (zfile!=file))
                else
                    stop(paste("The help file for `", topic, "' is missing",
                               sep = ""))
                return(invisible())
            }
            else {
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                if(zfile != file) on.exit(unlink(zfile))
                ## end of experimental code
                if(file.exists(zfile)) {
                    FILE <- tempfile()
                    on.exit(unlink(FILE))
                    cat("\\documentclass[", .Options$papersize, "paper]{article}\n",
                        file = FILE, sep = "")
                    file.append(FILE,
                                file.path(R.home(), "doc", "manual", "Rd.sty"))
                    cat("\\InputIfFileExists{Rhelp.cfg}{}{}\n\\begin{document}\n",
                        file = FILE, append = TRUE)
                    file.append(FILE, zfile)
                    cat("\\end{document}\n", file = FILE, append = TRUE)
                    system(paste(file.path(R.home(), "bin", "help"),
                                 "PRINT", FILE, topic,
                                 .Options$latexcmd, .Options$dvipscmd)
                           )
                    return(invisible())
                }
                else
                    stop(paste("No offline documentation for", topic, "is available"))
            }
        }
        else
            stop(paste("No documentation for `", topic, "'", sep = ""))
    }
    else if (!missing(package))
        library(help = package, lib = lib.loc, character.only = TRUE)
    else if (!missing(lib.loc))
        library(lib = lib.loc)
    else help("help", package = "base", lib.loc = .Library)
}
help.search <- function(topic, fields = c("name", "title"),
                        apropos, keyword, whatis, ignore.case = TRUE,
                        packages = NULL, lib.loc = .lib.loc,
                        help.db = .Options$help.db,
                        verbose = .Options$verbose,
                        rebuild = FALSE) {
    TABLE <- c("name", "alias", "title", "keyword")
    if (!missing(topic)) {
        if (!is.character(topic) || (length(topic) > 1))
            stop("`topic' must be a single character string")
        i <- pmatch(fields, TABLE)
        if (any(is.na(i)))
            stop("incorrect field specification")
        else
            fields <- TABLE[i]
    } else if (!missing(apropos)) {
        if (!is.character(apropos) || (length(apropos) > 1))
            stop("`apropos' must be a single character string")
        else {
            topic <- apropos
            fields <- c("name", "title")
        }
    } else if (!missing(keyword)) {
        if (!is.character(keyword) || (length(keyword) > 1))
            stop("`keyword' must be a single character string")
        else {
            topic <- keyword
            fields <- "keyword"
        }
    } else if (!missing(whatis)) {
        if (!is.character(whatis) || (length(whatis) > 1))
            stop("`whatis' must be a single character string")
        else {
            topic <- whatis
            fields <- "name"
        }
    } else {
        stop("don't know what to search")
    }

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

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

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

    ## Output
    fields <- paste(fields, collapse = " or ")
    if (NROW(db) > 0) {
        FILE <- tempfile()
        cat(paste("Objects with ", fields, " matching `", topic,
                  "':\n\n", sep = ""),
            file = FILE)
        dbnam <- paste(db[ , "name"], "(", db[, "pkg"], ")", sep = "")
        dbtit <- paste(db[ , "title"], sep = "")
        cat(paste(format(dbnam), dbtit, sep = "   "),
            sep = "\n", file = FILE, append = TRUE)
        file.show(FILE, delete.file = TRUE)
    } else {
        cat(paste("No objects found with ", fields, " matching `",
                  topic, "'\n", sep = ""))
    }

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

hist.default <-
    function (x, breaks, freq= NULL, probability = !freq, include.lowest= TRUE,
	      right=TRUE, col = NULL, border = par("fg"),
	      main = paste("Histogram of" , deparse(substitute(x))),
	      xlim = range(breaks), ylim = range(y, 0),
	      xlab = deparse(substitute(x)), ylab,
	      axes = TRUE, plot = TRUE, labels = FALSE, nclass = NULL, ...)
{
    if (!is.numeric(x))
	stop("hist: x must be numeric")
    main # eval() now: defeat lazy eval
    xlab
    n <- length(x <- x[!is.na(x)])
    use.br <- !missing(breaks)
    if(use.br) {
	if(!missing(nclass))
	    warning("`nclass' not used when `breaks' specified")
    }
    else if(!is.null(nclass) && length(nclass) == 1)
	breaks <- nclass
    use.br <- use.br && (nB <- length(breaks)) > 1
    if(use.br)
	breaks <- sort(breaks)
    else { # construct vector of breaks
	rx <- range(x)
	nnb <-
	    if(missing(breaks)) 1 + log2(n)
	    else { # breaks = `nclass'
		if (is.na(breaks) | breaks < 2)
		    stop("invalid number of breaks")
		breaks
	    }
	breaks <- pretty (rx, n = nnb, min.n=1, eps.corr = 2)
	nB <- length(breaks)
	if(nB <= 1) { ##-- Impossible !
	    stop(paste("hist.default: pretty() error, breaks=",format(breaks)))
	}
    }
    storage.mode(x) <- "double"
    storage.mode(breaks) <- "double"
    counts <- .C("bincount",
		 x,
		 n,
		 breaks,
		 nB,
		 counts = integer(nB - 1),
		 right	= as.logical(right),
		 include= as.logical(include.lowest),
		 NAOK = FALSE, DUP = FALSE, PACKAGE = "base") $counts
    if (any(counts < 0))
	stop("negative `counts'. Internal Error in C-code for \"bincount\"")
    if (sum(counts) < n)
	stop("some `x' not counted; maybe `breaks' do not span range of `x'")
    h <- diff(breaks)
    if (!use.br && any(h <= 0))
	stop("not strictly increasing `breaks'.")
    if (is.null(freq)) {
	freq <- if(!missing(probability))
	    !as.logical(probability)
	else if(use.br) {
	    ##-- Do frequencies if breaks are evenly spaced
	    max(h)-min(h) < 1e-7 * mean(h)
	} else TRUE
    } else if(!missing(probability) && any(probability == freq))
	stop("`probability is an alias for `!freq', however they differ.")
    intensities <- counts/(n*h)
    mids <- 0.5 * (breaks[-1] + breaks[-nB])
    y <- if (freq) counts else intensities
    r <- list(breaks = breaks, counts = counts,
	      intensities = intensities, mids = mids)
    if (plot) {
	plot.new()
	plot.window(xlim, ylim, "") #-> ylim's default from 'y'
	if (missing(ylab))
	    ylab <- paste(if(!freq)"Relative ", "Frequency", sep="")
	if(freq && use.br && max(h)-min(h) > 1e-7 * mean(h))
	    warning("the AREAS in the plot are wrong -- maybe use `freq=FALSE'")
	title(main = main, xlab = xlab, ylab = ylab, ...)
	if(axes) {
	    axis(1, ...)
	    axis(2, ...)
	}
	rect(breaks[-nB], 0, breaks[-1], y,
	     col = col, border = border)
	if(labels)
	    text(mids, y,
		 labels = if(freq) counts else round(intensities,3),
		 adj = c(0.5, -0.5))
	invisible(r)
    }
    else r
}
print.htest <- function(x, digits = 4, quote = TRUE, prefix = "", ...)
{
    cat("\n\t", x$method, "\n\n")
    cat("data: ", x$data.name, "\n")
    if(!is.null(x$statistic))
	cat(names(x$statistic), " = ", format(round(x$statistic, 4)),
	    ", ", sep = "")
    if(!is.null (x$parameter))
	cat(paste(names(x$parameter), " = ", format(round(x$parameter, 3)),
                  ",", sep = ""), "")
    cat("p-value =", format.pval(x$p.value, digits= digits), "\n")
    if(!is.null(x$alternative)) {
	if(!is.null(x$null.value)) {
	    if(length(x$null.value) == 1) {
		if (x$alternative == "two.sided" )
		    alt.char <- "not equal to"
		else if( x$alternative == "less" )
		    alt.char <- "less than"
		else if( x$alternative == "greater" )
		    alt.char <- "greater than"
		cat("alternative hypothesis:", "true", names(x$null.value),
                    "is", alt.char, x$null.value, "\n")
	    }
	    else {
		cat("alternative hypothesis:", x$alternative, "\n")
		cat("null values:\n")
		print(x$null.value, ...)
	    }
	}
	else cat("alternative hypothesis:", x$alternative, "\n")
    }
    if(!is.null(x$conf.int)) {
	cat(format(100 * attr(x$conf.int, "conf.level")),
	    "percent confidence interval:\n",
            format(c(x$conf.int[1], x$conf.int[2])), "\n")
    }
    if(!is.null(x$estimate)) {
	cat("sample estimates:\n")
	print(x$estimate, ...)
    }
    cat("\n")
    invisible(x)
}
identify <- function(x, ...) UseMethod("identify")

identify.default <- function(x, y=NULL, labels=seq(along=x), pos=FALSE,
			     n=length(x), plot=TRUE, offset=0.5, ...)
{
    opar <- par(list(...))
    on.exit(par(opar))
    xy <- xy.coords(x, y)
    z <- .Internal(identify(xy$x, xy$y, as.character(labels),
			    n, plot, offset))
    i <- seq(z[[1]])[z[[1]]]
    if(pos) list(ind= i, pos= z[[2]][z[[1]]]) else i
}
ifelse <-
    function (test, yes, no)
{
    ans <- test
    test <- as.logical(test)
    nas <- is.na(test)
    if (any(test[!nas])) {
        ans[test] <- rep(yes, length = length(ans))[test]
    }
    if (any(!test[!nas])) {
        ans[!test] <- rep(no, length = length(ans))[!test]
    }
    ans[nas] <- NA
    ans
}
image <- function (x = seq(0, 1, len = nrow(z)),
		   y = seq(0, 1, len = ncol(z)),
		   z,
		   zlim = range(z[is.finite(z)]),
		   xlim = range(x[is.finite(x)]),
		   ylim = range(y[is.finite(y)]),
		   col = heat.colors(12), add = FALSE,
		   xaxs = "i", yaxs = "i", xlab, ylab, ...)
{
    if (missing(z)) {
	if (!missing(x)) {
	    if (is.list(x)) {
		z <- x$z; y <- x$y; x <- x$x
	    } else {
		if(is.null(dim(x)))
		   stop("argument must be matrix alike")
		z <- x
		x <- seq(0, 1, len = nrow(z))
	    }
	    if (missing(xlab)) xlab <- ""
	    if (missing(ylab)) ylab <- ""
	} else stop("no `z' matrix specified")
    } else if (is.list(x)) {
	xn <- deparse(substitute(x))
	if (missing(xlab)) xlab <- paste(xn, "x", sep = "$")
	if (missing(ylab)) ylab <- paste(xn, "y", sep = "$")
	y <- x$y
	x <- x$x
    } else {
	if (missing(xlab))
	    xlab <- if (missing(x)) "" else deparse(substitute(x))
	if (missing(ylab))
	    ylab <- if (missing(y)) "" else deparse(substitute(y))
    }
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
	stop("increasing x and y values expected")
    if (!is.matrix(z))
        stop("`z' must be a matrix")
    if(length(x) > 1 && length(x) == e(substi, ny=NULL, col="lightgray", lty="dotted")
{
    if (is.null(nx)|| nx >= 1) {
        axp <- par("xaxp")
        if(is.null(nx)) nx <- axp[3]
	abline(v = seq(axp[1],axp[2],len=1+nx), col = col, lty = lty)
    }
    if (is.null(ny)|| ny >= 1) {
        axp <- par("yaxp")
        if(is.null(ny)) ny <- axp[3]
	abline(h = seq(axp[1],axp[2],len=1+ny), col = col, lty = lty)
    }
}
###-- NOTE: This is for  NON-Windows only  (cf. windows/help.R )

index.search <- function(topic, path, file="AnIndex", type="help")
    .Internal(index.search(topic, path, file, .Platform$file.sep, type))

help <-
    function (topic, offline = FALSE, package = c(.packages(), .Autoloaded),
              lib.loc = .lib.loc, verbose = .Options$verbose,
              htmlhelp = .Options$htmlhelp)
{
    htmlhelp <- is.logical(htmlhelp) && htmlhelp
    if (!missing(package))
        if (is.name(y <- substitute(package)))
            package <- as.character(y)
    if (!missing(topic)) {
        topic <- substitute(topic)
        if (is.name(topic))
            topic <- as.character(topic)
        else if (!is.character(topic))
            stop("Unimplemented help feature")
        # for cmd/help ..
        if (!is.na(match(topic, c("+", "-", "*", "/", "^", "%%"))))
            topic <- "Arithmetic"
        else if (!is.na(match(topic, c("<", ">", "<=", ">=", "==", "!="))))
            topic <- "Comparison"
        else if (!is.na(match(topic, c("[", "[[", "$"))))
            topic <- "Extract"
        else if (!is.na(match(topic, c("&", "&&", "|", "||", "!"))))
            topic <- "Logic"
        else if (!is.na(match(topic, c("%*%"))))
            topic <- "matmult"
        type <- if(offline) "latex" else if (htmlhelp) "html" else "help"
        INDICES <- system.file(pkg=package, lib=lib.loc)
        file <- index.search(topic, INDICES, "AnIndex", type)
        if (length(file) && file != "") {
            if (verbose)
                cat("\t\t\t\t\t\tHelp file name `", sub(".*/", "", file),
                    ".Rd'\n", sep = "")
            if (!offline) {
                if (htmlhelp) {
                    if(file.exists(file)) {
                        file <- paste("file:", file, sep="")
                        if (is.null(.Options$browser))
                            stop("options(\"browser\") not set")
                        browser <- .Options$browser
                        system(paste(browser, " -remote \"openURL(",
                                     file, ")\" 2>/dev/null || ", browser, " ",
                                     file, " &", sep = ""))
                        cat("help() for",topic, " is shown in browser",browser,
                            "...\nUse\t help(",topic,", htmlhelp=FALSE)\nor\t",
                            "options(htmlhelp = FALSE)\nto revert.\n")
                        return(invisible())
                    } else {
                        if(verbose)
                            cat("no HTML help for `", topic,
                                "' is available\n", sep = "")
                        file <- index.search(topic, INDICES, "AnIndex", "help")
                    }
                }
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                ## end of experimental code
                if(file.exists(zfile))
                    file.show(zfile,
                              ##header= paste("Help for `", topic, "'", sep=""),
                              delete.file = (zfile!=file))
                else
                    stop(paste("The help file for `", topic, "' is missing",
                               sep = ""))
                return(invisible())
            }
            else {
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                if(zfile != file) on.exit(unlink(zfile))
                ## end of experimental code
                if(file.exists(zfile)) {
                    FILE <- tempfile()
                    on.exit(unlink(FILE))
                    cat("\\documentclass[", .Options$papersize, "paper]{article}\n",
                        file = FILE, sep = "")
                    file.append(FILE,
                                file.path(R.home(), "doc", "manual", "Rd.sty"))
                    cat("\\InputIfFileExists{Rhelp.cfg}{}{}\n\\begin{document}\n",
                        file = FILE, append = TRUE)
                    file.append(FILE, zfile)
                    cat("\\end{document}\n", file = FILE, append = TRUE)
                    system(paste(file.path(R.home(), "bin", "help"),
                                 "PRINT", FILE, topic,
                                 .Options$latexcmd, .Options$dvipscmd)
                           )
                    return(invisible())
                }
                else
                    stop(paste("No offline documentation for", topic, "is available"))
            }
        }
        else
            stop(paste("No documentation for `", topic, "'", sep = ""))
    }
    else if (!missing(package))
        library(help = package, lib = lib.loc, character.only = TRUE)
    else if (!missing(lib.loc))
        library(lib = lib.loc)
    else help("help", package = "base", lib.loc = .Library)
}
help.search <- function(topic, fields = c("name", "title"),
                        apropos, keyword, whatis, ignore.case = TRUE,
                        packages = NULL, lib.loc = .lib.loc,
                        help.db = .Options$help.db,
                        verbose = .Options$verbose,
                        rebuild = FALSE) {
    TABLE <- c("name", "alias", "title", "keyword")
    if (!missing(topic)) {
        if (!is.character(topic) || (length(topic) > 1))
            stop("`topic' must be a single character string")
        i <- pmatch(fields, TABLE)
        if (any(is.na(i)))
            stop("incorrect field specification")
        else
            fields <- TABLE[i]
    } else if (!missing(apropos)) {
        if (!is.character(apropos) || (length(apropos) > 1))
            stop("`apropos' must be a single character string")
        else {
            topic <- apropos
            fields <- c("name", "title")
        }
    } else if (!missing(keyword)) {
        if (!is.character(keyword) || (length(keyword) > 1))
            stop("`keyword' must be a single character string")
        else {
            topic <- keyword
            fields <- "keyword"
        }
    } else if (!missing(whatis)) {
        if (!is.character(whatis) || (length(whatis) > 1))
            stop("`whatis' must be a single character string")
        else {
            topic <- whatis
            fields <- "name"
        }
    } else {
        stop("don't know what to search")
    }

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

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

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

    ## Output
    fields <- paste(fields, collapse = " or ")
    if (NROW(db) > 0) {
        FILE <- tempfile()
        cat(paste("Objects with ", fields, " matching `", topic,
                  "':\n\n", sep = ""),
            file = FILE)
        dbnam <- paste(db[ , "name"], "(", db[, "pkg"], ")", sep = "")
        dbtit <- paste(db[ , "title"], sep = "")
        cat(paste(format(dbnam), dbtit, sep = "   "),
            sep = "\n", file = FILE, append = TRUE)
        file.show(FILE, delete.file = TRUE)
    } else {
        cat(paste("No objects found with ", fields, " matching `",
                  topic, "'\n", sep = ""))
    }

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

hist.default <-
    function (x, breaks, freq= NULL, probability = !freq, include.lowest= TRUE,
	      right=TRUE, col = NULL, border = par("fg"),
	      main = paste("Histogram of" , deparse(substitute(x))),
	      xlim = range(breaks), ylim = range(y, 0),
	      xlab = deparse(substitute(x)), ylab,
	      axes = TRUE, plot = TRUE, labels = FALSE, nclass = NULL, ...)
{
    if (!is.numeric(x))
	stop("hist: x must be numeric")
    main # eval() now: defeat lazy eval
    xlab
    n <- length(x <- x[!is.na(x)])
    use.br <- !missing(breaks)
    if(use.br) {
	if(!missing(nclass))
	    warning("`nclass' not used when `breaks' specified")
    }
    else if(!is.null(nclass) && length(nclass) == 1)
	breaks <- nclass
    use.br <- use.br && (nB <- length(breaks)) > 1
    if(use.br)
	breaks <- sort(breaks)
    else { # construct vector of breaks
	rx <- range(x)
	nnb <-
	    if(missing(breaks)) 1 + log2(n)
	    else { # breaks = `nclass'
		if (is.na(breaks) | breaks < 2)
		    stop("invalid number of breaks")
		breaks
	    }
	breaks <- pretty (rx, n = nnb, min.n=1, eps.corr = 2)
	nB <- length(breaks)
	if(nB <= 1) { ##-- Impossible !
	    stop(paste("hist.default: pretty() error, breaks=",format(breaks)))
	}
    }
    storage.mode(x) <- "double"
    storage.mode(breaks) <- "double"
    counts <- .C("bincount",
		 x,
		 n,
		 breaks,
		 nB,
		 counts = integer(nB - 1),
		 right	= as.logical(right),
		 include= as.logical(include.lowest),
		 NAOK = FALSE, DUP = FALSE, PACKAGE = "base") $counts
    if (any(counts < 0))
	stop("negative `counts'. Internal Error in C-code for \"bincount\"")
    if (sum(counts) < n)
	stop("some `x' not counted; maybe `breaks' do not span range of `x'")
    h <- diff(breaks)
    if (!use.br && any(h <= 0))
	stop("not strictly increasing `breaks'.")
    if (is.null(freq)) {
	freq <- if(!missing(probability))
	    !as.logical(probability)
	else if(use.br) {
	    ##-- Do frequencies if breaks are evenly spaced
	    max(h)-min(h) < 1e-7 * mean(h)
	} else TRUE
    } else if(!missing(probability) && any(probability == freq))
	stop("`probability is an alias for `!freq', however they differ.")
    intensities <- counts/(n*h)
    mids <- 0.5 * (breaks[-1] + breaks[-nB])
    y <- if (freq) counts else intensities
    r <- list(breaks = breaks, counts = counts,
	      intensities = intensities, mids = mids)
    if (plot) {
	plot.new()
	plot.window(xlim, ylim, "") #-> ylim's default from 'y'
	if (missing(ylab))
	    ylab <- paste(if(!freq)"Relative ", "Frequency", sep="")
	if(freq && use.br && max(h)-min(h) > 1e-7 * mean(h))
	    warning("the AREAS in the plot are wrong -- maybe use `freq=FALSE'")
	title(main = main, xlab = xlab, ylab = ylab, ...)
	if(axes) {
	    axis(1, ...)
	    axis(2, ...)
	}
	rect(breaks[-nB], 0, breaks[-1], y,
	     col = col, border = border)
	if(labels)
	    text(mids, y,
		 labels = if(freq) counts else round(intensities,3),
		 adj = c(0.5, -0.5))
	invisible(r)
    }
    else r
}
print.htest <- function(x, digits = 4, quote = TRUE, prefix = "", ...)
{
    cat("\n\t", x$method, "\n\n")
    cat("data: ", x$data.name, "\n")
    if(!is.null(x$statistic))
	cat(names(x$statistic), " = ", format(round(x$statistic, 4)),
	    ", ", sep = "")
    if(!is.null (x$parameter))
	cat(paste(names(x$parameter), " = ", format(round(x$parameter, 3)),
                  ",", sep = ""), "")
    cat("p-value =", format.pval(x$p.value, digits= digits), "\n")
    if(!is.null(x$alternative)) {
	if(!is.null(x$null.value)) {
	    if(length(x$null.value) == 1) {
		if (x$alternative == "two.sided" )
		    alt.char <- "not equal to"
		else if( x$alternative == "less" )
		    alt.char <- "less than"
		else if( x$alternative == "greater" )
		    alt.char <- "greater than"
		cat("alternative hypothesis:", "true", names(x$null.value),
                    "is", alt.char, x$null.value, "\n")
	    }
	    else {
		cat("alternative hypothesis:", x$alternative, "\n")
		cat("null values:\n")
		print(x$null.value, ...)
	    }
	}
	else cat("alternative hypothesis:", x$alternative, "\n")
    }
    if(!is.null(x$conf.int)) {
	cat(format(100 * attr(x$conf.int, "conf.level")),
	    "percent confidence interval:\n",
            format(c(x$conf.int[1], x$conf.int[2])), "\n")
    }
    if(!is.null(x$estimate)) {
	cat("sample estimates:\n")
	print(x$estimate, ...)
    }
    cat("\n")
    invisible(x)
}
identify <- function(x, ...) UseMethod("identify")

identify.default <- function(x, y=NULL, labels=seq(along=x), pos=FALSE,
			     n=length(x), plot=TRUE, offset=0.5, ...)
{
    opar <- par(list(...))
    on.exit(par(opar))
    xy <- xy.coords(x, y)
    z <- .Internal(identify(xy$x, xy$y, as.character(labels),
			    n, plot, offset))
    i <- seq(z[[1]])[z[[1]]]
    if(pos) list(ind= i, pos= z[[2]][z[[1]]]) else i
}
ifelse <-
    function (test, yes, no)
{
    ans <- test
    test <- as.logical(test)
    nas <- is.na(test)
    if (any(test[!nas])) {
        ans[test] <- rep(yes, length = length(ans))[test]
    }
    if (any(!test[!nas])) {
        ans[!test] <- rep(no, length = length(ans))[!test]
    }
    ans[nas] <- NA
    ans
}
image <- function (x = seq(0, 1, len = nrow(z)),
		   y = seq(0, 1, len = ncol(z)),
		   z,
		   zlim = range(z[is.finite(z)]),
		   xlim = range(x[is.finite(x)]),
		   ylim = range(y[is.finite(y)]),
		   col = heat.colors(12), add = FALSE,
		   xaxs = "i", yaxs = "i", xlab, ylab, ...)
{
    if (missing(z)) {
	if (!missing(x)) {
	    if (is.list(x)) {
		z <- x$z; y <- x$y; x <- x$x
	    } else {
		if(is.null(dim(x)))
		   stop("argument must be matrix alike")
		z <- x
		x <- seq(0, 1, len = nrow(z))
	    }
	    if (missing(xlab)) xlab <- ""
	    if (missing(ylab)) ylab <- ""
	} else stop("no `z' matrix specified")
    } else if (is.list(x)) {
	xn <- deparse(substitute(x))
	if (missing(xlab)) xlab <- paste(xn, "x", sep = "$")
	if (missing(ylab)) ylab <- paste(xn, "y", sep = "$")
	y <- x$y
	x <- x$x
    } else {
	if (missing(xlab))
	    xlab <- if (missing(x)) "" else deparse(substitute(x))
	if (missing(ylab))
	    ylab <- if (missing(y)) "" else deparse(substitute(y))
    }
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
	stop("increasing x and y values expected")
    if (!is.matrix(z))
        stop("`z' must be a matrix")
    if(length(x) > 1 && length(x) == e(substi, ny=NULL, col="lightgray", lty="dotted")
{
    if (is.null(nx)|| nx >= 1) {
        axp <- par("xaxp")
        if(is.null(nx)) nx <- axp[3]
	abline(v = seq(axp[1],axp[2],len=1+nx), col = col, lty = lty)
    }
    if (is.null(ny)|| ny >= 1) {
        axp <- par("yaxp")
        if(is.null(ny)) ny <- axp[3]
	abline(h = seq(axp[1],axp[2],len=1+ny), col = col, lty = lty)
    }
}
###-- NOTE: This is for  NON-Windows only  (cf. windows/help.R )

index.search <- function(topic, path, file="AnIndex", type="help")
    .Internal(index.search(topic, path, file, .Platform$file.sep, type))

help <-
    function (topic, offline = FALSE, package = c(.packages(), .Autoloaded),
              lib.loc = .lib.loc, verbose = .Options$verbose,
              htmlhelp = .Options$htmlhelp)
{
    htmlhelp <- is.logical(htmlhelp) && htmlhelp
    if (!missing(package))
        if (is.name(y <- substitute(package)))
            package <- as.character(y)
    if (!missing(topic)) {
        topic <- substitute(topic)
        if (is.name(topic))
            topic <- as.character(topic)
        else if (!is.character(topic))
            stop("Unimplemented help feature")
        # for cmd/help ..
        if (!is.na(match(topic, c("+", "-", "*", "/", "^", "%%"))))
            topic <- "Arithmetic"
        else if (!is.na(match(topic, c("<", ">", "<=", ">=", "==", "!="))))
            topic <- "Comparison"
        else if (!is.na(match(topic, c("[", "[[", "$"))))
            topic <- "Extract"
        else if (!is.na(match(topic, c("&", "&&", "|", "||", "!"))))
            topic <- "Logic"
        else if (!is.na(match(topic, c("%*%"))))
            topic <- "matmult"
        type <- if(offline) "latex" else if (htmlhelp) "html" else "help"
        INDICES <- system.file(pkg=package, lib=lib.loc)
        file <- index.search(topic, INDICES, "AnIndex", type)
        if (length(file) && file != "") {
            if (verbose)
                cat("\t\t\t\t\t\tHelp file name `", sub(".*/", "", file),
                    ".Rd'\n", sep = "")
            if (!offline) {
                if (htmlhelp) {
                    if(file.exists(file)) {
                        file <- paste("file:", file, sep="")
                        if (is.null(.Options$browser))
                            stop("options(\"browser\") not set")
                        browser <- .Options$browser
                        system(paste(browser, " -remote \"openURL(",
                                     file, ")\" 2>/dev/null || ", browser, " ",
                                     file, " &", sep = ""))
                        cat("help() for",topic, " is shown in browser",browser,
                            "...\nUse\t help(",topic,", htmlhelp=FALSE)\nor\t",
                            "options(htmlhelp = FALSE)\nto revert.\n")
                        return(invisible())
                    } else {
                        if(verbose)
                            cat("no HTML help for `", topic,
                                "' is available\n", sep = "")
                        file <- index.search(topic, INDICES, "AnIndex", "help")
                    }
                }
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                ## end of experimental code
                if(file.exists(zfile))
                    file.show(zfile,
                              ##header= paste("Help for `", topic, "'", sep=""),
                              delete.file = (zfile!=file))
                else
                    stop(paste("The help file for `", topic, "' is missing",
                               sep = ""))
                return(invisible())
            }
            else {
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                if(zfile != file) on.exit(unlink(zfile))
                ## end of experimental code
                if(file.exists(zfile)) {
                    FILE <- tempfile()
                    on.exit(unlink(FILE))
                    cat("\\documentclass[", .Options$papersize, "paper]{article}\n",
                        file = FILE, sep = "")
                    file.append(FILE,
                                file.path(R.home(), "doc", "manual", "Rd.sty"))
                    cat("\\InputIfFileExists{Rhelp.cfg}{}{}\n\\begin{document}\n",
                        file = FILE, append = TRUE)
                    file.append(FILE, zfile)
                    cat("\\end{document}\n", file = FILE, append = TRUE)
                    system(paste(file.path(R.home(), "bin", "help"),
                                 "PRINT", FILE, topic,
                                 .Options$latexcmd, .Options$dvipscmd)
                           )
                    return(invisible())
                }
                else
                    stop(paste("No offline documentation for", topic, "is available"))
            }
        }
        else
            stop(paste("No documentation for `", topic, "'", sep = ""))
    }
    else if (!missing(package))
        library(help = package, lib = lib.loc, character.only = TRUE)
    else if (!missing(lib.loc))
        library(lib = lib.loc)
    else help("help", package = "base", lib.loc = .Library)
}
help.search <- function(topic, fields = c("name", "title"),
                        apropos, keyword, whatis, ignore.case = TRUE,
                        packages = NULL, lib.loc = .lib.loc,
                        help.db = .Options$help.db,
                        verbose = .Options$verbose,
                        rebuild = FALSE) {
    TABLE <- c("name", "alias", "title", "keyword")
    if (!missing(topic)) {
        if (!is.character(topic) || (length(topic) > 1))
            stop("`topic' must be a single character string")
        i <- pmatch(fields, TABLE)
        if (any(is.na(i)))
            stop("incorrect field specification")
        else
            fields <- TABLE[i]
    } else if (!missing(apropos)) {
        if (!is.character(apropos) || (length(apropos) > 1))
            stop("`apropos' must be a single character string")
        else {
            topic <- apropos
            fields <- c("name", "title")
        }
    } else if (!missing(keyword)) {
        if (!is.character(keyword) || (length(keyword) > 1))
            stop("`keyword' must be a single character string")
        else {
            topic <- keyword
            fields <- "keyword"
        }
    } else if (!missing(whatis)) {
        if (!is.character(whatis) || (length(whatis) > 1))
            stop("`whatis' must be a single character string")
        else {
            topic <- whatis
            fields <- "name"
        }
    } else {
        stop("don't know what to search")
    }

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

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

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

    ## Output
    fields <- paste(fields, collapse = " or ")
    if (NROW(db) > 0) {
        FILE <- tempfile()
        cat(paste("Objects with ", fields, " matching `", topic,
                  "':\n\n", sep = ""),
            file = FILE)
        dbnam <- paste(db[ , "name"], "(", db[, "pkg"], ")", sep = "")
        dbtit <- paste(db[ , "title"], sep = "")
        cat(paste(format(dbnam), dbtit, sep = "   "),
            sep = "\n", file = FILE, append = TRUE)
        file.show(FILE, delete.file = TRUE)
    } else {
        cat(paste("No objects found with ", fields, " matching `",
                  topic, "'\n", sep = ""))
    }

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

hist.default <-
    function (x, breaks, freq= NULL, probability = !freq, include.lowest= TRUE,
	      right=TRUE, col = NULL, border = par("fg"),
	      main = paste("Histogram of" , deparse(substitute(x))),
	      xlim = range(breaks), ylim = range(y, 0),
	      xlab = deparse(substitute(x)), ylab,
	      axes = TRUE, plot = TRUE, labels = FALSE, nclass = NULL, ...)
{
    if (!is.numeric(x))
	stop("hist: x must be numeric")
    main # eval() now: defeat lazy eval
    xlab
    n <- length(x <- x[!is.na(x)])
    use.br <- !missing(breaks)
    if(use.br) {
	if(!missing(nclass))
	    warning("`nclass' not used when `breaks' specified")
    }
    else if(!is.null(nclass) && length(nclass) == 1)
	breaks <- nclass
    use.br <- use.br && (nB <- length(breaks)) > 1
    if(use.br)
	breaks <- sort(breaks)
    else { # construct vector of breaks
	rx <- range(x)
	nnb <-
	    if(missing(breaks)) 1 + log2(n)
	    else { # breaks = `nclass'
		if (is.na(breaks) | breaks < 2)
		    stop("invalid number of breaks")
		breaks
	    }
	breaks <- pretty (rx, n = nnb, min.n=1, eps.corr = 2)
	nB <- length(breaks)
	if(nB <= 1) { ##-- Impossible !
	    stop(paste("hist.default: pretty() error, breaks=",format(breaks)))
	}
    }
    storage.mode(x) <- "double"
    storage.mode(breaks) <- "double"
    counts <- .C("bincount",
		 x,
		 n,
		 breaks,
		 nB,
		 counts = integer(nB - 1),
		 right	= as.logical(right),
		 include= as.logical(include.lowest),
		 NAOK = FALSE, DUP = FALSE, PACKAGE = "base") $counts
    if (any(counts < 0))
	stop("negative `counts'. Internal Error in C-code for \"bincount\"")
    if (sum(counts) < n)
	stop("some `x' not counted; maybe `breaks' do not span range of `x'")
    h <- diff(breaks)
    if (!use.br && any(h <= 0))
	stop("not strictly increasing `breaks'.")
    if (is.null(freq)) {
	freq <- if(!missing(probability))
	    !as.logical(probability)
	else if(use.br) {
	    ##-- Do frequencies if breaks are evenly spaced
	    max(h)-min(h) < 1e-7 * mean(h)
	} else TRUE
    } else if(!missing(probability) && any(probability == freq))
	stop("`probability is an alias for `!freq', however they differ.")
    intensities <- counts/(n*h)
    mids <- 0.5 * (breaks[-1] + breaks[-nB])
    y <- if (freq) counts else intensities
    r <- list(breaks = breaks, counts = counts,
	      intensities = intensities, mids = mids)
    if (plot) {
	plot.new()
	plot.window(xlim, ylim, "") #-> ylim's default from 'y'
	if (missing(ylab))
	    ylab <- paste(if(!freq)"Relative ", "Frequency", sep="")
	if(freq && use.br && max(h)-min(h) > 1e-7 * mean(h))
	    warning("the AREAS in the plot are wrong -- maybe use `freq=FALSE'")
	title(main = main, xlab = xlab, ylab = ylab, ...)
	if(axes) {
	    axis(1, ...)
	    axis(2, ...)
	}
	rect(breaks[-nB], 0, breaks[-1], y,
	     col = col, border = border)
	if(labels)
	    text(mids, y,
		 labels = if(freq) counts else round(intensities,3),
		 adj = c(0.5, -0.5))
	invisible(r)
    }
    else r
}
print.htest <- function(x, digits = 4, quote = TRUE, prefix = "", ...)
{
    cat("\n\t", x$method, "\n\n")
    cat("data: ", x$data.name, "\n")
    if(!is.null(x$statistic))
	cat(names(x$statistic), " = ", format(round(x$statistic, 4)),
	    ", ", sep = "")
    if(!is.null (x$parameter))
	cat(paste(names(x$parameter), " = ", format(round(x$parameter, 3)),
                  ",", sep = ""), "")
    cat("p-value =", format.pval(x$p.value, digits= digits), "\n")
    if(!is.null(x$alternative)) {
	if(!is.null(x$null.value)) {
	    if(length(x$null.value) == 1) {
		if (x$alternative == "two.sided" )
		    alt.char <- "not equal to"
		else if( x$alternative == "less" )
		    alt.char <- "less than"
		else if( x$alternative == "greater" )
		    alt.char <- "greater than"
		cat("alternative hypothesis:", "true", names(x$null.value),
                    "is", alt.char, x$null.value, "\n")
	    }
	    else {
		cat("alternative hypothesis:", x$alternative, "\n")
		cat("null values:\n")
		print(x$null.value, ...)
	    }
	}
	else cat("alternative hypothesis:", x$alternative, "\n")
    }
    if(!is.null(x$conf.int)) {
	cat(format(100 * attr(x$conf.int, "conf.level")),
	    "percent confidence interval:\n",
            format(c(x$conf.int[1], x$conf.int[2])), "\n")
    }
    if(!is.null(x$estimate)) {
	cat("sample estimates:\n")
	print(x$estimate, ...)
    }
    cat("\n")
    invisible(x)
}
identify <- function(x, ...) UseMethod("identify")

identify.default <- function(x, y=NULL, labels=seq(along=x), pos=FALSE,
			     n=length(x), plot=TRUE, offset=0.5, ...)
{
    opar <- par(list(...))
    on.exit(par(opar))
    xy <- xy.coords(x, y)
    z <- .Internal(identify(xy$x, xy$y, as.character(labels),
			    n, plot, offset))
    i <- seq(z[[1]])[z[[1]]]
    if(pos) list(ind= i, pos= z[[2]][z[[1]]]) else i
}
ifelse <-
    function (test, yes, no)
{
    ans <- test
    test <- as.logical(test)
    nas <- is.na(test)
    if (any(test[!nas])) {
        ans[test] <- rep(yes, length = length(ans))[test]
    }
    if (any(!test[!nas])) {
        ans[!test] <- rep(no, length = length(ans))[!test]
    }
    ans[nas] <- NA
    ans
}
image <- function (x = seq(0, 1, len = nrow(z)),
		   y = seq(0, 1, len = ncol(z)),
		   z,
		   zlim = range(z[is.finite(z)]),
		   xlim = range(x[is.finite(x)]),
		   ylim = range(y[is.finite(y)]),
		   col = heat.colors(12), add = FALSE,
		   xaxs = "i", yaxs = "i", xlab, ylab, ...)
{
    if (missing(z)) {
	if (!missing(x)) {
	    if (is.list(x)) {
		z <- x$z; y <- x$y; x <- x$x
	    } else {
		if(is.null(dim(x)))
		   stop("argument must be matrix alike")
		z <- x
		x <- seq(0, 1, len = nrow(z))
	    }
	    if (missing(xlab)) xlab <- ""
	    if (missing(ylab)) ylab <- ""
	} else stop("no `z' matrix specified")
    } else if (is.list(x)) {
	xn <- deparse(substitute(x))
	if (missing(xlab)) xlab <- paste(xn, "x", sep = "$")
	if (missing(ylab)) ylab <- paste(xn, "y", sep = "$")
	y <- x$y
	x <- x$x
    } else {
	if (missing(xlab))
	    xlab <- if (missing(x)) "" else deparse(substitute(x))
	if (missing(ylab))
	    ylab <- if (missing(y)) "" else deparse(substitute(y))
    }
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
	stop("increasing x and y values expected")
    if (!is.matrix(z))
        stop("`z' must be a matrix")
    if(length(x) > 1 && length(x) == e(substi, ny=NULL, col="lightgray", lty="dotted")
{
    if (is.null(nx)|| nx >= 1) {
        axp <- par("xaxp")
        if(is.null(nx)) nx <- axp[3]
	abline(v = seq(axp[1],axp[2],len=1+nx), col = col, lty = lty)
    }
    if (is.null(ny)|| ny >= 1) {
        axp <- par("yaxp")
        if(is.null(ny)) ny <- axp[3]
	abline(h = seq(axp[1],axp[2],len=1+ny), col = col, lty = lty)
    }
}
###-- NOTE: This is for  NON-Windows only  (cf. windows/help.R )

index.search <- function(topic, path, file="AnIndex", type="help")
    .Internal(index.search(topic, path, file, .Platform$file.sep, type))

help <-
    function (topic, offline = FALSE, package = c(.packages(), .Autoloaded),
              lib.loc = .lib.loc, verbose = .Options$verbose,
              htmlhelp = .Options$htmlhelp)
{
    htmlhelp <- is.logical(htmlhelp) && htmlhelp
    if (!missing(package))
        if (is.name(y <- substitute(package)))
            package <- as.character(y)
    if (!missing(topic)) {
        topic <- substitute(topic)
        if (is.name(topic))
            topic <- as.character(topic)
        else if (!is.character(topic))
            stop("Unimplemented help feature")
        # for cmd/help ..
        if (!is.na(match(topic, c("+", "-", "*", "/", "^", "%%"))))
            topic <- "Arithmetic"
        else if (!is.na(match(topic, c("<", ">", "<=", ">=", "==", "!="))))
            topic <- "Comparison"
        else if (!is.na(match(topic, c("[", "[[", "$"))))
            topic <- "Extract"
        else if (!is.na(match(topic, c("&", "&&", "|", "||", "!"))))
            topic <- "Logic"
        else if (!is.na(match(topic, c("%*%"))))
            topic <- "matmult"
        type <- if(offline) "latex" else if (htmlhelp) "html" else "help"
        INDICES <- system.file(pkg=package, lib=lib.loc)
        file <- index.search(topic, INDICES, "AnIndex", type)
        if (length(file) && file != "") {
            if (verbose)
                cat("\t\t\t\t\t\tHelp file name `", sub(".*/", "", file),
                    ".Rd'\n", sep = "")
            if (!offline) {
                if (htmlhelp) {
                    if(file.exists(file)) {
                        file <- paste("file:", file, sep="")
                        if (is.null(.Options$browser))
                            stop("options(\"browser\") not set")
                        browser <- .Options$browser
                        system(paste(browser, " -remote \"openURL(",
                                     file, ")\" 2>/dev/null || ", browser, " ",
                                     file, " &", sep = ""))
                        cat("help() for",topic, " is shown in browser",browser,
                            "...\nUse\t help(",topic,", htmlhelp=FALSE)\nor\t",
                            "options(htmlhelp = FALSE)\nto revert.\n")
                        return(invisible())
                    } else {
                        if(verbose)
                            cat("no HTML help for `", topic,
                                "' is available\n", sep = "")
                        file <- index.search(topic, INDICES, "AnIndex", "help")
                    }
                }
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                ## end of experimental code
                if(file.exists(zfile))
                    file.show(zfile,
                              ##header= paste("Help for `", topic, "'", sep=""),
                              delete.file = (zfile!=file))
                else
                    stop(paste("The help file for `", topic, "' is missing",
                               sep = ""))
                return(invisible())
            }
            else {
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                if(zfile != file) on.exit(unlink(zfile))
                ## end of experimental code
                if(file.exists(zfile)) {
                    FILE <- tempfile()
                    on.exit(unlink(FILE))
                    cat("\\documentclass[", .Options$papersize, "paper]{article}\n",
                        file = FILE, sep = "")
                    file.append(FILE,
                                file.path(R.home(), "doc", "manual", "Rd.sty"))
                    cat("\\InputIfFileExists{Rhelp.cfg}{}{}\n\\begin{document}\n",
                        file = FILE, append = TRUE)
                    file.append(FILE, zfile)
                    cat("\\end{document}\n", file = FILE, append = TRUE)
                    system(paste(file.path(R.home(), "bin", "help"),
                                 "PRINT", FILE, topic,
                                 .Options$latexcmd, .Options$dvipscmd)
                           )
                    return(invisible())
                }
                else
                    stop(paste("No offline documentation for", topic, "is available"))
            }
        }
        else
            stop(paste("No documentation for `", topic, "'", sep = ""))
    }
    else if (!missing(package))
        library(help = package, lib = lib.loc, character.only = TRUE)
    else if (!missing(lib.loc))
        library(lib = lib.loc)
    else help("help", package = "base", lib.loc = .Library)
}
help.search <- function(topic, fields = c("name", "title"),
                        apropos, keyword, whatis, ignore.case = TRUE,
                        packages = NULL, lib.loc = .lib.loc,
                        help.db = .Options$help.db,
                        verbose = .Options$verbose,
                        rebuild = FALSE) {
    TABLE <- c("name", "alias", "title", "keyword")
    if (!missing(topic)) {
        if (!is.character(topic) || (length(topic) > 1))
            stop("`topic' must be a single character string")
        i <- pmatch(fields, TABLE)
        if (any(is.na(i)))
            stop("incorrect field specification")
        else
            fields <- TABLE[i]
    } else if (!missing(apropos)) {
        if (!is.character(apropos) || (length(apropos) > 1))
            stop("`apropos' must be a single character string")
        else {
            topic <- apropos
            fields <- c("name", "title")
        }
    } else if (!missing(keyword)) {
        if (!is.character(keyword) || (length(keyword) > 1))
            stop("`keyword' must be a single character string")
        else {
            topic <- keyword
            fields <- "keyword"
        }
    } else if (!missing(whatis)) {
        if (!is.character(whatis) || (length(whatis) > 1))
            stop("`whatis' must be a single character string")
        else {
            topic <- whatis
            fields <- "name"
        }
    } else {
        stop("don't know what to search")
    }

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

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

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

    ## Output
    fields <- paste(fields, collapse = " or ")
    if (NROW(db) > 0) {
        FILE <- tempfile()
        cat(paste("Objects with ", fields, " matching `", topic,
                  "':\n\n", sep = ""),
            file = FILE)
        dbnam <- paste(db[ , "name"], "(", db[, "pkg"], ")", sep = "")
        dbtit <- paste(db[ , "title"], sep = "")
        cat(paste(format(dbnam), dbtit, sep = "   "),
            sep = "\n", file = FILE, append = TRUE)
        file.show(FILE, delete.file = TRUE)
    } else {
        cat(paste("No objects found with ", fields, " matching `",
                  topic, "'\n", sep = ""))
    }

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

hist.default <-
    function (x, breaks, freq= NULL, probability = !freq, include.lowest= TRUE,
	      right=TRUE, col = NULL, border = par("fg"),
	      main = paste("Histogram of" , deparse(substitute(x))),
	      xlim = range(breaks), ylim = range(y, 0),
	      xlab = deparse(substitute(x)), ylab,
	      axes = TRUE, plot = TRUE, labels = FALSE, nclass = NULL, ...)
{
    if (!is.numeric(x))
	stop("hist: x must be numeric")
    main # eval() now: defeat lazy eval
    xlab
    n <- length(x <- x[!is.na(x)])
    use.br <- !missing(breaks)
    if(use.br) {
	if(!missing(nclass))
	    warning("`nclass' not used when `breaks' specified")
    }
    else if(!is.null(nclass) && length(nclass) == 1)
	breaks <- nclass
    use.br <- use.br && (nB <- length(breaks)) > 1
    if(use.br)
	breaks <- sort(breaks)
    else { # construct vector of breaks
	rx <- range(x)
	nnb <-
	    if(missing(breaks)) 1 + log2(n)
	    else { # breaks = `nclass'
		if (is.na(breaks) | breaks < 2)
		    stop("invalid number of breaks")
		breaks
	    }
	breaks <- pretty (rx, n = nnb, min.n=1, eps.corr = 2)
	nB <- length(breaks)
	if(nB <= 1) { ##-- Impossible !
	    stop(paste("hist.default: pretty() error, breaks=",format(breaks)))
	}
    }
    storage.mode(x) <- "double"
    storage.mode(breaks) <- "double"
    counts <- .C("bincount",
		 x,
		 n,
		 breaks,
		 nB,
		 counts = integer(nB - 1),
		 right	= as.logical(right),
		 include= as.logical(include.lowest),
		 NAOK = FALSE, DUP = FALSE, PACKAGE = "base") $counts
    if (any(counts < 0))
	stop("negative `counts'. Internal Error in C-code for \"bincount\"")
    if (sum(counts) < n)
	stop("some `x' not counted; maybe `breaks' do not span range of `x'")
    h <- diff(breaks)
    if (!use.br && any(h <= 0))
	stop("not strictly increasing `breaks'.")
    if (is.null(freq)) {
	freq <- if(!missing(probability))
	    !as.logical(probability)
	else if(use.br) {
	    ##-- Do frequencies if breaks are evenly spaced
	    max(h)-min(h) < 1e-7 * mean(h)
	} else TRUE
    } else if(!missing(probability) && any(probability == freq))
	stop("`probability is an alias for `!freq', however they differ.")
    intensities <- counts/(n*h)
    mids <- 0.5 * (breaks[-1] + breaks[-nB])
    y <- if (freq) counts else intensities
    r <- list(breaks = breaks, counts = counts,
	      intensities = intensities, mids = mids)
    if (plot) {
	plot.new()
	plot.window(xlim, ylim, "") #-> ylim's default from 'y'
	if (missing(ylab))
	    ylab <- paste(if(!freq)"Relative ", "Frequency", sep="")
	if(freq && use.br && max(h)-min(h) > 1e-7 * mean(h))
	    warning("the AREAS in the plot are wrong -- maybe use `freq=FALSE'")
	title(main = main, xlab = xlab, ylab = ylab, ...)
	if(axes) {
	    axis(1, ...)
	    axis(2, ...)
	}
	rect(breaks[-nB], 0, breaks[-1], y,
	     col = col, border = border)
	if(labels)
	    text(mids, y,
		 labels = if(freq) counts else round(intensities,3),
		 adj = c(0.5, -0.5))
	invisible(r)
    }
    else r
}
print.htest <- function(x, digits = 4, quote = TRUE, prefix = "", ...)
{
    cat("\n\t", x$method, "\n\n")
    cat("data: ", x$data.name, "\n")
    if(!is.null(x$statistic))
	cat(names(x$statistic), " = ", format(round(x$statistic, 4)),
	    ", ", sep = "")
    if(!is.null (x$parameter))
	cat(paste(names(x$parameter), " = ", format(round(x$parameter, 3)),
                  ",", sep = ""), "")
    cat("p-value =", format.pval(x$p.value, digits= digits), "\n")
    if(!is.null(x$alternative)) {
	if(!is.null(x$null.value)) {
	    if(length(x$null.value) == 1) {
		if (x$alternative == "two.sided" )
		    alt.char <- "not equal to"
		else if( x$alternative == "less" )
		    alt.char <- "less than"
		else if( x$alternative == "greater" )
		    alt.char <- "greater than"
		cat("alternative hypothesis:", "true", names(x$null.value),
                    "is", alt.char, x$null.value, "\n")
	    }
	    else {
		cat("alternative hypothesis:", x$alternative, "\n")
		cat("null values:\n")
		print(x$null.value, ...)
	    }
	}
	else cat("alternative hypothesis:", x$alternative, "\n")
    }
    if(!is.null(x$conf.int)) {
	cat(format(100 * attr(x$conf.int, "conf.level")),
	    "percent confidence interval:\n",
            format(c(x$conf.int[1], x$conf.int[2])), "\n")
    }
    if(!is.null(x$estimate)) {
	cat("sample estimates:\n")
	print(x$estimate, ...)
    }
    cat("\n")
    invisible(x)
}
identify <- function(x, ...) UseMethod("identify")

identify.default <- function(x, y=NULL, labels=seq(along=x), pos=FALSE,
			     n=length(x), plot=TRUE, offset=0.5, ...)
{
    opar <- par(list(...))
    on.exit(par(opar))
    xy <- xy.coords(x, y)
    z <- .Internal(identify(xy$x, xy$y, as.character(labels),
			    n, plot, offset))
    i <- seq(z[[1]])[z[[1]]]
    if(pos) list(ind= i, pos= z[[2]][z[[1]]]) else i
}
ifelse <-
    function (test, yes, no)
{
    ans <- test
    test <- as.logical(test)
    nas <- is.na(test)
    if (any(test[!nas])) {
        ans[test] <- rep(yes, length = length(ans))[test]
    }
    if (any(!test[!nas])) {
        ans[!test] <- rep(no, length = length(ans))[!test]
    }
    ans[nas] <- NA
    ans
}
image <- function (x = seq(0, 1, len = nrow(z)),
		   y = seq(0, 1, len = ncol(z)),
		   z,
		   zlim = range(z[is.finite(z)]),
		   xlim = range(x[is.finite(x)]),
		   ylim = range(y[is.finite(y)]),
		   col = heat.colors(12), add = FALSE,
		   xaxs = "i", yaxs = "i", xlab, ylab, ...)
{
    if (missing(z)) {
	if (!missing(x)) {
	    if (is.list(x)) {
		z <- x$z; y <- x$y; x <- x$x
	    } else {
		if(is.null(dim(x)))
		   stop("argument must be matrix alike")
		z <- x
		x <- seq(0, 1, len = nrow(z))
	    }
	    if (missing(xlab)) xlab <- ""
	    if (missing(ylab)) ylab <- ""
	} else stop("no `z' matrix specified")
    } else if (is.list(x)) {
	xn <- deparse(substitute(x))
	if (missing(xlab)) xlab <- paste(xn, "x", sep = "$")
	if (missing(ylab)) ylab <- paste(xn, "y", sep = "$")
	y <- x$y
	x <- x$x
    } else {
	if (missing(xlab))
	    xlab <- if (missing(x)) "" else deparse(substitute(x))
	if (missing(ylab))
	    ylab <- if (missing(y)) "" else deparse(substitute(y))
    }
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
	stop("increasing x and y values expected")
    if (!is.matrix(z))
        stop("`z' must be a matrix")
    if(length(x) > 1 && length(x) == e(substi, ny=NULL, col="lightgray", lty="dotted")
{
    if (is.null(nx)|| nx >= 1) {
        axp <- par("xaxp")
        if(is.null(nx)) nx <- axp[3]
	abline(v = seq(axp[1],axp[2],len=1+nx), col = col, lty = lty)
    }
    if (is.null(ny)|| ny >= 1) {
        axp <- par("yaxp")
        if(is.null(ny)) ny <- axp[3]
	abline(h = seq(axp[1],axp[2],len=1+ny), col = col, lty = lty)
    }
}
###-- NOTE: This is for  NON-Windows only  (cf. windows/help.R )

index.search <- function(topic, path, file="AnIndex", type="help")
    .Internal(index.search(topic, path, file, .Platform$file.sep, type))

help <-
    function (topic, offline = FALSE, package = c(.packages(), .Autoloaded),
              lib.loc = .lib.loc, verbose = .Options$verbose,
              htmlhelp = .Options$htmlhelp)
{
    htmlhelp <- is.logical(htmlhelp) && htmlhelp
    if (!missing(package))
        if (is.name(y <- substitute(package)))
            package <- as.character(y)
    if (!missing(topic)) {
        topic <- substitute(topic)
        if (is.name(topic))
            topic <- as.character(topic)
        else if (!is.character(topic))
            stop("Unimplemented help feature")
        # for cmd/help ..
        if (!is.na(match(topic, c("+", "-", "*", "/", "^", "%%"))))
            topic <- "Arithmetic"
        else if (!is.na(match(topic, c("<", ">", "<=", ">=", "==", "!="))))
            topic <- "Comparison"
        else if (!is.na(match(topic, c("[", "[[", "$"))))
            topic <- "Extract"
        else if (!is.na(match(topic, c("&", "&&", "|", "||", "!"))))
            topic <- "Logic"
        else if (!is.na(match(topic, c("%*%"))))
            topic <- "matmult"
        type <- if(offline) "latex" else if (htmlhelp) "html" else "help"
        INDICES <- system.file(pkg=package, lib=lib.loc)
        file <- index.search(topic, INDICES, "AnIndex", type)
        if (length(file) && file != "") {
            if (verbose)
                cat("\t\t\t\t\t\tHelp file name `", sub(".*/", "", file),
                    ".Rd'\n", sep = "")
            if (!offline) {
                if (htmlhelp) {
                    if(file.exists(file)) {
                        file <- paste("file:", file, sep="")
                        if (is.null(.Options$browser))
                            stop("options(\"browser\") not set")
                        browser <- .Options$browser
                        system(paste(browser, " -remote \"openURL(",
                                     file, ")\" 2>/dev/null || ", browser, " ",
                                     file, " &", sep = ""))
                        cat("help() for",topic, " is shown in browser",browser,
                            "...\nUse\t help(",topic,", htmlhelp=FALSE)\nor\t",
                            "options(htmlhelp = FALSE)\nto revert.\n")
                        return(invisible())
                    } else {
                        if(verbose)
                            cat("no HTML help for `", topic,
                                "' is available\n", sep = "")
                        file <- index.search(topic, INDICES, "AnIndex", "help")
                    }
                }
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                ## end of experimental code
                if(file.exists(zfile))
                    file.show(zfile,
                              ##header= paste("Help for `", topic, "'", sep=""),
                              delete.file = (zfile!=file))
                else
                    stop(paste("The help file for `", topic, "' is missing",
                               sep = ""))
                return(invisible())
            }
            else {
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                if(zfile != file) on.exit(unlink(zfile))
                ## end of experimental code
                if(file.exists(zfile)) {
                    FILE <- tempfile()
                    on.exit(unlink(FILE))
                    cat("\\documentclass[", .Options$papersize, "paper]{article}\n",
                        file = FILE, sep = "")
                    file.append(FILE,
                                file.path(R.home(), "doc", "manual", "Rd.sty"))
                    cat("\\InputIfFileExists{Rhelp.cfg}{}{}\n\\begin{document}\n",
                        file = FILE, append = TRUE)
                    file.append(FILE, zfile)
                    cat("\\end{document}\n", file = FILE, append = TRUE)
                    system(paste(file.path(R.home(), "bin", "help"),
                                 "PRINT", FILE, topic,
                                 .Options$latexcmd, .Options$dvipscmd)
                           )
                    return(invisible())
                }
                else
                    stop(paste("No offline documentation for", topic, "is available"))
            }
        }
        else
            stop(paste("No documentation for `", topic, "'", sep = ""))
    }
    else if (!missing(package))
        library(help = package, lib = lib.loc, character.only = TRUE)
    else if (!missing(lib.loc))
        library(lib = lib.loc)
    else help("help", package = "base", lib.loc = .Library)
}
help.search <- function(topic, fields = c("name", "title"),
                        apropos, keyword, whatis, ignore.case = TRUE,
                        packages = NULL, lib.loc = .lib.loc,
                        help.db = .Options$help.db,
                        verbose = .Options$verbose,
                        rebuild = FALSE) {
    TABLE <- c("name", "alias", "title", "keyword")
    if (!missing(topic)) {
        if (!is.character(topic) || (length(topic) > 1))
            stop("`topic' must be a single character string")
        i <- pmatch(fields, TABLE)
        if (any(is.na(i)))
            stop("incorrect field specification")
        else
            fields <- TABLE[i]
    } else if (!missing(apropos)) {
        if (!is.character(apropos) || (length(apropos) > 1))
            stop("`apropos' must be a single character string")
        else {
            topic <- apropos
            fields <- c("name", "title")
        }
    } else if (!missing(keyword)) {
        if (!is.character(keyword) || (length(keyword) > 1))
            stop("`keyword' must be a single character string")
        else {
            topic <- keyword
            fields <- "keyword"
        }
    } else if (!missing(whatis)) {
        if (!is.character(whatis) || (length(whatis) > 1))
            stop("`whatis' must be a single character string")
        else {
            topic <- whatis
            fields <- "name"
        }
    } else {
        stop("don't know what to search")
    }

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

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

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

    ## Output
    fields <- paste(fields, collapse = " or ")
    if (NROW(db) > 0) {
        FILE <- tempfile()
        cat(paste("Objects with ", fields, " matching `", topic,
                  "':\n\n", sep = ""),
            file = FILE)
        dbnam <- paste(db[ , "name"], "(", db[, "pkg"], ")", sep = "")
        dbtit <- paste(db[ , "title"], sep = "")
        cat(paste(format(dbnam), dbtit, sep = "   "),
            sep = "\n", file = FILE, append = TRUE)
        file.show(FILE, delete.file = TRUE)
    } else {
        cat(paste("No objects found with ", fields, " matching `",
                  topic, "'\n", sep = ""))
    }

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

hist.default <-
    function (x, breaks, freq= NULL, probability = !freq, include.lowest= TRUE,
	      right=TRUE, col = NULL, border = par("fg"),
	      main = paste("Histogram of" , deparse(substitute(x))),
	      xlim = range(breaks), ylim = range(y, 0),
	      xlab = deparse(substitute(x)), ylab,
	      axes = TRUE, plot = TRUE, labels = FALSE, nclass = NULL, ...)
{
    if (!is.numeric(x))
	stop("hist: x must be numeric")
    main # eval() now: defeat lazy eval
    xlab
    n <- length(x <- x[!is.na(x)])
    use.br <- !missing(breaks)
    if(use.br) {
	if(!missing(nclass))
	    warning("`nclass' not used when `breaks' specified")
    }
    else if(!is.null(nclass) && length(nclass) == 1)
	breaks <- nclass
    use.br <- use.br && (nB <- length(breaks)) > 1
    if(use.br)
	breaks <- sort(breaks)
    else { # construct vector of breaks
	rx <- range(x)
	nnb <-
	    if(missing(breaks)) 1 + log2(n)
	    else { # breaks = `nclass'
		if (is.na(breaks) | breaks < 2)
		    stop("invalid number of breaks")
		breaks
	    }
	breaks <- pretty (rx, n = nnb, min.n=1, eps.corr = 2)
	nB <- length(breaks)
	if(nB <= 1) { ##-- Impossible !
	    stop(paste("hist.default: pretty() error, breaks=",format(breaks)))
	}
    }
    storage.mode(x) <- "double"
    storage.mode(breaks) <- "double"
    counts <- .C("bincount",
		 x,
		 n,
		 breaks,
		 nB,
		 counts = integer(nB - 1),
		 right	= as.logical(right),
		 include= as.logical(include.lowest),
		 NAOK = FALSE, DUP = FALSE, PACKAGE = "base") $counts
    if (any(counts < 0))
	stop("negative `counts'. Internal Error in C-code for \"bincount\"")
    if (sum(counts) < n)
	stop("some `x' not counted; maybe `breaks' do not span range of `x'")
    h <- diff(breaks)
    if (!use.br && any(h <= 0))
	stop("not strictly increasing `breaks'.")
    if (is.null(freq)) {
	freq <- if(!missing(probability))
	    !as.logical(probability)
	else if(use.br) {
	    ##-- Do frequencies if breaks are evenly spaced
	    max(h)-min(h) < 1e-7 * mean(h)
	} else TRUE
    } else if(!missing(probability) && any(probability == freq))
	stop("`probability is an alias for `!freq', however they differ.")
    intensities <- counts/(n*h)
    mids <- 0.5 * (breaks[-1] + breaks[-nB])
    y <- if (freq) counts else intensities
    r <- list(breaks = breaks, counts = counts,
	      intensities = intensities, mids = mids)
    if (plot) {
	plot.new()
	plot.window(xlim, ylim, "") #-> ylim's default from 'y'
	if (missing(ylab))
	    ylab <- paste(if(!freq)"Relative ", "Frequency", sep="")
	if(freq && use.br && max(h)-min(h) > 1e-7 * mean(h))
	    warning("the AREAS in the plot are wrong -- maybe use `freq=FALSE'")
	title(main = main, xlab = xlab, ylab = ylab, ...)
	if(axes) {
	    axis(1, ...)
	    axis(2, ...)
	}
	rect(breaks[-nB], 0, breaks[-1], y,
	     col = col, border = border)
	if(labels)
	    text(mids, y,
		 labels = if(freq) counts else round(intensities,3),
		 adj = c(0.5, -0.5))
	invisible(r)
    }
    else r
}
print.htest <- function(x, digits = 4, quote = TRUE, prefix = "", ...)
{
    cat("\n\t", x$method, "\n\n")
    cat("data: ", x$data.name, "\n")
    if(!is.null(x$statistic))
	cat(names(x$statistic), " = ", format(round(x$statistic, 4)),
	    ", ", sep = "")
    if(!is.null (x$parameter))
	cat(paste(names(x$parameter), " = ", format(round(x$parameter, 3)),
                  ",", sep = ""), "")
    cat("p-value =", format.pval(x$p.value, digits= digits), "\n")
    if(!is.null(x$alternative)) {
	if(!is.null(x$null.value)) {
	    if(length(x$null.value) == 1) {
		if (x$alternative == "two.sided" )
		    alt.char <- "not equal to"
		else if( x$alternative == "less" )
		    alt.char <- "less than"
		else if( x$alternative == "greater" )
		    alt.char <- "greater than"
		cat("alternative hypothesis:", "true", names(x$null.value),
                    "is", alt.char, x$null.value, "\n")
	    }
	    else {
		cat("alternative hypothesis:", x$alternative, "\n")
		cat("null values:\n")
		print(x$null.value, ...)
	    }
	}
	else cat("alternative hypothesis:", x$alternative, "\n")
    }
    if(!is.null(x$conf.int)) {
	cat(format(100 * attr(x$conf.int, "conf.level")),
	    "percent confidence interval:\n",
            format(c(x$conf.int[1], x$conf.int[2])), "\n")
    }
    if(!is.null(x$estimate)) {
	cat("sample estimates:\n")
	print(x$estimate, ...)
    }
    cat("\n")
    invisible(x)
}
identify <- function(x, ...) UseMethod("identify")

identify.default <- function(x, y=NULL, labels=seq(along=x), pos=FALSE,
			     n=length(x), plot=TRUE, offset=0.5, ...)
{
    opar <- par(list(...))
    on.exit(par(opar))
    xy <- xy.coords(x, y)
    z <- .Internal(identify(xy$x, xy$y, as.character(labels),
			    n, plot, offset))
    i <- seq(z[[1]])[z[[1]]]
    if(pos) list(ind= i, pos= z[[2]][z[[1]]]) else i
}
ifelse <-
    function (test, yes, no)
{
    ans <- test
    test <- as.logical(test)
    nas <- is.na(test)
    if (any(test[!nas])) {
        ans[test] <- rep(yes, length = length(ans))[test]
    }
    if (any(!test[!nas])) {
        ans[!test] <- rep(no, length = length(ans))[!test]
    }
    ans[nas] <- NA
    ans
}
image <- function (x = seq(0, 1, len = nrow(z)),
		   y = seq(0, 1, len = ncol(z)),
		   z,
		   zlim = range(z[is.finite(z)]),
		   xlim = range(x[is.finite(x)]),
		   ylim = range(y[is.finite(y)]),
		   col = heat.colors(12), add = FALSE,
		   xaxs = "i", yaxs = "i", xlab, ylab, ...)
{
    if (missing(z)) {
	if (!missing(x)) {
	    if (is.list(x)) {
		z <- x$z; y <- x$y; x <- x$x
	    } else {
		if(is.null(dim(x)))
		   stop("argument must be matrix alike")
		z <- x
		x <- seq(0, 1, len = nrow(z))
	    }
	    if (missing(xlab)) xlab <- ""
	    if (missing(ylab)) ylab <- ""
	} else stop("no `z' matrix specified")
    } else if (is.list(x)) {
	xn <- deparse(substitute(x))
	if (missing(xlab)) xlab <- paste(xn, "x", sep = "$")
	if (missing(ylab)) ylab <- paste(xn, "y", sep = "$")
	y <- x$y
	x <- x$x
    } else {
	if (missing(xlab))
	    xlab <- if (missing(x)) "" else deparse(substitute(x))
	if (missing(ylab))
	    ylab <- if (missing(y)) "" else deparse(substitute(y))
    }
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
	stop("increasing x and y values expected")
    if (!is.matrix(z))
        stop("`z' must be a matrix")
    if(length(x) > 1 && length(x) == e(substi, ny=NULL, col="lightgray", lty="dotted")
{
    if (is.null(nx)|| nx >= 1) {
        axp <- par("xaxp")
        if(is.null(nx)) nx <- axp[3]
	abline(v = seq(axp[1],axp[2],len=1+nx), col = col, lty = lty)
    }
    if (is.null(ny)|| ny >= 1) {
        axp <- par("yaxp")
        if(is.null(ny)) ny <- axp[3]
	abline(h = seq(axp[1],axp[2],len=1+ny), col = col, lty = lty)
    }
}
###-- NOTE: This is for  NON-Windows only  (cf. windows/help.R )

index.search <- function(topic, path, file="AnIndex", type="help")
    .Internal(index.search(topic, path, file, .Platform$file.sep, type))

help <-
    function (topic, offline = FALSE, package = c(.packages(), .Autoloaded),
              lib.loc = .lib.loc, verbose = .Options$verbose,
              htmlhelp = .Options$htmlhelp)
{
    htmlhelp <- is.logical(htmlhelp) && htmlhelp
    if (!missing(package))
        if (is.name(y <- substitute(package)))
            package <- as.character(y)
    if (!missing(topic)) {
        topic <- substitute(topic)
        if (is.name(topic))
            topic <- as.character(topic)
        else if (!is.character(topic))
            stop("Unimplemented help feature")
        # for cmd/help ..
        if (!is.na(match(topic, c("+", "-", "*", "/", "^", "%%"))))
            topic <- "Arithmetic"
        else if (!is.na(match(topic, c("<", ">", "<=", ">=", "==", "!="))))
            topic <- "Comparison"
        else if (!is.na(match(topic, c("[", "[[", "$"))))
            topic <- "Extract"
        else if (!is.na(match(topic, c("&", "&&", "|", "||", "!"))))
            topic <- "Logic"
        else if (!is.na(match(topic, c("%*%"))))
            topic <- "matmult"
        type <- if(offline) "latex" else if (htmlhelp) "html" else "help"
        INDICES <- system.file(pkg=package, lib=lib.loc)
        file <- index.search(topic, INDICES, "AnIndex", type)
        if (length(file) && file != "") {
            if (verbose)
                cat("\t\t\t\t\t\tHelp file name `", sub(".*/", "", file),
                    ".Rd'\n", sep = "")
            if (!offline) {
                if (htmlhelp) {
                    if(file.exists(file)) {
                        file <- paste("file:", file, sep="")
                        if (is.null(.Options$browser))
                            stop("options(\"browser\") not set")
                        browser <- .Options$browser
                        system(paste(browser, " -remote \"openURL(",
                                     file, ")\" 2>/dev/null || ", browser, " ",
                                     file, " &", sep = ""))
                        cat("help() for",topic, " is shown in browser",browser,
                            "...\nUse\t help(",topic,", htmlhelp=FALSE)\nor\t",
                            "options(htmlhelp = FALSE)\nto revert.\n")
                        return(invisible())
                    } else {
                        if(verbose)
                            cat("no HTML help for `", topic,
                                "' is available\n", sep = "")
                        file <- index.search(topic, INDICES, "AnIndex", "help")
                    }
                }
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                ## end of experimental code
                if(file.exists(zfile))
                    file.show(zfile,
                              ##header= paste("Help for `", topic, "'", sep=""),
                              delete.file = (zfile!=file))
                else
                    stop(paste("The help file for `", topic, "' is missing",
                               sep = ""))
                return(invisible())
            }
            else {
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                if(zfile != file) on.exit(unlink(zfile))
                ## end of experimental code
                if(file.exists(zfile)) {
                    FILE <- tempfile()
                    on.exit(unlink(FILE))
                    cat("\\documentclass[", .Options$papersize, "paper]{article}\n",
                        file = FILE, sep = "")
                    file.append(FILE,
                                file.path(R.home(), "doc", "manual", "Rd.sty"))
                    cat("\\InputIfFileExists{Rhelp.cfg}{}{}\n\\begin{document}\n",
                        file = FILE, append = TRUE)
                    file.append(FILE, zfile)
                    cat("\\end{document}\n", file = FILE, append = TRUE)
                    system(paste(file.path(R.home(), "bin", "help"),
                                 "PRINT", FILE, topic,
                                 .Options$latexcmd, .Options$dvipscmd)
                           )
                    return(invisible())
                }
                else
                    stop(paste("No offline documentation for", topic, "is available"))
            }
        }
        else
            stop(paste("No documentation for `", topic, "'", sep = ""))
    }
    else if (!missing(package))
        library(help = package, lib = lib.loc, character.only = TRUE)
    else if (!missing(lib.loc))
        library(lib = lib.loc)
    else help("help", package = "base", lib.loc = .Library)
}
help.search <- function(topic, fields = c("name", "title"),
                        apropos, keyword, whatis, ignore.case = TRUE,
                        packages = NULL, lib.loc = .lib.loc,
                        help.db = .Options$help.db,
                        verbose = .Options$verbose,
                        rebuild = FALSE) {
    TABLE <- c("name", "alias", "title", "keyword")
    if (!missing(topic)) {
        if (!is.character(topic) || (length(topic) > 1))
            stop("`topic' must be a single character string")
        i <- pmatch(fields, TABLE)
        if (any(is.na(i)))
            stop("incorrect field specification")
        else
            fields <- TABLE[i]
    } else if (!missing(apropos)) {
        if (!is.character(apropos) || (length(apropos) > 1))
            stop("`apropos' must be a single character string")
        else {
            topic <- apropos
            fields <- c("name", "title")
        }
    } else if (!missing(keyword)) {
        if (!is.character(keyword) || (length(keyword) > 1))
            stop("`keyword' must be a single character string")
        else {
            topic <- keyword
            fields <- "keyword"
        }
    } else if (!missing(whatis)) {
        if (!is.character(whatis) || (length(whatis) > 1))
            stop("`whatis' must be a single character string")
        else {
            topic <- whatis
            fields <- "name"
        }
    } else {
        stop("don't know what to search")
    }

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

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

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

    ## Output
    fields <- paste(fields, collapse = " or ")
    if (NROW(db) > 0) {
        FILE <- tempfile()
        cat(paste("Objects with ", fields, " matching `", topic,
                  "':\n\n", sep = ""),
            file = FILE)
        dbnam <- paste(db[ , "name"], "(", db[, "pkg"], ")", sep = "")
        dbtit <- paste(db[ , "title"], sep = "")
        cat(paste(format(dbnam), dbtit, sep = "   "),
            sep = "\n", file = FILE, append = TRUE)
        file.show(FILE, delete.file = TRUE)
    } else {
        cat(paste("No objects found with ", fields, " matching `",
                  topic, "'\n", sep = ""))
    }

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

hist.default <-
    function (x, breaks, freq= NULL, probability = !freq, include.lowest= TRUE,
	      right=TRUE, col = NULL, border = par("fg"),
	      main = paste("Histogram of" , deparse(substitute(x))),
	      xlim = range(breaks), ylim = range(y, 0),
	      xlab = deparse(substitute(x)), ylab,
	      axes = TRUE, plot = TRUE, labels = FALSE, nclass = NULL, ...)
{
    if (!is.numeric(x))
	stop("hist: x must be numeric")
    main # eval() now: defeat lazy eval
    xlab
    n <- length(x <- x[!is.na(x)])
    use.br <- !missing(breaks)
    if(use.br) {
	if(!missing(nclass))
	    warning("`nclass' not used when `breaks' specified")
    }
    else if(!is.null(nclass) && length(nclass) == 1)
	breaks <- nclass
    use.br <- use.br && (nB <- length(breaks)) > 1
    if(use.br)
	breaks <- sort(breaks)
    else { # construct vector of breaks
	rx <- range(x)
	nnb <-
	    if(missing(breaks)) 1 + log2(n)
	    else { # breaks = `nclass'
		if (is.na(breaks) | breaks < 2)
		    stop("invalid number of breaks")
		breaks
	    }
	breaks <- pretty (rx, n = nnb, min.n=1, eps.corr = 2)
	nB <- length(breaks)
	if(nB <= 1) { ##-- Impossible !
	    stop(paste("hist.default: pretty() error, breaks=",format(breaks)))
	}
    }
    storage.mode(x) <- "double"
    storage.mode(breaks) <- "double"
    counts <- .C("bincount",
		 x,
		 n,
		 breaks,
		 nB,
		 counts = integer(nB - 1),
		 right	= as.logical(right),
		 include= as.logical(include.lowest),
		 NAOK = FALSE, DUP = FALSE, PACKAGE = "base") $counts
    if (any(counts < 0))
	stop("negative `counts'. Internal Error in C-code for \"bincount\"")
    if (sum(counts) < n)
	stop("some `x' not counted; maybe `breaks' do not span range of `x'")
    h <- diff(breaks)
    if (!use.br && any(h <= 0))
	stop("not strictly increasing `breaks'.")
    if (is.null(freq)) {
	freq <- if(!missing(probability))
	    !as.logical(probability)
	else if(use.br) {
	    ##-- Do frequencies if breaks are evenly spaced
	    max(h)-min(h) < 1e-7 * mean(h)
	} else TRUE
    } else if(!missing(probability) && any(probability == freq))
	stop("`probability is an alias for `!freq', however they differ.")
    intensities <- counts/(n*h)
    mids <- 0.5 * (breaks[-1] + breaks[-nB])
    y <- if (freq) counts else intensities
    r <- list(breaks = breaks, counts = counts,
	      intensities = intensities, mids = mids)
    if (plot) {
	plot.new()
	plot.window(xlim, ylim, "") #-> ylim's default from 'y'
	if (missing(ylab))
	    ylab <- paste(if(!freq)"Relative ", "Frequency", sep="")
	if(freq && use.br && max(h)-min(h) > 1e-7 * mean(h))
	    warning("the AREAS in the plot are wrong -- maybe use `freq=FALSE'")
	title(main = main, xlab = xlab, ylab = ylab, ...)
	if(axes) {
	    axis(1, ...)
	    axis(2, ...)
	}
	rect(breaks[-nB], 0, breaks[-1], y,
	     col = col, border = border)
	if(labels)
	    text(mids, y,
		 labels = if(freq) counts else round(intensities,3),
		 adj = c(0.5, -0.5))
	invisible(r)
    }
    else r
}
print.htest <- function(x, digits = 4, quote = TRUE, prefix = "", ...)
{
    cat("\n\t", x$method, "\n\n")
    cat("data: ", x$data.name, "\n")
    if(!is.null(x$statistic))
	cat(names(x$statistic), " = ", format(round(x$statistic, 4)),
	    ", ", sep = "")
    if(!is.null (x$parameter))
	cat(paste(names(x$parameter), " = ", format(round(x$parameter, 3)),
                  ",", sep = ""), "")
    cat("p-value =", format.pval(x$p.value, digits= digits), "\n")
    if(!is.null(x$alternative)) {
	if(!is.null(x$null.value)) {
	    if(length(x$null.value) == 1) {
		if (x$alternative == "two.sided" )
		    alt.char <- "not equal to"
		else if( x$alternative == "less" )
		    alt.char <- "less than"
		else if( x$alternative == "greater" )
		    alt.char <- "greater than"
		cat("alternative hypothesis:", "true", names(x$null.value),
                    "is", alt.char, x$null.value, "\n")
	    }
	    else {
		cat("alternative hypothesis:", x$alternative, "\n")
		cat("null values:\n")
		print(x$null.value, ...)
	    }
	}
	else cat("alternative hypothesis:", x$alternative, "\n")
    }
    if(!is.null(x$conf.int)) {
	cat(format(100 * attr(x$conf.int, "conf.level")),
	    "percent confidence interval:\n",
            format(c(x$conf.int[1], x$conf.int[2])), "\n")
    }
    if(!is.null(x$estimate)) {
	cat("sample estimates:\n")
	print(x$estimate, ...)
    }
    cat("\n")
    invisible(x)
}
identify <- function(x, ...) UseMethod("identify")

identify.default <- function(x, y=NULL, labels=seq(along=x), pos=FALSE,
			     n=length(x), plot=TRUE, offset=0.5, ...)
{
    opar <- par(list(...))
    on.exit(par(opar))
    xy <- xy.coords(x, y)
    z <- .Internal(identify(xy$x, xy$y, as.character(labels),
			    n, plot, offset))
    i <- seq(z[[1]])[z[[1]]]
    if(pos) list(ind= i, pos= z[[2]][z[[1]]]) else i
}
ifelse <-
    function (test, yes, no)
{
    ans <- test
    test <- as.logical(test)
    nas <- is.na(test)
    if (any(test[!nas])) {
        ans[test] <- rep(yes, length = length(ans))[test]
    }
    if (any(!test[!nas])) {
        ans[!test] <- rep(no, length = length(ans))[!test]
    }
    ans[nas] <- NA
    ans
}
image <- function (x = seq(0, 1, len = nrow(z)),
		   y = seq(0, 1, len = ncol(z)),
		   z,
		   zlim = range(z[is.finite(z)]),
		   xlim = range(x[is.finite(x)]),
		   ylim = range(y[is.finite(y)]),
		   col = heat.colors(12), add = FALSE,
		   xaxs = "i", yaxs = "i", xlab, ylab, ...)
{
    if (missing(z)) {
	if (!missing(x)) {
	    if (is.list(x)) {
		z <- x$z; y <- x$y; x <- x$x
	    } else {
		if(is.null(dim(x)))
		   stop("argument must be matrix alike")
		z <- x
		x <- seq(0, 1, len = nrow(z))
	    }
	    if (missing(xlab)) xlab <- ""
	    if (missing(ylab)) ylab <- ""
	} else stop("no `z' matrix specified")
    } else if (is.list(x)) {
	xn <- deparse(substitute(x))
	if (missing(xlab)) xlab <- paste(xn, "x", sep = "$")
	if (missing(ylab)) ylab <- paste(xn, "y", sep = "$")
	y <- x$y
	x <- x$x
    } else {
	if (missing(xlab))
	    xlab <- if (missing(x)) "" else deparse(substitute(x))
	if (missing(ylab))
	    ylab <- if (missing(y)) "" else deparse(substitute(y))
    }
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
	stop("increasing x and y values expected")
    if (!is.matrix(z))
        stop("`z' must be a matrix")
    if(length(x) > 1 && length(x) == e(substi, ny=NULL, col="lightgray", lty="dotted")
{
    if (is.null(nx)|| nx >= 1) {
        axp <- par("xaxp")
        if(is.null(nx)) nx <- axp[3]
	abline(v = seq(axp[1],axp[2],len=1+nx), col = col, lty = lty)
    }
    if (is.null(ny)|| ny >= 1) {
        axp <- par("yaxp")
        if(is.null(ny)) ny <- axp[3]
	abline(h = seq(axp[1],axp[2],len=1+ny), col = col, lty = lty)
    }
}
###-- NOTE: This is for  NON-Windows only  (cf. windows/help.R )

index.search <- function(topic, path, file="AnIndex", type="help")
    .Internal(index.search(topic, path, file, .Platform$file.sep, type))

help <-
    function (topic, offline = FALSE, package = c(.packages(), .Autoloaded),
              lib.loc = .lib.loc, verbose = .Options$verbose,
              htmlhelp = .Options$htmlhelp)
{
    htmlhelp <- is.logical(htmlhelp) && htmlhelp
    if (!missing(package))
        if (is.name(y <- substitute(package)))
            package <- as.character(y)
    if (!missing(topic)) {
        topic <- substitute(topic)
        if (is.name(topic))
            topic <- as.character(topic)
        else if (!is.character(topic))
            stop("Unimplemented help feature")
        # for cmd/help ..
        if (!is.na(match(topic, c("+", "-", "*", "/", "^", "%%"))))
            topic <- "Arithmetic"
        else if (!is.na(match(topic, c("<", ">", "<=", ">=", "==", "!="))))
            topic <- "Comparison"
        else if (!is.na(match(topic, c("[", "[[", "$"))))
            topic <- "Extract"
        else if (!is.na(match(topic, c("&", "&&", "|", "||", "!"))))
            topic <- "Logic"
        else if (!is.na(match(topic, c("%*%"))))
            topic <- "matmult"
        type <- if(offline) "latex" else if (htmlhelp) "html" else "help"
        INDICES <- system.file(pkg=package, lib=lib.loc)
        file <- index.search(topic, INDICES, "AnIndex", type)
        if (length(file) && file != "") {
            if (verbose)
                cat("\t\t\t\t\t\tHelp file name `", sub(".*/", "", file),
                    ".Rd'\n", sep = "")
            if (!offline) {
                if (htmlhelp) {
                    if(file.exists(file)) {
                        file <- paste("file:", file, sep="")
                        if (is.null(.Options$browser))
                            stop("options(\"browser\") not set")
                        browser <- .Options$browser
                        system(paste(browser, " -remote \"openURL(",
                                     file, ")\" 2>/dev/null || ", browser, " ",
                                     file, " &", sep = ""))
                        cat("help() for",topic, " is shown in browser",browser,
                            "...\nUse\t help(",topic,", htmlhelp=FALSE)\nor\t",
                            "options(htmlhelp = FALSE)\nto revert.\n")
                        return(invisible())
                    } else {
                        if(verbose)
                            cat("no HTML help for `", topic,
                                "' is available\n", sep = "")
                        file <- index.search(topic, INDICES, "AnIndex", "help")
                    }
                }
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                ## end of experimental code
                if(file.exists(zfile))
                    file.show(zfile,
                              ##header= paste("Help for `", topic, "'", sep=""),
                              delete.file = (zfile!=file))
                else
                    stop(paste("The help file for `", topic, "' is missing",
                               sep = ""))
                return(invisible())
            }
            else {
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                if(zfile != file) on.exit(unlink(zfile))
                ## end of experimental code
                if(file.exists(zfile)) {
                    FILE <- tempfile()
                    on.exit(unlink(FILE))
                    cat("\\documentclass[", .Options$papersize, "paper]{article}\n",
                        file = FILE, sep = "")
                    file.append(FILE,
                                file.path(R.home(), "doc", "manual", "Rd.sty"))
                    cat("\\InputIfFileExists{Rhelp.cfg}{}{}\n\\begin{document}\n",
                        file = FILE, append = TRUE)
                    file.append(FILE, zfile)
                    cat("\\end{document}\n", file = FILE, append = TRUE)
                    system(paste(file.path(R.home(), "bin", "help"),
                                 "PRINT", FILE, topic,
                                 .Options$latexcmd, .Options$dvipscmd)
                           )
                    return(invisible())
                }
                else
                    stop(paste("No offline documentation for", topic, "is available"))
            }
        }
        else
            stop(paste("No documentation for `", topic, "'", sep = ""))
    }
    else if (!missing(package))
        library(help = package, lib = lib.loc, character.only = TRUE)
    else if (!missing(lib.loc))
        library(lib = lib.loc)
    else help("help", package = "base", lib.loc = .Library)
}
help.search <- function(topic, fields = c("name", "title"),
                        apropos, keyword, whatis, ignore.case = TRUE,
                        packages = NULL, lib.loc = .lib.loc,
                        help.db = .Options$help.db,
                        verbose = .Options$verbose,
                        rebuild = FALSE) {
    TABLE <- c("name", "alias", "title", "keyword")
    if (!missing(topic)) {
        if (!is.character(topic) || (length(topic) > 1))
            stop("`topic' must be a single character string")
        i <- pmatch(fields, TABLE)
        if (any(is.na(i)))
            stop("incorrect field specification")
        else
            fields <- TABLE[i]
    } else if (!missing(apropos)) {
        if (!is.character(apropos) || (length(apropos) > 1))
            stop("`apropos' must be a single character string")
        else {
            topic <- apropos
            fields <- c("name", "title")
        }
    } else if (!missing(keyword)) {
        if (!is.character(keyword) || (length(keyword) > 1))
            stop("`keyword' must be a single character string")
        else {
            topic <- keyword
            fields <- "keyword"
        }
    } else if (!missing(whatis)) {
        if (!is.character(whatis) || (length(whatis) > 1))
            stop("`whatis' must be a single character string")
        else {
            topic <- whatis
            fields <- "name"
        }
    } else {
        stop("don't know what to search")
    }

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

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

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

    ## Output
    fields <- paste(fields, collapse = " or ")
    if (NROW(db) > 0) {
        FILE <- tempfile()
        cat(paste("Objects with ", fields, " matching `", topic,
                  "':\n\n", sep = ""),
            file = FILE)
        dbnam <- paste(db[ , "name"], "(", db[, "pkg"], ")", sep = "")
        dbtit <- paste(db[ , "title"], sep = "")
        cat(paste(format(dbnam), dbtit, sep = "   "),
            sep = "\n", file = FILE, append = TRUE)
        file.show(FILE, delete.file = TRUE)
    } else {
        cat(paste("No objects found with ", fields, " matching `",
                  topic, "'\n", sep = ""))
    }

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

hist.default <-
    function (x, breaks, freq= NULL, probability = !freq, include.lowest= TRUE,
	      right=TRUE, col = NULL, border = par("fg"),
	      main = paste("Histogram of" , deparse(substitute(x))),
	      xlim = range(breaks), ylim = range(y, 0),
	      xlab = deparse(substitute(x)), ylab,
	      axes = TRUE, plot = TRUE, labels = FALSE, nclass = NULL, ...)
{
    if (!is.numeric(x))
	stop("hist: x must be numeric")
    main # eval() now: defeat lazy eval
    xlab
    n <- length(x <- x[!is.na(x)])
    use.br <- !missing(breaks)
    if(use.br) {
	if(!missing(nclass))
	    warning("`nclass' not used when `breaks' specified")
    }
    else if(!is.null(nclass) && length(nclass) == 1)
	breaks <- nclass
    use.br <- use.br && (nB <- length(breaks)) > 1
    if(use.br)
	breaks <- sort(breaks)
    else { # construct vector of breaks
	rx <- range(x)
	nnb <-
	    if(missing(breaks)) 1 + log2(n)
	    else { # breaks = `nclass'
		if (is.na(breaks) | breaks < 2)
		    stop("invalid number of breaks")
		breaks
	    }
	breaks <- pretty (rx, n = nnb, min.n=1, eps.corr = 2)
	nB <- length(breaks)
	if(nB <= 1) { ##-- Impossible !
	    stop(paste("hist.default: pretty() error, breaks=",format(breaks)))
	}
    }
    storage.mode(x) <- "double"
    storage.mode(breaks) <- "double"
    counts <- .C("bincount",
		 x,
		 n,
		 breaks,
		 nB,
		 counts = integer(nB - 1),
		 right	= as.logical(right),
		 include= as.logical(include.lowest),
		 NAOK = FALSE, DUP = FALSE, PACKAGE = "base") $counts
    if (any(counts < 0))
	stop("negative `counts'. Internal Error in C-code for \"bincount\"")
    if (sum(counts) < n)
	stop("some `x' not counted; maybe `breaks' do not span range of `x'")
    h <- diff(breaks)
    if (!use.br && any(h <= 0))
	stop("not strictly increasing `breaks'.")
    if (is.null(freq)) {
	freq <- if(!missing(probability))
	    !as.logical(probability)
	else if(use.br) {
	    ##-- Do frequencies if breaks are evenly spaced
	    max(h)-min(h) < 1e-7 * mean(h)
	} else TRUE
    } else if(!missing(probability) && any(probability == freq))
	stop("`probability is an alias for `!freq', however they differ.")
    intensities <- counts/(n*h)
    mids <- 0.5 * (breaks[-1] + breaks[-nB])
    y <- if (freq) counts else intensities
    r <- list(breaks = breaks, counts = counts,
	      intensities = intensities, mids = mids)
    if (plot) {
	plot.new()
	plot.window(xlim, ylim, "") #-> ylim's default from 'y'
	if (missing(ylab))
	    ylab <- paste(if(!freq)"Relative ", "Frequency", sep="")
	if(freq && use.br && max(h)-min(h) > 1e-7 * mean(h))
	    warning("the AREAS in the plot are wrong -- maybe use `freq=FALSE'")
	title(main = main, xlab = xlab, ylab = ylab, ...)
	if(axes) {
	    axis(1, ...)
	    axis(2, ...)
	}
	rect(breaks[-nB], 0, breaks[-1], y,
	     col = col, border = border)
	if(labels)
	    text(mids, y,
		 labels = if(freq) counts else round(intensities,3),
		 adj = c(0.5, -0.5))
	invisible(r)
    }
    else r
}
print.htest <- function(x, digits = 4, quote = TRUE, prefix = "", ...)
{
    cat("\n\t", x$method, "\n\n")
    cat("data: ", x$data.name, "\n")
    if(!is.null(x$statistic))
	cat(names(x$statistic), " = ", format(round(x$statistic, 4)),
	    ", ", sep = "")
    if(!is.null (x$parameter))
	cat(paste(names(x$parameter), " = ", format(round(x$parameter, 3)),
                  ",", sep = ""), "")
    cat("p-value =", format.pval(x$p.value, digits= digits), "\n")
    if(!is.null(x$alternative)) {
	if(!is.null(x$null.value)) {
	    if(length(x$null.value) == 1) {
		if (x$alternative == "two.sided" )
		    alt.char <- "not equal to"
		else if( x$alternative == "less" )
		    alt.char <- "less than"
		else if( x$alternative == "greater" )
		    alt.char <- "greater than"
		cat("alternative hypothesis:", "true", names(x$null.value),
                    "is", alt.char, x$null.value, "\n")
	    }
	    else {
		cat("alternative hypothesis:", x$alternative, "\n")
		cat("null values:\n")
		print(x$null.value, ...)
	    }
	}
	else cat("alternative hypothesis:", x$alternative, "\n")
    }
    if(!is.null(x$conf.int)) {
	cat(format(100 * attr(x$conf.int, "conf.level")),
	    "percent confidence interval:\n",
            format(c(x$conf.int[1], x$conf.int[2])), "\n")
    }
    if(!is.null(x$estimate)) {
	cat("sample estimates:\n")
	print(x$estimate, ...)
    }
    cat("\n")
    invisible(x)
}
identify <- function(x, ...) UseMethod("identify")

identify.default <- function(x, y=NULL, labels=seq(along=x), pos=FALSE,
			     n=length(x), plot=TRUE, offset=0.5, ...)
{
    opar <- par(list(...))
    on.exit(par(opar))
    xy <- xy.coords(x, y)
    z <- .Internal(identify(xy$x, xy$y, as.character(labels),
			    n, plot, offset))
    i <- seq(z[[1]])[z[[1]]]
    if(pos) list(ind= i, pos= z[[2]][z[[1]]]) else i
}
ifelse <-
    function (test, yes, no)
{
    ans <- test
    test <- as.logical(test)
    nas <- is.na(test)
    if (any(test[!nas])) {
        ans[test] <- rep(yes, length = length(ans))[test]
    }
    if (any(!test[!nas])) {
        ans[!test] <- rep(no, length = length(ans))[!test]
    }
    ans[nas] <- NA
    ans
}
image <- function (x = seq(0, 1, len = nrow(z)),
		   y = seq(0, 1, len = ncol(z)),
		   z,
		   zlim = range(z[is.finite(z)]),
		   xlim = range(x[is.finite(x)]),
		   ylim = range(y[is.finite(y)]),
		   col = heat.colors(12), add = FALSE,
		   xaxs = "i", yaxs = "i", xlab, ylab, ...)
{
    if (missing(z)) {
	if (!missing(x)) {
	    if (is.list(x)) {
		z <- x$z; y <- x$y; x <- x$x
	    } else {
		if(is.null(dim(x)))
		   stop("argument must be matrix alike")
		z <- x
		x <- seq(0, 1, len = nrow(z))
	    }
	    if (missing(xlab)) xlab <- ""
	    if (missing(ylab)) ylab <- ""
	} else stop("no `z' matrix specified")
    } else if (is.list(x)) {
	xn <- deparse(substitute(x))
	if (missing(xlab)) xlab <- paste(xn, "x", sep = "$")
	if (missing(ylab)) ylab <- paste(xn, "y", sep = "$")
	y <- x$y
	x <- x$x
    } else {
	if (missing(xlab))
	    xlab <- if (missing(x)) "" else deparse(substitute(x))
	if (missing(ylab))
	    ylab <- if (missing(y)) "" else deparse(substitute(y))
    }
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
	stop("increasing x and y values expected")
    if (!is.matrix(z))
        stop("`z' must be a matrix")
    if(length(x) > 1 && length(x) == e(substi, ny=NULL, col="lightgray", lty="dotted")
{
    if (is.null(nx)|| nx >= 1) {
        axp <- par("xaxp")
        if(is.null(nx)) nx <- axp[3]
	abline(v = seq(axp[1],axp[2],len=1+nx), col = col, lty = lty)
    }
    if (is.null(ny)|| ny >= 1) {
        axp <- par("yaxp")
        if(is.null(ny)) ny <- axp[3]
	abline(h = seq(axp[1],axp[2],len=1+ny), col = col, lty = lty)
    }
}
###-- NOTE: This is for  NON-Windows only  (cf. windows/help.R )

index.search <- function(topic, path, file="AnIndex", type="help")
    .Internal(index.search(topic, path, file, .Platform$file.sep, type))

help <-
    function (topic, offline = FALSE, package = c(.packages(), .Autoloaded),
              lib.loc = .lib.loc, verbose = .Options$verbose,
              htmlhelp = .Options$htmlhelp)
{
    htmlhelp <- is.logical(htmlhelp) && htmlhelp
    if (!missing(package))
        if (is.name(y <- substitute(package)))
            package <- as.character(y)
    if (!missing(topic)) {
        topic <- substitute(topic)
        if (is.name(topic))
            topic <- as.character(topic)
        else if (!is.character(topic))
            stop("Unimplemented help feature")
        # for cmd/help ..
        if (!is.na(match(topic, c("+", "-", "*", "/", "^", "%%"))))
            topic <- "Arithmetic"
        else if (!is.na(match(topic, c("<", ">", "<=", ">=", "==", "!="))))
            topic <- "Comparison"
        else if (!is.na(match(topic, c("[", "[[", "$"))))
            topic <- "Extract"
        else if (!is.na(match(topic, c("&", "&&", "|", "||", "!"))))
            topic <- "Logic"
        else if (!is.na(match(topic, c("%*%"))))
            topic <- "matmult"
        type <- if(offline) "latex" else if (htmlhelp) "html" else "help"
        INDICES <- system.file(pkg=package, lib=lib.loc)
        file <- index.search(topic, INDICES, "AnIndex", type)
        if (length(file) && file != "") {
            if (verbose)
                cat("\t\t\t\t\t\tHelp file name `", sub(".*/", "", file),
                    ".Rd'\n", sep = "")
            if (!offline) {
                if (htmlhelp) {
                    if(file.exists(file)) {
                        file <- paste("file:", file, sep="")
                        if (is.null(.Options$browser))
                            stop("options(\"browser\") not set")
                        browser <- .Options$browser
                        system(paste(browser, " -remote \"openURL(",
                                     file, ")\" 2>/dev/null || ", browser, " ",
                                     file, " &", sep = ""))
                        cat("help() for",topic, " is shown in browser",browser,
                            "...\nUse\t help(",topic,", htmlhelp=FALSE)\nor\t",
                            "options(htmlhelp = FALSE)\nto revert.\n")
                        return(invisible())
                    } else {
                        if(verbose)
                            cat("no HTML help for `", topic,
                                "' is available\n", sep = "")
                        file <- index.search(topic, INDICES, "AnIndex", "help")
                    }
                }
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                ## end of experimental code
                if(file.exists(zfile))
                    file.show(zfile,
                              ##header= paste("Help for `", topic, "'", sep=""),
                              delete.file = (zfile!=file))
                else
                    stop(paste("The help file for `", topic, "' is missing",
                               sep = ""))
                return(invisible())
            }
            else {
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                if(zfile != file) on.exit(unlink(zfile))
                ## end of experimental code
                if(file.exists(zfile)) {
                    FILE <- tempfile()
                    on.exit(unlink(FILE))
                    cat("\\documentclass[", .Options$papersize, "paper]{article}\n",
                        file = FILE, sep = "")
                    file.append(FILE,
                                file.path(R.home(), "doc", "manual", "Rd.sty"))
                    cat("\\InputIfFileExists{Rhelp.cfg}{}{}\n\\begin{document}\n",
                        file = FILE, append = TRUE)
                    file.append(FILE, zfile)
                    cat("\\end{document}\n", file = FILE, append = TRUE)
                    system(paste(file.path(R.home(), "bin", "help"),
                                 "PRINT", FILE, topic,
                                 .Options$latexcmd, .Options$dvipscmd)
                           )
                    return(invisible())
                }
                else
                    stop(paste("No offline documentation for", topic, "is available"))
            }
        }
        else
            stop(paste("No documentation for `", topic, "'", sep = ""))
    }
    else if (!missing(package))
        library(help = package, lib = lib.loc, character.only = TRUE)
    else if (!missing(lib.loc))
        library(lib = lib.loc)
    else help("help", package = "base", lib.loc = .Library)
}
help.search <- function(topic, fields = c("name", "title"),
                        apropos, keyword, whatis, ignore.case = TRUE,
                        packages = NULL, lib.loc = .lib.loc,
                        help.db = .Options$help.db,
                        verbose = .Options$verbose,
                        rebuild = FALSE) {
    TABLE <- c("name", "alias", "title", "keyword")
    if (!missing(topic)) {
        if (!is.character(topic) || (length(topic) > 1))
            stop("`topic' must be a single character string")
        i <- pmatch(fields, TABLE)
        if (any(is.na(i)))
            stop("incorrect field specification")
        else
            fields <- TABLE[i]
    } else if (!missing(apropos)) {
        if (!is.character(apropos) || (length(apropos) > 1))
            stop("`apropos' must be a single character string")
        else {
            topic <- apropos
            fields <- c("name", "title")
        }
    } else if (!missing(keyword)) {
        if (!is.character(keyword) || (length(keyword) > 1))
            stop("`keyword' must be a single character string")
        else {
            topic <- keyword
            fields <- "keyword"
        }
    } else if (!missing(whatis)) {
        if (!is.character(whatis) || (length(whatis) > 1))
            stop("`whatis' must be a single character string")
        else {
            topic <- whatis
            fields <- "name"
        }
    } else {
        stop("don't know what to search")
    }

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

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

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

    ## Output
    fields <- paste(fields, collapse = " or ")
    if (NROW(db) > 0) {
        FILE <- tempfile()
        cat(paste("Objects with ", fields, " matching `", topic,
                  "':\n\n", sep = ""),
            file = FILE)
        dbnam <- paste(db[ , "name"], "(", db[, "pkg"], ")", sep = "")
        dbtit <- paste(db[ , "title"], sep = "")
        cat(paste(format(dbnam), dbtit, sep = "   "),
            sep = "\n", file = FILE, append = TRUE)
        file.show(FILE, delete.file = TRUE)
    } else {
        cat(paste("No objects found with ", fields, " matching `",
                  topic, "'\n", sep = ""))
    }

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

hist.default <-
    function (x, breaks, freq= NULL, probability = !freq, include.lowest= TRUE,
	      right=TRUE, col = NULL, border = par("fg"),
	      main = paste("Histogram of" , deparse(substitute(x))),
	      xlim = range(breaks), ylim = range(y, 0),
	      xlab = deparse(substitute(x)), ylab,
	      axes = TRUE, plot = TRUE, labels = FALSE, nclass = NULL, ...)
{
    if (!is.numeric(x))
	stop("hist: x must be numeric")
    main # eval() now: defeat lazy eval
    xlab
    n <- length(x <- x[!is.na(x)])
    use.br <- !missing(breaks)
    if(use.br) {
	if(!missing(nclass))
	    warning("`nclass' not used when `breaks' specified")
    }
    else if(!is.null(nclass) && length(nclass) == 1)
	breaks <- nclass
    use.br <- use.br && (nB <- length(breaks)) > 1
    if(use.br)
	breaks <- sort(breaks)
    else { # construct vector of breaks
	rx <- range(x)
	nnb <-
	    if(missing(breaks)) 1 + log2(n)
	    else { # breaks = `nclass'
		if (is.na(breaks) | breaks < 2)
		    stop("invalid number of breaks")
		breaks
	    }
	breaks <- pretty (rx, n = nnb, min.n=1, eps.corr = 2)
	nB <- length(breaks)
	if(nB <= 1) { ##-- Impossible !
	    stop(paste("hist.default: pretty() error, breaks=",format(breaks)))
	}
    }
    storage.mode(x) <- "double"
    storage.mode(breaks) <- "double"
    counts <- .C("bincount",
		 x,
		 n,
		 breaks,
		 nB,
		 counts = integer(nB - 1),
		 right	= as.logical(right),
		 include= as.logical(include.lowest),
		 NAOK = FALSE, DUP = FALSE, PACKAGE = "base") $counts
    if (any(counts < 0))
	stop("negative `counts'. Internal Error in C-code for \"bincount\"")
    if (sum(counts) < n)
	stop("some `x' not counted; maybe `breaks' do not span range of `x'")
    h <- diff(breaks)
    if (!use.br && any(h <= 0))
	stop("not strictly increasing `breaks'.")
    if (is.null(freq)) {
	freq <- if(!missing(probability))
	    !as.logical(probability)
	else if(use.br) {
	    ##-- Do frequencies if breaks are evenly spaced
	    max(h)-min(h) < 1e-7 * mean(h)
	} else TRUE
    } else if(!missing(probability) && any(probability == freq))
	stop("`probability is an alias for `!freq', however they differ.")
    intensities <- counts/(n*h)
    mids <- 0.5 * (breaks[-1] + breaks[-nB])
    y <- if (freq) counts else intensities
    r <- list(breaks = breaks, counts = counts,
	      intensities = intensities, mids = mids)
    if (plot) {
	plot.new()
	plot.window(xlim, ylim, "") #-> ylim's default from 'y'
	if (missing(ylab))
	    ylab <- paste(if(!freq)"Relative ", "Frequency", sep="")
	if(freq && use.br && max(h)-min(h) > 1e-7 * mean(h))
	    warning("the AREAS in the plot are wrong -- maybe use `freq=FALSE'")
	title(main = main, xlab = xlab, ylab = ylab, ...)
	if(axes) {
	    axis(1, ...)
	    axis(2, ...)
	}
	rect(breaks[-nB], 0, breaks[-1], y,
	     col = col, border = border)
	if(labels)
	    text(mids, y,
		 labels = if(freq) counts else round(intensities,3),
		 adj = c(0.5, -0.5))
	invisible(r)
    }
    else r
}
print.htest <- function(x, digits = 4, quote = TRUE, prefix = "", ...)
{
    cat("\n\t", x$method, "\n\n")
    cat("data: ", x$data.name, "\n")
    if(!is.null(x$statistic))
	cat(names(x$statistic), " = ", format(round(x$statistic, 4)),
	    ", ", sep = "")
    if(!is.null (x$parameter))
	cat(paste(names(x$parameter), " = ", format(round(x$parameter, 3)),
                  ",", sep = ""), "")
    cat("p-value =", format.pval(x$p.value, digits= digits), "\n")
    if(!is.null(x$alternative)) {
	if(!is.null(x$null.value)) {
	    if(length(x$null.value) == 1) {
		if (x$alternative == "two.sided" )
		    alt.char <- "not equal to"
		else if( x$alternative == "less" )
		    alt.char <- "less than"
		else if( x$alternative == "greater" )
		    alt.char <- "greater than"
		cat("alternative hypothesis:", "true", names(x$null.value),
                    "is", alt.char, x$null.value, "\n")
	    }
	    else {
		cat("alternative hypothesis:", x$alternative, "\n")
		cat("null values:\n")
		print(x$null.value, ...)
	    }
	}
	else cat("alternative hypothesis:", x$alternative, "\n")
    }
    if(!is.null(x$conf.int)) {
	cat(format(100 * attr(x$conf.int, "conf.level")),
	    "percent confidence interval:\n",
            format(c(x$conf.int[1], x$conf.int[2])), "\n")
    }
    if(!is.null(x$estimate)) {
	cat("sample estimates:\n")
	print(x$estimate, ...)
    }
    cat("\n")
    invisible(x)
}
identify <- function(x, ...) UseMethod("identify")

identify.default <- function(x, y=NULL, labels=seq(along=x), pos=FALSE,
			     n=length(x), plot=TRUE, offset=0.5, ...)
{
    opar <- par(list(...))
    on.exit(par(opar))
    xy <- xy.coords(x, y)
    z <- .Internal(identify(xy$x, xy$y, as.character(labels),
			    n, plot, offset))
    i <- seq(z[[1]])[z[[1]]]
    if(pos) list(ind= i, pos= z[[2]][z[[1]]]) else i
}
ifelse <-
    function (test, yes, no)
{
    ans <- test
    test <- as.logical(test)
    nas <- is.na(test)
    if (any(test[!nas])) {
        ans[test] <- rep(yes, length = length(ans))[test]
    }
    if (any(!test[!nas])) {
        ans[!test] <- rep(no, length = length(ans))[!test]
    }
    ans[nas] <- NA
    ans
}
image <- function (x = seq(0, 1, len = nrow(z)),
		   y = seq(0, 1, len = ncol(z)),
		   z,
		   zlim = range(z[is.finite(z)]),
		   xlim = range(x[is.finite(x)]),
		   ylim = range(y[is.finite(y)]),
		   col = heat.colors(12), add = FALSE,
		   xaxs = "i", yaxs = "i", xlab, ylab, ...)
{
    if (missing(z)) {
	if (!missing(x)) {
	    if (is.list(x)) {
		z <- x$z; y <- x$y; x <- x$x
	    } else {
		if(is.null(dim(x)))
		   stop("argument must be matrix alike")
		z <- x
		x <- seq(0, 1, len = nrow(z))
	    }
	    if (missing(xlab)) xlab <- ""
	    if (missing(ylab)) ylab <- ""
	} else stop("no `z' matrix specified")
    } else if (is.list(x)) {
	xn <- deparse(substitute(x))
	if (missing(xlab)) xlab <- paste(xn, "x", sep = "$")
	if (missing(ylab)) ylab <- paste(xn, "y", sep = "$")
	y <- x$y
	x <- x$x
    } else {
	if (missing(xlab))
	    xlab <- if (missing(x)) "" else deparse(substitute(x))
	if (missing(ylab))
	    ylab <- if (missing(y)) "" else deparse(substitute(y))
    }
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
	stop("increasing x and y values expected")
    if (!is.matrix(z))
        stop("`z' must be a matrix")
    if(length(x) > 1 && length(x) == e(substi, ny=NULL, col="lightgray", lty="dotted")
{
    if (is.null(nx)|| nx >= 1) {
        axp <- par("xaxp")
        if(is.null(nx)) nx <- axp[3]
	abline(v = seq(axp[1],axp[2],len=1+nx), col = col, lty = lty)
    }
    if (is.null(ny)|| ny >= 1) {
        axp <- par("yaxp")
        if(is.null(ny)) ny <- axp[3]
	abline(h = seq(axp[1],axp[2],len=1+ny), col = col, lty = lty)
    }
}
###-- NOTE: This is for  NON-Windows only  (cf. windows/help.R )

index.search <- function(topic, path, file="AnIndex", type="help")
    .Internal(index.search(topic, path, file, .Platform$file.sep, type))

help <-
    function (topic, offline = FALSE, package = c(.packages(), .Autoloaded),
              lib.loc = .lib.loc, verbose = .Options$verbose,
              htmlhelp = .Options$htmlhelp)
{
    htmlhelp <- is.logical(htmlhelp) && htmlhelp
    if (!missing(package))
        if (is.name(y <- substitute(package)))
            package <- as.character(y)
    if (!missing(topic)) {
        topic <- substitute(topic)
        if (is.name(topic))
            topic <- as.character(topic)
        else if (!is.character(topic))
            stop("Unimplemented help feature")
        # for cmd/help ..
        if (!is.na(match(topic, c("+", "-", "*", "/", "^", "%%"))))
            topic <- "Arithmetic"
        else if (!is.na(match(topic, c("<", ">", "<=", ">=", "==", "!="))))
            topic <- "Comparison"
        else if (!is.na(match(topic, c("[", "[[", "$"))))
            topic <- "Extract"
        else if (!is.na(match(topic, c("&", "&&", "|", "||", "!"))))
            topic <- "Logic"
        else if (!is.na(match(topic, c("%*%"))))
            topic <- "matmult"
        type <- if(offline) "latex" else if (htmlhelp) "html" else "help"
        INDICES <- system.file(pkg=package, lib=lib.loc)
        file <- index.search(topic, INDICES, "AnIndex", type)
        if (length(file) && file != "") {
            if (verbose)
                cat("\t\t\t\t\t\tHelp file name `", sub(".*/", "", file),
                    ".Rd'\n", sep = "")
            if (!offline) {
                if (htmlhelp) {
                    if(file.exists(file)) {
                        file <- paste("file:", file, sep="")
                        if (is.null(.Options$browser))
                            stop("options(\"browser\") not set")
                        browser <- .Options$browser
                        system(paste(browser, " -remote \"openURL(",
                                     file, ")\" 2>/dev/null || ", browser, " ",
                                     file, " &", sep = ""))
                        cat("help() for",topic, " is shown in browser",browser,
                            "...\nUse\t help(",topic,", htmlhelp=FALSE)\nor\t",
                            "options(htmlhelp = FALSE)\nto revert.\n")
                        return(invisible())
                    } else {
                        if(verbose)
                            cat("no HTML help for `", topic,
                                "' is available\n", sep = "")
                        file <- index.search(topic, INDICES, "AnIndex", "help")
                    }
                }
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                ## end of experimental code
                if(file.exists(zfile))
                    file.show(zfile,
                              ##header= paste("Help for `", topic, "'", sep=""),
                              delete.file = (zfile!=file))
                else
                    stop(paste("The help file for `", topic, "' is missing",
                               sep = ""))
                return(invisible())
            }
            else {
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                if(zfile != file) on.exit(unlink(zfile))
                ## end of experimental code
                if(file.exists(zfile)) {
                    FILE <- tempfile()
                    on.exit(unlink(FILE))
                    cat("\\documentclass[", .Options$papersize, "paper]{article}\n",
                        file = FILE, sep = "")
                    file.append(FILE,
                                file.path(R.home(), "doc", "manual", "Rd.sty"))
                    cat("\\InputIfFileExists{Rhelp.cfg}{}{}\n\\begin{document}\n",
                        file = FILE, append = TRUE)
                    file.append(FILE, zfile)
                    cat("\\end{document}\n", file = FILE, append = TRUE)
                    system(paste(file.path(R.home(), "bin", "help"),
                                 "PRINT", FILE, topic,
                                 .Options$latexcmd, .Options$dvipscmd)
                           )
                    return(invisible())
                }
                else
                    stop(paste("No offline documentation for", topic, "is available"))
            }
        }
        else
            stop(paste("No documentation for `", topic, "'", sep = ""))
    }
    else if (!missing(package))
        library(help = package, lib = lib.loc, character.only = TRUE)
    else if (!missing(lib.loc))
        library(lib = lib.loc)
    else help("help", package = "base", lib.loc = .Library)
}
help.search <- function(topic, fields = c("name", "title"),
                        apropos, keyword, whatis, ignore.case = TRUE,
                        packages = NULL, lib.loc = .lib.loc,
                        help.db = .Options$help.db,
                        verbose = .Options$verbose,
                        rebuild = FALSE) {
    TABLE <- c("name", "alias", "title", "keyword")
    if (!missing(topic)) {
        if (!is.character(topic) || (length(topic) > 1))
            stop("`topic' must be a single character string")
        i <- pmatch(fields, TABLE)
        if (any(is.na(i)))
            stop("incorrect field specification")
        else
            fields <- TABLE[i]
    } else if (!missing(apropos)) {
        if (!is.character(apropos) || (length(apropos) > 1))
            stop("`apropos' must be a single character string")
        else {
            topic <- apropos
            fields <- c("name", "title")
        }
    } else if (!missing(keyword)) {
        if (!is.character(keyword) || (length(keyword) > 1))
            stop("`keyword' must be a single character string")
        else {
            topic <- keyword
            fields <- "keyword"
        }
    } else if (!missing(whatis)) {
        if (!is.character(whatis) || (length(whatis) > 1))
            stop("`whatis' must be a single character string")
        else {
            topic <- whatis
            fields <- "name"
        }
    } else {
        stop("don't know what to search")
    }

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

    ## Matching
    if(verbose) cat("\nDatabase of dimension", dim