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))
.Defunct <- function() {
    stop(paste(sQuote(as.character(sys.call(sys.parent())[[1]])),
	       " is defunct.\n",
	       "See ?Defunct.",
	       sep = ""),
         call. = FALSE)
}

Version <- function() .Defunct()
provide <- function(package) .Defunct()

## <entry>
## Deprecated in 1.2.0
## Defunct in 1.3.0
getenv <- function(...) .Defunct()
## </entry>

## <entry>
## Deprecated in 1.2.3
## Defunct in 1.3.0
## Removed in 1.4.0: conflicts with lattice
## dotplot <- function(...) .Defunct()
## stripplot <- function(...) .Defunct()
## </entry>

## <entry>
## Deprecated in 1.3.0
## Defunct in 1.4.0
read.table.url <- function(...) .Defunct()
scan.url <- function(...) .Defunct()
source.url <- function(...) .Defunct()
httpclient <- function(...) .Defunct()
parse.dcf <- function(...) .Defunct()
## </entry>

## <entry>
## Deprecated in 1.4.0
## Defunct in 1.5.0
.Alias <- function(...) .Defunct()
reshapeLong <- function(...) .Defunct()
reshapeWide <- function(...) .Defunct()
## </entry>

## <entry>
## Deprecated in 1.5.0
## Defunct in 1.6.0
piechart <- function(...) .Defunct()
## </entry>

## <entry>
## Deprecated in 1.6.0
## Defunct in 1.7.0
machine <- function(...) .Defunct()
Machine <- function(...) .Defunct()
Platform <- function(...) .Defunct()
restart <- function(...) .Defunct()
## </entry>

## <entry>
## Deprecated in 1.7.0
## Defunct in 1.8.0
printNoClass <- function(...) .Defunct()
## </entry>

## <entry>
## Deprecated in 1.8.0
## Defunct in 1.9.0
print.coefmat <- function(...) .Defunct()
codes <- function(x, ...) .Defunct()
codes.factor <- function(x, ...) .Defunct()
codes.ordered <- function(x, ...) .Defunct()
"codes<-" <- function(x, ..., value) .Defunct()
anovalist.lm <- function (...) .Defunct()
lm.fit.null <- function(...) .Defunct()
lm.wfit.null <- function(...) .Defunct()
glm.fit.null <- function(...) .Defunct()
print.atomic <- function(...) .Defunct()
## </entry>
###----- NOTE:	../man/Deprecated.Rd   must be synchronized with this!
###		--------------------
.Deprecated <- function(new, package=NULL) {
    warning(paste(sQuote(as.character(sys.call(sys.parent())[[1]])),
		  " is deprecated.\n",
		  if (!missing(new))
		  paste("Use", sQuote(new), "instead.\n"),
		  "See help(\"Deprecated\") ",
                  if(!is.null(package))
                  paste("and help(\"", package, "-deprecated\").", sep=""),
		  sep = ""),
            call. = FALSE)
}

## consider keeping one (commented) entry here, for easier additions
## <entry>
## Deprecated in 1.9.0
La.eigen <- function (x, symmetric, only.values = FALSE,
                      method = c("dsyevr", "dsyev"))
{
    .Deprecated("eigen")
    if(!is.numeric(x) && !is.complex(x))
	stop("argument to La.eigen must be numeric or complex")
    method <- match.arg(method)
    x <- as.matrix(x)
    if (nrow(x) != ncol(x)) stop("non-square matrix in La.eigen")
    if (nrow(x) == 0) stop("0 x 0 matrix in La.eigen")
    if (any(!is.finite(x))) stop("infinite or missing values in x")
    complex.x <- is.complex(x)
    if (missing(symmetric)) {
        tx <- if(complex.x) Conj(t(x)) else t(x)
        test <- all.equal.numeric(x, tx, 100 * .Machine$double.eps)
        symmetric <- is.logical(test) && test
    }
    if (is.numeric(x)) storage.mode(x) <- "double"
    if (symmetric) {
        z <- if(!complex.x)
            .Call("La_rs", x, only.values, method, PACKAGE = "base")
        else
            .Call("La_rs_cmplx", x, only.values, PACKAGE = "base")
        ord <- rev(seq(along = z$values))
    } else {
        z <- if(!complex.x)
            .Call("La_rg", x, only.values, PACKAGE = "base")
        else
            .Call("La_rg_cmplx", x, only.values, PACKAGE = "base")
        ord <- sort.list(Mod(z$values), decreasing = TRUE)
    }
    list(values = z$values[ord],
         vectors = if (!only.values) z$vectors[, ord, drop = FALSE])
}
## </entry>


## <entry>
## Deprecated in 1.9.0
tetragamma <- function(x) {
    .Deprecated("psigamma(*, deriv=2)")
    psigamma(x, deriv=2)
}
## </entry>


## <entry>
## Deprecated in 1.9.0
pentagamma <- function(x) {
    .Deprecated("psigamma(*, deriv=3)")
    psigamma(x, deriv=3)
}
## </entry>


## <entry>
## Deprecated in 1.9.0
package.description <- function(pkg, lib.loc=NULL, fields=NULL)
{
    .Deprecated("packageDescription")
    file <- system.file("DESCRIPTION", package = pkg, lib.loc = lib.loc)
    if(file != "") {
        retval <- read.dcf(file=file, fields=fields)[1,]
    }

    if((file == "") || (length(retval) == 0)){
        warning(paste("DESCRIPTION file of package", pkg,
                      "missing or broken"))
        if(!is.null(fields)){
            retval <- rep.int(NA, length(fields))
            names(retval) <- fields
        }
        else
            retval <- NA
    }

    retval
}
## </entry>
La.svd <- function(x, nu = min(n, p), nv = min(n, p),
                   method = c("dgesdd", "dgesvd"))
{
    if(!is.numeric(x) && !is.complex(x))
	stop("argument to La.svd must be numeric or complex")
    if (any(!is.finite(x))) stop("infinite or missing values in x")
    method <- match.arg(method)
    if(!capabilities("IEEE754")) method <- "dgesvd"
    if(is.complex(x) && method == "dgesdd") {
        method <- "dgesvd"
    }
    x <- as.matrix(x)
    if (is.numeric(x)) storage.mode(x) <- "double"
    n <- nrow(x)
    p <- ncol(x)
    if(!n || !p) stop("0 extent dimensions")

    if(method == "dgesvd") {
        if(nu == 0) {
            jobu <- 'N'
            u <- matrix(0, 1, 1)  # dim is checked
        }
        else if(nu == n) {
            jobu <- ifelse(n > p, 'A', 'S')
            u <- matrix(0, n, n)
        }
        else if(nu == p) {
            jobu <- ifelse(n > p, 'S', 'A')
            u <- matrix(0, n, p)
        }
        else
            stop("nu must be 0, nrow(x) or ncol(x)")

        if (nv == 0) {
            jobv <- 'N'
            v <- matrix(0, 1, 1) # dim is checked
        }
        else if (nv == n) {
            jobv <- ifelse(n > p, 'A', 'S')
            v <- matrix(0, min(n, p), p)
        }
        else if (nv == p) {
            jobv <- ifelse(n > p, 'S', 'A')
            v <- matrix(0, p, p)
        }
        else
            stop("nv must be 0, nrow(x) or ncol(x)")
    } else {
        if(nu > 0 || nv > 0) {
            np <- min(n, p)
            if(nu <= np && nv <= np) {
                jobu <- 'S'
                u <- matrix(0, n, np)
                v <- matrix(0, np, p)
            } else {
                jobu <- 'A'
                u <- matrix(0, n, n)
                v <- matrix(0, p, p)
            }
        } else {
            jobu <- 'N'
            # these dimensions _are_ checked, but unused
            u <- matrix(0, 1, 1)
            v <- matrix(0, 1, 1)
        }
        jobv <- ''
        res <- .Call("La_svd", jobu, jobv, x, double(min(n,p)), u, v,
                     method, PACKAGE = "base")
        res <- res[c("d", if(nu) "u", if(nv) "vt")]
        if(nu) res$u <- res$u[, 1:min(n, nu), drop = FALSE]
        if(nv) res$vt <- res$vt[1:min(p, nv), , drop = FALSE]
        return(res)
    }

    if(is.complex(x)) {
        u[] <- as.complex(u)
        v[] <- as.complex(v)
        res <- .Call("La_svd_cmplx", jobu, jobv, x, double(min(n, p)), u, v,
                     PACKAGE = "base")
    } else
        res <- .Call("La_svd", jobu, jobv, x, double(min(n, p)), u, v,
                     method, PACKAGE = "base")
    res[c("d", if(nu) "u", if(nv) "vt")]
}

La.chol <- function(x) .Call("La_chol", as.matrix(x), PACKAGE = "base")

La.chol2inv <- function(x, size = ncol(x)) {
    x <- as.matrix(x) # do it this way so ncol(x) is defined
    .Call("La_chol2inv", x, size, PACKAGE = "base")
}
geterrmessage <- function() .Internal(geterrmessage())

try <- function(expr, silent = FALSE)
{
    if (! exists("first", inherits = FALSE)) {
        first <- FALSE
        # turn on the restart bit of the current context, push an
        # error handler on the condition handler stack, and push
        # a tryRestart restart on the restart stack
        .Internal(.addTryHandlers())
        if (silent) {
            op <- options("show.error.messages")
            on.exit(options(op))
            options(show.error.messages = FALSE)
        }
        expr
    }
    else invisible(structure(.Internal(geterrmessage()), class = "try-error"))
}


comment <- function(x).Internal(comment(x))
"comment<-" <- function(x,value).Internal("comment<-"(x,value))

round <- function(x, digits = 0).Internal(round(x,digits))
signif <- function(x, digits = 6).Internal(signif(x,digits))
logb <- log <- function(x, base=exp(1))
    if(missing(base)).Internal(log(x)) else .Internal(log(x,base))
log1p <- function(x).Internal(log1p(x))
expm1 <- function(x).Internal(expm1(x))

atan2 <- function(y, x).Internal(atan2(y, x))

beta <- function(a, b).Internal( beta(a, b))
lbeta <- function(a, b).Internal(lbeta(a, b))

gamma <- function(x).Internal( gamma(x))
lgamma <- function(x).Internal(lgamma(x))
digamma <- function(x).Internal(   digamma(x))
trigamma <- function(x).Internal(  trigamma(x))
psigamma <- function(x, deriv=0) .Internal(psigamma(x, deriv))
## tetragamma, pentagamma : deprecated in 1.9.0

factorial <- function(x) gamma(x + 1)
lfactorial <- function(x) lgamma(x + 1)

choose <- function(n,k).Internal(choose(n,k))
lchoose <- function(n,k).Internal(lchoose(n,k))

##-- 2nd part --
# Machine <- function().Internal(Machine())
R.Version <- function().Internal(Version())
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) .NotYetUsed("deparse.level != 1")
    .Internal(cbind(...))
}
rbind <- function(..., deparse.level=1) {
    if(deparse.level != 1) .NotYetUsed("deparse.level != 1")
    .Internal(rbind(...))
}

deparse <-
    function(expr, width.cutoff = 60,
	     backtick = mode(expr) %in% c("call","expression","("))
	.Internal(deparse(expr, width.cutoff, backtick))


do.call <- function(what,args).Internal(do.call(what,args))
drop <- function(x).Internal(drop(x))
format.info <- function(x, nsmall=0).Internal(format.info(x, nsmall))
gc <- function(verbose = getOption("verbose"))
{
    res <-.Internal(gc(verbose))/c(1, 1, 10, 10, 1, 1, rep(10,4))
    res <- matrix(res, 2, 5,
                  dimnames = list(c("Ncells","Vcells"),
                  c("used", "(Mb)", "gc trigger", "(Mb)", "limit (Mb)")))
    if(all(is.na(res[, 5]))) res[, -5] else res
}
gcinfo <- function(verbose).Internal(gcinfo(verbose))
gctorture <- function(on=TRUE)invisible(.Internal(gctorture(on)))

is.unsorted <- function(x, na.rm = FALSE) {
    if(is.null(x)) return(FALSE)
    if(!is.atomic(x) ||
       (!na.rm && any(is.na(x))))
	return(NA)
    ## else
    if(na.rm && any(ii <- is.na(x)))
	x <- x[!ii]
    .Internal(is.unsorted(x))
}

mem.limits <- function(nsize=NA, vsize=NA)
{
    structure(.Internal(mem.limits(as.integer(nsize), as.integer(vsize))),
              names=c("nsize", "vsize"))
}

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

polyroot <- function(z).Internal(polyroot(z))

readline <- function(prompt="").Internal(readline(prompt))
search <- function().Internal(search())
searchpaths <- function()
{
    s <- search()
    paths <-
        lapply(1:length(s), function(i) attr(as.environment(i), "path"))
    paths[[length(s)]] <- system.file()
    m <- grep("^package:", s)
    if(length(m)) paths[-m] <- as.list(s[-m])
    unlist(paths)
}

sprintf <- function(fmt, ...) .Internal(sprintf(fmt, ...))

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


memory.profile <- function() .Internal(memory.profile())

capabilities <- function(what = NULL)
{
    z  <- .Internal(capabilities())
    if(is.null(what)) return(z)
    nm <- names(z)
    i <- pmatch(what, nm)
    if(is.na(i)) logical(0) else z[i]
}

inherits <- function(x, what, which = FALSE)
	.Internal(inherits(x, what, which))

NextMethod <- function(generic=NULL, object=NULL, ...)
    .Internal(NextMethod(generic, object,...))

data.class <- function(x) {
    if (length(cl <- oldClass(x)))
	cl[1]
    else {
	l <- length(dim(x))
	if (l == 2)	"matrix"
	else if (l > 0)	"array"
	else mode(x)
    }
}


## base has no S4 generics
.noGenerics <- TRUE
## Random Number Generator

## The available kinds are in
## ../../../include/Random.h  and ../../../main/RNG.c [RNG_Table]
##
RNGkind <- function(kind = NULL, normal.kind = NULL)
{
    kinds <- c("Wichmann-Hill", "Marsaglia-Multicarry", "Super-Duper",
               "Mersenne-Twister", "Knuth-TAOCP", "user-supplied",
               "Knuth-TAOCP-2002", "default")
    n.kinds <- c("Buggy Kinderman-Ramage", "Ahrens-Dieter", "Box-Muller",
                 "user-supplied", "Inversion", "Kinderman-Ramage",
		 "default")
    do.set <- length(kind) > 0
    if(do.set) {
	if(!is.character(kind) || length(kind) > 1)
	    stop("'kind' must be a character string of length 1 (RNG to be used).")
	if(is.na(i.knd <- pmatch(kind, kinds) - 1))
	    stop(paste("'",kind,"' is not a valid abbrevation of an RNG",
		       sep=""))
        if(i.knd == length(kinds) - 1) i.knd <- -1
    } else i.knd <- NULL

    if(!is.null(normal.kind)) {
	if(!is.character(normal.kind) || length(normal.kind) > 1)
	    stop("'normal.kind' must be a character string of length 1.")
	if (normal.kind == "Buggy Kinderman-Ramage")
		warning("Buggy version of Kinderman-Ramage generator used.")
        normal.kind <- pmatch(normal.kind, n.kinds) - 1
        if(is.na(normal.kind))
 	    stop(paste("'", normal.kind,"' is not a valid choice", sep=""))
        if(normal.kind == length(n.kinds) - 1) normal.kind <- -1
    }
    r <- 1 + .Internal(RNGkind(i.knd, normal.kind))
    r <- c(kinds[r[1]], n.kinds[r[2]])
    if(do.set || !is.null(normal.kind)) invisible(r) else r
}

set.seed <- function(seed, kind = NULL)
{
    kinds <- c("Wichmann-Hill", "Marsaglia-Multicarry", "Super-Duper",
               "Mersenne-Twister", "Knuth-TAOCP", "user-supplied",
               "Knuth-TAOCP-2002", "default")
    if(length(kind) > 0) {
	if(!is.character(kind) || length(kind) > 1)
	    stop("'kind' must be a character string of length 1 (RNG to be used).")
	if(is.na(i.knd <- pmatch(kind, kinds) - 1))
	    stop(paste("'",kind,"' is not a valid abbrevation of an RNG",
		       sep=""))
        if(i.knd == length(kinds) - 1) i.knd <- -1
    } else i.knd <- NULL

    invisible(.Internal(set.seed(seed, i.knd)))
}

# Compatibility function to set RNGkind as in a given R version

RNGversion <- function(vstr)
{
    vnum <- as.numeric(strsplit(vstr,".", fixed=TRUE)[[1]])
    if (length(vnum) < 2)
	stop("Malformed version string")
    if (vnum[1] == 0 && vnum[2] < 99)
        RNGkind("Wichmann-Hill", "Buggy Kinderman-Ramage")
    else if (vnum[1] == 0 || vnum[1] == 1 && vnum[2] <= 6)
	RNGkind("Marsaglia-Multicarry", "Buggy Kinderman-Ramage")
    else
	RNGkind("Mersenne-Twister", "Inversion")
}
.Script <- function(interpreter, script, args, ...)
{
    if(.Platform$OS.type == "windows") {
        cmd <- paste(file.path(R.home(), "bin", "Rcmd"),
                     file.path("..", "share", interpreter, script),
                     args)
        system(cmd, invisible = TRUE)
    }
    else
        system(paste(file.path(R.home(), "bin", "Rcmd"),
                     interpreter,
                     file.path(R.home(), "share", interpreter, script),
                     args),
               ...)
}
all.equal <- function(target, current, ...) UseMethod("all.equal")

all.equal.default <- function(target, current, ...)
{
    ## Really a dispatcher given mode() of args :
    ## use data.class as unlike class it does not give "Integer"
    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(is.numeric(target)) {
		 all.equal.numeric(target, current, ...)
	     } else
	     switch (mode(target),
		     logical = ,
		     complex = ,
		     numeric = all.equal.numeric(target, current, ...),
		     character = all.equal.character(target, current, ...),
		      if(data.class(target) != data.class(current)) {
		 paste("target is ", data.class(target), ", current is ",
		       data.class(current), sep = "")
	     } else NULL))
    if(is.null(msg)) TRUE else msg
}

all.equal.numeric <-
function(target, current, tolerance = .Machine$double.eps ^ .5,
         scale=NULL, ...)
{
    if(data.class(target) != data.class(current))
        return(paste("target is ", data.class(target), ", current is ",
		       data.class(current), sep = ""))
    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 = ""))
    target <- as.vector(target)
    current <- as.vector(current)
    out <- is.na(target)
    if(any(out != is.na(current)))
	return(paste("`is.NA' value mismatches:", sum(is.na(current)),
		     "in current,", sum(out), " in target"))
    out <- out | target == current
    if(all(out)) return(TRUE)
    target <- target[!out]
    current <- current[!out]
    xy <- mean((if(cplx)Mod else abs)(target - current))
    what <-
	if(is.null(scale)) {
	    xn <- mean(abs(target))
	    if(is.finite(xn) && xn > tolerance) {
		xy <- xy/xn
		"relative"
	    } else "absolute"
	} else {
	    xy <- xy/scale
	    "scaled"
	}
    if(is.na(xy) || xy > tolerance)
	paste("Mean", what, if(cplx)"Mod", "difference:", format(xy)) else TRUE
}

all.equal.character <- function(target, current, ...)
{
    if(data.class(target) != data.class(current))
        return(paste("target is ", data.class(target), ", current is ",
		       data.class(current), sep = ""))
    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
    nas <- is.na(target)
    if (any(nas != is.na(current)))
        return(paste("`is.NA' value mismatches:", sum(is.na(current)),
                     "in current,", sum(nas), " in target"))
    ne <- !nas & (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 <-
        ## <FIXME>
        ## Commenting this eliminates PR#674, and assumes that lists are
        ## regarded as generic vectors, so that they are equal iff they
        ## have identical names attributes and all components are equal.
        ## 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
        ## </FIXME>
        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))
aperm <- function(a, perm, resize=TRUE)
{
    if (missing(perm))
	perm <- integer(0) # will reverse the order
    .Internal(aperm(a, perm, resize))
}
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(oldClass(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

    d2 <- prod(d.ans)
    if(d2 == 0) {
        ## arrays with some 0 extents: return ``empty result'' trying
        ## to use proper mode and dimension:
        ## The following is still a bit `hackish': use non-empty X
        newX <- array(vector(typeof(X), 1), dim = c(prod(d.call), 1))
        ans <- FUN(if(length(d.call) < 2) newX[,1] else
                   array(newX[,1], d.call, dn.call), ...)
        return(if(is.null(ans)) ans else if(length(d.call) < 2) ans[1][-1]
               else array(ans, d.ans, dn.ans))
    }
    ## else
    newX <- aperm(X, c(s.call, s.ans))
    dim(newX) <- c(prod(d.call), d2)
    ans <- vector("list", d2)
    if(length(d.call) < 2) {# vector
        if (length(dn.call)) dimnames(newX) <- c(dn.call, list(NULL))
        for(i in 1:d2) ans[[i]] <- FUN(newX[,i], ...)
    } else
       for(i in 1:d2) ans[[i]] <- FUN(array(newX[,i], d.call, dn.call), ...)
#     if(length(d.call) == 1) {
#         X1 <- newX[,1]
#         if (length(dn.call)) names(X1) <- dn.call[[1]]
#     } else X1 <- array(newX[,1], d.call, dn.call)
#     ans <- .Internal(apply(newX, X1, FUN))

    ## answer dims and dimnames

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

    ans.names <- names(ans[[1]])
    if(!ans.list)
	ans.list <- any(unlist(lapply(ans, length)) != l.ans)
    if(!ans.list && length(ans.names)) {
        all.same <- sapply(ans, function(x) identical(names(x), ans.names))
        if (!all(all.same)) ans.names <- NULL
    }
    len.a <- if(ans.list) d2 else length(ans <- unlist(ans, recursive = FALSE))
    if(length(MARGIN) == 1 && len.a == d2) {
	names(ans) <- if(length(dn.ans[[1]])) dn.ans[[1]] # else NULL
	return(ans)
    }
    if(len.a == d2)
	return(array(ans, d.ans, dn.ans))
    if(len.a > 0 && len.a %% d2 == 0)
	return(array(ans, c(len.a %/% d2, d.ans),
                     if(is.null(dn.ans)) {
                         if(!is.null(ans.names)) list(ans.names,NULL)
                     } else c(list(ans.names), dn.ans)))
    return(ans)
}
### approx() and approxfun() are *very similar* -- keep in sync!

approx <- function(x, y = NULL, xout, method = "linear", n = 50,
                   yleft, yright, rule = 1, f = 0, ties = mean)
{
    x <- xy.coords(x, y)
    y <- x$y
    x <- x$x
    if (!is.numeric(x) || !is.numeric(y))
	stop("x and y must be numeric")
    nx <- length(x)
    if (nx != length(y))
	stop("x and y must have equal lengths")
    method <- pmatch(method, c("linear", "constant"))
    if (is.na(method))
	stop("invalid interpolation method")
    if (nx < 2 && method == "linear")
	stop("approx requires at least two values to interpolate")
    if(any(na <- is.na(x) | is.na(y))) {
	ok <- !na
	x <- x[ok]
	y <- y[ok]
	nx <- length(x)
    }
    if (!identical(ties, "ordered")) {
	if (length(ux <- unique(x)) < nx) {
	    if (missing(ties))
		warning("Collapsing to unique x values")
	    y <- as.vector(tapply(y,x,ties))# as.v: drop dim & dimn.
	    x <- sort(ux)
	    nx <- length(x)
	} else {
	    o <- order(x)
	    x <- x[o]
	    y <- y[o]
	}
    }
    if (nx < 2 && method == "linear")
	stop("need at least two unique non-missing values to interpolate")
    if (missing(yleft))
	yleft <- if (rule == 1) NA else y[1]
    if (missing(yright))
	yright <- if (rule == 1) NA else y[length(y)]
    if (missing(xout)) {
	if (n <= 0)
	    stop("approx requires n >= 1")
	xout <- seq(x[1], x[nx], length = n)
    }
    y <- .C("R_approx", as.double(x), as.double(y), as.integer(nx),
            xout = as.double(xout), as.integer(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, ties = mean)
{
    x <- xy.coords(x, y)
    y <- x$y
    x <- x$x
    if (!is.numeric(x) || !is.numeric(y))
	stop("x and y must be numeric")
    n <- length(x)
    if (n != length(y))
	stop("x and y must have equal lengths")
    method <- pmatch(method, c("linear", "constant"))
    if (is.na(method))
	stop("invalid interpolation method")
    if (n < 2 && method == "linear")
	stop("approx requires at least two values to interpolate")
    if(any(o <- is.na(x) | is.na(y))) {
	o <- !o
	x <- x[o]
	y <- y[o]
	n <- length(x)
    }
    if (!identical(ties, "ordered")) {
	if (length(ux <- unique(x)) < n) {
	    if (missing(ties))
		warning("Collapsing to unique x values")
	    y <- as.vector(tapply(y,x,ties))# as.v: drop dim & dimn.
	    x <- sort(ux)
	    n <- length(x)
	    rm(ux)
	} else {
	    o <- order(x)
	    x <- x[o]
	    y <- y[o]
	}
    }
    if (n < 2 && method == "linear")
	stop("need at least two unique non-missing values to interpolate")
    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, rule)
    function(v) .C("R_approx", as.double(x), as.double(y), as.integer(n),
                   xout = as.double(v), as.integer(length(v)),
                   as.integer(method), as.double(yleft), as.double(yright),
		   as.double(f), NAOK = TRUE, PACKAGE = "base")$xout
}

### This is a `variant' of  approx( method = "constant" ) :
findInterval <- function(x, vec, rightmost.closed = FALSE, all.inside = FALSE)
{
    ## Purpose: gives back the indices of  x in vec;  vec[] sorted
    ## -------------------------------------------------------------------------
    ## Author: Martin Maechler, Date:  4 Jan 2002, 10:16

    if(any(is.na(vec)))
        stop(sQuote("vec")," contains NAs")
    if(is.unsorted(vec))
        stop(sQuote("vec")," must be sorted non-decreasingly")
    ## deal with NA's in x:
    if(has.na <- any(ix <- is.na(x)))
        x <- x[!ix]
    nx <- length(x)
    index <- integer(nx)
    .C("find_interv_vec",
       xt = as.double(vec), n = as.integer(length(vec)),
       x  = as.double(x),  nx = as.integer(nx),
       as.logical(rightmost.closed),
       as.logical(all.inside),
       index, DUP = FALSE, NAOK = TRUE, # NAOK: 'Inf' only
       PACKAGE = "base")
    if(has.na) {
        ii <- as.integer(ix)
        ii[ix] <- NA
        ii[!ix] <- index
        ii
    } else index
}
array <-
function(data = NA, dim = length(data), dimnames = NULL)
{
    data <- as.vector(data)
    vl <- prod(dim)
    if(length(data) != vl) {
        if(vl > .Machine$integer.max)
            stop("dim specifies too large an array")
        data <- rep(data, length.out=vl)
    }
    if(length(dim))
	dim(data) <- dim
    if(is.list(dimnames) && length(dimnames))
	dimnames(data) <- dimnames
    data
}

slice.index <-
function(x, MARGIN)
{
    d <- dim(x)
    if(is.null(d))
        d <- length(x)
    n <- length(d)

    if((length(MARGIN) > 1) || (MARGIN < 1) || (MARGIN > n))
        stop("incorrect value for MARGIN")

    if(any(d == 0)) return(array(integer(0), d))

    y <- rep.int(rep.int(seq(1 : d[MARGIN]),
                 prod(d[seq(length = MARGIN - 1)]) * rep.int(1, d[MARGIN])),
             prod(d[seq(from = MARGIN + 1, length = n - MARGIN)]))
    dim(y) <- d
    y
}
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 <- 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 is now internal.  The default method remains here to
# preserve the semantics that for a call with an object argument
# dispatching is done first on as.character and then on as.vector.
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), list(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.list.environment <- function(x, all.names=FALSE, ...)
    .Internal(env2list(x, all.names))

##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 (x, envir = parent.frame(), ...)
    if (is.function(x)) x else .Internal(as.function.default(x, 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.symbol <- function(x) .Internal(as.vector(x, "symbol"))
as.name <- as.symbol
## would work too: 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
assign <-
    function (x, value, pos = -1, envir = as.environment(pos),
              inherits = FALSE, immediate = TRUE)
    .Internal(assign(x, value, envir, inherits))
attach <- function(what, pos=2, name=deparse(substitute(what)))
{
    if (is.character(what) && (length(what)==1)){
        if (!file.exists(what))
            stop(paste("File", what, " not found.", sep=""))
        name<-paste("file:", what, sep="")
        value <- .Internal(attach(NULL, pos, name))
        load(what, envir=as.environment(pos))
    }
    else
        value <- .Internal(attach(what, pos, name))
    if((length(objects(envir = value, all=TRUE)) > 0)
       && .isMethodsDispatchOn())
      methods:::cacheMetaData(value, TRUE)
    invisible(value)
}

detach <- function(name, pos=2, version)
{
    if(!missing(name)) {
        name <- substitute(name)# when a name..
	pos <-
	    if(is.numeric(name))
                name
	    else {
                if (!is.character(name))
                    name <- deparse(name)
                if (!missing(version))
                    name <- manglePackageName(name, version)
                match(name, search())
            }
	if(is.na(pos))
	    stop("invalid name")
    }
    env <- as.environment(pos)
    packageName <- search()[[pos]]
    libpath <- attr(env, "path")
    if(length(grep("^package:", packageName))) {
        pkgname <- sub("^package:", "", packageName)
        hook <- getHook(packageEvent(pkgname, "detach")) # might be list()
        for(fun in rev(hook)) try(fun(pkgname, libpath))
    }
    if(exists(".Last.lib", mode = "function", where = pos, inherits=FALSE)) {
        .Last.lib <- get(".Last.lib",  mode = "function", pos = pos,
                         inherits=FALSE)
        if(!is.null(libpath)) try(.Last.lib(libpath))
    }
    .Internal(detach(pos))
    ## check for detaching a  package required by another package (not by .GlobalEnv
    ## because detach() can't currently fix up the .required there)
    for(pkgs in search()[-1]) {
        if(!isNamespace(as.environment(pkgs)) &&
           exists(".required", pkgs, inherits = FALSE) &&
           packageName %in% paste("package:", get(".required", pkgs, inherits = FALSE),sep=""))
            warning(packageName, " is required by ", pkgs, " (still attached)")
    }
    if(.isMethodsDispatchOn())
            methods:::cacheMetaData(env, FALSE)
}

ls <- objects <-
    function (name, pos = -1, envir = as.environment(pos), all.names = FALSE,
              pattern)
{
    if (!missing(name)) {
        nameValue <- try(name)
        if(identical(class(nameValue), "try-error")) {
            name <- substitute(name)
            if (!is.character(name))
                name <- deparse(name)
            pos <- name
        }
        else
            pos <- nameValue
    }
    all.names <- .Internal(ls(envir, all.names))
    if (!missing(pattern)) {
        if ((ll <- length(grep("[", pattern, fixed=TRUE))) > 0 &&
            ll != length(grep("]", pattern, fixed=TRUE))) {
            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
}
"mostattributes<-" <- function(obj, value) {
    if(length(value)) {
	if(!is.list(value)) stop("RHS must be list")
	if(h.nam <- !is.na(inam <- match("names", names(value)))) {
	    n1 <- value[[inam]];	value <- value[-inam] }
	if(h.dim <- !is.na(idin <- match("dim", names(value)))) {
	    d1 <- value[[idin]];	value <- value[-idin] }
	if(h.dmn <- !is.na(idmn <- match("dimnames", names(value)))) {
	    dn1 <- value[[idmn]];	value <- value[-idmn] }
	attributes(obj) <- value
        dm <- dim(obj)
	if(h.nam && is.null(dm) && length(obj) == length(n1))
	    names(obj) <- n1
	if(h.dim && length(obj) == prod(d1))
	    dim(obj) <- dm <- d1
	if(h.dmn && !is.null(dm)) {
            ddn <- sapply(dn1, length)
            if( all((dm == ddn)[ddn > 0]) ) dimnames(obj) <- dn1
        }
    }
    obj
}
autoload <- function(name, package, reset=FALSE, ...)
{
    if (!reset && exists(name, envir = .GlobalEnv, inherits = FALSE))
	stop("Object with that name already exists")
    m <- match.call()
    m[[1]] <- as.name("list")
    newcall <- eval(m, parent.frame())
    newcall <- as.call(c(as.name("autoloader"), newcall))
    newcall$reset <- NULL
    if (is.na(match(package, .Autoloaded)))
	assign(".Autoloaded", c(package, .Autoloaded), env =.AutoloadEnv)
    assign(name, do.call("delay", list(newcall)), env = .AutoloadEnv)
    ## no longer return the result, which is a promise
    invisible()
}

autoloader <- function (name, package, ...)
{
    name <- paste(name, "", sep = "")
    rm(list = name, envir = .AutoloadEnv, inherits = FALSE)
    m <- match.call()
    m$name <- NULL
    m[[1]] <- as.name("library")
    ## load the package
    eval(m, .GlobalEnv)
    ## reset the autoloader
    autoload(name, package, reset = TRUE, ...)
    ## reevaluate the object
    where <- match(paste("package", package, sep = ":"), search())
    if (exists(name, where = where, inherits = FALSE))
	eval(as.name(name), as.environment(where))
    else
	stop(paste("autoloader didn't find `", name, "' in `", package,
                   "'.", sep = ""))
}


bquote<-function(expr, where=parent.frame()){

    
    unquote<-function(e){

        if (length(e)<=1)
            e
        else if (e[[1]]==as.name("."))
            eval(e[[2]],where)
        else
            as.call(lapply(e,unquote))
        
    }

    unquote(substitute(expr))

}

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)
}
lockEnvironment <- function(env, bindings = FALSE)
    .Internal(lockEnvironment(env, bindings))

environmentIsLocked <- function(env)
    .Internal(environmentIsLocked(env))

lockBinding <- function(sym, env) {
    if (is.character(sym)) sym <- as.name(sym)
    .Internal(lockBinding(sym, env))
}

bindingIsLocked <- function(sym, env) {
    if (is.character(sym)) sym <- as.name(sym)
    .Internal(bindingIsLocked(sym, env))
}

makeActiveBinding <- function(sym, fun, env) {
    if (is.character(sym)) sym <- as.name(sym)
    .Internal(makeActiveBinding(sym, fun, env))
}

bindingIsActive <- function(sym, env) {
    if (is.character(sym)) sym <- as.name(sym)
    .Internal(bindingIsActive(sym, env))
}

unlockBinding <- function(sym, env) {
    if (is.character(sym)) sym <- as.name(sym)
    .Internal(unlockBinding(sym, env))
}
builtins <- function(internal=FALSE)
    .Internal(builtins(internal))
by <- function(data, INDICES, FUN, ...) UseMethod("by")

by.default <- function(data, INDICES, FUN, ...)
    by(as.data.frame(data), INDICES, FUN, ...)

by.data.frame <- function(data, INDICES, FUN, ...)
{
    if(!is.list(INDICES)) { # record the names for print.by
        IND <- vector("list", 1)
        IND[[1]] <- INDICES
        names(IND) <- deparse(substitute(INDICES))
    } else IND <- INDICES
    FUNx <- function(x) FUN(data[x,], ...)
    nd <- nrow(data)
    ans <- eval(substitute(tapply(1:nd, IND, FUNx)), data)
    attr(ans, "call") <- match.call()
    class(ans) <- "by"
    ans
}

print.by <- function(x, ..., vsep)
{
    d <- dim(x)
    dn <- dimnames(x)
    dnn <- names(dn)
    if(missing(vsep))
        vsep <- paste(rep("-", 0.75*getOption("width")), collapse = "")
    lapply(seq(along = x), function(i, x, labs, vsep, ...) {
        if(i != 1 && !is.null(vsep)) cat(vsep, "\n")
        ii <- i - 1
        for(j in seq(along = dn)) {
            iii <- ii %% d[j] + 1; ii <- ii %/% d[j]
            cat(dnn[j], ": ", dn[[j]][iii], "\n", sep = "")
        }
        print(x[[i]], ...)
    } , x, labs, vsep, ...)
    invisible(x)
}
cat <- function(..., file = "", sep = " ", fill = FALSE,
                labels = NULL, append = FALSE)
{
    if(is.character(file))
        if(file == "") file <- stdout()
        else if(substring(file, 1, 1) == "|") {
            file <- pipe(substring(file, 2), "w")
            on.exit(close(file))
        } else {
            file <- file(file, ifelse(append, "a", "w"))
            on.exit(close(file))
        }
    .Internal(cat(list(...), file, sep, fill, labels, append))
}
strsplit <- function(x, split, extended = TRUE, fixed = FALSE, perl = FALSE)
    .Internal(strsplit(x, as.character(split), as.logical(extended),
                       as.logical(fixed), as.logical(perl)))

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 && lt < n) text <- rep(text, length.out = n)
    substr(text, first, last)
}

"substr<-" <- function(x, start, stop, value)
    .Internal(substrgets(x, as.integer(start), as.integer(stop), value))

"substring<-" <- function(text, first, last=1000000, value)
{
    "substr<-"(text, first, last, value)
}

abbreviate <-
    function(names.arg, minlength = 4, use.classes = TRUE, dot = FALSE)
{
    ## we just ignore use.classes
    if(minlength <= 0)
	return(rep.int("", length(names.arg)))
    ## need to remove leading/trailing spaces before we check for dups
    ## This is inefficient but easier than modifying do_abbrev (=> FIXME !)
    names.arg <- sub("^ +", "", sub(" +$", "", as.character(names.arg)))
    dups <- duplicated(names.arg)
    old <- names.arg
    if(any(dups))
	names.arg <- names.arg[!dups]
    dup2 <- rep.int(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[dup2], 0)
	these <- names.arg[dup2]
    }
    if(any(dups))
	x <- x[match(old,names.arg)]
    if(dot) { # add "." where we did abbreviate:
        chgd <- x != old
	x[chgd] <- paste(x[chgd],".",sep = "")
    }
    names(x) <- old
    x
}

make.names <- function(names, unique = FALSE)
{
    names <- .Internal(make.names(as.character(names)))
    if(unique) names <- make.unique(names)
    names
}

make.unique <- function (names, sep = ".") .Internal(make.unique(names, sep))

chartr <- function(old, new, x) .Internal(chartr(old, new, x))
tolower <- function(x) .Internal(tolower(x))
toupper <- function(x) .Internal(toupper(x))

casefold <- function(x, upper = FALSE)
    if(upper) toupper(x) else tolower(x)

sQuote <- function(x) {
    if(length(x) == 0) return(character())
    paste("'", x, "'", sep = "")
}
dQuote <- function(x) {
    if(length(x) == 0) return(character())
    paste("\"", x, "\"", sep = "")
}
chol <- function(x, pivot = FALSE, LINPACK = pivot)
{
    if (is.complex(x))
        stop("complex matrices not permitted at present")
    else 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(!pivot && !LINPACK) return(.Call("La_chol", as.matrix(x), PACKAGE = "base"))

    if(!is.double(x)) storage.mode(x) <- "double"

    if(pivot) {
        xx <- x
        xx[lower.tri(xx)] <- 0
        z <- .Fortran("dchdc",
                      x = xx,
                      n,
                      n,
                      double(n),
                      piv = as.integer(rep.int(0, n)),
                      as.integer(pivot),
                      rank = integer(1),
                      DUP = FALSE, PACKAGE = "base")
        if (!pivot && z$rank < n)
            stop("matrix not positive definite")
        robj <- z$x
        if (pivot) {
            attr(robj, "pivot") <- z$piv
            attr(robj, "rank") <- z$rank
        }
        robj
    } else {
        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("non-positive definite matrix in chol")
        z$v
    }
}

chol2inv <- function(x, size=NCOL(x), LINPACK=FALSE)
{
    if(!is.numeric(x))
	stop("non-numeric argument to chol2inv")
    if(!LINPACK) return(La.chol2inv(x, size))

    if(is.matrix(x)) {
	nr <- nrow(x)
	nc <- ncol(x)
    }
    else {
	nr <- length(x)
	nc <- as.integer(1)
    }
    size <- as.integer(size)
    if(size <= 0 || size > nr || size > nc)
	stop("invalid size argument in chol2inv")
    if(!is.double(x)) storage.mode(x) <- "double"
    z <- .Fortran("ch2inv",
		  x=x,
		  nr,
		  size,
		  v=matrix(0, nr=size, nc=size),
		  info=integer(1),
		  DUP=FALSE, PACKAGE="base")
    if(z$info)
	stop("singular matrix in chol2inv")
    z$v
}
chull <- function(x, y=NULL)
{
    X <- xy.coords(x, y, recycle = TRUE)
    x <- cbind(X$x, X$y)
    n <- nrow(x)
    if(n == 0) return(integer(0))
    z <- .C("R_chull",
	    n=as.integer(n),
	    as.double(x),
	    as.integer(n),
	    as.integer(1:n),
	    integer(n),
	    integer(n),
	    ih=integer(n),
	    nh=integer(1),
	    il=integer(n),
	    PACKAGE="base")
    rev(z$ih[1:z$nh])
}
citation <- function() {
    cat("To cite R in publications, use\n\n")
    msg <- paste("R Development Core Team (", version$year, "). ", 
                 "R: A language and environment for statistical computing. ",
                 "R Foundation for Statistical Computing, Vienna, Austria. ",
                 "ISBN 3-900051-00-3, URL http://www.R-project.org.",
                 sep="")
    writeLines(strwrap(msg, prefix="  "))
    cat("\n")
    msg <- paste("We have invested a lot of effort in creating R,",
                 "please cite it when using it for data analysis.")
    writeLines(strwrap(msg))
    cat("\nA BibTeX entry for LaTeX users is\n\n")
    cat("  @Manual{,\n")
    cat("     title        = {R: A language and environment for\n")
    cat("                     statistical computing},\n")
    cat("     author       = {{R Development Core Team}},\n")
    cat("     organization = {R Foundation for Statistical Computing},\n")
    cat("     address      = {Vienna, Austria},\n")
    cat("     year         = ",version$year,",\n",sep="")
    cat("     note         = {ISBN 3-900051-00-3},\n")
    cat("     url          = {http://www.R-project.org}\n")
    cat("   }\n\n")

}
colSums <- function(x, na.rm = FALSE, dims = 1)
{
    if(is.data.frame(x)) x <- as.matrix(x)
    if(!is.array(x) || length(dn <- dim(x)) < 2)
        stop("`x' must be an array of at least two dimensions")
    if(dims < 1 || dims > length(dn) - 1)
        stop("invalid `dims'")
    n <- prod(dn[1:dims])
    dn <- dn[-(1:dims)]
    z <- if(is.complex(x))
        .Internal(colSums(Re(x), n, prod(dn), na.rm)) +
            1i * .Internal(colSums(Im(x), n, prod(dn), na.rm))
    else .Internal(colSums(x, n, prod(dn), na.rm))
    if(length(dn) > 1) {
        dim(z) <- dn
        dimnames(z) <- dimnames(x)[-(1:dims)]
    } else names(z) <- dimnames(x)[[dims+1]]
    z
}

colMeans <- function(x, na.rm = FALSE, dims = 1)
{
    if(is.data.frame(x)) x <- as.matrix(x)
    if(!is.array(x) || length(dn <- dim(x)) < 2)
        stop("`x' must be an array of at least two dimensions")
    if(dims < 1 || dims > length(dn) - 1)
        stop("invalid `dims'")
    n <- prod(dn[1:dims])
    dn <- dn[-(1:dims)]
    z <- if(is.complex(x))
        .Internal(colMeans(Re(x), n, prod(dn), na.rm)) +
            1i * .Internal(colMeans(Im(x), n, prod(dn), na.rm))
    else .Internal(colMeans(x, n, prod(dn), na.rm))
    if(length(dn) > 1) {
        dim(z) <- dn
        dimnames(z) <- dimnames(x)[-(1:dims)]
    } else names(z) <- dimnames(x)[[dims+1]]
    z
}

rowSums <- function(x, na.rm = FALSE, dims = 1)
{
    if(is.data.frame(x)) x <- as.matrix(x)
    if(!is.array(x) || length(dn <- dim(x)) < 2)
        stop("`x' must be an array of at least two dimensions")
    if(dims < 1 || dims > length(dn) - 1)
        stop("invalid `dims'")
    p <- prod(dn[-(1:dims)])
    dn <- dn[1:dims]
    z <- if(is.complex(x))
        .Internal(rowSums(Re(x), prod(dn), p, na.rm)) +
            1i * .Internal(rowSums(Im(x), prod(dn), p, na.rm))
    else .Internal(rowSums(x, prod(dn), p, na.rm))
    if(length(dn) > 1) {
        dim(z) <- dn
        dimnames(z) <- dimnames(x)[1:dims]
    } else  names(z) <- dimnames(x)[[1]]
    z
}

rowMeans <- function(x, na.rm = FALSE, dims = 1)
{
    if(is.data.frame(x)) x <- as.matrix(x)
    if(!is.array(x) || length(dn <- dim(x)) < 2)
        stop("`x' must be an array of at least two dimensions")
    if(dims < 1 || dims > length(dn) - 1)
        stop("invalid `dims'")
    p <- prod(dn[-(1:dims)])
    dn <- dn[1:dims]
    z <- if(is.complex(x))
        .Internal(rowMeans(Re(x), prod(dn), p, na.rm)) +
            1i * .Internal(rowMeans(Im(x), prod(dn), p, na.rm))
    else .Internal(rowMeans(x, prod(dn), p, na.rm))
    if(length(dn) > 1) {
        dim(z) <- dn
        dimnames(z) <- dimnames(x)[1:dims]
    } else  names(z) <- dimnames(x)[[1]]
    z
}
##
## Handling Conditions
##

tryCatch <- function(expr, ..., finally) {
    tryCatchList <- function(expr, names, parentenv, handlers) {
	nh <- length(names)
	if (nh > 1)
	    tryCatchOne(tryCatchList(expr, names[-nh], parentenv,
                                     handlers[-nh]),
			names[nh], parentenv, handlers[[nh]])
	else if (nh == 1)
	    tryCatchOne(expr, names, parentenv, handlers[[1]])
	else expr
    }
    tryCatchOne <- function(expr, name, parentenv, handler) {
	doTryCatch <- function(expr, name, parentenv, handler) {
	    .Internal(.addCondHands(name, list(handler), parentenv,
				    environment(), FALSE))
	    expr
	}
	value <- doTryCatch(return(expr), name, parentenv, handler)
	# The return in the call above will exit withOneRestart unless
	# the handler is invoked; we only get to this point if the handler
	# is invoked.  If we get here then the handler will have been
	# popped off the internal handler stack.
	if (is.null(value[[1]])) {
	    # a simple error; message is stored internally
	    # and call is in result; this defers all allocs until
	    # after the jump
	    msg <- .Internal(geterrmessage())
	    call <- value[[2]]
	    cond <- simpleError(msg, call)
	}
	else cond <- value[[1]]
	value[[3]](cond)
    }
    if (! missing(finally))
        on.exit(finally)
    handlers <- list(...)
    classes <- names(handlers)
    parentenv <- parent.frame()
    if (length(classes) != length(handlers))
        stop("bad handler specification")
    tryCatchList(expr, classes, parentenv, handlers)
}

withCallingHandlers <- function(expr, ...) {
    handlers <- list(...)
    classes <- names(handlers)
    parentenv <- parent.frame()
    if (length(classes) != length(handlers))
        stop("bad handler specification")
    .Internal(.addCondHands(classes, handlers, parentenv, NULL, TRUE))
    expr
}

suppressWarnings <- function(expr) {
    withCallingHandlers(expr,
                        warning=function(w)
                            invokeRestart("muffleWarning"))
}


##
## Conditions and Condition Signaling
##

simpleCondition <- function(message, call = NULL) {
    class <- c("simpleCondition", "condition")
    structure(list(message=as.character(message), call = call), class=class)
}

simpleError <- function(message, call = NULL) {
    class <- c("simpleError", "error", "condition")
    structure(list(message=as.character(message), call = call), class=class)
}

simpleWarning <- function(message, call = NULL) {
    class <- c("simpleWarning", "warning", "condition")
    structure(list(message=as.character(message), call = call), class=class)
}

conditionMessage <- function(c) UseMethod("conditionMessage")
conditionCall <- function(c) UseMethod("conditionCall")

conditionMessage.condition <- function(c) c$message
conditionCall.condition <- function(c) c$call

print.condition <- function(x, ...) {
    msg <- conditionMessage(x)
    call <- conditionCall(x)
    cl <- class(x)[1]
    if (! is.null(call))
        cat("<", cl, " in ", deparse(call), ": ", msg, ">\n", sep="")
    else
        cat("<", cl, ": ", msg, ">\n", sep="")
}

as.character.condition <- function(x, ...) {
    msg <- conditionMessage(x)
    call <- conditionCall(x)
    cl <- class(x)[1]
    if (! is.null(call))
        paste(cl, " in ", deparse(call)[1], ": ", msg, "\n", sep="")
    else
        paste(cl, ": ", msg, "\n", sep="")
}

as.character.error <- function(x, ...) {
    msg <- conditionMessage(x)
    call <- conditionCall(x)
    if (! is.null(call))
        paste("Error in ", deparse(call)[1], ": ", msg, "\n", sep="")
    else
        paste("Error: ", msg, "\n", sep="")
}

signalCondition <- function(cond) {
    if (! inherits(cond, "condition"))
        cond <- simpleCondition(cond)
    msg <- conditionMessage(cond)
    call <- conditionCall(cond)
    .Internal(.signalCondition(cond, msg, call))
}


##
##  Restarts
##

restartDescription <- function(r) r$description
restartFormals <- function(r) formals(r$handler)

print.restart <- function(x, ...)
     cat(paste("<restart:", x[[1]], ">\n"))

isRestart <- function(x) inherits(x, "restart")

findRestart <- function(name, cond = NULL) {
    i <- 1
    repeat {
        r <- .Internal(.getRestart(i))
        if (is.null(r))
            return(NULL)
        else if (name == r[[1]] &&
                 (is.null(cond) || is.null(r$test) || r$test(cond)))
            return(r)
        else i <- i + 1
    }
}

computeRestarts <- function(cond = NULL) {
    val <- NULL
    i <- 1
    repeat {
        r <- .Internal(.getRestart(i))
        if (is.null(r))
            return(val)
        else if (is.null(cond) || is.null(r$test) || r$test(cond))
            val <- c(val, list(r))
        i <- i + 1
    }
}

invokeRestart <- function(r, ...) {
    if (! isRestart(r)) {
        res <- findRestart(r)
        if (is.null(res))
            stop(paste("no restart", sQuote(r), "found"))
        r <- res
    }
    .Internal(.invokeRestart(r, list(...)))
}

invokeRestartInteractively <- function(r) {
    if (! interactive())
        stop("not an interactive session")
    if (! isRestart(r)) {
        res <- findRestart(r)
        if (is.null(res))
            stop(paste("no restart", sQuote(r), "found"))
        r <- res
    }
    if (is.null(r$interactive)) {
        pars <- names(restartFormals(r))
        args <- NULL
        if (length(pars) > 0) {
            cat("Enter values for restart arguments:\n\n")
            for (p in pars) {
            if (p == "...") {
		    prompt <- "... (a list): "
		    args <- c(args, eval(parse(prompt = prompt)))
		}
		else {
		    prompt <- paste(p, ": ", sep="")
		    args <- c(args, list(eval(parse(prompt = prompt))))
		}
	    }
	}
    }
    else args <- r$interactive()
    .Internal(.invokeRestart(r, args))
}

withRestarts <- function(expr, ...) {
    docall <- function(fun, args) {
	enquote <- function(x) as.call(list(as.name("quote"), x))
	if ((is.character(fun) && length(fun) == 1) || is.name(fun))
	    fun <- get(as.character(fun), env = parent.frame(),
                       mode = "function")
	do.call("fun", lapply(args, enquote))
    }
    makeRestart <- function(name = "",
			   handler = function(...) NULL,
			   description = "",
			   test = function(c) TRUE,
			   interactive = NULL) {
	structure(list(name = name, exit = NULL, handler = handler,
		       description = description, test = test,
		       interactive = interactive),
		  class = "restart")
    }
    makeRestartList <- function(...) {
        specs <- list(...)
        names <- names(specs)
        restarts <- vector("list", length(specs))
        for (i in seq(along = specs)) {
            spec <- specs[[i]]
            name <- names[i]
            if (is.function(spec))
                restarts[[i]] <- makeRestart(handler = spec)
            else if (is.character(spec))
                restarts[[i]] <- makeRestart(description = spec)
            else if (is.list(spec))
                restarts[[i]] <- docall("makeRestart", spec)
            else
               stop("not a valid restart specification")
            restarts[[i]]$name <- name
        }
        restarts
    }
    withOneRestart <- function(expr, restart) {
	doWithOneRestart <- function(expr, restart) {
	    restart$exit <- environment()
	    .Internal(.addRestart(restart))
	    expr
	}
	restartArgs <- doWithOneRestart(return(expr), restart)
	# The return in the call above will exit withOneRestart unless
	# the restart is invoked; we only get to this point if the restart
	# is invoked.  If we get here then the restart will have been
	# popped off the internal restart stack.
	docall(restart$handler, restartArgs)
    }
    withRestartList <- function(expr, restarts) {
	nr <- length(restarts)
	if (nr > 1)
	    withOneRestart(withRestartList(expr, restarts[-nr]),
                           restarts[[nr]])
	else if (nr == 1)
	    withOneRestart(expr, restarts[[1]])
	else expr
    }
    restarts <- makeRestartList(...)
    if (length(restarts) == 0)
        expr
    else if (length(restarts) == 1)
        withOneRestart(expr, restarts[[1]])
    else withRestartList(expr, restarts)
}


##
## Callbacks
##

.signalSimpleWarning <- function(msg, call)
    withRestarts({
           .Internal(.signalCondition(simpleWarning(msg, call), msg, call))
           .Internal(.dfltWarn(msg, call))
        }, muffleWarning = function() NULL)

.handleSimpleError <- function(h, msg, call)
    h(simpleError(msg, call))
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
}
stdin <- function() .Internal(stdin())
stdout <- function() .Internal(stdout())
stderr <- function() .Internal(stderr())

readLines <- function(con = stdin(), n = -1, ok = TRUE)
{
    if(is.character(con)) {
        con <- file(con, "r")
        on.exit(close(con))
    }
    .Internal(readLines(con, n, ok))
}


writeLines <- function(text, con = stdout(), sep = "\n")
{
    if(is.character(con)) {
        con <- file(con, "w")
        on.exit(close(con))
    }
    invisible(.Internal(writeLines(text, con, sep)))
}

open <- function(con, ...)
    UseMethod("open")

open.connection <- function(con, open = "r", blocking = TRUE, ...)
{
    invisible(.Internal(open(con, open, blocking)))
}

isOpen <- function(con, rw = "")
{
    rw <- pmatch(rw, c("read", "write"), 0)
    .Internal(isOpen(con, rw))
}

isIncomplete <- function(con)
    .Internal(isIncomplete(con))

isSeekable <- function(con)
    .Internal(isSeekable(con))

close <- function(con, ...)
    UseMethod("close")

close.connection <- function (con, type = "rw", ...)
    invisible(.Internal(close(con, type)))

flush <- function(con) UseMethod("flush")

flush.connection <- function (con)
    invisible(.Internal(flush(con)))

file <- function(description = "", open = "", blocking = TRUE,
                 encoding = getOption("encoding"))
    .Internal(file(description, open, blocking, encoding))

pipe <- function(description, open = "", encoding = getOption("encoding"))
    .Internal(pipe(description, open, encoding))

fifo <- function(description = "", open = "", blocking = FALSE,
                 encoding = getOption("encoding"))
    .Internal(fifo(description, open, blocking, encoding))

url <- function(description, open = "", blocking = TRUE,
                encoding = getOption("encoding"))
    .Internal(url(description, open, blocking, encoding))

gzfile <- function(description, open = "",
                   encoding = getOption("encoding"), compression = 6)
    .Internal(gzfile(description, open, encoding, compression))

unz <- function(description, filename, open = "",
                encoding = getOption("encoding"))
    .Internal(unz(paste(description, filename, sep=":"), open, encoding))

bzfile <- function(description, open = "", encoding = getOption("encoding"))
    .Internal(bzfile(description, open, encoding))

socketConnection <- function(host= "localhost", port, server = FALSE,
                             blocking = FALSE, open = "a+",
                             encoding = getOption("encoding"))
    .Internal(socketConnection(host, port, server, blocking, open, encoding))

textConnection <- function(object, open = "r", local = FALSE) {
    if (local) env <- parent.frame()
    else env <- .GlobalEnv
    .Internal(textConnection(deparse(substitute(object)), object, open, env))
}

seek <- function(con, ...)
    UseMethod("seek")

seek.connection <- function(con, where = NA, origin = "start", rw = "", ...)
{
    origin <- pmatch(origin, c("start", "current", "end"))
    rw <- pmatch(rw, c("read", "write"), 0)
    if(is.na(origin))
        stop("`origin' must be one of `start', `current` or `end'")
    .Internal(seek(con, as.integer(where), origin, rw))
}

truncate <- function(con, ...)
    UseMethod("truncate")

truncate.connection <- function(con, ...)
{
    if(!isOpen(con)) stop("can only truncate an open connection")
    .Internal(truncate(con))
}

pushBack <- function(data, connection, newLine = TRUE)
    invisible(.Internal(pushBack(data, connection, newLine)))

pushBackLength <- function(connection)
    .Internal(pushBackLength(connection))

print.connection <- function(x, ...)
{
    print(unlist(summary(x)))
    invisible(x)
}

summary.connection <- function(object, ...)
    .Internal(summary.connection(object))

showConnections <- function(all = FALSE)
{
    set <- getAllConnections()
    if(!all) set <- set[set > 2]
    ans <- matrix("", length(set), 7)
    for(i in seq(along=set)) ans[i, ] <- unlist(summary.connection(set[i]))
    rownames(ans) <- set
    colnames(ans) <- c("description", "class", "mode", "text", "isopen",
                       "can read", "can write")
    if(!all) ans[ans[, 5] == "opened", , drop = FALSE]
    else ans[, , drop = FALSE]
}

getAllConnections <- function()
    .Internal(getAllConnections())

getConnection <- function(what)
{
    set <- getAllConnections()
    if(what %in% set) structure(what, class="connection")
    else NULL
}

closeAllConnections <- function()
{
    # first re-divert any diversion of stderr.
    i <- sink.number(type = "message")
    if(i > 0) sink(stderr(), type = "message")
    # now unwind the sink diversion stack.
    n <- sink.number()
    if(n > 0) for(i in 1:n) sink()
    # get all the open connections.
    set <- getAllConnections()
    set <- set[set > 2]
    # and close all user connections.
    for(i in seq(along=set)) close(getConnection(set[i]))
    invisible()
}

readBin <- function(con, what, n = 1, size = NA, signed = TRUE,
                    endian = .Platform$endian)
{
    if(is.character(con)) {
        con <- file(con, "rb")
        on.exit(close(con))
    }
    swap <- endian != .Platform$endian
    if(!is.character(what) || length(what) != 1 
    	|| !(what %in% c("numeric", "double", "integer",
    		"int", "logical", "complex", "character"))) what <- typeof(what)
    .Internal(readBin(con, what, n, size, signed, swap))
}

writeBin <- function(object, con, size = NA, endian = .Platform$endian)
{
    swap <- endian != .Platform$endian
    if(!is.vector(object) || mode(object) == "list")
        stop("can only write vector objects")
    if(is.character(con)) {
        con <- file(con, "wb")
        on.exit(close(con))
    }
    invisible(.Internal(writeBin(object, con, size, swap)))
}

## encoding vectors
native.enc <- 0:255
# rest in Rprofile.*

readChar <- function(con, nchars)
{
    if(is.character(con)) {
        con <- file(con, "rb")
        on.exit(close(con))
    }
    .Internal(readChar(con, as.integer(nchars)))
}

writeChar <- function(object, con, nchars = nchar(object), eos = "")
{
    if(!is.character(object))
        stop("can only write character objects")
    if(is.character(con)) {
        con <- file(con, "wb")
        on.exit(close(con))
    }
    invisible(.Internal(writeChar(object, con, as.integer(nchars), eos)))
}

gzcon <- function(con, level = 6, allowNonCompressed = TRUE)
    .Internal(gzcon(con, level, allowNonCompressed))

socketSelect <- function(socklist, write = FALSE, timeout = NULL) {
    if (is.null(timeout))
        timeout <- -1
    else if (timeout < 0)
        stop("supplied timeout must be NULL or a non-negative number")
    if (length(write) < length(socklist))
        write <- rep(write, length.out = length(socklist))
    .Internal(sockSelect(socklist, write, timeout))
}
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")
contributors <- function()
{
    outFile <- tempfile()
    outConn <- file(outFile, open = "w")
    writeLines(paste("R is a project which is attempting to provide a ",
                     "modern piece of\nstatistical software for the ",
                     "GNU suite of software.\n\n",
                     "The current R is the result of a collaborative ",
                     "effort with\ncontributions from all over the ",
                     "world.\n\n",
                     sep = ""), outConn)
    writeLines(readLines(file.path(R.home(), "AUTHORS")), outConn)
    writeLines("", outConn)
    writeLines(readLines(file.path(R.home(), "THANKS")), outConn)
    close(outConn)
    file.show(outFile, delete.file = TRUE)
}
getNumCConverters <-
function() {
 .Internal(getNumRtoCConverters())
}

getCConverterDescriptions <-
function() {
 .Internal(getRtoCConverterDescriptions())
}

getCConverterStatus <-
function() {
 v <- .Internal(getRtoCConverterStatus())
 names(v) <- getCConverterDescriptions()

 v
}


setCConverterStatus <-
function(id, status)
{
  .Internal(setToCConverterActiveStatus(id, as.logical(status)))
}

removeCConverter <-
function(id)
{
  .Internal(removeToCConverterActiveStatus(id))
}

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, digits=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="_")
        if (ok && include.lowest) {
            if (right)
                substr(labels[1], 1,1) <- "["
            else
                substring(labels[nb-1], nchar(labels[nb-1])) <- "]"
        }
    } 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 =	as.integer(length(x)),
	       breaks =	as.double(breaks),
               as.integer(nb),
	       code= 	integer(length(x)),
               right=	as.logical(right),
	       include= as.logical(include.lowest), naok = TRUE,
	       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)
}
data <-
function(..., list = character(0),
         package = .packages(), lib.loc = NULL,
         verbose = getOption("verbose"), envir = .GlobalEnv)
{
    fileExt <- function(x) sub(".*\\.", "", x)

    names <- c(as.character(substitute(list(...))[-1]), list)

    ## Find the directories of the given packages and maybe the working
    ## directory.
    paths <- .find.package(package, lib.loc, verbose = verbose)
    if(is.null(lib.loc))
        paths <- c(.path.package(package, TRUE), getwd(), paths)
    paths <- unique(paths[file.exists(paths)])

    ## Find the directories with a 'data' subdirectory.
    paths <- paths[tools::fileTest("-d", file.path(paths, "data"))]
    ## Earlier versions remembered given packages with no 'data'
    ## subdirectory, and warned about them.

    dataExts <- tools:::.makeFileExts("data")

    if(length(names) == 0) {
        ## List all possible data sets.

        ## Build the data db.
        db <- matrix(character(0), nr = 0, nc = 4)
        noindex <- character(0)
        for(path in paths) {
            entries <- NULL
            ## Use "." as the 'package name' of the working directory.
            packageName <-
                if(tools::fileTest("-f",
                                   file.path(path, "DESCRIPTION")))
                    basename(path)
                else
                    "."
            ## Check for new-style 'Meta/data.rds', then for '00Index'.
            ## Earlier versions also used to check for 'index.doc'.
            if(tools::fileTest("-f",
                               INDEX <-
                               file.path(path, "Meta", "data.rds"))) {
                entries <- .readRDS(INDEX)
            }
            else if(tools::fileTest("-f",
                                    INDEX <-
                                    file.path(path, "data", "00Index")))
                entries <- read.00Index(INDEX)
            else {
                ## No index: check whether subdir 'data' contains data
                ## sets.  Easy if data files were not collected into a
                ## zip archive ... in any case, as data sets found are
                ## available for loading, we also list their names.
                dataDir <- file.path(path, "data")
                entries <- tools::listFilesWithType(dataDir, "data")
                if((length(entries) == 0)
                   && all(tools::fileTest("-f",
                                          file.path(dataDir,
                                                    c("Rdata.zip",
                                                      "filelist"))))) {
                    entries <- readLines(file.path(dataDir, "filelist"))
                    entries <- entries[fileExt(entries) %in% dataExts]
                }
                if(length(entries) > 0) {
                    entries <-
                        unique(tools::filePathSansExt(basename(entries)))
                    entries <- cbind(entries, "")
                }
                else
                    noindex <- c(noindex, packageName)
            }
            if(NROW(entries) > 0) {
                db <- rbind(db,
                            cbind(packageName, dirname(path),
                                  entries))
            }
        }
        colnames(db) <- c("Package", "LibPath", "Item", "Title")

        if(length(noindex) > 0) {
            if(!missing(package) && (length(package) > 0)) {
                ## Warn about given packages which do not have a data
                ## index.
                packagesWithNoIndex <- package[package %in% noindex]
                if(length(packagesWithNoIndex) > 0)
                    warning(paste("packages with data sets",
                                  "but no index:",
                                  paste(sQuote(packagesWithNoIndex),
                                        collapse = ",")))
            }
        }

        footer <- if(missing(package))
            paste("Use ",
                  sQuote(paste("data(package =",
                               ".packages(all.available = TRUE))")),
                  "\n",
                  "to list the data sets in all *available* packages.",
                  sep = "")
        else
            NULL
        y <- list(title = "Data sets", header = NULL, results = db,
                  footer = footer)
        class(y) <- "packageIQR"
        return(y)
    }

    paths <- file.path(paths, "data")
    for(name in names) {
	if (name == "CO2") name <- "zCO2"
        files <- NULL
        for(p in paths) {
            if(tools::fileTest("-f", file.path(p, "Rdata.zip"))) {
                if(tools::fileTest("-f",
                                   fp <- file.path(p, "filelist")))
                    files <-
                        c(files,
                          file.path(p, scan(fp, what="", quiet = TRUE)))
                else warning(paste(sQuote("filelist"),
                                    "is missing for dir",
                                   sQuote(p)))
            } else {
                files <- c(files, list.files(p, full = TRUE))
            }
        }
        files <- files[grep(name, files, fixed = TRUE)]
        found <- FALSE
        if(length(files) > 1) {
            ## more than one candidate
            o <- match(fileExt(files), dataExts, nomatch = 100)
            paths0 <- dirname(files)
            paths0 <- factor(paths0, levels=paths0)
            files <- files[order(paths0, o)]
        }
        if(length(files) > 0) {
            for(file in files) {
                if(verbose)
                    cat("name=", name, ":\t file= ...",
                        .Platform$file.sep, basename(file), "::\t",
                        sep = "")
                if(found)
                    break
                found <- TRUE
                ext <- fileExt(file)
                ## make sure the match is really for 'name.ext'
                ## otherwise
                if(basename(file) != paste(name, ".", ext, sep = ""))
                    found <- FALSE
                else {
                    zfile <- zip.file.extract(file, "Rdata.zip")
                    switch(ext,
                           R = , r =
                           sys.source(zfile, chdir = TRUE,
                                      envir = envir),
                           RData = , rdata = , rda =
                           load(zfile, envir = envir),
                           TXT = , txt = , tab =
                           assign(name,
                                  read.table(zfile, header = TRUE),
                                  envir = envir),
                           CSV = , csv =
                           assign(name,
                                  read.table(zfile, header = TRUE,
                                             sep = ";"),
                                  envir = envir),
                           found <- FALSE)
                    if(zfile != file) unlink(zfile)
                }
                if(verbose)
                    cat(if(!found) "*NOT* ", "found\n")
            }
        }
        if(!found)
            warning(paste("Data set", sQuote(name), "not found"))
    }
    invisible(names)
}
data.matrix <- function(frame)
{
    if(!is.data.frame(frame))
	return(as.matrix(frame))
    d <- dim(frame)
    if(all(d > 0)) {
	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")
    }
    x <- matrix(nr=d[1], nc=d[2], dimnames=dimnames(frame))
    for(i in seq(len=d[2])) {
	xi <- frame[[i]]
	x[,i] <-
	    if(is.logical(xi) || is.factor(xi)) as.numeric(xi) else xi
    }
    x
}
row.names <- function(x) UseMethod("row.names")
row.names.data.frame <- function(x) attr(x, "row.names")
row.names.default <- function(x) if(!is.null(dim(x))) rownames(x)# else NULL

"row.names<-" <- function(x, value) UseMethod("row.names<-")
"row.names<-.data.frame" <- 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")
    if (any(is.na(value)))
	stop("missing row.names are not allowed")
    attr(x, "row.names") <- value
    x
}

"row.names<-.default" <- function(x, value) "rownames<-"(x, value)

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

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

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

print.AsIs <- function (x, ...)
{
    cl <- oldClass(x)
    oldClass(x) <- cl[cl != "AsIs"]
    NextMethod("print")
    invisible(x)
}


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

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

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

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

as.data.frame <- function(x, row.names = NULL, optional = FALSE) {
    if(is.null(x))			# can't assign class to NULL
	return(as.data.frame(list()))
    UseMethod("as.data.frame")
}
as.data.frame.default <- function(x, row.names = NULL, optional = FALSE)
    stop(paste("can't coerce", 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 <- oldClass(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
}

## prior to 1.8.0 this coerced names - PR#3280
as.data.frame.list <- function(x, row.names = NULL, optional = FALSE)
{
    ## need to protect names in x.
    cn <- names(x)
    m <- match(c("row.names", "check.rows", "check.names"), cn, 0)
    if(any(m > 0)) {
        cn[m] <- paste("..adfl.", cn[m], sep="")
        names(x) <- cn
    }
    x <- eval(as.call(c(expression(data.frame), x, check.names = !optional)))
    if(any(m > 0)) names(x) <- sub("^\\.\\.adfl\\.", "", names(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  <- as.data.frame.vector
as.data.frame.ordered <- as.data.frame.vector
as.data.frame.integer <- as.data.frame.vector
as.data.frame.numeric <- as.data.frame.vector
as.data.frame.complex <- 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 <- as.data.frame.vector

as.data.frame.matrix <- function(x, row.names = NULL, optional = FALSE)
{
    d <- dim(x)
    nrows <- d[1]; ir <- seq(length = nrows)
    ncols <- d[2]; ic <- seq(length = ncols)
    dn <- dimnames(x)
    ## surely it cannot be right to override the supplied row.names?
    ## changed in 1.8.0
    if(missing(row.names)) row.names <- dn[[1]]
    collabs <- dn[[2]]
    if(any(empty <- nchar(collabs)==0))
	collabs[empty] <- paste("V", ic, sep = "")[empty]
    value <- vector("list", ncols)
    if(mode(x) == "character") {
	for(i in ic)
	    value[[i]] <- as.factor(x[,i])
    } else {
	for(i in ic)
	    value[[i]] <- as.vector(x[,i])
    }
    if(length(row.names) != nrows)
	row.names <- if(optional) character(nrows) else as.character(ir)
    if(length(collabs) == ncols)
	names(value) <- collabs
    else if(!optional)
	names(value) <- paste("V", ic, 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.array <- function(x, row.names = NULL, optional = FALSE)
{
    d <- dim(x)
    if(length(d) == 1) { ## same as as.data.frame.vector, but deparsed here
        value <- as.data.frame.vector(drop(x), row.names, optional)
        if(!optional) names(value) <- deparse(substitute(x))[[1]]
        value
    } else if (length(d) == 2) {
        as.data.frame.matrix(x, row.names, optional)
    } else {
        dn <- dimnames(x)
        dim(x) <- c(d[1], prod(d[-1]))
        if(!is.null(dn)) {
            if(length(dn[[1]])) rownames(x) <- dn[[1]]
            for(i in 2:length(d))
                if(is.null(dn[[i]])) dn[[i]] <- seq(len=d[i])
            colnames(x) <- interaction(expand.grid(dn[-1]))
        }
        as.data.frame.matrix(x, row.names, optional)
    }
}

## will always have a class here
"[.AsIs" <- function(x, i, ...) structure(NextMethod("["), class = class(x))

as.data.frame.AsIs <- function(x, row.names = NULL, optional = FALSE)
{
    ## why not remove class and NextMethod here?
    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(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]
    mrn <- missing(row.names)
    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
    vlist <- vnames <- as.list(vnames)
    nrows <- ncols <- integer(n)
    for(i in 1:n) {
	xi <- as.data.frame(x[[i]], optional=TRUE)
	rowsi <- attr(xi, "row.names")
	ncols[i] <- length(xi)
	namesi <- names(xi)
	if(ncols[i] > 1) {
	    if(length(namesi) == 0) namesi <- 1:ncols[i]
	    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]]) {
                tmpname <- deparse(object[[i]])[1]
                if( substr(tmpname,1,2) == "I(" ) {
                    ntmpn <- nchar(tmpname)
                    if(substr(tmpname, ntmpn, ntmpn) == ")")
                        tmpname <- substr(tmpname,3,ntmpn-1)
                }
                vnames[[i]] <- tmpname
            }
        } # end of ncols[i] <= 1
	nrows[i] <- length(rowsi)
	if(missing(row.names) && (nrows[i] > 0) && !(rowsi[[1]] %in% ""))
	    row.names <- data.row.names(row.names, rowsi, i)
	vlist[[i]] <- xi
    }
    nr <- max(nrows)
    for(i in (1:n)[nrows < nr]) {
	xi <- vlist[[i]]
	if(length(xi)==1 && nrows[i] > 0 && nr%%nrows[i]==0) {
            xi1 <- xi[[1]]
            if(is.vector(xi1) || is.factor(xi1)) {
                vlist[[i]] <- list(rep(xi1, length.out = nr))
                next
            }
            if(is.character(xi1) && class(xi1) == "AsIs") {
                ## simple char vectors only
                cl <- class(xi1) # `methods' adds a class -- Eh?
                vlist[[i]] <- list(structure(rep(xi1, length.out = nr), class=cl))
                next
            }
        }
	stop(paste("arguments imply differing number of rows:",
                   paste(unique(nrows), collapse = ", ")))
    }
    value <- unlist(vlist, recursive=FALSE, use.names=FALSE)
    ## unlist() drops i-th component if it has 0 columns
    vnames <- unlist(vnames[ncols > 0])
    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(!mrn) { # row.names arg was supplied
        if(length(row.names) == 1 && nr != 1) {  # one of the variables
            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]
        } else if (length(row.names) > 0 && length(row.names) != nr)
            stop("row names supplied are of the wrong length")
    } else if(length(row.names) > 0 && length(row.names) != nr) {
        warning("row names were found from a short variable and have been discarded")
        row.names <- NULL
    }
    if(length(row.names) == 0) row.names <- seq(length = nr)
    row.names <- as.character(row.names)
    if(any(is.na(row.names)))
        stop("row names contain missing values")
    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)
{
    mdrop <- missing(drop)
    Narg <- nargs() - !mdrop  # number of arg from x,i,j that were specified

    if(Narg < 3) {  # list-like indexing or matrix indexing
        if(!mdrop) warning("drop argument will be ignored")
	if(missing(i))
	    return(x)
	if(is.matrix(i))
	    return(as.matrix(x)[i])  # desperate measures
	y <- NextMethod("[")
        nm <- names(y)
	if(any(is.na(nm))) stop("undefined columns selected")
        ## added in 1.8.0
        if(any(duplicated(nm))) names(y) <- make.unique(nm)
	return(structure(y, class = oldClass(x), row.names = row.names(x)))
    }

    ## preserve the attributes for later use ...

    rows <- attr(x, "row.names")
    cols <- names(x)
    cl <- oldClass(x) # doesn't really matter unless called directly
    class(x) <- attr(x, "row.names") <- NULL


    if(missing(i)) { # df[, j] or df[ , ]
        ## handle the column only subsetting ...
        if(!missing(j)) x <- x[j]
	cols <- names(x)
	if(any(is.na(cols))) stop("undefined columns selected")
    }
    else { # df[i, j] or df[i , ]
	if(is.character(i))
	    i <- pmatch(i, rows, duplicates.ok = TRUE)
	rows <- rows[i]
	if(!missing(j)) { # df[i, j]
	    x <- x[j]
	    cols <- names(x)
	    if(any(is.na(cols))) stop("undefined columns selected")
	}
	for(j in seq(along = x)) {
	    xj <- x[[j]]
            ## had drop = drop prior to 1.8.0
	    x[[j]] <- if(length(dim(xj)) != 2) xj[i] else xj[i, , drop = FALSE]
	}
    }
    if(drop) {
	drop <- FALSE
	n <- length(x)
	if(n == 1) {
	    x <- x[[1]]
	    drop <- TRUE
	}
	else if(n > 1) {
	    xj <- x[[1]]
	    nrow <- if(length(dim(xj)) == 2) dim(xj)[1] else length(xj)
            ## for consistency with S: don't drop (to a list)
            ## if only one row unless explicitly asked for
	    if(!mdrop && nrow == 1) {
		drop <- TRUE
		names(x) <- cols
		attr(x, "row.names") <- NULL
	    }
	}
    }
    if(!drop) { # not else as previous section might reset drop
	names(x) <- cols
        ## row names might have NAs.
	if(any(is.na(rows) | duplicated(rows))) {
            rows[is.na(rows)] <- "NA"
	    rows <- make.unique(rows)
        }
        ## new in 1.8.0  -- might have duplicate columns
        if(any(duplicated(nm <- names(x)))) names(x) <- make.unique(nm)
	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 .subset2(x,i))(x, ...)
    else
        .subset2(.subset2(x, ..2), ..1)
}

"[<-.data.frame" <- function(x, i, j, value)
{
    nA <- nargs() # value is never missing, so 3 or 4.
    if(nA == 4) { ## df[,] or df[i,] or df[, j] or df[i,j]
	has.i <- !missing(i)
	has.j <- !missing(j)
    }
    else if(nA == 3) {
        ## this collects both df[] and df[ind]
        if(missing(i) && missing(j)) { # case df[]
            i <- j <- NULL
            has.i <- has.j <- FALSE
            ## added in 1.8.0
            if(is.null(value)) return(x[logical(0)])
        } else { # case df[ind]
            ## really ambiguous, but follow common use as if list
            ## except for a full-sized logical matrix
            if(is.logical(i) && is.matrix(i) && all(dim(i) == dim(x))) {
                nreplace <- sum(i, na.rm=TRUE)
                ## allow replication of length(value) > 1 in 1.8.0
                N <- length(value)
                if(N > 0 && N < nreplace && (nreplace %% N) == 0)
                    value <- rep(value, length.out = nreplace)
                if(length(value) != nreplace)
                    stop("rhs is the wrong length for indexing by a logical matrix")
                n <- 0
                nv <- nrow(x)
                for(v in seq(len = dim(i)[2])) {
                    thisvar <- i[, v, drop = TRUE]
                    nv <- sum(thisvar, na.rm = TRUE)
                    if(nv) {
                        if(is.matrix(x[[v]]))
                            x[[v]][thisvar, ] <- value[n+(1:nv)]
                        else
                            x[[v]][thisvar] <- value[n+(1:nv)]
                    }
                    n <- n+nv
                }
                return(x)
            }  # end of logical matrix
            if(is.matrix(i))
                stop("only logical matrix subscripts are allowed in replacement")
            j <- i
            i <- NULL
            has.i <- FALSE
            has.j <- TRUE
        }
    }
    else {
	stop("Need 0, 1, or 2 subscripts")
    }
    ## no columns specified
    if(has.j && length(j) ==0) return(x)

    cl <- oldClass(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) { # df[i, ] or df[i, j]
	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") &&
		   (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 <- 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 <- paste("V", seq(from = nvars + 1, to = max(jseq)),
                                  sep = "")
		if(length(new.cols)  != sum(jseq > nvars))
		    stop(paste("new columns would leave holes",
			       "after existing columns"))
                ## try to use the names of a list `value'
                if(is.list(value) && !is.null(vnm <- names(value))) {
                    p <- length(jseq)
                    if(length(vnm) < p) vnm <- rep(vnm, length.out = p)
                    new.cols <- vnm[jseq > nvars]
                }
	    }
	}
    }
    else jseq <- seq(along = x)
    ## addition in 1.8.0
    if(any(duplicated(jseq)))
        stop("duplicate subscripts for columns")
    n <- length(iseq)
    if(n == 0) n <- nrows
    p <- length(jseq)
    m <- length(value)
    if(!is.list(value)) {
        if(p == 1) {
            N <- NROW(value)
            if(N > n)
                stop(paste("replacement has", N, "rows, data has", n))
            if(N < n && N > 0)
                if(n %% N == 0 && length(dim(value)) <= 1)
                    value <- rep(value, length.out = n)
                else
                    stop(paste("replacement has", N, "rows, data has", n))
            value <- list(value)
         } else {
            if(m < n*p && (n*p) %% m)
                stop(paste("replacement has", m, "items, need", n*p))
            value <- matrix(value, n, p)  ## will recycle
            value <- split(value, col(value))
        }
	dimv <- c(n, p)
    } else { # a list
        ## careful, as.data.frame turns things into factors.
	## value <- as.data.frame(value)
        value <- unclass(value) # to avoid data frame indexing
        lens <- sapply(value, NROW)
        for(k in seq(along=lens)) {
            N <- lens[k]
            if(n != N && length(dim(value[[k]])) == 2)
                stop(paste("replacement element", k,
                           "is a matrix/data frame of", N,
                           "rows, need", n))
            if(N > 0 && N < n && n %% N)
                stop(paste("replacement element", k, "has", N,
                           "rows, need", n))
            ## these fixing-ups will not work for matrices
            if(N > 0 && N < n) value[[k]] <- rep(value[[k]], length.out = n)
            if(N > n) {
                warning(paste("replacement element", k, "has", N,
                              "rows to replace", n, "rows"))
                value[[k]] <- value[[k]][1:n]
            }
        }
	dimv <- c(n, length(value))
    }
    nrowv <- dimv[1]
    if(nrowv < n && nrowv > 0) {
	if(n %% nrowv == 0)
	    value <- value[rep(1:nrowv, length.out = 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"))
    ncolv <- dimv[2]
    jvseq <- seq(len=p)
    if(ncolv < p) jvseq <- rep(1:ncolv, length.out = p)
    else if(ncolv > p)
	warning(paste("provided", ncolv, "variables to replace", p,
		      "variables"))
    if(length(new.cols)) {
        ## extend and name now, as assignment of NULL may delete cols later.
        nm <- names(x)
        rows <- attr(x, "row.names")
        x <- c(x, vector("list", length(new.cols)))
        names(x) <- c(nm, new.cols)
        attr(x, "row.names") <- rows
    }
    if(has.i)
	for(jjj in seq(len=p)) {
	    jj <- jseq[jjj]
	    vjj <- value[[ jvseq[[jjj]] ]]
	    xj <- x[[jj]]
	    if(length(dim(xj)) != 2) xj[iseq] <- vjj else xj[iseq, ] <- vjj
            ## if a column exists, preserve its attributes
            if(jj <= nvars) x[[jj]][] <- xj else x[[jj]] <- xj
	}
    else if(p > 0) for(jjj in p:1) { # we might delete columns with NULL
	jj <- jseq[jjj]
	x[[jj]] <- value[[ jvseq[[jjj]] ]]
    }
    if(length(new.cols) > 0) {
        new.cols <- names(x) # we might delete columns with NULL
        ## added in 1.8.0
        if(any(duplicated(new.cols))) names(x) <- make.unique(new.cols)
    }
    class(x) <- cl
    x
}

"[[<-.data.frame"<- function(x, i, j, value)
{
    cl <- oldClass(x)
    ## delete class: Version 3 idiom
    ## to avoid any special methods for [[<-
    class(x) <- NULL
    rows <- attr(x, "row.names")
    nrows <- length(rows)
    if(nargs() < 4) {
	## really ambiguous, but follow common use as if list
        nc <- length(x)
	if(!is.null(value)) {
            N <- NROW(value)
            if(N > nrows)
                stop(paste("replacement has", N, "rows, data has", nrows))
            if(N < nrows && N > 0)
                if(nrows %% N == 0 && length(dim(value)) <= 1)
                    value <- rep(value, length.out = nrows)
                else
                    stop(paste("replacement has", N, "rows, data has", nrows))
	}
	x[[i]] <- value
        ## added in 1.8.0 -- make sure there is a name
        if(length(x) > nc) {
            nc <- length(x)
            if(names(x)[nc] == "") names(x)[nc] <- paste("V", nc, sep="")
            names(x) <- make.unique(names(x))
        }
	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(n > 0) {
	    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") &&
	       (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
}

## added in 1.8.0
"$<-.data.frame"<- function(x, i, value)
{
    cl <- oldClass(x)
    ## delete class: Version 3 idiom
    ## to avoid any special methods for [[<-
    class(x) <- NULL
    nrows <- length(attr(x, "row.names"))
    if(!is.null(value)) {
        N <- NROW(value)
        if(N > nrows)
            stop(paste("replacement has", N, "rows, data has", nrows))
        if(N < nrows && N > 0)
            if(nrows %% N == 0 && length(dim(value)) <= 1)
                value <- rep(value, length.out = nrows)
            else
                stop(paste("replacement has", N, "rows, data has", nrows))
    }
    x[[i]] <- value
    class(x) <- cl
    return(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 <- oldClass(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 && identical(ri, 1:ni))
	    seq(from = nrow + 1, length = ni)
	else ri
    }
    allargs <- list(...)
    allargs <- allargs[sapply(allargs, length) > 0]
    n <- length(allargs)
    if(n == 0)
	return(structure(list(),
			 class = "data.frame",
			 row.names = character()))
    nms <- names(allargs)
    if(is.null(nms))
	nms <- character(length(allargs))
    cl <- NULL
    perm <- rows <- rlabs <- vector("list", n)
    nrow <- 0
    value <- clabs <- NULL
    all.levs <- list()
    for(i in 1:n) {
	## check the arguments, develop row and column labels
	xi <- allargs[[i]]
	nmi <- nms[i]
        ## coerce matrix to data frame
        if(is.matrix(xi)) allargs[[i]] <- xi <- as.data.frame(xi)
	if(inherits(xi, "data.frame")) {
	    if(is.null(cl))
		cl <- oldClass(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]] <- 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)
                facCol <- logical(nvar)
                ordCol <- logical(nvar)
		for(j in 1:nvar) {
		    xj <- value[[j]]
		    if( !is.null(levels(xj)) ) {
			all.levs[[j]] <- levels(xj)
                        facCol[j] <- TRUE # turn categories into factors
                    } else facCol[j] <- is.factor(xj)
                    ordCol[j] <- is.ordered(xj)
		    has.dim[j] <- length(dim(xj)) == 2
		}
	    }
	    else for(j in 1:nvar)
                if(facCol[j]) {
                    xij <- xi[[j]]
                    if(is.null(pi) || is.na(jj <- pi[[j]])) jj <- j
                    if(length(lij <- levels(xij)) > 0) {
                        all.levs[[jj]] <- unique(c(all.levs[[jj]], lij))
                        ordCol[j] <- ordCol[j] & is.ordered(xij)
                    } else if(is.character(xij))
                        all.levs[[jj]] <- unique(c(all.levs[[jj]], xij))
                }
	}
	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, ordered = ordCol[j])
    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)
		rn <- dn[[1]]
		if(length(rn) > 0) length(rn) <- rmax
		pi <- dim(xi)[2]
		length(xi) <- rmax * pi
		value[[i]] <- array(xi, c(rmax, pi), list(rn, dn[[2]]))
	    }
    }
    for(i in 1:n) {
	xi <- unclass(allargs[[i]])
	if(!is.list(xi))
	    if(length(xi) != nvar)
		xi <- rep(xi, length.out = nvar)
	ri <- rows[[i]]
	pi <- perm[[i]]
	if(is.null(pi))
	    pi <- pseq
	for(j in 1:nvar) {
	    jj <- pi[j]
            xij <- xi[[j]]
	    if(has.dim[jj])
		value[[jj]][ri,	 ] <- xij
            ## coerce factors to vectors, in case lhs is character or
            ## level set has changed
	    else value[[jj]][ri] <- if(is.factor(xij)) as.vector(xij) else xij
	}
    }
#     for(j in 1:nvar) {
# 	xj <- value[[j]]
# 	if(!has.dim[j] && !inherits(xj, "AsIs") && is.character(xj))
# 	    value[[j]] <- factor(xj)
#     }
    rlabs <- make.unique(as.character(unlist(rlabs)), sep = "")
    if(is.null(cl)) {
	as.data.frame(value, row.names = rlabs)
    } else {
	class(value) <- cl
	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 {
	## avoiding picking up e.g. format.AsIs
	print(as.matrix(format.data.frame(x, digits=digits)), ...,
              quote = quote, right = right)
    }
    invisible(x)
}

as.matrix.data.frame <- function (x)
{
    dm <- dim(x)
    dn <- dimnames(x)
    if(any(dm == 0))
	return(array(NA, dim = dm, dimnames = dn))
    p <- dm[2]
    n <- dm[1]
    collabs <- as.list(dn[[2]])
    X <- x
    class(X) <- NULL
    non.numeric <- non.atomic <- FALSE
    all.logical <- TRUE
    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(!is.logical(xj)) all.logical <- FALSE
	if(length(levels(xj)) > 0 || !(is.numeric(xj) || is.complex(xj))
	   || (!is.null(cl <- attr(xj, "class")) && # numeric classed objects to format:
	       any(cl == c("Date", "POSIXct", "POSIXlt"))))
	    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(all.logical) {
        ## do nothing for logical columns if a logical matrix will result.
    } else if(non.numeric) {
	for (j in 1:p) {
	    if (is.character(X[[j]]))
		next
	    xj <- X[[j]]
            miss<-is.na(xj)
	    xj <- if(length(levels(xj))) as.vector(xj) else format(xj)
            is.na(xj)<-miss
            X[[j]]<-xj
	}
    }
    X <- unlist(X, recursive = FALSE, use.names = FALSE)
    dim(X) <- c(n, length(X)/n)
    dimnames(X) <- list(dn[[1]], unlist(collabs, use.names = FALSE))
    ##NO! don't copy buggy S-plus!  either all matrices have class or none!!
    ##NO class(X) <- "matrix"
    X
}

Math.data.frame <- function (x, ...)
{
    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 <- parent.frame()
    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) <- oldClass(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 = parent.frame(),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(rscalar) 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.out = prod(dim(e1))),
			    rep.int(1:ncol(e1), rep.int(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.out = prod(dim(e2))),
			    rep.int(1:ncol(e2), rep.int(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) && !is.complex(x))
	stop("only defined on a data frame with all numeric or complex variables")
    NextMethod(.Generic)
}
## First shot at adding a "Date" class to base R.
## Representation is the number of whole days since 1970-01-01.

## The difftime class already covers time differences in days.

## Need to take timezone into account here
Sys.Date <- function() .Internal(POSIXlt2Date(as.POSIXlt(Sys.time())))

as.Date <- function(x, ...) UseMethod("as.Date")

as.Date.POSIXct <- function(x, ...) {
    z <- trunc(unclass(x)/86400)
    attr(z, "tzone") <- NULL
    structure(z, class="Date")
}

as.Date.POSIXlt <- function(x, ...) .Internal(POSIXlt2Date(x))

as.Date.factor <- function(x, ...) as.Date(as.character(x))


as.Date.character <- function(x, format="", ...)
{
    fromchar <- function(x) {
	xx <- x[1]
        if(is.na(xx)) {
            j <- 1
            while(is.na(xx) && (j <- j+1) <= length(x)) xx <- x[j]
            if(is.na(xx)) f <- "%Y-%m-%d" # all NAs
        }
	if(is.na(xx) ||
	   !is.na(strptime(xx, f <- "%Y-%m-%d")) ||
	   !is.na(strptime(xx, f <- "%Y/%m/%d"))
           ) return(strptime(x, f))
	stop("character string is not in a standard unambiguous format")
    }
    res <- if(missing(format)) fromchar(x) else strptime(x, format)
    .Internal(POSIXlt2Date(res))
}

as.Date.default <- function(x, ...)
{
    if(inherits(x, "Date")) return(x)
    if(is.logical(x) && all(is.na(x)))
        return(structure(as.numeric(x), class = "Date"))
    stop(paste("Don't know how to convert `", deparse(substitute(x)),
	       "' to class \"Date\"", sep=""))
}

## convert from package date
as.Date.date <- function(x, ...)
{
    if(inherits(x, "date")) {
        x <- (x - 3653) # origin 1960-01-01
        return(structure(x, class = "Date"))
    } else stop(paste("`", deparse(substitute(x)),
                      "' is not a \"dates\" object", sep=""))
}

## convert from package chron
as.Date.dates <- function(x, ...)
{
    if(inherits(x, "dates")) {
        z <- attr(x, "origin")
        x <- trunc(as.numeric(x))
        if(length(z) == 3 && is.numeric(z))
            x  <- x + as.numeric(as.Date(paste(z[3], z[1], z[2], sep="/")))
        return(structure(x, class = "Date"))
    } else stop(paste("`", deparse(substitute(x)),
                      "' is not a \"dates\" object", sep=""))
}

format.Date <- function(x, ...)
{
    xx <- format(as.POSIXlt(x), ...)
    names(xx) <- names(x)
    xx
}

print.Date <- function(x, ...)
{
    print(format(x), ...)
    invisible(x)
}

summary.Date <- function(object, ...)
{
    x <- summary.default(unclass(object), ...)[1:6]# not NA's
    class(x) <- oldClass(object)
    x
}

"+.Date" <- function(e1, e2)
{
    coerceTimeUnit <- function(x)
    {
        round(switch(attr(x,"units"),
               secs = x/86400, mins = x/1440, hours = x/24,
               days = x, weeks = 7*x))
    }

    if (nargs() == 1) return(e1)
    # only valid if one of e1 and e2 is a scalar.
    if(inherits(e1, "Date") && inherits(e2, "Date"))
        stop("binary + is not defined for Date objects")
    if (inherits(e1, "difftime")) e1 <- coerceTimeUnit(e1)
    if (inherits(e2, "difftime")) e2 <- coerceTimeUnit(e2)
    structure(unclass(e1) + unclass(e2), class = "Date")
}

"-.Date" <- function(e1, e2)
{
    coerceTimeUnit <- function(x)
    {
        round(switch(attr(x,"units"),
               secs = x/86400, mins = x/1440, hours = x/24,
               days = x, weeks = 7*x))
    }
    if(!inherits(e1, "Date"))
        stop("Can only subtract from Date objects")
    if (nargs() == 1) stop("unary - is not defined for Date objects")
    if(inherits(e2, "Date")) return(difftime(e1, e2, units="days"))
    if (inherits(e2, "difftime")) e2 <- unclass(coerceTimeUnit(e2))
    if(!is.null(attr(e2, "class")))
        stop("can only subtract numbers from Date objects")
    structure(unclass(as.Date(e1)) - e2, class = "Date")
}

Ops.Date <- function(e1, e2)
{
    if (nargs() == 1)
        stop(paste("unary", .Generic, "not defined for Date objects"))
    boolean <- switch(.Generic, "<" = , ">" = , "==" = ,
                      "!=" = , "<=" = , ">=" = TRUE, FALSE)
    if (!boolean) stop(paste(.Generic, "not defined for Date objects"))
    NextMethod(.Generic)
}

Math.Date <- function (x, ...)
    stop(paste(.Generic, "not defined for Date objects"))

Summary.Date <- function (x, ...)
{
    ok <- switch(.Generic, max = , min = , range = TRUE, FALSE)
    if (!ok) stop(paste(.Generic, "not defined for Date objects"))
    val <- NextMethod(.Generic)
    class(val) <- oldClass(x)
    val
}

"[.Date" <- function(x, ..., drop = TRUE)
{
    cl <- oldClass(x)
    class(x) <- NULL
    val <- NextMethod("[")
    class(val) <- cl
    val
}

"[[.Date" <- function(x, ..., drop = TRUE)
{
    cl <- oldClass(x)
    class(x) <- NULL
    val <- NextMethod("[[")
    class(val) <- cl
    val
}

"[<-.Date" <- function(x, ..., value)
{
    if(!as.logical(length(value))) return(x)
    value <- as.Date(value)
    cl <- oldClass(x)
    class(x) <- class(value) <- NULL
    x <- NextMethod(.Generic)
    class(x) <- cl
    x
}

as.character.Date <- function(x, ...) format(x, ...)

as.data.frame.Date <- as.data.frame.vector

c.Date <- function(..., recursive=FALSE)
    structure(c(unlist(lapply(list(...), unclass))), class="Date")

mean.Date <- function (x, ...)
    structure(mean(unclass(x), ...), class = "Date")

seq.Date <- function(from, to, by, length.out=NULL, along.with=NULL, ...)
{
    if (missing(from)) stop("`from` must be specified")
    if (!inherits(from, "Date")) stop("`from' must be a Date object")
        if(length(as.Date(from)) != 1) stop("`from' must be of length 1")
    if (!missing(to)) {
        if (!inherits(to, "Date")) stop("`to' must be a Date object")
        if (length(as.Date(to)) != 1) stop("`to' must be of length 1")
        if (to <= from) stop("`to' must be later than `from'")
    }
    if (!missing(along.with)) {
        length.out <- length(along.with)
    }  else if (!missing(length.out)) {
        if (length(length.out) != 1) stop("`length.out' must be of length 1")
        length.out <- ceiling(length.out)
    }
    status <- c(!missing(to), !missing(by), !is.null(length.out))
    if(sum(status) != 2)
        stop("exactly two of `to', `by' and `length.out' / `along.with' must be specified")
    if (missing(by)) {
        from <- unclass(as.Date(from))
        to <- unclass(as.Date(to))
        res <- seq.default(from, to, length.out = length.out)
        return(structure(res, class = "Date"))
    }

    if (length(by) != 1) stop("`by' must be of length 1")
    valid <- 0
    if (inherits(by, "difftime")) {
        by <- switch(attr(by,"units"), secs = 1/86400, mins = 1/1440,
                     hours = 1/24, days = 1, weeks = 7) * unclass(by)
    } else if(is.character(by)) {
        by2 <- strsplit(by, " ", fixed=TRUE)[[1]]
        if(length(by2) > 2 || length(by2) < 1)
            stop("invalid `by' string")
        valid <- pmatch(by2[length(by2)],
                        c("days", "weeks", "months", "years"))
        if(is.na(valid)) stop("invalid string for `by'")
        if(valid <= 2) {
            by <- c(1, 7)[valid]
            if (length(by2) == 2) by <- by * as.integer(by2[1])
        } else
            by <- if(length(by2) == 2) as.integer(by2[1]) else 1
    } else if(!is.numeric(by)) stop("invalid mode for `by'")
    if(is.na(by)) stop("`by' is NA")

    if(valid <= 2) {
        from <- unclass(as.Date(from))
        if(!is.null(length.out))
            res <- seq.default(from, by=by, length.out=length.out)
        else {
            to <- unclass(as.Date(to))
            ## defeat test in seq.default
            res <- seq.default(0, to - from, by) + from
        }
        return(structure(res, class="Date"))
    } else {  # months or years or DSTdays
        r1 <- as.POSIXlt(from)
        if(valid == 4) {
            if(missing(to)) { # years
                yr <- seq(r1$year, by = by, length = length.out)
            } else {
                to <- as.POSIXlt(to)
                yr <- seq(r1$year, to$year, by)
            }
            r1$year <- yr
            res <- .Internal(POSIXlt2Date(r1))
        } else if(valid == 3) { # months
            if(missing(to)) {
                mon <- seq(r1$mon, by = by, length = length.out)
            } else {
                to <- as.POSIXlt(to)
                mon <- seq(r1$mon, 12*(to$year - r1$year) + to$mon, by)
            }
            r1$mon <- mon
            res <- .Internal(POSIXlt2Date(r1))
        }
        return(res)
    }
}

cut.Date <-
    function (x, breaks, labels = NULL, start.on.monday = TRUE,
              right = FALSE, ...)
{
    if(!inherits(x, "Date")) stop("`x' must be a date-time object")
    x <- as.Date(x)

    if (inherits(breaks, "Date")) {
	breaks <- as.Date(breaks)
    } else if(is.numeric(breaks) && length(breaks) == 1) {
	## specified number of breaks
    } else if(is.character(breaks) && length(breaks) == 1) {
        by2 <- strsplit(breaks, " ", fixed=TRUE)[[1]]
        if(length(by2) > 2 || length(by2) < 1)
            stop("invalid specification of `breaks'")
	valid <-
	    pmatch(by2[length(by2)], c("days", "weeks", "months", "years"))
	if(is.na(valid)) stop("invalid specification of `breaks'")
	start <- as.POSIXlt(min(x, na.rm=TRUE))
	if(valid == 1) incr <- 1
	if(valid == 2) {
	    start$mday <- start$mday - start$wday
	    if(start.on.monday)
		start$mday <- start$mday + ifelse(start$wday > 0, 1, -6)
	    incr <- 7
	}
	if(valid == 3) { start$mday <- 1; incr <- 31 }
	if(valid == 4) { start$mon <- 0; incr <- 366 }
        start <- .Internal(POSIXlt2Date(start))
        if (length(by2) == 2) incr <- incr * as.integer(by2[1])
	maxx <- max(x, na.rm = TRUE)
	breaks <- seq(start, maxx + incr, breaks)
	breaks <- breaks[1:(1+max(which(breaks < maxx)))]
    } else stop("invalid specification of `breaks'")
    res <- cut(unclass(x), unclass(breaks), labels = labels,
               right = right, ...)
    if(is.null(labels)) levels(res) <- as.character(breaks[-length(breaks)])
    res
}

julian.Date <- function(x, origin = as.Date("1970-01-01"), ...)
{
    if(length(origin) != 1) stop("`origin' must be of length one")
    structure(unclass(x) - unclass(origin), "origin" = origin)
}

weekdays.Date <- function(x, abbreviate = FALSE)
    format(x, ifelse(abbreviate, "%a", "%A"))

months.Date <- function(x, abbreviate = FALSE)
    format(x, ifelse(abbreviate, "%b", "%B"))

quarters.Date <- function(x, ...)
{
    x <- (as.POSIXlt(x)$mon) %/% 3
    paste("Q", x+1, sep = "")
}

## These only make sense for negative digits, but still ...
round.Date <- function(x, ...)
{
    cl <- oldClass(x)
    class(x) <- NULL
    val <- NextMethod()
    class(val) <- cl
    val
}
trunc.Date <- function(x) round.Date(x)

rep.Date <- function(x, times, ...)
{
    y <- NextMethod()
    structure(y, class="Date")
}

diff.Date <- function (x, lag = 1, differences = 1, ...)
{
    ismat <- is.matrix(x)
    xlen <- if (ismat) dim(x)[1] else length(x)
    if (length(lag) > 1 || length(differences) > 1 || lag < 1 || differences < 1)
        stop("`lag' and `differences' must be integers >= 1")
    if (lag * differences >= xlen)
        return(structure(numeric(0), class="difftime", units="days"))
    r <- x
    i1 <- -1:-lag
    if (ismat) for (i in 1:differences) r <- r[i1, , drop = FALSE] -
            r[-nrow(r):-(nrow(r) - lag + 1), , drop = FALSE]
    else for (i in 1:differences)
        r <- r[i1] - r[-length(r):-(length(r) - lag + 1)]
    r
}
Sys.time <- function()
    structure(.Internal(Sys.time()), class = c("POSIXt", "POSIXct"))

Sys.timezone <- function() as.vector(Sys.getenv("TZ"))

as.POSIXlt <- function(x, tz = "")
{
    fromchar <- function(x) {
	xx <- x[1]
        if(is.na(xx)) {
            j <- 1
            while(is.na(xx) && (j <- j+1) <= length(x))
                xx <- x[j]
            if(is.na(xx)) f <- "%Y-%m-%d" # all NAs
        }
	if(is.na(xx) ||
           !is.na(strptime(xx, f <- "%Y-%m-%d %H:%M:%S")) ||
	   !is.na(strptime(xx, f <- "%Y/%m/%d %H:%M:%S")) ||
	   !is.na(strptime(xx, f <- "%Y-%m-%d %H:%M")) ||
	   !is.na(strptime(xx, f <- "%Y/%m/%d %H:%M")) ||
	   !is.na(strptime(xx, f <- "%Y-%m-%d")) ||
	   !is.na(strptime(xx, f <- "%Y/%m/%d")))
        {
	    res <- strptime(x, f)
            if(nchar(tz)) attr(res, "tzone") <- tz
            return(res)
        }
	stop("character string is not in a standard unambiguous format")
    }

    if(inherits(x, "POSIXlt")) return(x)
    if(inherits(x, "Date")) return(.Internal(Date2POSIXlt(x)))
    tzone <- attr(x, "tzone")
    if(inherits(x, "date") || inherits(x, "dates")) x <- as.POSIXct(x)
    if(is.character(x)) return(fromchar(x))
    if(is.factor(x))	return(fromchar(as.character(x)))
    if(is.logical(x) && all(is.na(x))) x <- as.POSIXct.default(x)
    if(!inherits(x, "POSIXct"))
	stop(paste("Don't know how to convert `", deparse(substitute(x)),
		   "' to class \"POSIXlt\"", sep=""))
    if(missing(tz) && !is.null(tzone)) tz <- tzone[1]
    .Internal(as.POSIXlt(x, tz))
}

as.POSIXct <- function(x, tz = "") UseMethod("as.POSIXct")

as.POSIXct.Date <- function(x, ...)
    structure(unclass(x)*86400, class=c("POSIXt", "POSIXct"))


## convert from package date
as.POSIXct.date <- function(x, ...)
{
    if(inherits(x, "date")) {
        x <- (x - 3653) * 86400 # origin 1960-01-01
        return(structure(x, class = c("POSIXt", "POSIXct")))
    } else stop(paste("`", deparse(substitute(x)),
                      "' is not a \"dates\" object", sep=""))
}

## convert from package chron
as.POSIXct.dates <- function(x, ...)
{
    if(inherits(x, "dates")) {
        z <- attr(x, "origin")
        x <- as.numeric(x) * 86400
        if(length(z) == 3 && is.numeric(z))
            x  <- x + as.numeric(ISOdate(z[3], z[1], z[2], 0))
        return(structure(x, class = c("POSIXt", "POSIXct")))
    } else stop(paste("`", deparse(substitute(x)),
                      "' is not a \"dates\" object", sep=""))
}

as.POSIXct.POSIXlt <- function(x, tz = "")
{
    tzone <- attr(x, "tzone")
    if(missing(tz) && !is.null(tzone)) tz <- tzone[1]
    structure(.Internal(as.POSIXct(x, tz)), class = c("POSIXt", "POSIXct"),
              tzone = tz)
}

as.POSIXct.default <- function(x, tz = "")
{
    if(inherits(x, "POSIXct")) return(x)
    if(is.character(x) || is.factor(x))
	return(as.POSIXct(as.POSIXlt(x), tz))
    if(is.logical(x) && all(is.na(x)))
        return(structure(as.numeric(x), class = c("POSIXt", "POSIXct")))
    stop(paste("Don't know how to convert `", deparse(substitute(x)),
	       "' to class \"POSIXct\"", sep=""))
}

format.POSIXlt <- function(x, format = "", usetz = FALSE, ...)
{
    if(!inherits(x, "POSIXlt")) stop("wrong class")
    if(format == "") {
        ## need list [ method here.
        times <- unlist(unclass(x)[1:3])
        format <- if(all(times[!is.na(times)] == 0)) "%Y-%m-%d"
        else "%Y-%m-%d %H:%M:%S"
    }
    .Internal(format.POSIXlt(x, format, usetz))
}

strftime <- format.POSIXlt

strptime <- function(x, format)
    .Internal(strptime(x, format))


format.POSIXct <- function(x, format = "", tz = "", usetz = FALSE, ...)
{
    if(!inherits(x, "POSIXct")) stop("wrong class")
    if(missing(tz) && !is.null(tzone <- attr(x, "tzone"))) tz <- tzone
    structure(format.POSIXlt(as.POSIXlt(x, tz), format, usetz, ...),
              names=names(x))
}

print.POSIXct <- function(x, ...)
{
    print(format(x, usetz=TRUE, ...), ...)
    invisible(x)
}

print.POSIXlt <- function(x, ...)
{
    print(format(x, usetz=TRUE), ...)
    invisible(x)
}

summary.POSIXct <- function(object, digits=15, ...)
{
    x <- summary.default(unclass(object), digits=digits, ...)[1:6]# no NA's
    class(x) <- oldClass(object)
    attr(x, "tzone") <- attr(object, "tzone")
    x
}

summary.POSIXlt <- function(object, digits = 15, ...)
    summary(as.POSIXct(object), digits = digits, ...)


"+.POSIXt" <- function(e1, e2)
{
    coerceTimeUnit <- function(x)
    {
        switch(attr(x,"units"),
               secs = x, mins = 60*x, hours = 60*60*x,
               days = 60*60*24*x, weeks = 60*60*24*7*x)
    }

    if (nargs() == 1) return(e1)
    # only valid if one of e1 and e2 is a scalar.
    if(inherits(e1, "POSIXt") && inherits(e2, "POSIXt"))
        stop("binary + is not defined for POSIXt objects")
    if(inherits(e1, "POSIXlt")) e1 <- as.POSIXct(e1)
    if(inherits(e2, "POSIXlt")) e2 <- as.POSIXct(e2)
    if (inherits(e1, "difftime")) e1 <- coerceTimeUnit(e1)
    if (inherits(e2, "difftime")) e2 <- coerceTimeUnit(e2)
    structure(unclass(e1) + unclass(e2), class = c("POSIXt", "POSIXct"))
}

"-.POSIXt" <- function(e1, e2)
{
    coerceTimeUnit <- function(x)
    {
        switch(attr(x,"units"),
               secs = x, mins = 60*x, hours = 60*60*x,
               days = 60*60*24*x, weeks = 60*60*24*7*x)
    }
    if(!inherits(e1, "POSIXt"))
        stop("Can only subtract from POSIXt objects")
    if (nargs() == 1) stop("unary - is not defined for POSIXt objects")
    if(inherits(e2, "POSIXt")) return(difftime(e1, e2))
    if (inherits(e2, "difftime")) e2 <- unclass(coerceTimeUnit(e2))
    if(!is.null(attr(e2, "class")))
        stop("can only subtract numbers from POSIXt objects")
    structure(unclass(as.POSIXct(e1)) - e2, class = c("POSIXt", "POSIXct"))
}

Ops.POSIXt <- function(e1, e2)
{
    if (nargs() == 1)
        stop(paste("unary", .Generic, "not defined for POSIXt objects"))
    boolean <- switch(.Generic, "<" = , ">" = , "==" = ,
                      "!=" = , "<=" = , ">=" = TRUE, FALSE)
    if (!boolean) stop(paste(.Generic, "not defined for POSIXt objects"))
    if(inherits(e1, "POSIXlt")) e1 <- as.POSIXct(e1)
    if(inherits(e2, "POSIXlt")) e2 <- as.POSIXct(e2)
    NextMethod(.Generic)
}

Math.POSIXt <- function (x, ...)
{
    stop(paste(.Generic, "not defined for POSIXt objects"))
}

Summary.POSIXct <- function (x, ...)
{
    ok <- switch(.Generic, max = , min = , range = TRUE, FALSE)
    if (!ok) stop(paste(.Generic, "not defined for POSIXct objects"))
    val <- NextMethod(.Generic)
    class(val) <- oldClass(x)
    val
}

Summary.POSIXlt <- function (x, ...)
{
    ok <- switch(.Generic, max = , min = , range = TRUE, FALSE)
    if (!ok) stop(paste(.Generic, "not defined for POSIXlt objects"))
    x <- as.POSIXct(x)
    val <- NextMethod(.Generic)
    as.POSIXlt(structure(val, class = c("POSIXt", "POSIXct")))
}

"[.POSIXct" <-
function(x, ..., drop = TRUE)
{
    cl <- oldClass(x)
    class(x) <- NULL
    val <- NextMethod("[")
    class(val) <- cl
    val
}

"[[.POSIXct" <-
function(x, ..., drop = TRUE)
{
    cl <- oldClass(x)
    class(x) <- NULL
    val <- NextMethod("[[")
    class(val) <- cl
    val
}

"[<-.POSIXct" <-
function(x, ..., value) {
    if(!as.logical(length(value))) return(x)
    value <- as.POSIXct(value)
    cl <- oldClass(x)
    class(x) <- class(value) <- NULL
    x <- NextMethod(.Generic)
    class(x) <- cl
    x
}

as.character.POSIXt <- function(x, ...) format(x, ...)

str.POSIXt <- function(object, ...) {
    cl <- oldClass(object)
    cat("`", cl[min(2, length(cl))],"', format:", sep = "")
    str(format(object), ...)
}

as.data.frame.POSIXct <- as.data.frame.vector

is.na.POSIXlt <- function(x) is.na(as.POSIXct(x))

c.POSIXct <- function(..., recursive=FALSE)
    structure(c(unlist(lapply(list(...), unclass))),
              class=c("POSIXt","POSIXct"))

## we need conversion to POSIXct as POSIXlt objects can be in different tz.
c.POSIXlt <- function(..., recursive=FALSE)
    as.POSIXlt(do.call("c", lapply(list(...), as.POSIXct)))

## force absolute comparisons
all.equal.POSIXct <- function(target, current, ..., scale=1)
    NextMethod("all.equal")



ISOdatetime <- function(year, month, day, hour, min, sec, tz="")
{
    x <- paste(year, month, day, hour, min, sec, sep="-")
    as.POSIXct(strptime(x, "%Y-%m-%d-%H-%M-%S"), tz=tz)
}

ISOdate <- function(year, month, day, hour=12, min=0, sec=0, tz="GMT")
    ISOdatetime(year, month, day, hour, min, sec, tz)

as.matrix.POSIXlt <- function(x)
{
    as.matrix(as.data.frame(unclass(x)))
}

mean.POSIXct <- function (x, ...)
    structure(mean(unclass(x), ...), class = c("POSIXt", "POSIXct"),
              tzone=attr(x, "tzone"))

mean.POSIXlt <- function (x, ...)
    as.POSIXlt(mean(as.POSIXct(x), ...))

## ----- difftime -----

difftime <-
    function(time1, time2, tz = "",
             units = c("auto", "secs", "mins", "hours", "days", "weeks"))
{
    time1 <- as.POSIXct(time1, tz = tz)
    time2 <- as.POSIXct(time2, tz = tz)
    z <- unclass(time1) - unclass(time2)
    units <- match.arg(units)
    if(units == "auto") {
        if(all(is.na(z))) units <- "secs"
        else {
            zz <- min(abs(z),na.rm=TRUE)
            if(is.na(zz) || zz < 60) units <- "secs"
            else if(zz < 3600) units <- "mins"
            else if(zz < 86400) units <- "hours"
            else units <- "days"
        }
    }
    switch(units,
           "secs" = structure(z, units="secs", class="difftime"),
           "mins" = structure(z/60, units="mins", class="difftime"),
           "hours"= structure(z/3600, units="hours", class="difftime"),
           "days" = structure(z/86400, units="days", class="difftime"),
           "weeks" = structure(z/(7*86400), units="weeks", class="difftime")
           )
}

## "difftime" constructor
## Martin Maechler, Date: 16 Sep 2002
as.difftime <- function(tim, format="%X")
{
    difftime(strptime(tim, format=format),
             strptime("0:0:0", format="%X"))
}

print.difftime <- function(x, digits = getOption("digits"), ...)
{
    if(is.array(x)) {
        cat("Time differences in ", attr(x, "units"), "\n", sep="")
        y <- unclass(x); attr(y, "units") <- NULL
        print(y)
    } else if(length(x) > 1)
        cat("Time differences of ",
            paste(format(unclass(x), digits=digits), collapse = ", "), " ",
            attr(x, "units"), "\n", sep="")
    else
        cat("Time difference of ", format(unclass(x), digits=digits), " ",
            attr(x, "units"), "\n", sep="")

    invisible(x)
}

round.difftime <- function (x, digits = 0)
{
   units <- attr(x, "units")
   structure(NextMethod(), units=units, class="difftime")
}

"[.difftime" <- function(x, ..., drop = TRUE)
{
    cl <- oldClass(x)
    class(x) <- NULL
    val <- NextMethod("[")
    class(val) <- cl
    attr(val, "units") <- attr(x, "units")
    val
}

Ops.difftime <- function(e1, e2)
{
    coerceTimeUnit <- function(x)
    {
        switch(attr(x,"units"),
               secs = x, mins = 60*x, hours = 60*60*x,
               days = 60*60*24*x, weeks = 60*60*24*7*x)
    }
    if (nargs() == 1)
        stop(paste("unary", .Generic, "not defined for difftime objects"))
    boolean <- switch(.Generic, "<" = , ">" = , "==" = ,
                      "!=" = , "<=" = , ">=" = TRUE, FALSE)
    if (boolean) {
        ## assume user knows what he/she is doing if not both difftime
        if(inherits(e1, "difftime") && inherits(e2, "difftime")) {
            e1 <- coerceTimeUnit(e1)
            e2 <- coerceTimeUnit(e2)
        }
        NextMethod(.Generic)
    } else if(.Generic == "+" || .Generic == "-") {
        if(inherits(e1, "difftime") && !inherits(e2, "difftime"))
            return(structure(NextMethod(.Generic),
                             units = attr(e1, "units"), class = "difftime"))
        if(!inherits(e1, "difftime") && inherits(e2, "difftime"))
            return(structure(NextMethod(.Generic),
                             units = attr(e2, "units"), class = "difftime"))
        u1 <- attr(e1, "units")
        if(attr(e2, "units") == u1) {
            structure(NextMethod(.Generic), units=u1, class="difftime")
        } else {
            e1 <- coerceTimeUnit(e1)
            e2 <- coerceTimeUnit(e2)
            structure(NextMethod(.Generic), units="secs", class="difftime")
        }
    } else {
        ## `*' is covered by a specific method
        stop(paste(.Generic, "not defined for difftime objects"))
    }
}

"*.difftime" <- function (e1, e2)
{
    ## need one scalar, one difftime.
    if(inherits(e1, "difftime") && inherits(e2, "difftime"))
        stop("both arguments of * cannot be difftime objects")
    if(inherits(e2, "difftime")) {tmp <- e1; e1 <- e2; e2 <- tmp}
    structure(e2 * unclass(e1), units = attr(e1, "units"),
              class = "difftime")
}

"/.difftime" <- function (e1, e2)
{
    ## need one scalar, one difftime.
    if(inherits(e2, "difftime"))
        stop("second argument of / cannot be a difftime object")
    structure(unclass(e1) / e2, units = attr(e1, "units"),
              class = "difftime")
}

Math.difftime <- function (x, ...)
{
    stop(paste(.Generic, "not defined for difftime objects"))
}

mean.difftime <- function (x, ..., na.rm = FALSE)
{
    coerceTimeUnit <- function(x)
    {
        as.vector(switch(attr(x,"units"),
               secs = x, mins = 60*x, hours = 60*60*x,
               days = 60*60*24*x, weeks = 60*60*24*7*x))
    }
    if(length(list(...))) {
        args <- c(lapply(list(x, ...), coerceTimeUnit), na.rm = na.rm)
        structure(do.call("mean", args), units="secs", class="difftime")
    } else {
        structure(mean(as.vector(x), na.rm = na.rm),
                  units=attr(x, "units"), class="difftime")
    }
}

Summary.difftime <- function (x, ..., na.rm = FALSE)
{
    coerceTimeUnit <- function(x)
    {
        as.vector(switch(attr(x,"units"),
                         secs = x, mins = 60*x, hours = 60*60*x,
                         days = 60*60*24*x, weeks = 60*60*24*7*x))
    }
    ok <- switch(.Generic, max = , min = , range = TRUE, FALSE)
    if (!ok) stop(paste(.Generic, "not defined for difftime objects"))
    args <- c(lapply(list(x, ...), coerceTimeUnit), na.rm = na.rm)
    structure(do.call(.Generic, args), units="secs", class="difftime")
}


## ----- convenience functions -----

seq.POSIXt <-
    function(from, to, by, length.out = NULL, along.with = NULL, ...)
{
    if (missing(from)) stop("`from` must be specified")
    if (!inherits(from, "POSIXt")) stop("`from' must be a POSIXt object")
        if(length(as.POSIXct(from)) != 1) stop("`from' must be of length 1")
    if (!missing(to)) {
        if (!inherits(to, "POSIXt")) stop("`to' must be a POSIXt object")
        if (length(as.POSIXct(to)) != 1) stop("`to' must be of length 1")
        if (to <= from) stop("`to' must be later than `from'")
    }
    if (!missing(along.with)) {
        length.out <- length(along.with)
    }  else if (!missing(length.out)) {
        if (length(length.out) != 1) stop("`length.out' must be of length 1")
        length.out <- ceiling(length.out)
    }
    status <- c(!missing(to), !missing(by), !is.null(length.out))
    if(sum(status) != 2)
        stop("exactly two of `to', `by' and `length.out' / `along.with' must be specified")
    if (missing(by)) {
        from <- unclass(as.POSIXct(from))
        to <- unclass(as.POSIXct(to))
        ## Till (and incl.) 1.6.0 :
        ##- incr <- (to - from)/length.out
        ##- res <- seq.default(from, to, incr)
        res <- seq.default(from, to, length.out = length.out)
        return(structure(res, class = c("POSIXt", "POSIXct")))
    }

    if (length(by) != 1) stop("`by' must be of length 1")
    valid <- 0
    if (inherits(by, "difftime")) {
        by <- switch(attr(by,"units"), secs = 1, mins = 60, hours = 3600,
                     days = 86400, weeks = 7*86400) * unclass(by)
    } else if(is.character(by)) {
        by2 <- strsplit(by, " ", fixed=TRUE)[[1]]
        if(length(by2) > 2 || length(by2) < 1)
            stop("invalid `by' string")
        valid <- pmatch(by2[length(by2)],
                        c("secs", "mins", "hours", "days", "weeks",
                          "months", "years", "DSTdays"))
        if(is.na(valid)) stop("invalid string for `by'")
        if(valid <= 5) {
            by <- c(1, 60, 3600, 86400, 7*86400)[valid]
            if (length(by2) == 2) by <- by * as.integer(by2[1])
        } else
            by <- if(length(by2) == 2) as.integer(by2[1]) else 1
    } else if(!is.numeric(by)) stop("invalid mode for `by'")
    if(is.na(by)) stop("`by' is NA")

    if(valid <= 5) {
        from <- unclass(as.POSIXct(from))
        if(!is.null(length.out))
            res <- seq.default(from, by=by, length.out=length.out)
        else {
            to <- unclass(as.POSIXct(to))
            ## defeat test in seq.default
            res <- seq.default(0, to - from, by) + from
        }
        return(structure(res, class=c("POSIXt", "POSIXct")))
    } else {  # months or years or DSTdays
        r1 <- as.POSIXlt(from)
        if(valid == 7) {
            if(missing(to)) { # years
                yr <- seq(r1$year, by = by, length = length.out)
            } else {
                to <- as.POSIXlt(to)
                yr <- seq(r1$year, to$year, by)
            }
            r1$year <- yr
            r1$isdst <- -1
            res <- as.POSIXct(r1)
        } else if(valid == 6) { # months
            if(missing(to)) {
                mon <- seq(r1$mon, by = by, length = length.out)
            } else {
                to <- as.POSIXlt(to)
                mon <- seq(r1$mon, 12*(to$year - r1$year) + to$mon, by)
            }
            r1$mon <- mon
            r1$isdst <- -1
            res <- as.POSIXct(r1)
        } else if(valid == 8) { # DSTdays
            if(!missing(to)) {
                ## We might have a short day, so need to over-estimate.
                length.out <- 2 + floor((unclass(as.POSIXct(to)) -
                                         unclass(as.POSIXct(from)))/86400)
            }
            r1$mday <- seq(r1$mday, by = by, length = length.out)
            r1$isdst <- -1
            res <- as.POSIXct(r1)
            ## now correct if necessary.
            if(!missing(to)) res <- res[res <= as.POSIXct(to)]
        }
        return(res)
    }
}

cut.POSIXt <-
    function (x, breaks, labels = NULL, start.on.monday = TRUE,
              right = FALSE, ...)
{
    if(!inherits(x, "POSIXt")) stop("`x' must be a date-time object")
    x <- as.POSIXct(x)

    if (inherits(breaks, "POSIXt")) {
	breaks <- as.POSIXct(breaks)
    } else if(is.numeric(breaks) && length(breaks) == 1) {
	## specified number of breaks
    } else if(is.character(breaks) && length(breaks) == 1) {
        by2 <- strsplit(breaks, " ", fixed=TRUE)[[1]]
        if(length(by2) > 2 || length(by2) < 1)
            stop("invalid specification of `breaks'")
	valid <-
	    pmatch(by2[length(by2)],
		   c("secs", "mins", "hours", "days", "weeks",
		     "months", "years", "DSTdays"))
	if(is.na(valid)) stop("invalid specification of `breaks'")
	start <- as.POSIXlt(min(x, na.rm=TRUE))
	incr <- 1
	if(valid > 1) { start$sec <- 0; incr <- 59.99 }
	if(valid > 2) { start$min <- 0; incr <- 3600 - 1 }
	if(valid > 3) { start$hour <- 0; incr <- 86400 - 1 }
	if(valid == 5) {
	    start$mday <- start$mday - start$wday
	    if(start.on.monday)
		start$mday <- start$mday + ifelse(start$wday > 0, 1, -6)
	    incr <- 7*86400
	}
	if(valid == 6) { start$mday <- 1; incr <- 31*86400 }
	if(valid == 7) { start$mon <- 0; incr <- 366*86400 }
        if(valid == 8) incr <- 25*3600
        if (length(by2) == 2) incr <- incr * as.integer(by2[1])
	maxx <- max(x, na.rm = TRUE)
	breaks <- seq(start, maxx + incr, breaks)
	breaks <- breaks[1:(1+max(which(breaks < maxx)))]
    } else stop("invalid specification of `breaks'")
    res <- cut(unclass(x), unclass(breaks), labels = labels,
               right = right, ...)
    if(is.null(labels)) levels(res) <- as.character(breaks[-length(breaks)])
    res
}

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

julian.POSIXt <- function(x, origin = as.POSIXct("1970-01-01", tz="GMT"), ...)
{
    if(length(origin) != 1) stop("`origin' must be of length one")
    res <- difftime(as.POSIXct(x), origin, units = "days")
    structure(res, "origin" = origin)
}

weekdays <- function(x, abbreviate) UseMethod("weekdays")
weekdays.POSIXt <- function(x, abbreviate = FALSE)
{
    format(x, ifelse(abbreviate, "%a", "%A"))
}

months <- function(x, abbreviate) UseMethod("months")
months.POSIXt <- function(x, abbreviate = FALSE)
{
    format(x, ifelse(abbreviate, "%b", "%B"))
}

quarters <- function(x, abbreviate) UseMethod("quarters")
quarters.POSIXt <- function(x, ...)
{
    x <- (as.POSIXlt(x)$mon)%/%3
    paste("Q", x+1, sep = "")
}

trunc.POSIXt <- function(x, units=c("secs", "mins", "hours", "days"))
{
    units <- match.arg(units)
    x <- as.POSIXlt(x)
    if(length(x$sec) > 0)
	switch(units,
	       "secs" = {x$sec <- trunc(x$sec)},
	       "mins" = {x$sec <- 0},
	       "hours"= {x$sec <- 0; x$min <- 0},
	       "days" = {x$sec <- 0; x$min <- 0; x$hour <- 0; x$isdst <- -1}
	       )
    x
}

round.POSIXt <- function(x, units=c("secs", "mins", "hours", "days"))
{
    ## this gets the default from the generic, as that has two args.
    if(is.numeric(units) && units == 0.0) units <-"secs"
    units <- match.arg(units)
    x <- as.POSIXct(x)
    x <- x + switch(units,
                    "secs" = 0.5, "mins" = 30, "hours"= 1800, "days" = 43200)
    trunc.POSIXt(x, units = units)
}

# ---- additions in 1.5.0 -----

"[.POSIXlt" <- function(x, ..., drop = TRUE)
{
    val <- lapply(x, "[", ..., drop = drop)
    attributes(val) <- attributes(x) # need to preserve timezones
    val
}

"[<-.POSIXlt" <- function(x, i, value)
{
    if(!as.logical(length(value))) return(x)
    value <- as.POSIXlt(value)
    cl <- oldClass(x)
    class(x) <- class(value) <- NULL
    for(n in names(x)) x[[n]][i] <- value[[n]]
    class(x) <- cl
    x
}

as.data.frame.POSIXlt <- function(x, row.names = NULL, optional = FALSE)
{
    value <- as.data.frame.POSIXct(as.POSIXct(x), row.names, optional)
    if (!optional)
        names(value) <- deparse(substitute(x))[[1]]
    value
}

# ---- additions in 1.8.0 -----

rep.POSIXct <- function(x, times,  ...)
{
    y <- NextMethod()
    structure(y, class=c("POSIXt", "POSIXct"), tzone = attr(x, "tzone"))
}

rep.POSIXlt <- function(x, times, ...)
{
    y <- if(missing(times)) lapply(x, rep, ...)
       else lapply(x, rep, times=times, ...)
    attributes(y) <- attributes(x)
    y
}

diff.POSIXt <- function (x, lag = 1, differences = 1, ...)
{
    ismat <- is.matrix(x)
    xlen <- if (ismat) dim(x)[1] else length(x)
    if (length(lag) > 1 || length(differences) > 1 || lag < 1 || differences < 1)
        stop("`lag' and `differences' must be integers >= 1")
    if (lag * differences >= xlen)
        return(structure(numeric(0), class="difftime", units="secs"))
    r <- x
    i1 <- -1:-lag
    if (ismat) for (i in 1:differences) r <- r[i1, , drop = FALSE] -
            r[-nrow(r):-(nrow(r) - lag + 1), , drop = FALSE]
    else for (i in 1:differences)
        r <- r[i1] - r[-length(r):-(length(r) - lag + 1)]
    r
}
read.dcf <- function(file, fields = NULL)
{
    if(is.character(file)){
        file <- file(file, "r")
        on.exit(close(file))
    }
    if(!inherits(file, "connection"))
        stop(paste("argument", sQuote("file"),
                   "must be a character string or connection"))
    .Internal(readDCF(file, fields))
}

write.dcf <-
function(x, file = "", append = FALSE,
         indent = 0.1 * getOption("width"),
         width = 0.9 * getOption("width"))
{
    if(!is.data.frame(x))
        x <- data.frame(x)
    x <- as.matrix(x)
    mode(x) <- "character"

    if(file == "")
        file <- stdout()
    else if(is.character(file)) {
        file <- file(file, ifelse(append, "a", "w"))
        on.exit(close(file))
    }
    if(!inherits(file, "connection"))
        stop(paste("argument", sQuote("file"),
                   "must be a character string or connection"))

    nr <- nrow(x)
    nc <- ncol(x)

    eor <- character(nr * nc)
    eor[seq(1, nr - 1) * nc] <- "\n"    # newline for end of record

    writeLines(paste(formatDL(rep.int(colnames(x), nr), c(t(x)), style =
                     "list", width = width, indent = indent),
                     eor, sep = ""),
               file)
}
delay <- function(x, env=.GlobalEnv)
    .Internal(delay(substitute(x), env))
## det now uses Lapack and an LU decomposition.  The method argument is
##     no longer used.
## S-plus' Matrix pkg has arg. "logarithm = TRUE" and returns list
##        (which is necessary for keeping the sign when taking log ..)
## S-plus v 6.x has incorporated the Matrix pkg det as determinant

det = function(x, ...)
{
    z = determinant(x, logarithm = TRUE, ...)
    c(z$sign * exp(z$modulus))
}

determinant = function(x, logarithm = TRUE, ...) UseMethod("determinant")

determinant.matrix = function(x, logarithm = TRUE, ...)
{
    if ((n <- ncol(x)) != nrow(x))
        stop("x must be a square matrix")
    if (n < 1)
        return(list(modulus = double(0), sign = as.integer(1),
                    logarithm = logarithm))
    if (is.complex(x))
        stop("determinant not currently defined for complex matrices")
    storage.mode(x) = "double"
    .Call("det_ge_real", x, logarithm, PACKAGE = "base")
}
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")
    if(length(i) > 0) x[cbind(i, i)] <- value
    x
}
diff <- function(x, ...) UseMethod("diff")

diff.default <- function(x, lag = 1, differences = 1, ...)
{
    ismat <- is.matrix(x)
    xlen <- if(ismat) dim(x)[1] else length(x)
    if (length(lag) > 1 || length(differences) > 1 ||
        lag < 1 || differences < 1)
	stop("`lag' and `differences' must be integers >= 1")
    if (lag * differences >= xlen)
	return(x[0]) # empty of proper mode
    r <- unclass(x)  # don't want class-specific subset methods
    i1 <- -1:-lag
    if (ismat)
	for (i in 1:differences)
	    r <- r[i1, , drop = FALSE] -
                r[-nrow(r):-(nrow(r)-lag+1), , drop = FALSE]
    else
        for (i in 1:differences)
            r <- r[i1] - r[-length(r):-(length(r)-lag+1)]
    class(r) <- oldClass(x)
    r
}
dput <- function(x, file = "")
{
    if(is.character(file))
        if(nchar(file) > 0) {
            file <- file(file, "wt")
            on.exit(close(file))
        } else file <- stdout()
    .Internal(dput(x, file))
}

dget <- function(file)
    eval(parse(file = file))
dump <- function (list, file = "dumpdata.R", append = FALSE,
                  envir = parent.frame())
{
    digits <- options("digits")
    on.exit(options(digits))
    options(digits = 12)
    if(is.character(file))
        if(nchar(file) > 0) {
            file <- file(file, ifelse(append, "a", "w"))
            on.exit(close(file), add = TRUE)
        } else file <- stdout()
    .Internal(dump(list, file, envir))
}

duplicated <- function(x, incomparables = FALSE, ...) UseMethod("duplicated")

duplicated.default <- function(x, incomparables = FALSE, ...)
{
    if(!is.logical(incomparables) || incomparables)
	.NotYetUsed("incomparables != FALSE")
    .Internal(duplicated(x))
}

duplicated.data.frame <- function(x, incomparables = FALSE, ...)
{
    if(!is.logical(incomparables) || incomparables)
	.NotYetUsed("incomparables != FALSE")
    duplicated(do.call("paste", c(x, sep="\r")))
}

duplicated.matrix <- duplicated.array <-
    function(x, incomparables = FALSE , MARGIN = 1, ...)
{
    if(!is.logical(incomparables) || incomparables)
	.NotYetUsed("incomparables != FALSE")
    ndim <- length(dim(x))
    if (length(MARGIN) > ndim || any(MARGIN > ndim))
        stop("MARGIN = ", MARGIN, " is invalid for dim = ", dim(x))
    temp <- apply(x, MARGIN, function(x) paste(x, collapse = "\r"))
    res <- duplicated(as.vector(temp))
    dim(res) <- dim(temp)
    dimnames(res) <- dimnames(temp)
    res
}

unique <- function(x, incomparables = FALSE, ...) UseMethod("unique")


## NB unique.default is used by factor to avoid unique.matrix,
## so it needs to handle some other cases.
unique.default <- function(x, incomparables = FALSE, ...)
{
    if(!is.logical(incomparables) || incomparables)
	.NotYetUsed("incomparables != FALSE")
    z <- .Internal(unique(x))
    if(is.factor(x))
	factor(z, levels = seq(len=nlevels(x)), labels = levels(x),
               ordered = is.ordered(x))
    else if(inherits(x, "POSIXct") || inherits(x, "Date"))
        structure(z, class=class(x))
    else z
}

unique.data.frame <- function(x, incomparables = FALSE, ...)
{
    if(!is.logical(incomparables) || incomparables)
	.NotYetUsed("incomparables != FALSE")
    x[!duplicated(x),  , drop = FALSE]
}

unique.matrix <- unique.array <-
    function(x, incomparables = FALSE , MARGIN = 1, ...)
{
    if(!is.logical(incomparables) || incomparables)
	.NotYetUsed("incomparables != FALSE")
    ndim <- length(dim(x))
    if (length(MARGIN) > 1 || any(MARGIN > ndim))
        stop("MARGIN = ", MARGIN, " is invalid for dim = ", dim(x))
    temp <- apply(x, MARGIN, function(x) paste(x, collapse = "\r"))
    args <- rep(alist(a=), ndim)
    names(args) <- NULL
    args[[MARGIN]] <- !duplicated(as.vector(temp))
    do.call("[", c(list(x=x), args, list(drop=FALSE)))
}
##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))

getNativeSymbolInfo <- function(name, PACKAGE)
{
    if(missing(PACKAGE)) PACKAGE <- ""
    v <- .Call("R_getSymbolInfo", as.character(name), as.character(PACKAGE),
               PACKAGE = "base")
    if(is.null(v)) {
        msg <- paste("no such symbol",name)
        if(length(PACKAGE) && nchar(PACKAGE[1]))
            msg <- paste(msg, "in package",PACKAGE[1])
        stop(msg)
    }
    names(v) <- c("name", "address", "package", "numParameters")[1:length(v)]
    v
}
eigen <- function(x, symmetric, only.values = FALSE, EISPACK = FALSE)
{
    x <- as.matrix(x)
    dimnames(x) <- list(NULL, NULL)  # or they appear on eigenvectors
    n <- nrow(x)
    if (!n) stop("0 x 0 matrix")
    if (n != ncol(x)) stop("non-square matrix in eigen")

    complex.x <- is.complex(x)

    if (any(!is.finite(x))) stop("infinite or missing values in x")

    if(complex.x) {
	if(missing(symmetric)) {
            test <- all.equal.numeric(x, Conj(t(x)), 100*.Machine$double.eps)
	    symmetric <- is.logical(test) && test
        }
    }
    else if(is.numeric(x)) {
	storage.mode(x) <- "double"
	if(missing(symmetric)) {
            test <- all.equal.numeric(x, t(x), 100*.Machine$double.eps)
	    symmetric <- is.logical(test) && test
        }
    }
    else stop("numeric or complex values required in eigen")
    if (!EISPACK) {
        if (symmetric) {
            z <- if(!complex.x)
                .Call("La_rs", x, only.values,
                      if(capabilities("IEEE754")) "dsyevr" else "dsyev",
                      PACKAGE = "base")
            else
                .Call("La_rs_cmplx", x, only.values, PACKAGE = "base")
            ord <- rev(seq(along = z$values))
        } else {
            z <- if(!complex.x)
                .Call("La_rg", x, only.values, PACKAGE = "base")
            else
                .Call("La_rg_cmplx", x, only.values, PACKAGE = "base")
            ord <- sort.list(Mod(z$values), decreasing = TRUE)
        }
        return(list(values = z$values[ord],
                    vectors = if (!only.values) z$vectors[, ord, drop = FALSE]))
    }

    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 <- sort.list(z$values, decreasing = TRUE)
    }
    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 <- sort.list(Mod(z$values), decreasing = TRUE)
    }
    list(values = z$values[ord],
	 vectors = if(!only.values) z$vectors[,ord, drop = FALSE])
}
environment <- function(fun=NULL) .Internal(environment(fun))
.GlobalEnv <- environment()
parent.frame <- function(n = 1) .Internal(parent.frame(n))

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

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 (hash=FALSE, parent=parent.frame())
    .Internal(new.env(hash, parent))

parent.env <- function(env)
    .Internal(parent.env(env))

"parent.env<-" <- function(env, value)
    .Internal("parent.env<-"(env, value))

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

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

with <- function(data, expr, ...) UseMethod("with")

with.default <- function(data, expr, ...)
    eval(substitute(expr), data, enclos=parent.frame())

force <- function(x) x
exists <-
    function (x, where = -1,
              envir = if(missing(frame)) as.environment(where) else sys.frame(frame),
              frame, mode = "any", inherits = TRUE)
    .Internal(exists(x, envir, mode, inherits))
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 == 0) return(as.data.frame(list()))
    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
    d <- sapply(args, length)
    dn <- vector("list", nargs)
    names(dn) <- nmc
    orep <- prod(d)
    for(i in 1:nargs) {
	x <- args[[i]]
        dn[[i]] <- paste(nmc[i], "=", if(is.numeric(x)) format(x) else x,
                         sep = "")
	nx <- length(x)
	orep <- orep/nx
	x <- rep.int(rep.int(x, rep.int(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
    }
    res <- do.call("cbind.data.frame", cargs)
    attr(res, "out.attrs") <- list(dim=d, dimnames=dn)
    res
}
factor <- function (x, levels = sort(unique.default(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.int(names(value), lapply(value, length))
        value <- unlist(value)
        m <- match(value, xlevs, nomatch=0)
        xlevs[m] <- nlevs[m > 0]
    } else {
        if (length(xlevs) > length(value))
            stop("number of levels differs")
        nlevs <- xlevs <- as.character(value)
    }
    factor(xlevs[x], levels = unique(nlevs))
}

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

as.character.factor <- function(x,...)
{
    cx <- levels(x)[x]
    if("NA" %in% levels(x)) cx[is.na(x)] <- "<NA>"
    cx
}

## for `factor' *and* `ordered' :
print.factor <- function (x, quote = FALSE, max.levels = NULL,
                          width = getOption("width"), ...)
{
    ord <- is.ordered(x)
    if (length(x) <= 0)
        cat(if(ord)"ordered" else "factor","(0)\n",sep="")
    else
        print(as.character(x), quote = quote, ...)
    maxl <- if(is.null(max.levels)) TRUE else max.levels
    if (maxl) {
        n <- length(lev <- levels(x))
        colsep <- if(ord) " < " else " "
        T0 <- "Levels: "
        if(is.logical(maxl))
            maxl <- { ## smart default
                width <- width - (nchar(T0) + 3 + 1 + 3)# 3='...', 3=#lev, 1=extra
                lenl <- cumsum(nchar(lev) + nchar(colsep))# + ifelse(quote,2,0))
                if(n <= 1 || lenl[n] <= width) n
                else max(1, which(lenl > width)[1] - 1)
            }
        drop <- n > maxl
        cat(if(drop)paste(format(n),""), T0,
            paste(if(drop)c(lev[1:max(1,maxl-1)],"...",if(maxl > 1) lev[n])
                      else lev, collapse= colsep), "\n", sep="")
    }
    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('"',.Generic,'"', " not meaningful for factors")
	return(rep.int(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("[")
    attr(y,"contrasts")<-attr(x,"contrasts")
    ## NB factor has levels before class in attribute list (PR#6799)
    attr(y,"levels")<-attr(x,"levels")
    class(y) <- oldClass(x)
    if ( drop ) factor(y) else y
}

"[<-.factor" <- function(x, i, value)
{
    lx <- levels(x)
    cx <- oldClass(x)
#    nas <- is.na(x) # unused
    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
    if (missing(i))
	x[] <- m
    else
        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)

Ops.ordered <-
function (e1, e2)
{
    ok <- switch(.Generic,
		 "<" = , ">" = , "<=" = , ">=" = ,"=="=, "!=" =TRUE,
		 FALSE)
    if(!ok) {
	warning('"',.Generic,'"', " not meaningful for ordered factors")
	return(rep.int(NA, max(length(e1), if(!missing(e2))length(e2))))
    }
    if (.Generic %in% c("==", "!="))
      return(NextMethod(.Generic))  ##not S-PLUS compatible, but saner
    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 <- as.integer(e1) # was codes, but same thing for ordered factor.
	e2 <- as.integer(e2)
    }
    else if (!ord1) {
	e1 <- match(e1, l2)
	e2 <- as.integer(e2)
    }
    else if (!ord2) {
	e2 <- match(e2, l1)
	e1 <- as.integer(e1)
    }
    value <- get(.Generic, mode = "function")(e1, e2)
    value[nas] <- NA
    value
}

"is.na<-.factor" <- function(x, value)
{
    lx <- levels(x)
    cx <- oldClass(x)
    class(x) <- NULL
    x[value] <- NA
    structure(x, levels = lx, class = cx)
}

"length<-.factor" <- function(x, value)
{
    cl <- class(x)
    levs <- levels(x)
    x <- NextMethod()
    structure(x, levels=levs, class=cl)
}
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.int(0, n1), x)
        n <- length(y <- c(y, rep.int(0, n - 1)))# n = nx+ny-1
    }
    x <- fft(fft(x)* (if(conj)Conj(fft(y)) else fft(y)), inv=TRUE)
    if(type == "filter")
        (if(Real) Re(x) else x)[-c(1:n1, (n-n1+1):n)]/n
    else
        (if(Real) Re(x) else x)/n
}

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

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

file.show <-
function (..., header=rep("", nfiles), title="R Information",
          delete.file=FALSE, pager=getOption("pager"))
{
    file <- c(...)
    nfiles <- length(file)
    if(nfiles == 0)
        return(invisible(NULL))
    if(is.function(pager))
	pager(file, header, title, delete.file)
    else
        .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(...)))

file.rename <- function(from, to)
.Internal(file.rename(from, to))

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

dir <- list.files

file.path <-
function(..., fsep=.Platform$file.sep)
{
    if(any(sapply(list(...), length) == 0)) return(character())
    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))

file.copy <- function(from, to, overwrite=FALSE)
{
    if (!(nf <- length(from))) stop("no files to copy from")
    if (!(nt <- length(to)))   stop("no files to copy to")
    if (nt == 1 && file.exists(to) && file.info(to)$isdir)
        to <- file.path(to, basename(from))
    else if (nf > nt) stop("more 'from' files than 'to' files")
    if(nt > nf) from <- rep(from, length.out = nt)
    if (!overwrite) okay <- !file.exists(to)
    else okay <- rep.int(TRUE, length(to))
    if (any(from[okay] %in% to[okay]))
        stop("file can't be copied both from and to")
    if (any(okay)) { ## care: create could fail but append work.
    	okay[okay] <- file.create(to[okay])
    	if(any(okay)) okay[okay] <- file.append(to[okay], from[okay])
    }
    okay
}

file.symlink <- function(from, to) {
    if (!(length(from))) stop("no files to link from")
    if (!(nt <- length(to)))   stop("no files/dir to link to")
    if (nt == 1 && file.exists(to) && file.info(to)$isdir)
        to <- file.path(to, basename(from))
    .Internal(file.symlink(from, to))
}

file.info <- function(...)
{
    res <- .Internal(file.info(fn <- c(...)))
    class(res$mtime) <- class(res$ctime) <- class(res$atime) <-
        c("POSIXt", "POSIXct")
    class(res) <- "data.frame"
    row.names(res) <- fn
    res
}

file.access <- function(names, mode = 0)
{
    res <- .Internal(file.access(names, mode))
    names(res) <- names
    res
}

dir.create <- function(path, showWarnings = TRUE)
    invisible(.Internal(dir.create(path, showWarnings)))

format.octmode <- function(x, ...)
{
    if(!inherits(x, "octmode")) stop("calling wrong method")
    isna <- is.na(x)
    y <- x[!isna]
    class(y) <- NULL
    ans0 <- character(length(y))
    z <- NULL
    while(any(y > 0) || is.null(z)) {
        z <- y%%8
        y <- floor(y/8)
        ans0 <- paste(z, ans0, sep="")
    }
    ans <- rep.int(as.character(NA), length(x))
    ans[!isna] <- ans0
    ans
}
as.character.octmode <- format.octmode

print.octmode <- function(x, ...)
{
    print(format(x), ...)
    invisible(x)
}

"[.octmode" <- function (x, i)
{
    cl <- oldClass(x)
    y <- NextMethod("[")
    oldClass(y) <- cl
    y
}

system.file <-
function(..., package = "base", lib.loc = NULL)
{
    if(nargs() == 0)
        return(file.path(.Library, "base"))
    if(length(package) != 1)
        stop(paste("argument", sQuote("package"), "must be of length 1"))
    packagePath <- .find.package(package, lib.loc, quiet = TRUE)
    if(length(packagePath) == 0)
        return("")
    FILES <- file.path(packagePath, ...)
    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))

Sys.info <- function()
    .Internal(Sys.info())

Sys.sleep <- function(time)
    invisible(.Internal(Sys.sleep(time)))

path.expand <- function(path)
    .Internal(path.expand(path))
formals <- function(fun = sys.function(sys.parent())) {
    if(is.character(fun))
	fun <- get(fun, mode = "function", envir = parent.frame())
    .Internal(formals(fun))
}

body <- function(fun = sys.function(sys.parent())) {
    if(is.character(fun))
	fun <- get(fun, mode = "function", envir = parent.frame())
    .Internal(body(fun))
}

alist <- function (...) as.list(sys.call())[-1]

"body<-" <- function (fun, envir = parent.frame(), value) {
    if (is.expression(value)) value <- value[[1]]
    as.function(c(formals(fun), value), envir)
}

"formals<-" <- function (fun, envir = parent.frame(), value)
    as.function(c(value, body(fun)), 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 dealt with there (dim, dimnames *are*) !
###
### The new (1.2) switch "character" would be faster in .Internal()
### combine with "width = ", and format.char() below!

format.default <-
    function(x, trim = FALSE, digits = NULL, nsmall = 0,
             justify = c("left", "right", "none"),
             big.mark = "", big.interval = 3,
             small.mark = "", small.interval = 5, decimal.mark = ".",
             ...)
{
    f.char <- function(x, justify) {
	if(length(x) <= 1) return(x)
	nc <- nchar(x)
        nc[is.na(nc)] <- 2
	w <- max(nc)
	sp <- substring(paste(rep.int(" ", w), collapse=""), 1, w-nc)
	res <-
	    if(justify == "left") paste(x, sp, sep="") else paste(sp, x, sep="")
	attributes(res) <- attributes(x) ## at least names, dim, dimnames
	res
    }
    if(!is.null(digits)) {
	op <- options(digits=digits)
	on.exit(options(op))
    }
    justify <- match.arg(justify)
    switch(mode(x),
	   NULL = "NULL",
	   character = switch(justify,
                              none = x,
                  	      left = f.char(x, "left"),
                              right= f.char(x, "right")),
	   list = sapply(lapply(x, function(x)
				.Internal(format(unlist(x), trim=trim))),
			 paste, collapse=", "),
	   call=, expression=, "function"=, "(" = deparse(x),
	   ## else: numeric, complex, .. :
	   { r <- prettyNum(.Internal(format(x, trim = trim, small=nsmall)),
                            big.mark = big.mark, big.interval = big.interval,
                            small.mark = small.mark,
                            small.interval = small.interval,
                            decimal.mark = decimal.mark)
             if(!is.null(a <- attributes(x)) &&
                !is.null(a <- a[names(a) != "class"]))
                 attributes(r) <- a
             r })
}
## NOTE: Currently need non-default format.dist() -> ../../stats/R/dist.R


## MM: This should also happen in C(.) :
##	.Internal(format(..) should work  with	'width =' and 'flag=.."
##		at least for the case of character arguments.
## Note that format.default now has a `justify' argument
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
    nc[is.na(nc)] <- 2
    if(is.null(width)) width <- max(nc)
    else if(width<0) { flag <- "-"; width <- -width }
    ##- 0.90.1 and earlier:
    ##- pad <- sapply(pmax(0,width - nc),
    ##-			function(no) paste(character(no+1), collapse =" "))
    ## Speedup by Jens Oehlschlaegel:
    tab <- unique(no <- pmax(0, width - nc))
    tabpad <- sapply(tab+1, function(n) paste(character(n), collapse = " "))
    pad <- tabpad[match(no, tab)]

    r <-
	if(flag=="-")	paste(x, pad, sep="")#-- LEFT  justified
	else		paste(pad, x, sep="")#-- RIGHT justified
    if(!is.null(at))
	attributes(r) <- at
    r
}


format.pval <- function(pv, digits = max(1, getOption("digits")-2),
			eps = .Machine$double.eps, na.form = "NA")
{
    ## Format  P values; auxiliary for print.summary.[g]lm(.)

    if((has.na <- any(ina <- is.na(pv)))) pv <- pv[!ina]
    ## Better than '0.0' for very small values `is0':
    r <- character(length(is0 <- pv < eps))
    if(any(!is0)) {
	rr <- pv <- pv[!is0]
	## be smart -- differ for fixp. and expon. display:
	expo <- floor(log10(ifelse(pv > 0, pv, 1e-50)))
	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,
                     big.mark = "", big.interval = 3,
                     small.mark = "", small.interval = 5,
                     decimal.mark = ".")
{
    blank.chars <- function(no)
	sapply(no+1, function(n) paste(character(n), collapse=" "))

    if (!(n <- length(x))) return("")
    if (is.null(mode))	  mode <- storage.mode(x)
    else if (any(mode == c("double", "real", "integer")))  {
      ## for .C call later on
	if(mode=="real") mode <- "double"
	storage.mode(x) <- mode
    }
    else stop("\"mode\" must be \"double\" (\"real\") or \"integer\"")
    if (mode == "character" || (!is.null(format) && format == "s")) {
	if (mode != "character") {
	    warning('formatC: Coercing argument to "character" for format="s"')
	    x <- as.character(x)
	}
	return(format.char(x, width=width, flag=flag))
    }
    if (missing(format) || is.null(format))
	format <- if (mode == "integer") "d" else "g"
    else {
	if (any(format == c("f", "e", "E", "g", "G", "fg"))) {
	    if (mode == "integer") mode <- storage.mode(x) <- "double"
	}
	else if (format == "d") {
	    if (mode != "integer") mode <- storage.mode(x) <- "integer"
	}
	else stop('"format" must be in {"f","e","E","g","G", "fg", "s"}')
    }
    some.special <- !all(Ok <- is.finite(x))
    if (some.special) {
	rQ <- as.character(x[!Ok])
	x[!Ok] <- as.vector(0, mode = mode)
    }
    if(is.null(width) && is.null(digits))
	width <- 1
    if (is.null(digits))
	digits <- if (mode == "integer") 2 else 4
    else if(digits < 0)
	digits <- 6
    if(is.null(width))	width <- digits + 1
    else if (width == 0)width <- digits
    i.strlen <-
	pmax(abs(width),
	     if(format == "fg"||format == "f") {
		 xEx <- as.integer(floor(log10(abs(x+ifelse(x==0,1,0)))))
		 as.integer(x < 0 | flag!="") + digits +
		     if(format == "f") {
			 2 + pmax(xEx,0)
		     } else {# format == "fg"
			 pmax(xEx, digits,digits+(-xEx)+1) +
			     ifelse(flag!="",nchar(flag),0) + 1
		     }
	     } else # format == "g" or "e":
	     rep.int(digits+8, 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
    if (some.special)
	r[!Ok] <- format.char(rQ, width=width, flag=flag)

    if(big.mark != "" || small.mark != "" || decimal.mark != ".")
        r <- prettyNum(r, big.mark = big.mark, big.interval = big.interval,
                       small.mark = small.mark, small.interval = small.interval,
                       decimal.mark = decimal.mark)

    if (!is.null(x.atr <- attributes(x)))
	attributes(r) <- x.atr
    r
}

format.factor <- function(x, ...)
    format(as.character(x), ...)

format.data.frame <- function(x, ..., justify = "none")
{
    dims <- dim(x)
    nr <- dims[1]
    nc <- dims[2]
    rval <- vector("list", nc)
    for(i in 1:nc)
	rval[[i]] <- format(x[[i]], ..., justify = justify)
    lens <- sapply(rval, NROW)
    if(any(lens != nr)) { # corrupt data frame, must have at least one column
        warning("corrupt data frame: columns will be truncated or padded with NAs")
        for(i in 1:nc) {
            len <- NROW(rval[[i]])
            if(len == nr) next
            if(length(dim(rval[[i]])) == 2) {
                rval[[i]] <- if(len < nr)
                    rbind(rval[[i]], matrix(NA, nr-len, ncol(rval[[i]])))
                else rval[[i]][1:nr,]
            } else {
                rval[[i]] <- if(len < nr) c(rval[[i]], rep.int(NA, nr-len))
                else rval[[i]][1:nr]
            }
        }
    }
    dn <- dimnames(x)
    cn <- dn[[2]]
    m <- match(c("row.names", "check.rows", "check.names"), cn, 0)
    if(any(m > 0)) cn[m] <- paste("..dfd.", cn[m], sep="")
    names(rval) <- cn
    rval$check.names <- FALSE
    rval$row.names <- dn[[1]]
    x <- do.call("data.frame", rval)
    ## x will have more cols than rval if there are matrix/data.frame cols
    if(any(m > 0)) names(x) <- sub("^..dfd.", "", names(x))
    x
}

format.AsIs <- function(x, width = 12, ...)
{
    if(is.character(x)) return(format.default(x, ...))
    n <- length(x)
    rvec <- rep.int(as.character(NA), n)
    for(i in 1:n)
	rvec[i] <- toString(x[[i]], width, ...)
#    return(format.char(rvec, flag = "+"))
    ## AsIs might be around a matrix, which is not a class.
    dim(rvec) <- dim(x)
    format.default(rvec, justify = "right")
}

prettyNum <-
    function(x,
             big.mark = "", big.interval = 3,
             small.mark = "", small.interval = 5,
             decimal.mark = ".", ...)
{
    ## be fast in trivial case:
    if(!is.character(x))
        x <- sapply(x,format, ...)
    if(big.mark == "" && small.mark == "" && decimal.mark == ".")
        return(x)
    ## else
    x.sp <- strsplit(x, ".", fixed=TRUE)
    P0 <- function(...) paste(..., sep="")
    revStr <- function(cc)
        sapply(lapply(strsplit(cc,NULL), rev), paste, collapse="")
    B. <- sapply(x.sp, "[", 1)      # Before "."
    A. <- sapply(x.sp, "[", 2)      # After  "." ; empty == NA
    if(any(iN <- is.na(A.))) A.[iN] <- ""
    if(nchar(big.mark) &&
       length(i.big <- grep(P0("[0-9]{", big.interval + 1,",}"), B.))
       ) { ## add `big.mark' in decimals before "." :
        B.[i.big] <-
            revStr(gsub(P0("([0-9]{",big.interval,"})\\B"),
                        P0("\\1",big.mark), revStr(B.[i.big])))
    }
    if(nchar(small.mark) &&
       length(i.sml <- grep(P0("[0-9]{", small.interval + 1,",}"), A.))
       ) { ## add `small.mark' in decimals after "." :
        A.[i.sml] <- gsub(P0("([0-9]{",small.interval,"})"),
                          P0("\\1",small.mark), A.[i.sml])
    }
    ## extraneous trailing dec.marks: paste(B., A., sep = decimal.mark)
    P0(B., c(decimal.mark, "")[iN+ 1:1], A.)
}
subset.data.frame <-
    function (x, subset, select, drop = FALSE, ...)
{
    if(missing(subset))
	r <- TRUE
    else {
	e <- substitute(subset)
	r <- eval(e, x, parent.frame())
	r <- r & !is.na(r)
    }
    if(missing(select))
	vars <- TRUE
    else {
	nl <- as.list(1:ncol(x))
	names(nl) <- names(x)
	vars <- eval(substitute(select), nl, parent.frame())
    }
    x[r, vars, drop = drop]
}

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

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

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

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),...)

stack.data.frame <-
    function(x, select, ...)
{
    if (!missing(select)) {
	nl <- as.list(1:ncol(x))
	names(nl) <- names(x)
	vars <- eval(substitute(select),nl, parent.frame())
        x <- x[, vars, drop=FALSE]
    }
    x <- x[, unlist(lapply(x, is.vector)), drop = FALSE]
    data.frame(values = unlist(unname(x)),
               ind = factor(rep.int(names(x), lapply(x, length))))
}

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

stack.default <-
    function(x, ...)
{
    x <- as.list(x)
    x <- x[unlist(lapply(x, is.vector))]
    data.frame(values = unlist(unname(x)),
               ind = factor(rep.int(names(x), lapply(x, length))))
}

unstack.data.frame <-
    function(x, form = formula(x), ...)
{
    form <- as.formula(form)
    if (length(form) < 3)
        stop("form must be a two-sided formula")
    res <- c(tapply(eval(form[[2]], x), eval(form[[3]], x), as.vector))
    if (length(res) < 2 || any(diff(unlist(lapply(res, length))) != 0))
        return(res)
    data.frame(res)
}

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

unstack.default <-
    function(x, form, ...)
{
    x <- as.list(x)
    form <- as.formula(form)
    if (length(form) < 3)
        stop("form must be a two-sided formula")
    res <- c(tapply(eval(form[[2]], x), eval(form[[3]], x), as.vector))
    if (length(res) < 2 || any(diff(unlist(lapply(res, length))) != 0))
        return(res)
    data.frame(res)
}
get <-
    function (x, pos = -1, envir = as.environment(pos), mode = "any",
              inherits = TRUE)
    .Internal(get(x, envir, mode, inherits))

mget <- function(x, envir, mode = "any", 
          ifnotfound= list(function(x) 
	                stop(paste("value for \"", x, "\" not found", sep=""), 
				call.=FALSE)),
          inherits = FALSE)
     .Internal(mget(x, envir, mode, ifnotfound, inherits))
Sys.getenv <- function(x) {
    if (missing(x)) {
	x <- strsplit(.Internal(getenv(character())), "=", fixed=TRUE)
	v <- n <- character(LEN <- length(x))
	for (i in 1:LEN) {
	    n[i] <- x[[i]][1]
	    v[i] <- paste(x[[i]][-1], collapse = "=")
	}
	structure(v, names = n)
    } else {
	structure(.Internal(getenv(x)), names = x)
    }
}

Sys.putenv <- function(...)
{
    x <- list(...)
    nm <- names(x)
    val <- as.character(unlist(x))
    x <- paste(nm,val, sep="=")
    invisible(.Internal(putenv(x)))
}

Sys.getpid <- function() .Internal(getpid())
## gl function of GLIM
gl <- function (n, k, length = n*k, labels=1:n, ordered=FALSE)
    factor(rep(rep.int(1:n, rep.int(k,n)), length.out=length),
	   levels=1:n, labels=labels, ordered=ordered)
grep <-
function(pattern, x, ignore.case = FALSE, extended = TRUE, perl = FALSE,
         value = FALSE, fixed = FALSE)
{
  ## behaves like == for NA pattern
  if (is.na(pattern)){
    if(value)
      return(rep.int(as.character(NA), length(x)))
    else
      return(rep.int(NA, length(x)))
  }

  if(perl)
    .Internal(grep.perl(pattern, x, ignore.case, value))
  else
    .Internal(grep(pattern, x, ignore.case, extended, value, fixed))
}

sub <-
function(pattern, replacement, x, ignore.case = FALSE, extended = TRUE,
         perl = FALSE)
{
  if (is.na(pattern))
    return(rep.int(as.character(NA), length(x)))

    if(perl)
        .Internal(sub.perl(pattern, replacement, x, ignore.case))
    else
        .Internal(sub(pattern, replacement, x, ignore.case, extended))
}

gsub <-
function(pattern, replacement, x, ignore.case = FALSE, extended = TRUE,
         perl = FALSE)
{
  if (is.na(pattern))
    return(rep.int(as.character(NA), length(x)))

  if(perl)
        .Internal(gsub.perl(pattern, replacement, x, ignore.case))
    else
        .Internal(gsub(pattern, replacement, x, ignore.case, extended))
}

regexpr <-
function(pattern, text, extended = TRUE, perl = FALSE, fixed = FALSE)
{
    if(perl)
        .Internal(regexpr.perl(pattern, text))
    else
        .Internal(regexpr(pattern, text, extended, fixed))
}

agrep <-
function(pattern, x, ignore.case = FALSE, value = FALSE,
         max.distance = 0.1)
{
  ## behaves like == for NA pattern
   if (is.na(pattern)){
     if (value)
       return(rep.int(as.character(NA), length(x)))
     else
       return(rep.int(NA, length(x)))
   }

    if(!is.character(pattern)
       || (length(pattern) < 1)
       || ((n <- nchar(pattern)) == 0))
        stop("pattern must be a non-empty character string")

    if(!is.list(max.distance)) {
        if(!is.numeric(max.distance) || (max.distance < 0))
            stop("max.distance must be non-negative")
        if(max.distance < 1)            # transform percentages
            max.distance <- ceiling(n * max.distance)
        max.insertions <- max.deletions <- max.substitutions <-
            max.distance
    }
    else {
        ## partial matching
        table <- c("all", "deletions", "insertions", "substitutions")
        ind <- pmatch(names(max.distance), table)
        if(any(is.na(ind)))
            warning("unknown match distance components ignored")
        max.distance <- max.distance[!is.na(ind)]
        names(max.distance) <- table[ind]
        ## sanity checks
        comps <- unlist(max.distance)
        if(!all(is.numeric(comps)) || any(comps < 0))
            stop("max.distance components must be non-negative")
        ## extract restrictions
        if(is.null(max.distance$all))
            max.distance$all <- 0.1
        max.insertions <- max.deletions <- max.substitutions <-
            max.distance$all
        if(!is.null(max.distance$deletions))
            max.deletions <- max.distance$deletions
        if(!is.null(max.distance$insertions))
            max.insertions <- max.distance$insertions
        if(!is.null(max.distance$substitutions))
            max.substitutions <- max.distance$substitutions
        max.distance <- max.distance$all
        ## transform percentages
        if(max.distance < 1)
            max.distance <- ceiling(n * max.distance)
        if(max.deletions < 1)
            max.deletions <- ceiling(n * max.deletions)
        if(max.insertions < 1)
            max.insertions <- ceiling(n * max.insertions)
        if(max.substitutions < 1)
            max.substitutions <- ceiling(n * max.substitutions)
    }

    .Internal(agrep(pattern, x, ignore.case, value, max.distance,
                    max.deletions, max.insertions, max.substitutions))
}
identical <-
  function(x, y)
  .Internal(identical(x,y))
ifelse <-
    function (test, yes, no)
{
    storage.mode(test) <- "logical"
    ans <- test
    nas <- is.na(test)
    if (any(test[!nas]))
        ans[test] <- rep(yes, length.out = length(ans))[test]
    if (any(!test[!nas]))
        ans[!test] <- rep(no, length.out = length(ans))[!test]
    ans[nas] <- NA
    ans
}
index.search <- function(topic, path, file = "AnIndex", type = "help")
    .Internal(index.search(topic, path, file, .Platform$file.sep, type))

read.00Index <-
function(file)
{
    if(is.character(file)) {
        if(file == "") file <- stdin()
        else {
            file <- file(file, "r")
            on.exit(close(file))
        }
    }
    if(!inherits(file, "connection"))
        stop(paste("argument", sQuote("file"),
                   "must be a character string or connection"))

    y <- matrix("", nr = 0, nc = 2)
    x <- paste(readLines(file), collapse = "\n")

    ## <FIXME>
    ## We cannot necessarily assume that the 00Index-style file to be
    ## read in was generated by @code{R CMD Rdindex} or by R using
    ## formatDL(style = "table").  In particular, some packages have
    ## 00Index files with (section) headers and footers in addition to
    ## the data base chunks which are description lists rendered in
    ## tabular form.  Hence, we need some heuristic for identifying the
    ## db chunks.  Easy to the human eye (is there a column for aligning
    ## entries?) but far from trivial ... as a first approximation we
    ## try to consider chunks containing at least one tab or three
    ## spaces a db chunk.  (A better heuristic would be the following:
    ## entries rendered in one line have item and description separated
    ## by at least 3 spaces or tabs; entries with a line break have
    ## continuation lines starting with whitespace (no test whether for
    ## alignment).  If a chunk is made of such entries only it is
    ## considered a db chunk.  But not all current packages follow this
    ## scheme.  Argh.)
    ## Clearly we need to move to something better in future versions.
    ## </FIXME>

    ## First split into paragraph chunks separated by whitespace-only
    ## lines.
    for(chunk in unlist(strsplit(x, "\n[ \t\n]*\n"))) {
        entries <- try({
            if(regexpr("\(   \|\t\)", chunk) == -1)
                NULL
            else {
                ## Combine entries with continuation lines.
                chunk <- gsub("\n[ \t]+", "\t", chunk)
                ## Split into lines and then according to whitespace.
                x <- strsplit(unlist(strsplit(chunk, "\n")), "[ \t]")
                cbind(unlist(lapply(x, "[[", 1)),
                      unlist(lapply(x, function(t) {
                          paste(t[-c(1, which(nchar(t) == 0))],
                                collapse = " ")
                      })))
            }
        })
        if(!inherits(entries, "try-error") && NCOL(entries) == 2)
            y <- rbind(y, entries)
    }
    colnames(y) <- c("Item", "Description")
    y
}

print.libraryIQR <-
function(x, ...)
{
    db <- x$results
    ## Split according to LibPath.
    out <- if(nrow(db) == 0)
        NULL
    else lapply(split(1 : nrow(db), db[, "LibPath"]),
                function(ind) db[ind, c("Package", "Title"),
                                 drop = FALSE])
    outFile <- tempfile("RlibraryIQR")
    outConn <- file(outFile, open = "w")
    first <- TRUE
    for(lib in names(out)) {
        writeLines(paste(ifelse(first, "", "\n"),
                         "Packages in library ", sQuote(lib), ":\n",
                         sep = ""),
                   outConn)
        writeLines(formatDL(out[[lib]][, "Package"],
                            out[[lib]][, "Title"]),
                   outConn)
        first <- FALSE
    }
    if(first) {
        close(outConn)
        unlink(outFile)
        writeLines("no packages found")
    }
    else {
        if(!is.null(x$footer))
            writeLines(c("\n", x$footer), outConn)
        close(outConn)
        file.show(outFile, delete.file = TRUE,
                  title = "R packages available")
    }
    invisible(x)
}

print.packageIQR <-
function(x, ...)
{
    db <- x$results
    ## Split according to Package.
    out <- if(nrow(db) == 0)
         NULL
    else
        lapply(split(1 : nrow(db), db[, "Package"]),
               function(ind) db[ind, c("Item", "Title"),
                                drop = FALSE])
    outFile <- tempfile("RpackageIQR")
    outConn <- file(outFile, open = "w")
    first <- TRUE
    for(pkg in names(out)) {
        writeLines(paste(ifelse(first, "", "\n"), x$title,
                         " in package ", sQuote(pkg), ":\n",
                         sep = ""),
                   outConn)
        writeLines(formatDL(out[[pkg]][, "Item"],
                            out[[pkg]][, "Title"]),
                   outConn)
        first <- FALSE
    }
    if(first) {
        close(outConn)
        unlink(outFile)
        writeLines(paste("no", tolower(x$title), "found"))
    }
    else {
        if(!is.null(x$footer))
            writeLines(c("\n", x$footer), outConn)
        close(outConn)
        file.show(outFile, delete.file = TRUE,
                  title = paste("R", tolower(x$title)))
    }
    invisible(x)
}
### This is almost like the Primitive ":" for factors
### (that has no "drop = TRUE") --- it's not used anywhere in "standard R"
interaction <- function(..., drop=FALSE)
{
    args <- list(...)
    narg <- length(args)
    if (narg == 1 && is.list(args[[1]])) {
	args <- args[[1]]
	narg <- length(args)
    }
    ans <- 0
    lvs <- NULL
    for(i in narg:1) {
        f <- args[[i]]
	if (!is.factor(f))
	    f <- factor(f)
	l <- levels(f)
	ans <- ans * length(l) + as.integer(f) - 1
	lvs <- if (i == narg) l	else as.vector(outer(l, lvs, paste, sep="."))
    }
    ans <- ans + 1
    if (drop) {
	f <- unique(ans[!is.na(ans)])
	ans <- match(ans, f)
	lvs <- lvs[f]
    }
    ans <- as.integer(ans)
    levels(ans) <- lvs
    class(ans) <- "factor"
    ans
}
is.vector <- function(x, mode="any") .Internal(is.vector(x,mode))
## is.finite <- function(x) !is.na(x)

is.name <- is.symbol # which is Primitive
##Was is.symbol <- function(x) typeof(x)=="symbol"


"is.na<-" <- function(x, value) UseMethod("is.na<-")

"is.na<-.default" <- function(x, value)
{
    x[value] <- NA
    x
}
### Unimplemented Idea {for amount = NULL ?}
### Really "optimal" (e.g. for rug()), use a non-constant amount,
### e.g. use "d" = diff(xx)  BEFORE  taking min()...

jitter <- function(x, factor = 1, amount=NULL)
{
    if(length(x) == 0)
	return(x)
    z <- diff(r <- range(x[is.finite(x)]))
    if(z == 0) z <- abs(r[1])
    if(z == 0) z <- 1

    if(is.null(amount)) {		# default: Find 'necessary' amount
	d <- diff(xx <- unique(sort(round(x, 3 - floor(log10(z))))))
	d <- if(length(d)) min(d) else if(xx!=0) xx/10 else z/10
	amount <- factor/5 * d
    } else if(amount == 0)		# only then: S compatibility
	amount <- factor * (z/50)

    x + runif(length(x),  - amount, amount)
}
kappa <- function(z, ...) UseMethod("kappa")

kappa.lm <- function(z, ...)
{
    kappa.qr(z$qr, ...)
}

kappa.default <- function(z, exact = FALSE, ...)
{
    z <- as.matrix(z)
    if(exact) {
	s <- svd(z, nu=0, nv=0)$d
	max(s)/min(s[s > 0])
    } else if(is.qr(z)) kappa.qr(z)
    else if(nrow(z) < ncol(z)) kappa.qr(qr(t(z)))
    else kappa.qr(qr(z))
}

kappa.qr <- function(z, ...)
{
    qr <- z$qr
    R <- qr[1:min(dim(qr)), , drop = FALSE]
    R[lower.tri(R)] <- 0
    kappa.tri(R, ...)
}

kappa.tri <- function(z, exact = FALSE, ...)
{
    if(exact) kappa.default(z)
    else {
	p <- nrow(z)
	if(p != ncol(z)) stop("matrix should be square")
	1 / .Fortran("dtrco",
		     as.double(z),
		     p,
		     p,
		     k = double(1),
		     double(p),
		     as.integer(1),
                     PACKAGE="base")$k
    }
}
"kronecker" <-
function (X, Y, FUN = "*", make.dimnames = FALSE, ...)
{
    X <- as.array(X)
    Y <- as.array(Y)
    if (make.dimnames) {
      dnx <- dimnames(X)
      dny <- dimnames(Y)
    }
    dX <- dim(X)
    dY <- dim(Y)
    ld <- length(dX) - length(dY)
    if (ld < 0)
        dX <- dim(X) <- c(dX, rep.int(1, -ld))
    else if (ld > 0)
        dY <- dim(Y) <- c(dY, rep.int(1, ld))
    opobj <- outer(X, Y, FUN, ...)
    dp <- as.vector(t(matrix(1:(2*length(dX)), ncol = 2)[, 2:1]))
    opobj <- aperm(opobj, dp)
    dim(opobj) <- dX * dY

    if (make.dimnames && !(is.null(dnx) && is.null(dny))) {

        if (is.null(dnx))
            dnx <- rep.int(list(NULL), length(dX))
        else if (ld < 0)
            dnx <- c(dnx, rep.int(list(NULL), -ld))
        tmp <- which(sapply(dnx, is.null))
        dnx[tmp] <- lapply(tmp, function(i) rep.int("", dX[i]))

        if (is.null(dny))
            dny <- rep.int(list(NULL), length(dY))
        else if (ld > 0)
            dny <- c(dny, rep.int(list(NULL), ld))
        tmp <- which(sapply(dny, is.null))
        dny[tmp] <- lapply(tmp, function(i) rep.int("", dY[i]))

        k <- length(dim(opobj))
        dno <- vector("list", k)
        for (i in 1:k) {
            tmp <- outer(dnx[[i]], dny[[i]], FUN="paste", sep=":")
            dno[[i]] <- as.vector(t(tmp))
        }
        dimnames(opobj) <- dno
    }
    opobj
}

## Binary operator, hence don't simply do "%x%" <- kronecker.
"%x%" <- function(X, Y) kronecker(X, Y)
labels <- function(object, ...) UseMethod("labels")

labels.default <- function(object, ...)
{
    if(length(d <- dim(object))) {	# array or data frame
	nt <- dimnames(object)
	if(is.null(nt)) nt <- vector("list", length(d))
	for(i in 1:length(d))
	    if(!length(nt[[i]])) nt[[i]] <- as.character(seq(length = d[i]))
    } else {
	nt <- names(object)
	if(!length(nt)) nt <- as.character(seq(along = object))
    }
    nt
}

labels.terms <- function(object, ...) attr(object, "term.labels")

labels.lm <- function(object, ...)
{
    tl <- attr(object$terms, "term.labels")
    asgn <- object$asgn[object$qr$pivot[1:object$rank]]
    tl[unique(asgn)]
}
lapply <- function (X, FUN, ...)
{
    FUN <- match.fun(FUN)
    if (!is.list(X)) X <- as.list(X)
    rval <-.Internal(lapply(X, FUN))
    names(rval) <- names(X)
    return(rval)
}
if(FALSE) {
lapply <- function(X, FUN, ...) {
    FUN <- match.fun(FUN)
    if (!is.list(X))
	X <- as.list(X)
    rval <- vector("list", length(X))
    for(i in seq(along = X))
	rval[i] <- list(FUN(X[[i]], ...))
    names(rval) <- names(X)		  # keep `names' !
    return(rval)
}
}
library <-
function(package, help, pos = 2, lib.loc = NULL, character.only = FALSE,
         logical.return = FALSE, warn.conflicts = TRUE,
         keep.source = getOption("keep.source.pkgs"),
         verbose = getOption("verbose"), version)
{
    testRversion <- function(fields)
    {
        current <- paste(R.version[c("major", "minor")], collapse = ".")
        ## depends on R version?
        if(!package.dependencies(fields, check = TRUE)) {
            dep <- package.dependencies(fields)[[1]]
            o <- match("R", dep[, 1])
            stop(paste("This is R ", current, ", package ",
                       fields[1, "Package"],
                       " needs ", dep[o, 2], " ", dep[o, 3], sep=""),
                 call. = FALSE)
        }
        ## which version was this package built under?
        if(!is.na(built <- fields[1, "Built"])) {
            builtFields <- strsplit(built, ";", fixed=TRUE)[[1]]
            builtunder <- substring(builtFields[1], 3)
            if(nchar(builtunder) &&
               compareVersion(current, builtunder) < 0) {
                warning(paste("package", fields[1, "Package"],
                              "was built under R version", builtunder),
                        call. = FALSE)
            }
            if(.Platform$OS.type == "unix") {
                platform <- builtFields[2]
                if(length(grep("\\w", platform))) {
                    ## allow for small mismatches, e.g. OS version number.
                    m <- agrep(platform, R.version$platform)
                    if(!length(m))
                        stop(paste("package", fields[1, "Package"],
                                   "was built for", platform),
                             call. = FALSE)
		}
            }
        }
        else
            stop(paste("This package has not been installed properly\n",
                       "See the Note in ?library"))
    }

    checkNoGenerics <- function(env, pkg)
    {
        nenv <- env
        ns <- .Internal(getRegisteredNamespace(as.name(libraryPkgName(pkg))))
        if(!is.null(ns)) nenv <- asNamespace(ns)
        if (exists(".noGenerics", envir = nenv, inherits = FALSE))
            TRUE
        else {
            ## A package will have created a generic
            ## only if it has created a formal method.
            length(objects(env, pattern="^\\.__M", all=TRUE)) == 0
        }
    }

    checkConflicts <- function(package, pkgname, pkgpath, nogenerics)
    {
        dont.mind <- c("last.dump", "last.warning", ".Last.value",
                       ".Random.seed", ".First.lib", ".Last.lib",
                       ".packageName", ".noGenerics", ".required")
        sp <- search()
        lib.pos <- match(pkgname, sp)
        ## ignore generics not defined for the package
        ob <- objects(lib.pos, all = TRUE)
        if(!nogenerics && .isMethodsDispatchOn()) {
            these <- objects(lib.pos, all = TRUE)
            these <- these[substr(these, 1, 6) == ".__M__"]
            gen <- gsub(".__M__(.*):([^:]+)", "\\1", these)
            from <- gsub(".__M__(.*):([^:]+)", "\\2", these)
            gen <- gen[from != ".GlobalEnv"]
            ob <- ob[!(ob %in% gen)]
        }
        fst <- TRUE
        ipos <- seq(along = sp)[-c(lib.pos, match("Autoloads", sp))]
        for (i in ipos) {
            obj.same <- match(objects(i, all = TRUE), ob, nomatch = 0)
            if (any(obj.same > 0)) {
                same <- ob[obj.same]
                same <- same[!(same %in% dont.mind)]
                Classobjs <- grep("^\\.__", same)
                if(length(Classobjs)) same <- same[-Classobjs]
                if(length(same)) {
                    if (fst) {
                        fst <- FALSE
                        cat("\nAttaching package ", sQuote(package),
                            ":\n\n", sep = "")
                    }
                    cat("\n\tThe following object(s) are masked",
                        if (i < lib.pos) "_by_" else "from", sp[i],
                        ":\n\n\t", same, "\n\n")
                }
            }
        }
    }

    libraryPkgName <- function(pkgName, sep = "_")
	unlist(strsplit(pkgName, sep, fixed=TRUE))[1]

    libraryPkgVersion <- function(pkgName, sep = "_")
    {
        splitName <- unlist(strsplit(pkgName, sep, fixed=TRUE))
	if (length(splitName) > 1) splitName[2] else NULL
    }

    libraryMaxVersPos <- function(vers)
    {
	## Takes in a character vector of version numbers
        ## returns the position of the maximum version utilizing
        ## compareVersion.  Can't do as.numeric due to the "-" in versions.
	max <- vers[1]

        for (ver in vers) if (compareVersion(max, ver) < 0) max <- ver
	out <- match(max, vers)
	out
    }

    runUserHook <- function(pkgname, pkgpath) {
        hook <- getHook(packageEvent(pkgname, "attach")) # might be list()
        for(fun in hook) try(fun(pkgname, pkgpath))
    }

    if(!missing(package)) {
        if (is.null(lib.loc)) lib.loc <- .libPaths()
        
	if(!character.only)
	    package <- as.character(substitute(package))

	if (!missing(version)) {
	     package <- manglePackageName(package, version)
        } else {
	   ## Need to find the proper package to install
	   pkgDirs <- list.files(lib.loc,
                                 pattern = paste("^", package, sep=""))
           ## See if any directories in lib.loc match the pattern of
           ## 'package', if none do, just continue as it will get caught
           ## below.  Otherwise, if there is actually a 'package', use
           ## that, and if not, then use the highest versioned dir.
	   if (length(pkgDirs) > 0) {
	       if (!(package %in% pkgDirs)) {
		   ## Need to find the highest version available
		   vers <- unlist(lapply(pkgDirs, libraryPkgVersion))
		   pos <- libraryMaxVersPos(vers)
		   if (length(pos) > 0) package <- pkgDirs[pos]
               }
           }
        }

        ## NB from this point on `package' is either the original name or
        ## something like ash_1.0-8
        if(length(package) != 1)
            stop(paste("argument", sQuote("package"), "must be of length 1"))
	pkgname <- paste("package", package, sep = ":")
	newpackage <- is.na(match(pkgname, search()))
	if(newpackage) {
            ## Check for the methods package before attaching this
            ## package.
            ## Only if it is _already_ here do we do cacheMetaData.
            ## The methods package caches all other libs when it is
            ## attached.

            pkgpath <- .find.package(package, lib.loc, quiet = TRUE,
                                     verbose = verbose)
            if(length(pkgpath) == 0) {
               txt <- paste("There is no package called",
			     sQuote(libraryPkgName(package)))
		vers <- libraryPkgVersion(package)
		if (!is.null(vers))
		   txt <- paste(txt, ", version ", vers, sep="")
                if(logical.return) {
                    warning(txt)
		    return(FALSE)
		} else stop(txt)
            }
            which.lib.loc <- dirname(pkgpath)
            descfile <- system.file("DESCRIPTION", package = package,
                                    lib.loc = which.lib.loc)
            if(!nchar(descfile))
            	stop("This is not a valid package -- no DESCRIPTION exists")

            descfields <- read.dcf(descfile, fields =
                                   c("Package", "Depends", "Built"))
            testRversion(descfields)

            ## Check for inconsistent naming
            if(descfields[1, "Package"] != libraryPkgName(package)) {
            	warning(paste("Package", sQuote(package), "not found.\n",
			"Using case-insensitive match",
            		sQuote(descfields[1, "Package"]), ".\n",
			"Future versions of R will require exact matches."),
			call.=FALSE)
            	package <- descfields[1, "Package"]
            	pkgname <- paste("package", package, sep = ":")
            	newpackage <- is.na(match(pkgname, search()))
	    }
            if(is.character(pos)) {
                npos <- match(pos, search())
                if(is.na(npos)) {
                    warning(paste(sQuote(pos),
                                  "not found on search path, using",
                                  sQuote("pos=2")))
                    pos <- 2
                } else pos <- npos
            }
            if(newpackage) {
		## If the name space mechanism is available and the package
		## has a name space, then the name space loading mechanism
		## takes over.
		if (packageHasNamespace(package, which.lib.loc)) {
		    tt <- try({
			ns <- loadNamespace(package, c(which.lib.loc, lib.loc))
			env <- attachNamespace(ns, pos = pos)
		    })
		    if (inherits(tt, "try-error"))
			if (logical.return)
			    return(FALSE)
			else stop("package/namespace load failed")
		    else {
			on.exit(do.call("detach", list(name = pkgname)))
			nogenerics <- checkNoGenerics(env, package)
			if(warn.conflicts &&
			   !exists(".conflicts.OK", envir = env, inherits = FALSE))
                            checkConflicts(package, pkgname, pkgpath, nogenerics)

                        if(!nogenerics && .isMethodsDispatchOn() &&
                           !identical(pkgname, "package:methods"))
                            methods::cacheMetaData(env, TRUE, searchWhere = .GlobalEnv)
                        runUserHook(package, pkgpath)
			on.exit()
			if (logical.return)
			    return(TRUE)
			else
			    return(invisible(.packages()))
		    }
		}
		codeFile <- file.path(which.lib.loc, package, "R",
				      libraryPkgName(package))
		## create environment (not attached yet)
		loadenv <- new.env(hash = TRUE, parent = .GlobalEnv)
		## save the package name in the environment
		assign(".packageName", package, envir = loadenv)
		## source file into loadenv
		if(file.exists(codeFile))
		    sys.source(codeFile, loadenv, keep.source = keep.source)
		else if(verbose)
		    warning(paste("Package ", sQuote(package),
				  "contains no R code"))
		## now transfer contents of loadenv to an attached frame
		env <- attach(NULL, pos = pos, name = pkgname)
		## detach does not allow character vector args
		on.exit(do.call("detach", list(name = pkgname)))
		attr(env, "path") <- file.path(which.lib.loc, package)
		## the actual copy has to be done by C code to avoid forcing
		## promises that might have been created using delay().
		.Internal(lib.fixup(loadenv, env))

		## run .First.lib
		if(exists(".First.lib", mode = "function",
                          envir = env, inherits = FALSE)) {
		    firstlib <- get(".First.lib", mode = "function",
                                    envir = env, inherits = FALSE)
		    tt<- try(firstlib(which.lib.loc, package))
		    if(inherits(tt, "try-error"))
			if (logical.return) return(FALSE)
			else stop(".First.lib failed")
		}
		if(!is.null(firstlib <- getOption(".First.lib")[[package]])){
		    tt<- try(firstlib(which.lib.loc, package))
		    if(inherits(tt, "try-error"))
			if (logical.return) return(FALSE)
			else stop(".First.lib failed")
		}
		nogenerics <- checkNoGenerics(env, package)
		if(warn.conflicts &&
		   !exists(".conflicts.OK", envir = env, inherits = FALSE))
		    checkConflicts(package, pkgname, pkgpath, nogenerics)

		if(!nogenerics && .isMethodsDispatchOn() &&
		   !identical(pkgname, "package:methods"))
                    methods::cacheMetaData(env, TRUE, searchWhere = .GlobalEnv)
                runUserHook(package, pkgpath)
		on.exit()
	    }
	}
	if (verbose && !newpackage)
            warning(paste("Package", sQuote(package),
                          "already present in search()"))
    }
    else if(!missing(help)) {
	if(!character.only)
	    help <- as.character(substitute(help))
        pkgName <- help[1]              # only give help on one package
        pkgPath <- .find.package(pkgName, lib.loc, verbose = verbose)
        docFiles <- file.path(pkgPath, c("DESCRIPTION", "INDEX"))
        ## This is a bit ugly, but in the future we might also have
        ## DESCRIPTION or INDEX files as serialized R objects ...
        if(file.exists(vignetteIndexRDS <-
                       file.path(pkgPath, "Meta", "vignette.rds")))
            docFiles <- c(docFiles, vignetteIndexRDS)
        else
            docFiles <- c(docFiles,
                          file.path(pkgPath, "doc", "00Index.dcf"))
        pkgInfo <- vector(length = 4, mode = "list")
        pkgInfo[[1]] <- paste("\n\t\tInformation on Package",
                              sQuote(pkgName))
        readDocFile <- function(f) {
            if(basename(f) %in% c("DESCRIPTION", "00Index.dcf")) {
                ## This should be in valid DCF format ...
                txt <- try(read.dcf(f))
                if(inherits(txt, "try-error")) {
                    warning(paste("file",
                                  sQuote(f),
                                  "is not in valid DCF format"))
                    return(NULL)
                }
                ## Return a list so that the print method knows to
                ## format as a description list (if non-empty).
                txt <- if(all(dim(txt) >= 1))
                    list(colnames(txt), as.character(txt[1, ]))
                else
                    NULL
            }
            else if(basename(f) %in% c("vignette.rds")) {
                txt <- .readRDS(f)
                ## New-style vignette indexes are data frames with more
                ## info than just the base name of the PDF file and the
                ## title.  For such an index, we give the names of the
                ## vignettes, their titles, and indicate whether PDFs
                ## are available.
                ## The index might have zero rows.
                txt <- if(is.data.frame(txt) && nrow(txt))
                    cbind(basename(gsub("\\.[[:alpha:]]+$", "",
                                        txt$File)),
                          paste(txt$Title,
                                paste(rep.int("(source", NROW(txt)),
                                      ifelse(txt$PDF != "",
                                             ", pdf",
                                             ""),
                                      ")", sep = "")))
                else NULL
            }
            else
                txt <- readLines(f)
            txt
        }
        for(i in which(file.exists(docFiles)))
            pkgInfo[[i+1]] <- readDocFile(docFiles[i])
        y <- list(name = pkgName, path = pkgPath, info = pkgInfo)
        class(y) <- "packageInfo"
        return(y)
    }
    else {
	## library():
        if(is.null(lib.loc))
            lib.loc <- .libPaths()
        db <- matrix(character(0), nr = 0, nc = 3)
        nopkgs <- character(0)

        for(lib in lib.loc) {
            a <- .packages(all.available = TRUE, lib.loc = lib)
            for(i in sort(a)) {
                title <- packageDescription(i, lib.loc = lib, field="Title")
                if(is.na(title)) title <- ""
                db <- rbind(db, cbind(i, lib, title))
            }
            if(length(a) == 0)
                nopkgs <- c(nopkgs, lib)
        }
        colnames(db) <- c("Package", "LibPath", "Title")
        if((length(nopkgs) > 0) && !missing(lib.loc)) {
            if(length(nopkgs) > 1)
                warning(paste("libraries",
                              paste(sQuote(nopkgs), collapse = ", "),
                              "contain no packages"))
            else
                warning(paste("library",
                              paste(sQuote(nopkgs)),
                              "contains no package"))
        }

        y <- list(header = NULL, results = db, footer = NULL)
        class(y) <- "libraryIQR"
        return(y)
    }

    if (logical.return)
	TRUE
    else invisible(.packages())
}

library.dynam <-
function(chname, package = .packages(), lib.loc = NULL, verbose =
         getOption("verbose"), file.ext = .Platform$dynlib.ext, ...)
{
    .Dyn.libs <- .dynLibs()
    if(missing(chname) || (ncChname <- nchar(chname)) == 0)
        return(.Dyn.libs)
    ncFileExt <- nchar(file.ext)
    if(substr(chname, ncChname - ncFileExt + 1, ncChname) == file.ext)
        chname <- substr(chname, 1, ncChname - ncFileExt)
    if(is.na(match(chname, .Dyn.libs))) {
        for(pkg in .find.package(package, lib.loc, verbose = verbose)) {
            file <- file.path(pkg, "libs",
                              paste(chname, file.ext, sep = ""))
            if(file.exists(file)) break
            else
                file <- ""
        }
        if(file == "") {
            stop(paste("shared library", sQuote(chname), "not found"))
        }
        if(verbose)
            cat("now dyn.load(", file, ") ...\n", sep = "")
        dyn.load(file, ...)
        .dynLibs(c(.Dyn.libs, chname))
    }
    invisible(.dynLibs())
}

library.dynam.unload <-
function(chname, libpath, verbose = getOption("verbose"),
         file.ext = .Platform$dynlib.ext)
{
    .Dyn.libs <- .dynLibs()
    if(missing(chname) || (ncChname <- nchar(chname)) == 0)
        stop("no shared library was specified")
    ncFileExt <- nchar(file.ext)
    if(substr(chname, ncChname - ncFileExt + 1, ncChname) == file.ext)
        chname <- substr(chname, 1, ncChname - ncFileExt)
    num <- match(chname, .Dyn.libs, 0)
    if(is.na(num))
        stop(paste("shared library", sQuote(chname), "was not loaded"))
    file <- file.path(libpath, "libs", paste(chname, file.ext, sep = ""))
    if(!file.exists(file))
        stop(paste("shared library", sQuote(chname), "not found"))
    if(verbose)
        cat("now dyn.unload(", file, ") ...\n", sep = "")
    dyn.unload(file)
    .dynLibs(.Dyn.libs[-num])
    invisible(.dynLibs())
}

require <-
function(package, quietly = FALSE, warn.conflicts = TRUE,
         keep.source = getOption("keep.source.pkgs"),
         character.only = FALSE, version, save = TRUE)
{
    if( !character.only )
        package <- as.character(substitute(package)) # allowing "require(eda)"
    if (missing(version))
        pkgName <- package
    else
        pkgName <- manglePackageName(package, version)


    if (is.na(match(paste("package", pkgName, sep = ":"), search()))) {
	if (!quietly) cat("Loading required package:", package, "\n")
	value <- library(package, character.only = TRUE, logical = TRUE,
		warn.conflicts = warn.conflicts, keep.source = keep.source,
                version = version)
    } else value <- TRUE

    if(identical(save, FALSE)) {}
    else {
        ## update the ".required" variable
        if(identical(save, TRUE)) {
            save <- topenv(parent.frame())
            ## (a package namespace, topLevelEnvironment option or
            ## .GlobalEnv)
            if(identical(save, .GlobalEnv)) {
                ## try to detect call from .First.lib in  a package
                ## <FIXME>
                ## Although the docs have long and perhaps always had
                ##   .First.lib(libname, pkgname)
                ## the majority of CRAN packages seems to use arguments
                ## 'lib' and 'pkg'.
                objectsInParentFrame <- sort(objects(parent.frame()))
                if(identical(sort(c("libname", "pkgname")),
                             objectsInParentFrame))
                    save <-
                        as.environment(paste("package:",
                                             get("pkgname",
                                                 parent.frame()),
                                             sep = ""))
                else if(identical(sort(c("lib", "pkg")),
                                  objectsInParentFrame))
                    save <-
                        as.environment(paste("package:",
                                             get("pkg",
                                                 parent.frame()),
                                             sep = ""))
                ## </FIXME>
                ## else either from prompt or in the source for install
                ## with saved image ?
            }
        }
        else
            save <- as.environment(save)
        hasDotRequired <- exists(".required", save, inherits=FALSE)
        if(!isNamespace(save) || hasDotRequired) { ## so assignment allowed
            if(hasDotRequired)
                packages <- unique(c(package, get(".required", save)))
            else
                packages <- package
            assign(".required", packages, save)
        }
    }
    value
}

.packages <- function(all.available = FALSE, lib.loc = NULL)
{
    if(is.null(lib.loc))
        lib.loc <- .libPaths()
    if(all.available) {
	ans <- character(0)
        lib.loc <- lib.loc[file.exists(lib.loc)]
        for(lib in lib.loc) {
            a <- list.files(lib, all.files = FALSE, full.names = FALSE)
            for(nam in a) {
                if(file.exists(file.path(lib, nam, "DESCRIPTION")))
                    ans <- c(ans, nam)
            }
        }
        return(unique(ans))
    } ## else
    s <- search()
    return(invisible(substring(s[substr(s, 1, 8) == "package:"], 9)))
}

.path.package <- function(package = .packages(), quiet = FALSE)
{
    if(length(package) == 0) return(character(0))
    s <- search()
    searchpaths <-
        lapply(1:length(s), function(i) attr(as.environment(i), "path"))
    searchpaths[[length(s)]] <- system.file()
    pkgs <- paste("package", package, sep = ":")
    pos <- match(pkgs, s)
    if(any(m <- is.na(pos))) {
        if(!quiet) {
            if(all(m))
                stop(paste("none of the packages are loaded"))
            else
                warning(paste("package(s)",
                              paste(package[m], collapse=", "),
                              "are not loaded"))
        }
        pos <- pos[!m]
    }
    unlist(searchpaths[pos], use.names = FALSE)
}

.find.package <-
    function(package, lib.loc = NULL, quiet = FALSE,
             verbose = getOption("verbose"))
{
    .filePathAsAbsolute <- function(x) {
        ## Note that we cannot use tools::filePathAsAbsolute() here, as
        ## cyclic name space dependencies are not supported.  Argh.
        ## This version is simpler: we only need it for directories
        ## already known to exist.
        cwd <- getwd(); on.exit(setwd(cwd))
        setwd(path.expand(x))
        getwd()
    }

    useAttached <- FALSE
    if(is.null(lib.loc)) {
        useAttached <- TRUE
        lib.loc <- .libPaths()
    }

    n <- length(package)
    if(n == 0) return(character(0))

    bad <- character(0)                 # names of packages not found
    paths <- character(0)               # paths to packages found

    for(pkg in package) {
        fp <- file.path(lib.loc, pkg)
        if(useAttached)
            fp <- c(.path.package(pkg, TRUE), fp)
        ## Note that we cannot use tools::fileTest() here, as cyclic
        ## name space dependencies are not supported.  Argh.
        fp <- unique(fp[file.exists(fp) &
                        file.exists(file.path(fp, "DESCRIPTION"))])
        if(length(fp) == 0) {
            bad <- c(bad, pkg)
            next
        }
        afp <- .filePathAsAbsolute(fp[1])
        if(verbose && (length(fp) > 1))
            warning(paste("package ", sQuote(pkg),
                          " found more than once,\n",
                          "using the one found in ",
                          sQuote(dirname(afp)),
                          sep = ""))
        paths <- c(paths, afp)
    }

    if(!quiet && (length(bad) > 0)) {
        if(length(paths) == 0)
            stop("none of the packages were found")
        for(pkg in bad)
            warning(paste("there is no package called", sQuote(pkg)))
    }

    paths
}

print.packageInfo <- function(x, ...)
{
    if(!inherits(x, "packageInfo")) stop("wrong class")
    outFile <- tempfile("RpackageInfo")
    outConn <- file(outFile, open = "w")
    vignetteMsg <-
        paste("Further information is available in the following ",
              "vignettes in directory ",
              sQuote(file.path(x$path, "doc")),
              ":",
              sep = "")
    headers <- c("", "Description:\n\n", "Index:\n\n",
                 paste(paste(strwrap(vignetteMsg), collapse = "\n"),
                       "\n\n", sep = ""))
    footers <- c("\n", "\n", "\n", "")
    formatDocEntry <- function(entry) {
        if(is.list(entry) || is.matrix(entry))
            formatDL(entry, style = "list")
        else
            entry
    }
    for(i in which(!sapply(x$info, is.null))) {
        writeLines(headers[i], outConn, sep = "")
        writeLines(formatDocEntry(x$info[[i]]), outConn)
        writeLines(footers[i], outConn, sep = "")
    }
    close(outConn)
    file.show(outFile, delete.file = TRUE,
              title = paste("Documentation for package",
              sQuote(x$name)))
    invisible(x)
}

manglePackageName <- function(pkgName, pkgVersion)
    paste(pkgName, "_", pkgVersion, sep = "")
licence <- license <- function() {
    cat("\nThis software is distributed under the terms of the GNU GENERAL\n")
    cat("PUBLIC LICENSE Version 2, June 1991.  The terms of this license\n")
    cat("are in a file called COPYING which you should have received with\n")
    cat("this software.\n")
    cat("\n")
    cat("If you have not received a copy of this file, you can obtain one\n")
    cat("via WWW at http://www.gnu.org/copyleft/gpl.html, or by writing to:\n")
    cat("\n")
    cat("   The Free Software Foundation, Inc.,\n")
    cat("   59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.\n")
    cat("\n")
    cat("A small number of files (the API header files and export files,\n")
    cat("listed in R_HOME/COPYRIGHTS) are distributed under the\n")
    cat("LESSER GNU GENERAL PUBLIC LICENSE version 2.1.\n")
    cat("This can be obtained via WWW at\n")
    cat("http://www.gnu.org/copyleft/lgpl.html, or by writing to the\n")
    cat("address above\n")
    cat("\n")
    cat("``Share and Enjoy.''\n\n")
}
load <- function (file, envir = parent.frame())
{
    if (is.character(file)) {
        ## As zlib is available just open with gzfile, whether file
        ## is compressed or not; zlib works either way.
        con <- gzfile(file)
        on.exit(close(con))
    }
    else if (inherits(file, "connection")) con <- gzcon(file)
    else stop("bad file argument")
    if(!isOpen(con)) {
        ## code below assumes that the connection is open ...
        open(con, "rb")
    }

    magic <- readChar(con, 5)

    if (regexpr("RD[AX]2\n", magic) == -1) {
        ## Not a version 2 magic number, so try the old way.
        if (is.character(file)) {
            close(con)
            on.exit()
        }
        else stop("loading from connections not compatible with magic number")
        .Internal(load(file, envir))
    }
    else .Internal(loadFromConn(con, envir))
}

save <- function(..., list = character(0),
                 file = stop("'file' must be specified"),
                 ascii = FALSE, version = NULL, envir = parent.frame(),
                 compress = FALSE)
{
    opts <- getOption("save.defaults")
    if (missing(compress) && ! is.null(opts$compress))
        compress <- opts$compress
    if (missing(ascii) && ! is.null(opts$ascii))
        ascii <- opts$ascii
    if (missing(version)) version <- opts$version
    
    names <- as.character( substitute( list(...)))[-1]
    list<- c(list, names)
    if (! is.null(version) && version == 1)
        invisible(.Internal(save(list, file, ascii, version, envir)))
    else {
        if (is.character(file)) {
            if (file == "") stop("`file' must be non-empty string")
            if (compress && capabilities("libz")) con <- gzfile(file, "wb")
            else con <- file(file, "wb")
            on.exit(close(con))
        }
        else if (inherits(file, "connection"))
            con <- file
        else stop("bad file argument")
        invisible(.Internal(saveToConn(list, con, ascii, version, envir)))
    }
}

save.image <- function (file = ".RData", version = NULL, ascii = FALSE,
                        compress = FALSE, safe = TRUE) {
    if (! is.character(file) || file == "")
        stop("`file' must be non-empty string")

    opts <- getOption("save.image.defaults")
    if(is.null(opts)) opts <- getOption("save.defaults")
        
    if (missing(safe) && ! is.null(opts$safe))
        safe <- opts$safe
    if (missing(compress) && ! is.null(opts$compress))
        compress <- opts$compress
    if (missing(ascii) && ! is.null(opts$ascii))
        ascii <- opts$ascii
    if (missing(version)) version <- opts$version

    if (safe) {
        ## find a temporary file name in the same directory so we can
        ## rename it to the final output file on success
        outfile <- paste(file, "Tmp", sep = "")
        i <- 0;
        while (file.exists(outfile)) {
            i <- i + 1
            outfile <- paste(file, "Tmp", i, sep = "")
        }
    }
    else outfile <- file

    on.exit(file.remove(outfile))
    save(list = ls(envir = .GlobalEnv, all.names = TRUE), file = outfile,
         version = version, ascii = ascii, compress = compress,
         envir = .GlobalEnv)
    if (safe)
        if (! file.rename(outfile, file)) {
            on.exit()
            stop(paste("image could not be renamed and is left in", outfile))
        }
    on.exit()
}

sys.load.image <- function(name, quiet) {
    if (file.exists(name)) {
        load(name, envir = .GlobalEnv)
        if (! quiet)
	    cat("[Previously saved workspace restored]\n\n")
    }
}

sys.save.image <- function(name)
{
    ## Ensure that there is a reasonable chance that we can open a
    ## connection.
    closeAllConnections()
    save.image(name)
}

loadURL <- function (url, envir = parent.frame(), quiet = TRUE, ...)
{
    tmp <- tempfile("url")
    download.file(url, tmp, quiet = quiet, ...)
    on.exit(unlink(tmp))
    load(tmp, envir = envir)
}
Sys.getlocale <- function(category = "LC_ALL")
{
    category <- match(category, c("LC_ALL", "LC_COLLATE", "LC_CTYPE",
                                  "LC_MONETARY", "LC_NUMERIC", "LC_TIME"))
    if(is.na(category)) stop("invalid `category' argument")
    .Internal(getlocale(category))
}

Sys.setlocale <- function(category = "LC_ALL", locale = "")
{
    category <- match(category, c("LC_ALL", "LC_COLLATE", "LC_CTYPE",
                                  "LC_MONETARY", "LC_NUMERIC", "LC_TIME"))
    if(is.na(category)) stop("invalid `category' argument")
    .Internal(setlocale(category, locale))
}

Sys.localeconv <- function() .Internal(localeconv())
log10 <- function(x) log(x,10)
log2 <- function(x) log(x,2)
lower.tri <- function(x, diag = FALSE)
{
    x <- as.matrix(x)
    if(diag) row(x) >= col(x)
    else row(x) > col(x)
}
mapply<-function(FUN,..., MoreArgs=NULL, SIMPLIFY=TRUE, USE.NAMES=TRUE)
{
    FUN <- match.fun(FUN)
    dots <- list(...)

    answer<-.Call("do_mapply", FUN, dots, MoreArgs, environment(),
                  PACKAGE="base")

    if (USE.NAMES && length(dots) && is.character(dots[[1]]) &&
        is.null(names(answer))) names(answer) <- dots[[1]]
    if (SIMPLIFY && length(answer) &&
        length(common.len <- unique(unlist(lapply(answer, length)))) == 1) {
        if (common.len == 1)
            unlist(answer, recursive = FALSE)
        else if (common.len > 1)
            array(unlist(answer, recursive = FALSE),
                  dim = c(common.len, max(sapply(dots,length))),
                  dimnames = list(names(answer[[1]]), names(answer)))
        else answer
    }
    else answer
}

## till R 1.1.1:
match <- function(x, table, nomatch=NA)
    .Internal(match(as.character(x), as.character(table), nomatch))
## New:
match <- function(x, table, nomatch=NA, incomparables = FALSE) {
    if(!is.logical(incomparables) || incomparables)
        .NotYetUsed("incomparables != FALSE")
    .Internal(match(if(is.factor(x)) as.character(x) else x,
                    if(is.factor(table)) as.character(table) else table,
                    nomatch))
}

match.call <-
    function(definition=NULL, call=sys.call(sys.parent()), expand.dots=TRUE)
    .Internal(match.call(definition,call,expand.dots))

pmatch <-
    function(x, table, nomatch=NA, duplicates.ok=FALSE)
{
    y <- .Internal(pmatch(x,table,duplicates.ok))
    y[y == 0] <- nomatch
    y
}

"%in%" <- function(x, table) match(x, table, nomatch = 0) > 0

match.arg <- function (arg, choices) {
    if (missing(choices)) {
	formal.args <- formals(sys.function(sys.parent()))
	choices <- eval(formal.args[[deparse(substitute(arg))]])
    }
    if (all(arg == choices)) return(choices[1])
    i <- pmatch(arg, choices)
    if (is.na(i))
	stop(paste("ARG should be one of", paste(choices, collapse = ", "),
		   sep = " "))
    if (length(i) > 1) stop("there is more than one match in match.arg")
    choices[i]
}

charmatch <-
    function(x, table, nomatch=NA)
{
    y <- .Internal(charmatch(x,table))
    y[is.na(y)] <- nomatch
    y
}

char.expand <-
    function(input, target, nomatch = stop("no match"))
{
    if(length(input) != 1)
	stop("char.expand: input must have length 1")
    if(!(is.character(input) && is.character(target)))
	stop("char.expand: input and target must be character")
    y <- .Internal(charmatch(input,target))
    if(any(is.na(y))) eval(nomatch)
    target[y]
}
### clean up FUN arguments to *apply, outer, sweep, etc.
### note that this grabs two levels back and is not designed
### to be called at top level
match.fun <- function (FUN, descend = TRUE)
{
    if ( is.function(FUN) )
        return(FUN)
    if (!(is.character(FUN) && length(FUN) == 1 || is.symbol(FUN))) {
        ## Substitute in parent 
        FUN <- eval.parent(substitute(substitute(FUN)))
        if (!is.symbol(FUN))
            stop(paste("not function, character, or symbol: \"",
                       deparse(FUN), "\"", sep = ""))
    }
    envir <- parent.frame(2)
    if( descend ) 
        FUN <- get(as.character(FUN), mode = "function", env=envir)
    else {
        FUN <- get(as.character(FUN), mode = "any", env=envir)
        if( !is.function(FUN) )
           stop(paste("found non-function: \"", FUN, "\"", sep = ""))
    }
    return(FUN)
}
matrix <- function(data=NA, nrow=1, ncol=1, byrow=FALSE, dimnames=NULL) {
    data <- as.vector(data)
    if(missing(nrow))
        nrow <- ceiling(length(data)/ncol)
    else if(missing(ncol))
        ncol <- ceiling(length(data)/nrow)
    x <- .Internal(matrix(data, nrow, ncol, byrow))
    dimnames(x) <- dimnames
    x
}
nrow <- function(x) dim(x)[1]
ncol <- function(x) dim(x)[2]

NROW <- function(x) if(is.array(x)||is.data.frame(x)) nrow(x) else length(x)
NCOL <- function(x) if(is.array(x) && length(dim(x)) > 1||is.data.frame(x)) ncol(x) else as.integer(1)

rownames <- function(x, do.NULL = TRUE, prefix = "row")
{
    dn <- dimnames(x)
    if(!is.null(dn[[1]]))
	dn[[1]]
    else {
	if(do.NULL) NULL else paste(prefix, seq(length=NROW(x)), sep="")
    }
}

"rownames<-" <- function(x, value)
{
    dn <- dimnames(x)
    if(is.null(dn)) {
        if(is.null(value)) return(x)
        if((nd <- length(dim(x))) < 1)
            stop("attempt to set rownames on object with no dimensions")
        dn <- vector("list", nd)
    }
    if(length(dn) < 1)
        stop("attempt to set rownames on object with no dimensions")
    if(is.null(value)) dn[1] <- list(NULL) else dn[[1]] <- value
    dimnames(x) <- dn
    x
}

colnames <- function(x, do.NULL = TRUE, prefix = "col")
{
    dn <- dimnames(x)
    if(!is.null(dn[[2]]))
	dn[[2]]
    else {
	if(do.NULL) NULL else paste(prefix, seq(length=NCOL(x)), sep="")
    }
}

"colnames<-" <- function(x, value)
{
    dn <- dimnames(x)
    if(is.null(dn)) {
        if(is.null(value)) return(x)
        if((nd <- length(dim(x))) < 2)
            stop("attempt to set colnames on object with less than two dimensions")
        dn <- vector("list", nd)
    }
    if(length(dn) < 2)
        stop("attempt to set colnames on object with less than two dimensions")
    if(is.null(value)) dn[2] <- list(NULL) else dn[[2]] <- value
    dimnames(x) <- dn
    x
}

row <- function(x, as.factor=FALSE) {
    if(as.factor) factor(.Internal(row(x)), labels=rownames(x))
    else .Internal(row(x))
}

col <- function(x, as.factor=FALSE) {
    if(as.factor) factor(.Internal(col(x)), labels=colnames(x))
    else .Internal(col(x))
}

crossprod <- function(x, y=NULL) .Internal(crossprod(x,y))

t <- function(x) UseMethod("t")
## t.default is <primitive>
t.data.frame<- function(x)
{
    x <- as.matrix(x)
    NextMethod("t")
}
## as.matrix  is in "as"
max.col <- function(m)
{
    m <- as.matrix(m)
    n <- nrow(m)
    .C("R_max_col",
       as.double(m),
       n,
       ncol(m),
       rmax = integer(n),
       NAOK = TRUE,
       DUP  = FALSE,
       PACKAGE = "base")$rmax
}

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

mean.default <- function(x, trim = 0, na.rm = FALSE, ...)
{
    if(!is.numeric(x) && !is.complex(x) && !is.logical(x)) {
        warning("argument is not numeric or logical: returning NA")
        return(as.numeric(NA))
    }
    if (na.rm)
	x <- x[!is.na(x)]
    trim <- trim[1]
    n <- length(x)
    if(trim > 0 && n > 0) {
	if(is.complex(x))
	    stop("trimmed means are not defined for complex data")
	if(trim >= 0.5) return(median(x, na.rm=FALSE))
	lo <- floor(n*trim)+1
	hi <- n+1-lo
	x <- sort(x, partial=unique(c(lo, hi)))[lo:hi]
	n <- hi-lo+1
    }
    ## sum(int) can overflow, so convert here.
    if(is.integer(x)) sum(as.numeric(x))/n else sum(x)/n
}

mean.data.frame <- function(x, ...) sapply(x, mean, ...)
merge <- function(x, y, ...) UseMethod("merge")

merge.default <- function(x, y, ...)
    merge(as.data.frame(x), as.data.frame(y), ...)

merge.data.frame <-
    function(x, y, by = intersect(names(x), names(y)), by.x = by, by.y = by,
             all = FALSE, all.x = all, all.y = all,
             sort = TRUE, suffixes = c(".x",".y"), ...)
{
    fix.by <- function(by, df)
    {
        ## fix up `by' to be a valid set of cols by number: 0 is row.names
        by <- as.vector(by)
        nc <- ncol(df)
        if(is.character(by))
            by <- match(by, c("row.names", names(df))) - 1
        else if(is.numeric(by)) {
            if(any(by < 0) || any(by > nc))
                stop("`by' must match numbers of columns")
        } else if(is.logical(by)) {
            if(length(by) != nc) stop("`by' must match number of columns")
            by <- seq(along = by)[by]
        } else stop("`by' must specify column(s)")
        if(any(is.na(by))) stop("`by' must specify valid column(s)")
        unique(by)
    }

    nx <- nrow(x <- as.data.frame(x)); ny <- nrow(y <- as.data.frame(y))
    if (nx == 0 || ny == 0) stop("no rows to match")
    by.x <- fix.by(by.x, x)
    by.y <- fix.by(by.y, y)
    if((l.b <- length(by.x)) != length(by.y))
        stop("by.x and by.y specify different numbers of columns")
    if(l.b == 0) {
        ## was: stop("no columns to match on")
        ## return the cartesian product of x and y :
        ij <- expand.grid(1:nx, 1:ny)
        res <- cbind(x[ij[,1], , drop = FALSE], y[ij[,2], , drop = FALSE])
    }
    else {
        if(any(by.x == 0)) {
            x <- cbind(Row.names = row.names(x), x)
            by.x <- by.x + 1
        }
        if(any(by.y == 0)) {
            y <- cbind(Row.names = row.names(y), y)
            by.y <- by.y + 1
        }
        row.names(x) <- 1:nx
        row.names(y) <- 1:ny
        ## create keys from `by' columns:
        if(l.b == 1) {                  # (be faster)
            bx <- x[, by.x]; if(is.factor(bx)) bx <- as.character(bx)
            by <- y[, by.y]; if(is.factor(by)) by <- as.character(by)
        } else {
            ## Do these together for consistency in as.character.
            ## Use same set of names.
            bx <- x[, by.x, drop=FALSE]; by <- y[, by.y, drop=FALSE]
            names(bx) <- names(by) <- paste("V", 1:ncol(bx), sep="")
            bz <- do.call("paste", c(rbind(bx, by), sep = "\r"))
            bx <- bz[1:nx]
            by <- bz[nx + (1:ny)]
        }
        comm <- match(bx, by, 0)
        bxy <- bx[comm > 0]             # the keys which are in both
        xinds <- match(bx, bxy, 0)
        yinds <- match(by, bxy, 0)
        ## R-only solution {when !all.x && !all.y} :
        ##   o <- outer(xinds, yinds, function(x, y) (x > 0) & x==y)
        ##   m <- list(xi = row(o)[o], yi = col(o)[o])
        m <- .Internal(merge(xinds, yinds, all.x, all.y))
        nm <- nm.x <- names(x)[-by.x]
        nm.by <- names(x)[by.x]
        nm.y <- names(y)[-by.y]
        ncx <- ncol(x)
        if(all.x) all.x <- (nxx <- length(m$x.alone)) > 0
        if(all.y) all.y <- (nyy <- length(m$y.alone)) > 0
        lxy <- length(m$xi)             # == length(m$yi)
        ## x = [ by | x ] :
        has.common.nms <- any(cnm <- nm.x %in% nm.y)
        if(has.common.nms)
            nm.x[cnm] <- paste(nm.x[cnm], suffixes[1], sep="")
        x <- x[c(m$xi, if(all.x) m$x.alone),
               c(by.x, (1:ncx)[-by.x]), drop=FALSE]
        names(x) <- c(nm.by, nm.x)
        if(all.y) { ## add the `y.alone' rows to x[]
            ## need to have factor levels extended as well -> using [cr]bind
            ya <- y[m$y.alone, by.y, drop=FALSE]
            names(ya) <- nm.by
            x <- rbind(x, cbind(ya, matrix(NA, nyy, ncx-l.b,
                                           dimnames=list(NULL,nm.x))))
        }
        ## y (w/o `by'):
        if(has.common.nms) {
            cnm <- nm.y %in% nm
            nm.y[cnm] <- paste(nm.y[cnm], suffixes[2], sep="")
        }
        y <- y[c(m$yi, if(all.x) rep.int(1:1, nxx), if(all.y) m$y.alone),
               -by.y, drop = FALSE]
        if(all.x)
            for(i in seq(along = y))
                ## do it this way to invoke methods for e.g. factor
                is.na(y[[i]]) <- (lxy+1):(lxy+nxx)

        if(has.common.nms) names(y) <- nm.y
        res <- cbind(x, y)

        if (sort)
            res <- res[if(all.x || all.y)## does NOT work
                       do.call("order", x[, 1:l.b, drop=FALSE])
            else sort.list(bx[m$xi]),, drop=FALSE]
    }

    row.names(res) <- seq(length=nrow(res))
    res
}
trace <- function(what, tracer, exit, at, print, signature, where = topenv(parent.frame())) {
    needsAttach <- nargs() > 1 && !.isMethodsDispatchOn()
    if(needsAttach) {
        ns <- try(loadNamespace("methods"))
        if(isNamespace(ns))
            methods::message("(loaded the methods namespace)")
        else
            stop("Tracing functions requires the methods package, but unable to load methods namespace")
    }
    else if(nargs() == 1)
        return(.primTrace(what))
    tState <- tracingState(FALSE)
    ## now call the version in the methods package, to ensure we get
    ## the correct name space (e.g., correct version of class())
    call <- sys.call()
    call[[1]] <- quote(methods::.TraceWithMethods)
    call$where <- where
    value <- eval.parent(call)
    on.exit() ## no error
    tracingState(tState)
    value
}

untrace <- function(what, signature = NULL, where = topenv(parent.frame())) {
    ## NOTE: following test is TRUE after loadNamespace("methods") (even if not in search())
    MethodsDispatchOn <- .isMethodsDispatchOn()
    if(MethodsDispatchOn) {
        tState <- tracingState(FALSE)
        on.exit(tracingState(tState))
    }
    if(is.function(what)) {
        fname <- substitute(what)
        if(is.name(fname))
            what <- as.character(fname)
        else
            stop("Argument what should be the name of a function")
    }
    else {
        what <- as.character(what)
        if(length(what) != 1) {
            for(f in what)
                untrace(f, signature)
            return(what)
        }
    }
    if(!MethodsDispatchOn)
        return(.primUntrace(what)) ## can't have called trace except in primitive form
    ## at this point we can believe that the methods namespace was successfully loaded
    f <- NULL
    if(is.null(signature)) {
        where <- methods::findFunction(what, where = where)
        if(length(where) == 0)
            warning("No function \"", what, "\" to untrace")
        else {
            f <- methods::getFunction(what, where = where[[1]])
            ## ensure that the version to assign is untraced (should be, but ...)
            if(methods::is(f, "traceable")) {
                methods::.untracedFunction(f, what, where[[1]])
            }
            else
                .primUntrace(what) # to be safe--no way to know if it's traced or not
        }
    }
    else {
        f <- methods::getMethod(what, signature,  where)
        if(is.null(f))
            warning("No method for \"", what, "\" for this signature to untrace")
        else {
            if(is(f, "traceable"))
                methods::.untracedFunction(f, what, where, signature)
            else
                warning("The method for \"", what, "\" for this signature was not being traced")
        }
    }
    invisible(f)
}

.isMethodsDispatchOn <- function(onOff = NULL)
    .Call("R_isMethodsDispatchOn", onOff, PACKAGE = "base")

tracingState <- function( on = NULL)
    .Call("R_traceOnOff", on, PACKAGE = "base")
mode <- function(x) {
    if(is.expression(x)) return("expression")
    if(is.call(x))
	return(switch(deparse(x[[1]])[1],
		      "(" = "(",
		      ## otherwise
		      "call"))
    if(is.name(x)) "name" else
    switch(tx <- typeof(x),
	   double=, integer= "numeric",# 'real=' dropped, 2000/Jan/14
	   closure=, builtin=, special= "function",
	   ## otherwise
	   tx)
}
"storage.mode<-" <-
"mode<-" <- function(x, value)
{
    mde <- paste("as.",value,sep="")
    atr <- attributes(x)
    x <- eval(call(mde,x), parent.frame())
    attributes(x) <- atr
    attr(x, "Csingle") <- if(value == "single") TRUE # else NULL
    x
}
storage.mode <- function(x) {
    x <- typeof(x)
    if (x == "closure" || x == "builtin" || x == "special") return("function")
    x
}
names <- function(x) UseMethod("names")
names.default <- function(x) .Internal(names(x))

"names<-" <- function(x, value) UseMethod("names<-")
"names<-.default" <- function(x, value) .Internal("names<-"(x, value))
## give the base namespace a table for registered methods
".__S3MethodsTable__." <- new.env(hash = TRUE, parent = NULL)

getNamespace <- function(name) {
    ns <- .Internal(getRegisteredNamespace(as.name(name)))
    if (! is.null(ns)) ns
    else tryCatch(loadNamespace(name),
                  error = function(e) {
                    # This assignment is needed because 'name' contains
                    # version as second component when called from internal
                    # serialization code
                    name <- name[1]
                      if (name  %in% c("ctest","eda","modreg","mva","nls",
                                       "stepfun","ts")) {
                          warning(paste("package", sQuote(name),
                                        "has been merged into 'stats'"),
                                  call. = FALSE)
                          return(getNamespace("stats"))
                      }
                      else stop(e)
                  })
}

loadedNamespaces <- function()
    ls(env = .Internal(getNamespaceRegistry()), all = TRUE)

getNamespaceName <- function(ns) {
    ns <- asNamespace(ns)
    if (isBaseNamespace(ns)) "base"
    else getNamespaceInfo(ns, "spec")["name"]
}

getNamespaceVersion <- function(ns) {
    ns <- asNamespace(ns)
    if (isBaseNamespace(ns))
        c(version = paste(R.version$major, R.version$minor, sep="."))
    else getNamespaceInfo(ns, "spec")["version"]
}

getNamespaceExports <- function(ns) {
    ns <- asNamespace(ns)
    if (isBaseNamespace(ns)) ls(NULL, all = TRUE)
    else ls(getNamespaceInfo(ns, "exports"), all = TRUE)
}

getNamespaceImports <- function(ns) {
    ns <- asNamespace(ns)
    if (isBaseNamespace(ns)) NULL
    else getNamespaceInfo(ns, "imports")
}

getNamespaceUsers <- function(ns) {
    nsname <- getNamespaceName(asNamespace(ns))
    users <- character(0)
    for (n in loadedNamespaces()) {
        inames <- names(getNamespaceImports(n))
        if (match(nsname, inames, 0))
            users <- c(n, users)
    }
    users
}

getExportedValue <- function(ns, name) {
    getInternalExportName <- function(name, ns) {
        exports <- getNamespaceInfo(ns, "exports")
        if (! exists(name, env = exports, inherits = FALSE))
            stop(paste(sQuote(name), "is not an exported object from",
                       sQuote(paste("namespace",
                                    getNamespaceName(ns), sep=":"))),
                 call. = FALSE)
        get(name, env = exports, inherits = FALSE)
    }
    ns <- asNamespace(ns)
    if (isBaseNamespace(ns)) get(name, env = ns, inherits=FALSE)
    else get(getInternalExportName(name, ns), env = ns)
}

"::" <- function(pkg, name){
    pkg <- as.character(substitute(pkg))
    name <- as.character(substitute(name))
    getExportedValue(pkg, name)
}

":::" <- function(pkg, name){
    pkg <- as.character(substitute(pkg))
    name <- as.character(substitute(name))
    get(name, env = asNamespace(pkg), inherits=FALSE)
}

attachNamespace <- function(ns, pos = 2) {
    runHook <- function(hookname, env, ...) {
        if (exists(hookname, envir = env, inherits = FALSE)) {
            fun <- get(hookname, envir = env, inherits = FALSE)
            if (! is.null(try({ fun(...); NULL})))
                stop(paste(hookname, "failed in attachNamespace"),
                     call. = FALSE)
        }
    }
    ns <- asNamespace(ns, base.OK = FALSE)
    nsname <- getNamespaceName(ns)
    nspath <- getNamespaceInfo(ns, "path")
    attname <- paste("package", nsname, sep=":")
    if (attname %in% search())
        stop("name space is already attached")
    env <- attach(NULL, pos = pos, name = attname)
    on.exit(detach(pos = pos))
    attr(env, "path") <- nspath
    exports <- getNamespaceExports(ns)
    importIntoEnv(env, exports, ns, exports)
    runHook(".onAttach", ns, dirname(nspath), nsname)
    lockEnvironment(env, TRUE)
    on.exit()
    invisible(env)
}

loadNamespace <- function (package, lib.loc = NULL,
                           keep.source = getOption("keep.source.pkgs"),
                           partial = FALSE, declarativeOnly = FALSE) {
    # eventually allow version as second component; ignore for now.
    package <- as.character(package)[[1]]

    # check for cycles
    dynGet <- function(name, notFound = stop(paste(name, "not found"))) {
        n <- sys.nframe()
        while (n > 1) {
            n <- n - 1
            env <- sys.frame(n)
            if (exists(name, env = env, inherits = FALSE))
                return(get(name, env = env, inherits = FALSE))
        }
        notFound
    }
    loading <- dynGet("__NameSpacesLoading__", NULL)
    if (match(package, loading, 0))
        stop("cyclic name space dependencies are not supported")
    "__NameSpacesLoading__" <- c(package, loading)

    ns <- .Internal(getRegisteredNamespace(as.name(package)))
    if (! is.null(ns))
        ns
    else {
        runHook <- function(hookname, env, ...) {
            if (exists(hookname, envir = env, inherits = FALSE)) {
                fun <- get(hookname, envir = env, inherits = FALSE)
                if (! is.null(try({ fun(...); NULL})))
                    stop(paste(hookname, "failed in loadNamespace"),
                         call. = FALSE)
            }
        }
        runUserHook <- function(pkgname, pkgpath) {
            hook <- getHook(packageEvent(pkgname, "onLoad")) # might be list()
            for(fun in hook) try(fun(pkgname, pkgpath))
        }
        makeNamespace <- function(name, version = NULL, lib = NULL) {
            impenv <- new.env(parent = .BaseNamespaceEnv, hash = TRUE)
            env <- new.env(parent = impenv, hash = TRUE)
            name <- as.character(as.name(name))
            version <- as.character(version)
            info <- new.env(hash = TRUE, parent = NULL)
            assign(".__NAMESPACE__.", info, env = env)
            assign("spec", c(name=name,version=version), env = info)
            setNamespaceInfo(env, "exports", new.env(hash = TRUE, parent = NULL))
            setNamespaceInfo(env, "imports", list("base"=TRUE))
            setNamespaceInfo(env, "path", file.path(lib, name))
            setNamespaceInfo(env, "dynlibs", NULL)
            setNamespaceInfo(env, "S3methods", matrix(as.character(NA), 0, 3))
            assign(".__S3MethodsTable__.", new.env(hash = TRUE, parent = NULL),
                   envir = env)
            .Internal(registerNamespace(name, env))
            env
        }
        sealNamespace <- function(ns) {
            namespaceIsSealed <- function(ns)
               environmentIsLocked(ns)
            ns <- asNamespace(ns, base.OK = FALSE)
            if (namespaceIsSealed(ns))
                stop("namespace", sQuote(getNamespaceName(ns)),
                     " is already sealed in loadNamespace", call.=FALSE)
            lockEnvironment(ns, TRUE)
            lockEnvironment(parent.env(ns), TRUE)
        }
        addNamespaceDynLibs <- function(ns, newlibs) {
            dynlibs <- getNamespaceInfo(ns, "dynlibs")
            setNamespaceInfo(ns, "dynlibs", c(dynlibs, newlibs))
        }

        # find package and check it has a name space
        pkgpath <- .find.package(package, lib.loc, quiet = TRUE)
        if (length(pkgpath) == 0)
            stop(paste("There is no package called", sQuote(package)))
        package.lib <- dirname(pkgpath)
        if (! packageHasNamespace(package, package.lib))
            stop(paste("package", sQuote(package),
                       "does not have a name space"))

        # create namespace; arrange to unregister on error
        nsInfoFilePath <- file.path(package.lib, package, "Meta", "nsInfo.rds")
        nsInfo <- if(file.exists(nsInfoFilePath)) .readRDS(nsInfoFilePath)
        else parseNamespaceFile(package, package.lib, mustExist = FALSE)
        version <- read.dcf(file.path(package.lib, package, "DESCRIPTION"),
                            fields = "Version")
        ns <- makeNamespace(package, version = version, lib = package.lib)
        on.exit(.Internal(unregisterNamespace(package)))

        # process imports
        for (i in nsInfo$imports) {
            if (is.character(i))
                namespaceImport(ns, loadNamespace(i, c(lib.loc, .libPaths()),
                                                  keep.source))
            else
                namespaceImportFrom(ns,
                                    loadNamespace(i[[1]],
                                                  c(lib.loc, .libPaths()),
                                                  keep.source), i[[2]])
        }
        for(imp in nsInfo$importClasses)
            namespaceImportClasses(ns, loadNamespace(imp[[1]],
                                                     c(lib.loc, .libPaths()),
                                                     keep.source), imp[[2]])
        for(imp in nsInfo$importMethods)
            namespaceImportMethods(ns, loadNamespace(imp[[1]],
                                                     c(lib.loc, .libPaths()),
                                                     keep.source), imp[[2]])


        # dynamic variable to allow/disable .Import and friends
        "__NamespaceDeclarativeOnly__" <- declarativeOnly

        # store info for loading name space for loadingNamespaceInfo to read
        "__LoadingNamespaceInfo__" <- list(libname = package.lib,
                                           pkgname = package)

        env <- asNamespace(ns)
        # save the package name in the environment
        assign(".packageName", package, envir = env)

        # load the code
        codename <- strsplit(package, "_", fixed=TRUE)[[1]][1]
        codeFile <- file.path(package.lib, package, "R", codename)
        if (file.exists(codeFile))
            sys.source(codeFile, env, keep.source = keep.source)
        else warning(paste("Package ", sQuote(package), "contains no R code"))

        # partial loading stops at this point
        if (partial) return(ns)

        # register any S3 methods
        registerS3methods(nsInfo$S3methods, package, env)

        # load any dynamic libraries
        for (lib in nsInfo$dynlibs)
            library.dynam(lib, package, package.lib)
        addNamespaceDynLibs(env, nsInfo$dynlibs)

        # run the load hook
        runHook(".onLoad", env, package.lib, package)

        # process exports, seal, and clear on.exit action
        exports <- nsInfo$exports

        for (p in nsInfo$exportPatterns)
            exports <- c(ls(env, pat = p, all = TRUE), exports)
        if(.isMethodsDispatchOn() &&
           !exists(".noGenerics", envir = ns, inherits = FALSE)) {
            ## process class definition objects
            expClasses <- nsInfo$exportClasses
            if(length(expClasses) > 0) {
                missingClasses <- !sapply(expClasses, methods:::isClass, where = ns)
                if(any(missingClasses))
                    stop("Classes for export not defined: ",
                         paste(expClasses[missingClasses], collapse = ", "))
                expClasses <- paste(methods:::classMetaName(""), expClasses, sep="")
            }
            ## process methods metadata explicitly exported or
            ## implied by exporting the generic function.
            allMethods <- unique(c(methods:::.getGenerics(ns),
                                   methods:::.getGenerics(parent.env(ns))))
            expMethods <- nsInfo$exportMethods
            if(length(allMethods) > 0) {
                expMethods  <- unique(c(expMethods,
                                       exports[!is.na(match(exports, allMethods))]))
                missingMethods <- !(expMethods %in% allMethods)
                if(any(missingMethods))
                    stop("Methods for export not found: ",
                         paste(expMethods[missingMethods], collapse = ", "))
                needMethods <- (exports %in% allMethods) & !(exports %in% expMethods)
                if(any(needMethods))
                    expMethods <- c(expMethods, exports[needMethods])
                for(i in seq(along=expMethods)) {
                    mi <- expMethods[[i]]
                    if(!(mi %in% exports) &&
                       exists(mi, envir = ns, mode = "function", inherits = FALSE))
                        exports <- c(exports, mi)
                    expMethods[[i]] <- methods:::mlistMetaName(mi, ns)
                }
            }
            else if(length(expMethods) > 0)
                stop("Methods specified for export, but none defined: ",
                     paste(expMethods, collapse=", "))
            exports <- c(exports, expClasses, expMethods)
        }
        namespaceExport(ns, exports)
        sealNamespace(ns)
        ## run user hooks here
        runUserHook(package, file.path(package.lib, package))
        on.exit()
        ns
    }
}

loadingNamespaceInfo <- function() {
    dynGet <- function(name, notFound = stop(paste(name, "not found"))) {
        n <- sys.nframe()
        while (n > 1) {
            n <- n - 1
            env <- sys.frame(n)
            if (exists(name, env = env, inherits = FALSE))
                return(get(name, env = env, inherits = FALSE))
        }
        notFound
    }
    dynGet("__LoadingNamespaceInfo__", stop("not loading a name space"))
}

saveNamespaceImage <- function (package, rdafile, lib.loc = NULL,
                                keep.source = getOption("keep.source.pkgs"),
                                compress = TRUE)
{
    if (! is.null(.Internal(getRegisteredNamespace(as.name(package)))))
        stop(paste("name space", sQuote(package), "is loaded"));
    ns <- loadNamespace(package, lib.loc, keep.source, TRUE, TRUE)
    vars <- ls(ns, all = TRUE)
    vars <- vars[vars != ".__NAMESPACE__."]
    save(list = vars, file = rdafile, envir = ns, compress = compress)
}

topenv <- function(envir = parent.frame(),
                   matchThisEnv = getOption("topLevelEnvironment")) {
    while (! is.null(envir)) {
        if (! is.null(attr(envir, "name")) ||
            identical(envir, matchThisEnv) ||
            identical(envir, .GlobalEnv) ||
            .Internal(isNamespaceEnv(envir)) ||
            exists(".packageName", envir = envir, inherits = FALSE))
            return(envir)
        else envir <- parent.env(envir)
    }
    return(.GlobalEnv)
}

unloadNamespace <- function(ns) {
    runHook <- function(hookname, env, ...) {
        if (exists(hookname, envir = env, inherits = FALSE)) {
            fun <- get(hookname, envir = env, inherits = FALSE)
            if (! is.null(try({ fun(...); NULL})))
                stop(paste(hookname, "failed in unloadNamespace"),
                     call. = FALSE)
        }
    }
    ns <- asNamespace(ns, base.OK = FALSE)
    nsname <- getNamespaceName(ns)
    pos <- match(paste("package", nsname, sep=":"), search())
    if (! is.na(pos)) detach(pos = pos)
    users <- getNamespaceUsers(ns)
    if (length(users) != 0)
        stop(paste("name space still used by:", paste(users, collapse = ", ")))
    nspath <- getNamespaceInfo(ns, "path")
    hook <- getHook(packageEvent(nsname, "onUnload")) # might be list()
    for(fun in rev(hook)) try(fun(nsname, nspath))
    try(runHook(".onUnload", ns, nspath))
    .Internal(unregisterNamespace(nsname))
    invisible()
}

.Import <- function(...) {
    dynGet <- function(name, notFound = stop(paste(name, "not found"))) {
        n <- sys.nframe()
        while (n > 1) {
            n <- n - 1
            env <- sys.frame(n)
            if (exists(name, env = env, inherits = FALSE))
                return(get(name, env = env, inherits = FALSE))
        }
        notFound
    }
    if (dynGet("__NamespaceDeclarativeOnly__", FALSE))
        stop("imperative name space directives are disabled")
    envir <- parent.frame()
    names <- as.character(substitute(list(...)))[-1]
    for (n in names)
        namespaceImportFrom(envir, n)
}

.ImportFrom <- function(name, ...) {
    dynGet <- function(name, notFound = stop(paste(name, "not found"))) {
        n <- sys.nframe()
        while (n > 1) {
            n <- n - 1
            env <- sys.frame(n)
            if (exists(name, env = env, inherits = FALSE))
                return(get(name, env = env, inherits = FALSE))
        }
        notFound
    }
    if (dynGet("__NamespaceDeclarativeOnly__", FALSE))
        stop("imperative name space directives are disabled")
    envir <- parent.frame()
    name <-  as.character(substitute(name))
    names <- as.character(substitute(list(...)))[-1]
    namespaceImportFrom(envir, name, names)
}

.Export <- function(...) {
    dynGet <- function(name, notFound = stop(paste(name, "not found"))) {
        n <- sys.nframe()
        while (n > 1) {
            n <- n - 1
            env <- sys.frame(n)
            if (exists(name, env = env, inherits = FALSE))
                return(get(name, env = env, inherits = FALSE))
        }
        notFound
    }
    if (dynGet("__NamespaceDeclarativeOnly__", FALSE))
        stop("imperative name space directives are disabled")
    ns <- topenv(parent.frame(), NULL)
    if (identical(ns, .BaseNamespaceEnv))
        warning("all objects in base name space are currently exported.")
    else if (! isNamespace(ns))
        stop("can only export from a name space")
    else {
        names <- as.character(substitute(list(...)))[-1]
        namespaceExport(ns, names)
    }
}

.S3method <- function(generic, class, method) {
    dynGet <- function(name, notFound = stop(paste(name, "not found"))) {
        n <- sys.nframe()
        while (n > 1) {
            n <- n - 1
            env <- sys.frame(n)
            if (exists(name, env = env, inherits = FALSE))
                return(get(name, env = env, inherits = FALSE))
        }
        notFound
    }
    if (dynGet("__NamespaceDeclarativeOnly__", FALSE))
        stop("imperative name space directives are disabled")
    generic <- as.character(substitute(generic))
    class <- as.character(substitute(class))
    if (missing(method)) method <- paste(generic, class, sep=".")
    registerS3method(generic, class, method, envir = parent.frame())
    invisible(NULL)
}

isNamespace <- function(ns) .Internal(isNamespaceEnv(ns))

isBaseNamespace <- function(ns) identical(ns, .BaseNamespaceEnv)

getNamespaceInfo <- function(ns, which) {
    ns <- asNamespace(ns, base.OK = FALSE)
    info <- get(".__NAMESPACE__.", env = ns, inherits = FALSE)
    get(which, env = info, inherits = FALSE)
}

setNamespaceInfo <- function(ns, which, val) {
    ns <- asNamespace(ns, base.OK = FALSE)
    info <- get(".__NAMESPACE__.", env = ns, inherits = FALSE)
    assign(which, val, env = info)
}

asNamespace <- function(ns, base.OK = TRUE) {
    if (is.character(ns) || is.name(ns))
        ns <- getNamespace(ns)
    if (! isNamespace(ns))
        stop("not a name space")
    else if (! base.OK && isBaseNamespace(ns))
        stop("operation not allowed on base name space")
    else ns
}

namespaceImport <- function(self, ...) {
    for (ns in list(...))
        namespaceImportFrom(self, asNamespace(ns))
}

namespaceImportFrom <- function(self, ns, vars) {
    addImports <- function(ns, from, what) {
        imp <- structure(list(what), names = getNamespaceName(from))
        imports <- getNamespaceImports(ns)
        setNamespaceInfo(ns, "imports", c(imports, imp))
    }
    namespaceIsSealed <- function(ns)
       environmentIsLocked(ns)
    makeImportExportNames <- function(spec) {
        old <- as.character(spec)
        new <- names(spec)
        if (is.null(new)) new <- old
        else new[new==""] <- old[new==""]
        names(old) <- new
        old
    }
    mergeImportMethods <- function(impenv, expenv, metaname) {
        expMethods <- get(metaname, envir = expenv)
        if(exists(metaname, envir = impenv, inherits = FALSE)) {
            impMethods <- get(metaname, envir = impenv)
            assign(metaname, methods:::mergeMethods(impMethods, expMethods), envir = impenv)
            TRUE
        }
        else
            FALSE
    }
    whichMethodMetaNames <- function(impvars) {
        if(!.isMethodsDispatchOn())
            return(numeric())
        mm <- ".__M__" # methods:::mlistMetaName() is slow
        seq(along = impvars)[substr(impvars, 1, nchar(mm)) == mm]
    }
    if (is.character(self))
        self <- getNamespace(self)
    ns <- asNamespace(ns)
    if (missing(vars)) impvars <- getNamespaceExports(ns)
    else impvars <- vars
    impvars <- makeImportExportNames(impvars)
    impnames <- names(impvars)
    if (any(duplicated(impnames))) {
        stop("duplicate import names ",
             paste(impnames[duplicated(impnames)], collapse=", "))
    }
    if (isNamespace(self) && isBaseNamespace(self)) {
        impenv <- self
        msg <- "replacing local value with import:"
        register <- FALSE
    }
    else if (isNamespace(self)) {
        if (namespaceIsSealed(self))
            stop("cannot import into a sealed namespace")
        impenv <- parent.env(self)
        msg <- "replacing previous import:"
        register <- TRUE
    }
    else if (is.environment(self)) {
        impenv <- self
        msg <- "replacing local value with import:"
        register <- FALSE
    }
    else stop("invalid import target")
    which <- whichMethodMetaNames(impvars)
    if(length(which)) {
        ## If methods are already in impenv, merge and don't import
        delete <- integer()
        for(i in which)
            if(mergeImportMethods(impenv, ns, impvars[[i]]))
                delete <- c(delete, i)
        if(length(delete)>0) {
            impvars <- impvars[-delete]
            impnames <- impnames[-delete]
        }
    }
    for (n in impnames)
        if (exists(n, env = impenv, inherits = FALSE))
            warning(paste(msg, n))
    importIntoEnv(impenv, impnames, ns, impvars)
    if (register) {
        if (missing(vars)) addImports(self, ns, TRUE)
        else addImports(self, ns, impvars)
    }
}

namespaceImportClasses <- function(self, ns, vars) {
    for(i in seq(along = vars))
        vars[[i]] <- methods:::classMetaName(vars[[i]])
    namespaceImportFrom(self, asNamespace(ns), vars)
}

namespaceImportMethods <- function(self, ns, vars) {
    allVars <- character()
    allMlists <- methods:::.getGenerics(ns)
    if(any(is.na(match(vars, allMlists))))
        stop("Requested methods objects not found in environment/package \"",
                methods:::getPackageName(ns), "\": ",
                paste(vars[is.na(match(vars, allMlists))], collapse = ", "))
    for(i in seq(along = allMlists)) {
        ## import methods list objects if asked for
        ## or if the corresponding generic was imported
        g <- allMlists[[i]]
        if(exists(g, envir=self, inherits = FALSE) # already imported
           || g %in% vars) # requested explicitly
            allVars <- c(allVars, methods:::mlistMetaName(g, ns))
        if(g %in% vars && !exists(g, envir=self, inherits = FALSE) &&
           exists(g, envir=ns, inherits = FALSE) &&
           methods:::is(get(g, envir = ns), "genericFunction"))
            allVars <- c(allVars, g)
    }
    namespaceImportFrom(self, asNamespace(ns), allVars)
}

importIntoEnv <- function(impenv, impnames, expenv, expnames) {
    exports <- getNamespaceInfo(expenv, "exports")
    ex <- .Internal(ls(exports, TRUE))
    if(!all(expnames %in% ex)) {
        miss <- expnames[! expnames %in% ex]
        stop("object(s) ", paste(sQuote(miss), collapse=", "),
             " are not exported by ",
             sQuote(paste("namespace", getNamespaceName(expenv), sep=";"))
             )
    }
    expnames <- unlist(lapply(expnames, get, env = exports, inherits = FALSE))
    if (is.null(impnames)) impnames <- character(0)
    if (is.null(expnames)) expnames <- character(0)
    .Internal(importIntoEnv(impenv, impnames, expenv, expnames))
}

namespaceExport <- function(ns, vars) {
    namespaceIsSealed <- function(ns)
       environmentIsLocked(ns)
    if (namespaceIsSealed(ns))
        stop("cannot add to exports of a sealed namespace")
    ns <- asNamespace(ns, base.OK = FALSE)
    if (length(vars) > 0) {
        addExports <- function(ns, new) {
            exports <- getNamespaceInfo(ns, "exports")
            expnames <- names(new)
            intnames <- new
            objs <- .Internal(ls(exports, TRUE))
            ex <- expnames %in% objs
            if(any(ex))
                warning(paste("previous export(s)",
                              paste(sQuote(info[notex, 3]), collapse=", "),
                              "are being replaced"), call. = FALSE)
            for (i in seq(along = new))
                assign(expnames[i], intnames[i], env = exports)
        }
        makeImportExportNames <- function(spec) {
            old <- as.character(spec)
            new <- names(spec)
            if (is.null(new)) new <- old
            else new[new==""] <- old[new==""]
            names(old) <- new
            old
        }
        new <- makeImportExportNames(unique(vars))
        ## calling exists each time is too slow, so do two phases
        undef <- new[! new %in% .Internal(ls(ns, TRUE))]
        undef <- undef[! sapply(undef, exists, env = ns)]
        if (length(undef) != 0) {
            undef <- do.call("paste", as.list(c(undef, sep=", ")))
            stop(paste("undefined exports:", undef))
        }
        if(.isMethodsDispatchOn()) .mergeExportMethods(new, ns)
        addExports(ns, new)
    }
}

.mergeExportMethods <- function(new, ns) {
#    if(!.isMethodsDispatchOn()) return(FALSE)
    mm <- methods:::mlistMetaName()
    newMethods <- new[substr(new, 1, nchar(mm)) == mm]
    nsimports <- parent.env(ns)
    for(what in newMethods) {
        if(exists(what, envir = nsimports, inherits = FALSE)) {
            m1 <- get(what, envir = nsimports)
            m2 <- get(what, envir = ns)
            assign(what, envir = ns, methods:::mergeMethods(m1, m2))
        }
    }
}

packageHasNamespace <- function(package, package.lib) {
    namespaceFilePath <- function(package, package.lib)
        file.path(package.lib, package, "NAMESPACE")
    file.exists(namespaceFilePath(package, package.lib)) ||
    ! is.na(read.dcf(file.path(package.lib, package, "DESCRIPTION"),
                               fields="Namespace"))
}

parseNamespaceFile <- function(package, package.lib, mustExist = TRUE) {
    namespaceFilePath <- function(package, package.lib)
        file.path(package.lib, package, "NAMESPACE")
    nsFile <- namespaceFilePath(package, package.lib)
    if (file.exists(nsFile))
        directives <- parse(nsFile)
    else if (mustExist)
        stop(paste("package", sQuote(package), "has no NAMESPACE file"))
    else directives <- NULL
    exports <- character(0)
    exportPatterns <- character(0)
    exportClasses <- character(0)
    exportMethods <- character(0)
    imports <- list()
    importMethods <- list()
    importClasses <- list()
    dynlibs <- character(0)
    S3methods <- matrix(as.character(NA), 500, 3)
    nS3 <- 0
    parseDirective <- function(e) {
        switch(as.character(e[[1]]),
               "if" = if (eval(e[[2]], .GlobalEnv))
                          parseDirective(e[[3]])
                      else if (length(e) == 4)
                          parseDirective(e[[4]]),
               "{" =  for (ee in as.list(e[-1])) parseDirective(ee),
               export = {
                   exp <- e[-1]
                   exp <- structure(as.character(exp), names=names(exp))
                   exports <<- c(exports, exp)
               },
               exportPattern = {
                   pat <- as.character(e[-1])
                   exportPatterns <<- c(pat, exportPatterns)
               },
               exportClass = , exportClasses = {
                   exportClasses <<- c(as.character(e[-1]), exportClasses)
               },
               exportMethods = {
                   exportMethods <<- c(as.character(e[-1]), exportMethods)
               },
               import = imports <<- c(imports,as.list(as.character(e[-1]))),
               importFrom = {
                   imp <- e[-1]
                   ivars <- imp[-1]
                   inames <- names(ivars)
                   imp <- list(as.character(imp[1]),
                               structure(as.character(ivars), names=inames))
                   imports <<- c(imports, list(imp))
               },
               importClassFrom = , importClassesFrom = {
                   imp <- as.character(e[-1])
                   pkg <- imp[[1]]
                   impClasses <- imp[-1]
                   imp <- list(as.character(pkg), as.character(impClasses))
                   importClasses <<- c(importClasses, list(imp))
               },
               importMethodsFrom = {
                   imp <- as.character(e[-1])
                   pkg <- imp[[1]]
                   impMethods <- imp[-1]
                   imp <- list(as.character(pkg), as.character(impMethods))
                   importMethods <<- c(importMethods, list(imp))
               },
               useDynLib = {
                   dyl <- e[-1]
                   dynlibs <<- c(dynlibs, as.character(dyl))
               },
               S3method = {
                   spec <- e[-1]
                   if (length(spec) != 2 && length(spec) != 3)
                       stop(paste("bad S3method directive:", deparse(e)),
                            call. = FALSE)
                   nS3 <<- nS3 + 1;
                   if(nS3 > 500)
                       stop("too many S3method directives", call. = FALSE)
                   S3methods[nS3, 1:length(spec)] <<- as.character(spec)
               },
               stop(paste("unknown namespace directive:", deparse(e)),
                    call. = FALSE)
               )
    }
    for (e in directives)
        parseDirective(e)
    list(imports=imports, exports=exports, exportPatterns = exportPatterns,
         importClasses=importClasses, importMethods=importMethods,
         exportClasses=exportClasses, exportMethods=exportMethods,
         dynlibs=dynlibs, S3methods = S3methods[seq(len=nS3), ,drop=FALSE])
}

registerS3method <- function(genname, class, method, envir = parent.frame()) {
    addNamespaceS3method <- function(ns, generic, class, method) {
        regs <- getNamespaceInfo(ns, "S3methods")
        regs <- cbind(regs, c(generic, class, method))
        setNamespaceInfo(ns, "S3methods", regs)
    }
    groupGenerics <- c("Math", "Ops",  "Summary", "Complex")
    defenv <- if(genname %in% groupGenerics) .BaseNamespaceEnv
    else {
        genfun <- get(genname, envir = envir)
        if(.isMethodsDispatchOn() && methods::is(genfun, "genericFunction"))
            genfun <- methods::finalDefaultMethod(methods::getMethods(genname))@.Data
        if (typeof(genfun) == "closure") environment(genfun)
        else .BaseNamespaceEnv
    }
    if (! exists(".__S3MethodsTable__.", envir = defenv, inherits = FALSE))
        assign(".__S3MethodsTable__.", new.env(hash = TRUE, parent = NULL),
               envir = defenv)
    table <- get(".__S3MethodsTable__.", envir = defenv, inherits = FALSE)
    if (is.character(method)) {
        wrap <- function(method, home) {
            method <- method            # force evaluation
            home <- home                # force evaluation
            delay(get(method, env = home), env = environment())
        }
        if(!exists(method, env = envir)) {
            warning(paste("S3 method",
                          sQuote(method),
                          "was declared in NAMESPACE but not found"),
                    call. = FALSE)
        } else {
            assign(paste(genname, class, sep = "."), wrap(method, envir),
                   envir = table)
        }
    }
    else if (is.function(method))
        assign(paste(genname, class, sep = "."), method, envir = table)
    else stop("bad method")
    if (isNamespace(envir) && ! identical(envir, .BaseNamespaceEnv))
        addNamespaceS3method(envir, genname, class, method)
}

# export <- function(expr, where = topenv(parent.frame()),
#                    exclusions = c("last.dump", "last.warning", ".Last.value",
#                        ".Random.seed", ".packageName", ".noGenerics", ".required")) {
#     ns <- as.environment(where)
#     if(isNamespace(ns)) {
#         expEnv <- new.env(hash = TRUE, parent =ns)
#         ## copy .packageName (will also make this qualify as topenv()
#         ## for class & method assignment
#         assign(".packageName", get(".packageName", envir = ns), envir = expEnv)
#         eval(substitute(expr), expEnv)
#         ## objects assigned will be exported.
#         allObjects  <- objects(expEnv, all=TRUE)
#         newExports <- allObjects[!(allObjects %in% exclusions)]
#         ## Merge any methods lists with existing versions in ns == parent.env(expEnv)
#         .mergeExportMethods(newExports, expEnv)
#         ## copy the objects
#         for(what in allObjects)
#             assign(what, get(what, envir = expEnv), envir = ns)
#         ## and update the exports information
#         exports <- getNamespaceInfo(ns, "exports")
#         for(what in newExports)
#             assign(what, what, envir = exports)
#     }
#     else
#         eval(substitute(expr), ns)
# }

registerS3methods <- function(info, package, env)
{
    wrap <- function(method, home) {
        method <- method            # force evaluation
        home <- home                # force evaluation
        delay(get(method, env = home), env = environment())
    }
    .registerS3method <- function(genname, class, method, nm, envir)
    {
        ## S3 generics should either be imported explicitly or be in
        ## the base namespace, so we start the search at the imports
        ## environment, parent.env(envir), which is followed by the
        ## base namespace.  (We have already looked in the namespace.)
        ## However, in case they have not been imported, we first
        ## look up where some commonly used generics are (including the
        ## group generics).
        defenv <- if(!is.na(w <- .knownS3Generics[genname])) asNamespace(w)
        else {
            if(!exists(genname, envir = parent.env(envir)))
                stop("object ", sQuote(genname),
                     " not found whilst loading namespace ",
                     sQuote(package), call. = FALSE)
            genfun <- get(genname, envir = parent.env(envir))
            if(.isMethodsDispatchOn() && methods::is(genfun, "genericFunction")) {
                genfun <- methods::slot(genfun, "default")@methods$ANY
                warning("found an S4 version of ", sQuote(genname),
                        " so it has not been imported correctly", call.=FALSE)
            }
            if (typeof(genfun) == "closure") environment(genfun)
            else .BaseNamespaceEnv
        }
        if (! exists(".__S3MethodsTable__.", envir = defenv, inherits = FALSE))
            assign(".__S3MethodsTable__.", new.env(hash = TRUE, parent = NULL),
                   envir = defenv)
        table <- get(".__S3MethodsTable__.", envir = defenv, inherits = FALSE)
        assign(nm, wrap(method, envir), envir = table)
    }

    n <- NROW(info)
    if(n == 0) return()
    methname <- paste(info[,1], info[,2], sep=".")
    z <- is.na(info[,3])
    info[z,3] <- methname[z]
    Info <- cbind(info, methname)
    loc <- .Internal(ls(env, TRUE))
    notex <- !(info[,3] %in% loc)
    if(any(notex))
        warning(paste("S3 method(s)",
                      paste(sQuote(info[notex, 3]), collapse=", "),
                      "were declared in NAMESPACE but not found"),
                call. = FALSE)
    Info <- Info[!notex, , drop = FALSE]

    ## do local generics first -- this could be load-ed if pre-computed.
    localGeneric <- Info[,1] %in% loc
    lin <- Info[localGeneric, , drop = FALSE]
    S3MethodsTable <- get(".__S3MethodsTable__.", envir = env,
                          inherits = FALSE)
    for(i in seq(len=nrow(lin)))
        assign(lin[i,4], get(lin[i,3], envir=env), envir = S3MethodsTable)

    ## now the rest
    fin <- Info[!localGeneric, , drop = FALSE]
    for(i in seq(len=nrow(fin)))
        .registerS3method(fin[i, 1], fin[i, 2], fin[i, 3], fin[i, 4], env)

    setNamespaceInfo(env, "S3methods",
                     rbind(info, getNamespaceInfo(env, "S3methods")))
}
.NotYetImplemented <- function ()
    stop(sQuote(as.character(sys.call(sys.parent())[[1]])),
         " is not implemented yet", call. = FALSE)

.NotYetUsed <- function(arg, error = TRUE) {
    msg <- paste("argument", sQuote(arg), "is not used (yet)")
    if(error) stop(msg) else warning(msg)
}
options <- function(...) .Internal(options(...))

getOption <- function(x) options(x)[[1]]

## transferred to system profile, where all the others are
## initial options settings (others are done in C code in InitOptions)
## options(defaultPackages = c("methods", "ctest"))

outer <- function (X, Y, FUN = "*", ...)
{
    no.nx <- is.null(nx <- dimnames(X <- as.array(X))); dX <- dim(X)
    no.ny <- is.null(ny <- dimnames(Y <- as.array(Y))); dY <- dim(Y)
    if (is.character(FUN) && FUN=="*") {
        robj <- as.vector(X) %*% t(as.vector(Y))
        dim(robj) <- c(dX, dY)
    } else {
        FUN <- match.fun(FUN)
        ## Y may have a class, so don't use rep.int
        Y <- rep(Y, rep.int(length(X), length(Y)))
        ##  length.out is not an argument of the generic rep()
##        X <- rep(X, length.out = length(Y))
        if(length(X) > 0)
            X <- rep(X, times = ceiling(length(Y)/length(X)))
        robj <- FUN(X, Y, ...)
        dim(robj) <- c(dX, dY) # careful not to lose class here
    }
    ## no dimnames if both don't have ..
    if(no.nx) nx <- vector("list", length(dX)) else
    if(no.ny) ny <- vector("list", length(dY))
    if(!(no.nx && no.ny))
	dimnames(robj) <- c(nx, ny)
    robj
}

## Binary operator, hence don't simply do "%o%" <- outer.
"%o%" <- function(X, Y) outer(X, Y)
compareVersion <- function(a, b){
    if(is.na(a))
        return(-1)
    if(is.na(b))
        return(1)
    a <- as.integer(strsplit(a, "[\\.-]")[[1]])
    b <- as.integer(strsplit(b, "[\\.-]")[[1]])
    for(k in 1:length(a)){
        if(k <= length(b)){
            if(a[k]>b[k])
                return(1)
            else if(a[k]<b[k])
                return(-1)
        }
        else{
            return(1)
        }
    }
    if(length(b)>length(a))
        return(-1)
    else
        return(0)
}

package.dependencies <- function(x, check = FALSE,
                                 depLevel=c("Depends", "Suggests"))
{
    depLevel <- match.arg(depLevel)

    if(!is.matrix(x))
        x <- matrix(x, nrow = 1, dimnames = list(NULL, names(x)))

    deps <- list()
    for(k in 1:nrow(x)){
        z <- x[k, depLevel]
        if(!is.na(z) & z != ""){
            ## split dependencies, remove leading and trailing whitespace
            z <- unlist(strsplit(z, ",", fixed=TRUE))
            z <- sub("^[[:space:]]*(.*)", "\\1", z)
            z <- sub("(.*)[[:space:]]*$", "\\1", z)

            ## split into package names and version
            pat <- "^([^\\([:space:]]+)[[:space:]]*\\(([^\\)]+)\\).*"
            deps[[k]] <-
                cbind(sub(pat, "\\1", z), sub(pat, "\\2", z), NA)

            noversion <- deps[[k]][,1] == deps[[k]][,2]
            deps[[k]][noversion,2] <- NA

            ## split version dependency into operator and version number
            pat <- "[[:space:]]*([[<>=]+)[[:space:]]+(.*)"
            deps[[k]][!noversion, 2:3] <-
                c(sub(pat, "\\1", deps[[k]][!noversion, 2]),
                  sub(pat, "\\2", deps[[k]][!noversion, 2]))
        }
        else
            deps[[k]] <- NA
    }

    if(check){
        z <- rep.int(TRUE, nrow(x))
        for(k in 1:nrow(x)){
            ## currently we only check the version of R itself
            if(!is.na(deps[[k]]) &&
               any(ok <- deps[[k]][,1] == "R")) {
                ## NOTE: currently operators must be `<=' or `>='.
                if(!is.na(deps[[k]][ok, 2])
                   && deps[[k]][ok, 2] %in% c("<=", ">=")) {
                    comptext <-
                        paste('"', R.version$major, ".",
                              R.version$minor, '" ',
                              deps[[k]][ok,2], ' "',
                              deps[[k]][ok,3], '"', sep = "")
                    compres <- try(eval(parse(text = comptext)))
                    if(!inherits(compres, "try-error"))
                        z[k] <- compres
                }
            }
        }
        names(z) <- x[,"Package"]
        return(z)
    }
    else{
        names(deps) <- x[,"Package"]
        return(deps)
    }
}

packageDescription <- function(pkg, lib.loc=NULL, fields=NULL, drop=TRUE)
{ 
    retval <- list()
    if(!is.null(fields)){
        fields <- as.character(fields)
        retval[fields] <- NA
    }
    
    file <- system.file("DESCRIPTION", package = pkg, lib.loc = lib.loc)
    
    if(file != "") {
        desc <- as.list(read.dcf(file=file)[1,])
        if(!is.null(fields)){
            ok <- names(desc) %in% fields
            retval[names(desc)[ok]] <- desc[ok]
        }
        else
            retval[names(desc)] <- desc
    }

    if((file == "") || (length(retval) == 0)){
        warning(paste("DESCRIPTION file of package ", sQuote(pkg),
                      " missing or broken\n"))
        return(NA)
    }

    if(drop & length(fields)==1)
        return(retval[[1]])
    
    class(retval) <- "packageDescription"
    if(!is.null(fields)) attr(retval, "fields") <- fields
    attr(retval, "file") <- file
    retval
}


print.packageDescription <- function(x, ...)
{
    write.dcf(as.data.frame.list(x))
    cat("-- File:", attr(x, "file"), "\n")
    if(!is.null(attr(x, "fields"))){
        cat("-- Fields read: ")
        cat(attr(x, "fields"), sep=", ")
        cat("\n")
    }
}
as.pairlist <- function(x) .Internal(as.vector(x, "pairlist"))
pairlist <- function(...) as.pairlist(list(...))
## This is now .Primitive:
##is.pairlist <- function(x) typeof(x) == "pairlist"
parse <- function(file = "", n = NULL, text = NULL, prompt = "?")
{
    if(!is.null(text) && length(as.character(text)) == 0)
        return(expression())
    if(is.character(file))
        if(file == "") file <- stdin()
        else {
            file <- file(file, "r")
            on.exit(close(file))
        }
    .Internal(parse(file, n, text, prompt))
}
paste <- function (..., sep = " ", collapse = NULL)
{
    args <- list(...)
    if(length(args) == 0)
        if(length(collapse) == 0) character(0) else ""
    else {
	for(i in seq(along = args)) args[[i]] <- as.character(args[[i]])
	.Internal(paste(args, sep, collapse))
    }
}

##=== Could we extend  paste(.) to (optionally) accept a
##    2-vector for collapse ?	 With the following functionality

##- paste.extra <- function(r, collapse=c(", "," and ")) {
##-	    n <- length(r)
##-	    if(n <= 1) paste(r)
##-	    else
##-	      paste(paste(r[-n],collapse=collapse[1]),
##-		    r[n], sep=collapse[min(2,length(collapse))])
##- }
### pmax() & pmin() only differ by name and ONE character :

pmax <- function (..., na.rm = FALSE)
{
    elts <- list(...)
    mmm <- as.vector(elts[[1]])
    has.na <- FALSE
    for (each in elts[-1]) {
	work <- cbind(mmm, as.vector(each)) # recycling..
        nas <- is.na(work)
	if(has.na || (has.na <- any(nas))) {
            work[,1][nas[,1]] <- work[,2][nas[,1]]
            work[,2][nas[,2]] <- work[,1][nas[,2]]
        }
        change <- work[,1] < work[,2]
	work[,1][change] <- work[,2][change]
	if (has.na && !na.rm) work[,1][nas[,1] | nas[,2]] <- NA
	mmm <- work[,1]
    }
    mostattributes(mmm) <- attributes(elts[[1]])
    mmm
}

pmin <- function (..., na.rm = FALSE)
{
    elts <- list(...)
    mmm <- as.vector(elts[[1]])
    has.na <- FALSE
    for (each in elts[-1]) {
	work <- cbind(mmm, as.vector(each)) # recycling..
        nas <- is.na(work)
	if(has.na || (has.na <- any(nas))) {
            work[,1][nas[,1]] <- work[,2][nas[,1]]
            work[,2][nas[,2]] <- work[,1][nas[,2]]
        }
	change <- work[,1] > work[,2]
	work[,1][change] <- work[,2][change]
	if(has.na && !na.rm) work[,1][nas[,1] | nas[,2]] <- NA
	mmm <- work[,1]
    }
    mostattributes(mmm) <- attributes(elts[[1]])
    mmm
}
## --> see ./pmax.R
pretty <- function(x, n=5, min.n= n %/% 3, shrink.sml = 0.75,
                   high.u.bias = 1.5, u5.bias = .5 + 1.5*high.u.bias,
                   eps.correct = 0)
{
    if(!is.numeric(x))
	stop("x must be numeric")
    if(length(x)==0)
	return(x)
    if(is.na(n <- as.integer(n[1])) || n < 0)# n=0 !!
	stop("invalid n value")
    if(!is.numeric(shrink.sml) || shrink.sml <= 0)
	stop("argument `shrink.sml' must be numeric > 0")
    if((min.n <- as.integer(min.n)) < 0 || min.n > n)
	stop("argument `min.n' must be non-negative integer <= n")
    if(!is.numeric(high.u.bias) || high.u.bias < 0)
	stop("argument `high.u.bias' must be non-negative numeric")
    if(!is.numeric(u5.bias) || u5.bias < 0)
	stop("argument `u5.bias' must be non-negative numeric")
    if((eps.correct <- as.integer(eps.correct)) < 0 || eps.correct > 2)
	stop("argument `eps.correct' must be 0, 1, or 2")
    z <- .C("R_pretty", l=as.double(min(x)), u=as.double(max(x)),
            n = n,
            min.n,
	    shrink = as.double(shrink.sml),
            high.u.fact = as.double(c(high.u.bias, u5.bias)),
            eps.correct,
            DUP = FALSE, PACKAGE = "base")
    s <- seq(z$l, z$u, length = z$n+1)
    if(!eps.correct && z$n) { # maybe zap smalls from seq() rounding errors
        ## better than zapsmall(s, digits = 14) :
        delta <- diff(range(z$l, z$u)) / z$n
        if(any(small <- abs(s) < 1e-14 * delta))
            s[small] <- 0
    }
    s
}
print <- function(x, ...) UseMethod("print")

##- Need '...' such that it can be called as  NextMethod("print", ...):
print.default <- function(x, digits = NULL, quote = TRUE, na.print = NULL,
                          print.gap = NULL, right = FALSE, ...)
{
    noOpt <- missing(digits) && missing(quote) && missing(na.print) &&
      missing(print.gap) && missing(right) && length(list(...)) == 0
    .Internal(print.default(x, digits, quote, na.print, print.gap, right,
                            noOpt))
}

print.matrix <- print.default  ## back-compatibility

prmatrix <-
    function (x, rowlab = dn[[1]], collab = dn[[2]],
              quote = TRUE, right = FALSE,
              na.print = NULL, ...)
{
    x <- as.matrix(x)
    dn <- dimnames(x)
    .Internal(prmatrix(x, rowlab, collab, quote, right, na.print))
}

noquote <- function(obj) {
    ## constructor for a useful "minor" class
    if(!inherits(obj,"noquote")) class(obj) <- c(attr(obj, "class"),"noquote")
    obj
}

as.matrix.noquote <- function(x) noquote(NextMethod("as.matrix", x))
c.noquote <- function(..., recursive = FALSE) structure(NextMethod(...), class = "noquote")

"[.noquote" <- function (x, ...) {
    attr <- attributes(x)
    r <- unclass(x)[...] ## shouldn't this be NextMethod?
    attributes(r) <- c(attributes(r),
		       attr[is.na(match(names(attr),
                                        c("dim","dimnames","names")))])
    r
}

print.noquote <- function(x, ...) {
    if(!is.null(cl <- attr(x, "class"))) {
	cl <- cl[cl != "noquote"]
        attr(x, "class") <-
          (if(length(cl)>0) cl else NULL)
      }
    print(x, quote = FALSE, ...)
}

## for alias:
print.listof <- function(x, ...)
{
    nn <- names(x)
    ll <- length(x)
    if(length(nn) != ll) nn <- paste("Component", seq(ll))
    for(i in seq(length=ll)) {
	cat(nn[i], ":\n"); print(x[[i]], ...); cat("\n")
    }
    invisible(x)
}

## used for version:
print.simple.list <- function(x, ...)
    print(noquote(cbind("_"=unlist(x))), ...)

#is.qr <- function(x) !is.null(x$qr) && !is.null(x$rank) && !is.null(x$qraux)

is.qr <- function(x) inherits(x, "qr")

qr <- function(x, tol = 1e-07, LAPACK = FALSE)
{
    x <- as.matrix(x)
    if(is.complex(x))
        return(structure(.Call("La_zgeqp3", x, PACKAGE = "base"), class="qr"))
    if(LAPACK) {
        res <- .Call("La_dgeqp3", x, PACKAGE = "base")
        attr(res, "useLAPACK") <- TRUE
        class(res) <- "qr"
        return(res)
    }

    p <- ncol(x) # guaranteed to be integer
    n <- nrow(x)
    if(!is.double(x))
	storage.mode(x) <- "double"
    res <- .Fortran("dqrdc2",
	     qr=x,
	     n,
	     n,
	     p,
	     as.double(tol),
	     rank=integer(1),
	     qraux = double(p),
	     pivot = as.integer(1:p),
	     double(2*p),
	     PACKAGE="base")[c(1,6,7,8)]# c("qr", "rank", "qraux", "pivot")
    class(res) <- "qr"
    res
}

qr.coef <- function(qr, y)
{
    if( !is.qr(qr) )
	stop("first argument must be a QR decomposition")
    n <- nrow(qr$qr)
    p <- ncol(qr$qr)
    k <- as.integer(qr$rank)
    im <- is.matrix(y)
    if (!im) y <- as.matrix(y)
    ny <- ncol(y)
    if (p==0) return( if (im) matrix(0,p,ny) else numeric(0) )
    if(is.complex(qr$qr)) {
	if(!is.complex(y)) y[] <- as.complex(y)
	coef <- matrix(as.complex(NA), nr=p, nc=ny)
	coef[qr$pivot,] <- .Call("qr_coef_cmplx", qr, y, PACKAGE = "base")[1:p]
	return(if(im) coef else c(coef))
    }
    ## else {not complex} :
    a <- attr(qr, "useLAPACK")
    if(!is.null(a) && is.logical(a) && a) {
	coef <- matrix(as.double(NA), nr=p, nc=ny)
	coef[qr$pivot,] <- .Call("qr_coef_real", qr, y, PACKAGE = "base")[1:p]
	return(if(im) coef else c(coef))
    }
    if (k==0) return( if (im) matrix(NA,p,ny) else rep.int(NA,p))

    storage.mode(y) <- "double"
    if( nrow(y) != n )
	stop("qr and y must have the same number of rows")
    z <- .Fortran("dqrcf",
		  as.double(qr$qr),
		  n, k,
		  as.double(qr$qraux),
		  y,
		  ny,
		  coef=matrix(0,nr=k,nc=ny),
		  info=integer(1),
		  NAOK = TRUE, PACKAGE="base")[c("coef","info")]
    if(z$info != 0) stop("exact singularity in qr.coef")
    if(k < p) {
	coef <- matrix(as.double(NA), nr=p, nc=ny)
	coef[qr$pivot[1:k],] <- z$coef
    }
    else coef <- z$coef

    if(!is.null(nam <- colnames(qr$qr)))
	rownames(coef) <- nam
    if(im && !is.null(nam <- colnames(y)))
       colnames(coef) <- nam

    if(im) coef else drop(coef)
}

qr.qy <- function(qr, y)
{
    if(!is.qr(qr)) stop("argument is not a QR decomposition")
    if(is.complex(qr$qr)) {
        y <- as.matrix(y)
        if(!is.complex(y)) y[] <- as.complex(y)
        return(.Call("qr_qy_cmplx", qr, y, 0, PACKAGE = "base"))
    }
    a <- attr(qr, "useLAPACK")
    if(!is.null(a) && is.logical(a) && a)
        return(.Call("qr_qy_real", qr, as.matrix(y), 0, PACKAGE = "base"))
    n <- nrow(qr$qr)
#    p <- ncol(qr$qr)
    k <- as.integer(qr$rank)
    ny <- NCOL(y)
    storage.mode(y) <- "double"
    if(NROW(y) != n)
	stop("qr and y must have the same number of rows")
    .Fortran("dqrqy",
	     as.double(qr$qr),
	     n, k,
	     as.double(qr$qraux),
	     y,
	     ny,
	     qy = y,# incl. {dim}names
	     PACKAGE="base")$qy
}

qr.qty <- function(qr, y)
{
    if(!is.qr(qr)) stop("argument is not a QR decomposition")
    if(is.complex(qr$qr)){
        y <- as.matrix(y)
        if(!is.complex(y)) y[] <- as.complex(y)
        return(.Call("qr_qy_cmplx", qr, y, 1, PACKAGE = "base"))
    }
    a <- attr(qr, "useLAPACK")
    if(!is.null(a) && is.logical(a) && a)
        return(.Call("qr_qy_real", qr, as.matrix(y), 1, PACKAGE = "base"))

    n <- nrow(qr$qr)
#    p <- ncol(qr$qr)
    k <- as.integer(qr$rank)
    ny <- NCOL(y)
    if(NROW(y) != n)
	stop("qr and y must have the same number of rows")
    storage.mode(y) <- "double"
    .Fortran("dqrqty",
	     as.double(qr$qr),
	     n, k,
	     as.double(qr$qraux),
	     y,
	     ny,
	     qty = y,# incl. {dim}names
             PACKAGE = "base")$qty
}

qr.resid <- function(qr, y)
{
    if(!is.qr(qr)) stop("argument is not a QR decomposition")
    if(is.complex(qr$qr)) stop("implemented for complex qr")
    a <- attr(qr, "useLAPACK")
    if(!is.null(a) && is.logical(a) && a)
        stop("not supported for LAPACK QR")
    k <- as.integer(qr$rank)
    if (k==0) return(y)
    n <- nrow(qr$qr)
#    p <- ncol(qr$qr)
    ny <- NCOL(y)
    if( NROW(y) != n )
	stop("qr and y must have the same number of rows")
    storage.mode(y) <- "double"
    .Fortran("dqrrsd",
	     as.double(qr$qr),	     n, k,
	     as.double(qr$qraux),
             y,
	     ny,
	     rsd = y,# incl. {dim}names
	     PACKAGE="base")$rsd
}

qr.fitted <- function(qr, y, k=qr$rank)
{
    if(!is.qr(qr)) stop("argument is not a QR decomposition")
    if(is.complex(qr$qr)) stop("implemented for complex qr")
    a <- attr(qr, "useLAPACK")
    if(!is.null(a) && is.logical(a) && a)
        stop("not supported for LAPACK QR")
    n <- nrow(qr$qr)
    k <- as.integer(k)
    if(k > qr$rank) stop("k is too large")
    ny <- NCOL(y)
    if( NROW(y) != n )
	stop("qr and y must have the same number of rows")
    storage.mode(y) <- "double"
    .Fortran("dqrxb",
	     as.double(qr$qr),
	     n, k,
	     as.double(qr$qraux),
	     y,
	     ny,
	     xb = (yy <- y),# incl. {dim}names
             DUP=FALSE, PACKAGE="base")$xb
}

## qr.solve is defined in  ./solve.R

##---- The next three are from Doug Bates ('st849'):
qr.Q <- function (qr, complete = FALSE,
		  Dvec = rep.int(if (cmplx) 1 + 0i else 1,
		  if (complete) dqr[1] else min(dqr)))
{
    if(!is.qr(qr)) stop("argument is not a QR decomposition")
    dqr <- dim(qr$qr)
    cmplx <- mode(qr$qr) == "complex"
    D <-
	if (complete) diag(Dvec, dqr[1])
	else {
	    ncols <- min(dqr)
	    diag(Dvec[1:ncols], nrow = dqr[1], ncol = ncols)
	}
    qr.qy(qr, D)
}

qr.R <- function (qr, complete = FALSE)
{
    if(!is.qr(qr)) stop("argument is not a QR decomposition")
    R <- qr$qr
    if (!complete)
	R <- R[seq(min(dim(R))), , drop = FALSE]
    R[row(R) > col(R)] <- 0
    R
}

qr.X <- function (qr, complete = FALSE,
		  ncol = if (complete) nrow(R) else min(dim(R)))
{
    if(!is.qr(qr)) stop("argument is not a QR decomposition")
    pivoted <- !identical(qr$pivot, seq(along=qr$pivot))
    R <- qr.R(qr, complete = TRUE)
    if(pivoted && ncol < length(qr$pivot))
        stop("need larger value of ncol as pivoting occurred")
    cmplx <- mode(R) == "complex"
    p <- dim(R)[2]
    if (ncol < p)
	R <- R[, 1:ncol, drop = FALSE]
    else if (ncol > p) {
	tmp <- diag(if (!cmplx) 1 else 1 + 0i, nrow(R), ncol)
	tmp[, 1:p] <- R
	R <- tmp
    }
    res <- qr.qy(qr, R)
    if(pivoted) res[, qr$pivot] <- res[, seq(along=qr$pivot)]
    res
}
quit <- function(save = "default", status=0, runLast=TRUE)
    .Internal(quit(save, status, runLast))
q <- quit
range <- function(..., na.rm = FALSE)
    .Internal(range(..., na.rm = na.rm))

range.default <- function(..., na.rm = FALSE, finite = FALSE) {
    x <- c(..., recursive = TRUE)
    if(finite) x <- x[is.finite(x)]
    else if(na.rm) x <- x[!is.na(x)]
    c(min(x), max(x)) # even if x is empty from 1.5.0
}
rank <- function(x, na.last = TRUE, ties.method=c("average", "first", "random"))
{
    nas <- is.na(x)
    ties.method <- match.arg(ties.method)
    y <- switch(ties.method,
                "average" = .Internal(rank(   x[!nas])),
                "first" = sort.list(sort.list(x[!nas])),
                "random" = sort.list(order(   x[!nas], runif(sum(!nas)))))
    if(!is.na(na.last) && any(nas)) {
	## the internal code has ranks in [1, length(y)]
	storage.mode(x) <- "double"
	NAkeep <- (na.last == "keep")
	if(NAkeep || na.last) {
	    x[!nas] <- y
	    if(!NAkeep) x[nas] <- (length(y) + 1:1):length(x)
	} else {
	    len <- sum(nas)
	    x[!nas] <- y + len
	    x[nas] <- 1 : len
	}
	y <- x
    } else names(y) <- names(x)[!nas]
    y
}
count.fields <- function(file, sep = "", quote = "\"'", skip = 0,
                         blank.lines.skip = TRUE, comment.char = "#")
{
    if(is.character(file)) {
        file <- file(file)
        on.exit(close(file))
    }
    if(!inherits(file, "connection"))
        stop("argument `file' must be a character string or connection")
    .Internal(count.fields(file, sep, quote, skip, blank.lines.skip,
                           comment.char))
}


type.convert <- function(x, na.strings = "NA", as.is = FALSE, dec = ".")
    .Internal(type.convert(x, na.strings, as.is, dec))


read.table <-
    function (file, header = FALSE, sep = "", quote = "\"'", dec = ".",
              row.names, col.names, as.is = FALSE,
	      na.strings = "NA", colClasses = NA,
              nrows = -1, skip = 0,
              check.names = TRUE, fill = !blank.lines.skip,
              strip.white = FALSE, blank.lines.skip = TRUE,
              comment.char = "#")
{
    if(is.character(file)) {
        file <- file(file, "r")
        on.exit(close(file))
    }
    if(!inherits(file, "connection"))
        stop("argument `file' must be a character string or connection")
    if(!isOpen(file)) {
        open(file, "r")
        on.exit(close(file))
    }

    if(skip > 0) readLines(file, skip)
    ## read a few lines to determine header, no of cols.
    nlines <- if (nrows < 0) 5 else min(5, (header + nrows))

    lines <- .Internal(readTableHead(file, nlines, comment.char,
                                     blank.lines.skip, quote))
    nlines <- length(lines)
    if(!nlines) {
        if(missing(col.names))
            stop("no lines available in input")
        else {
            tmp <- vector("list", length(col.names))
            names(tmp) <- col.names
            class(tmp) <- "data.frame"
            return(tmp)
        }
    }
    if(all(nchar(lines) == 0)) stop("empty beginning of file")
    pushBack(c(lines, lines), file)
    first <- scan(file, what = "", sep = sep, quote = quote,
                  nlines = 1, quiet = TRUE, skip = 0,
                  strip.white = TRUE,
                  blank.lines.skip = blank.lines.skip,
                  comment.char = comment.char)
    col1 <- if(missing(col.names)) length(first) else length(col.names)
    col <- numeric(nlines - 1)
    if (nlines > 1)
        for (i in seq(along=col))
            col[i] <- length(scan(file, what = "", sep = sep,
                                  quote = quote,
                                  nlines = 1, quiet = TRUE, skip = 0,
                                  strip.white = strip.white,
                                  blank.lines.skip = blank.lines.skip,
                                  comment.char = comment.char))
    cols <- max(col1, col)

    ##	basic column counting and header determination;
    ##	rlabp (logical) := it looks like we have column names

    rlabp <- (cols - col1) == 1
    if(rlabp && missing(header))
	header <- TRUE
    if(!header) rlabp <- FALSE

    if (header) {
        readLines(file, 1) # skip over header
        if(missing(col.names)) col.names <- first
        else if(length(first) != length(col.names))
            warning("header and `col.names' are of different lengths")

    } else if (missing(col.names))
	col.names <- paste("V", 1:cols, sep = "")
    if(length(col.names) + rlabp < cols)
        stop("more columns than column names")
    if(fill && length(col.names) > cols)
        cols <- length(col.names)
    if(!fill && cols > 0 && length(col.names) > cols)
        stop("more column names than columns")
    if(cols == 0) stop("first five rows are empty: giving up")


    if(check.names) col.names <- make.names(col.names, unique = TRUE)
    if (rlabp) col.names <- c("row.names", col.names)

    if(length(colClasses) < cols)
        colClasses <- rep(colClasses, length.out=cols)

    ##	set up for the scan of the file.
    ##	we read unknown values as character strings and convert later.

    what <- rep.int(list(""), cols)
    names(what) <- col.names

    colClasses[colClasses %in% c("real", "double")] <- "numeric"
    known <- colClasses %in%
                c("logical", "integer", "numeric", "complex", "character")
    what[known] <- sapply(colClasses[known], do.call, list(0))

    data <- scan(file = file, what = what, sep = sep, quote = quote,
                 dec = dec, nmax = nrows, skip = 0,
		 na.strings = na.strings, quiet = TRUE, fill = fill,
                 strip.white = strip.white,
                 blank.lines.skip = blank.lines.skip, multi.line = FALSE,
                 comment.char = comment.char)

    nlines <- length(data[[1]])

    ##	now we have the data;
    ##	convert to numeric or factor variables
    ##	(depending on the specified value of "as.is").
    ##	we do this here so that columns match up

    if(cols != length(data)) { # this should never happen
	warning(paste("cols =", cols," != length(data) =", length(data)))
	cols <- length(data)
    }

    if(is.logical(as.is)) {
	as.is <- rep(as.is, length.out=cols)
    } else if(is.numeric(as.is)) {
	if(any(as.is < 1 | as.is > cols))
	    stop("invalid numeric as.is expression")
	i <- rep.int(FALSE, cols)
	i[as.is] <- TRUE
	as.is <- i
    } else if(is.character(as.is)) {
        i <- match(as.is, col.names, 0)
        if(any(i <= 0))
            warning("not all columns named in as.is exist")
        i <- i[i > 0]
        as.is <- rep.int(FALSE, cols)
        as.is[i] <- TRUE
    } else if (length(as.is) != cols)
	stop(paste("as.is has the wrong length",
		   length(as.is),"!= cols =", cols))
    for (i in 1:cols) {
#        if(known[i] || as.is[i]) next
        if(known[i]) next
        data[[i]] <-
            if (!is.na(colClasses[i])) as(data[[i]], colClasses[i])
            else type.convert(data[[i]], as.is = as.is[i], dec = dec,
                              na.strings = character(0))
        ## as na.strings have already be converted to <NA>
    }

    ##	now determine row names

    if (missing(row.names)) {
	if (rlabp) {
	    row.names <- data[[1]]
	    data <- data[-1]
	}
	else row.names <- as.character(seq(len=nlines))
    } else if (is.null(row.names)) {
	row.names <- as.character(seq(len=nlines))
    } else if (is.character(row.names)) {
	if (length(row.names) == 1) {
	    rowvar <- (1:cols)[match(col.names, row.names, 0) == 1]
	    row.names <- data[[rowvar]]
	    data <- data[-rowvar]
	}
    } else if (is.numeric(row.names) && length(row.names) == 1) {
	rlabp <- row.names
	row.names <- data[[rlabp]]
	data <- data[-rlabp]
    } else stop("invalid row.names specification")

    ##	this is extremely underhanded
    ##	we should use the constructor function ...
    ##	don't try this at home kids

    class(data) <- "data.frame"
    row.names(data) <- row.names
    data
}

read.csv <-
    function (file, header = TRUE, sep = ",", quote="\"", dec=".",
              fill = TRUE, ...)
    read.table(file = file, header = header, sep = sep,
               quote = quote, dec = dec, fill = fill, ...)

read.csv2 <-
    function (file, header = TRUE, sep = ";", quote="\"", dec=",",
              fill = TRUE, ...)
    read.table(file = file, header = header, sep = sep,
               quote = quote, dec = dec, fill = fill, ...)

read.delim <-
    function (file, header = TRUE, sep = "\t", quote="\"", dec=".",
              fill = TRUE, ...)
    read.table(file = file, header = header, sep = sep,
               quote = quote, dec = dec, fill = fill, ...)

read.delim2 <-
    function (file, header = TRUE, sep = "\t", quote="\"", dec=",",
              fill = TRUE, ...)
    read.table(file = file, header = header, sep = sep,
               quote = quote, dec = dec, fill = fill, ...)

rep <- function(x, times, ...) UseMethod("rep")

rep.default <- function(x, times, length.out, each, ...)
{
    if (length(x) == 0)
        return(if(missing(length.out)) x else x[seq(len=length.out)])
    if (!missing(each)) {
        tm <- .Internal(rep(each, length(x)))
        nm <- names(x)
        x <- .Internal(rep(x, tm))
        if(!is.null(nm)) names(x) <- .Internal(rep(nm, tm))
        if(missing(length.out) && missing(times)) return(x)
    }
    if (!missing(length.out)) # takes precedence over times
	times <- ceiling(length.out/length(x))
    r <- .Internal(rep(x, times))
    if(!is.null(nm <- names(x))) names(r) <- .Internal(rep(nm, times))
    if (!missing(length.out))
	return(r[if(length.out > 0) 1:length.out else integer(0)])
    return(r)
}

rep.int <- function(x, times) .Internal(rep(x, times))
replace <-
    function (x, list, values)
{
    x[list] <- values
    x
}
replicate <- function(n, expr, simplify = TRUE) 
        sapply(integer(n), 
           eval.parent(substitute(function(...)expr)), simplify = simplify)
rev <- function(x) UseMethod("rev")

rev.default <- function(x) if (length(x) > 0) x[length(x):1] else x
rle <- function(x) {
    if (!is.vector(x))
        stop("x must be a vector")
    n <- length(x)
    if (n == 0)
        return(list(lengths = integer(0), values = x))
    y <- x[-1] != x[-n]
    i <- c(which(y | is.na(y)), n)
    structure(list(lengths = diff(c(0:0, i)), values = x[i]),
              class = "rle")
}

print.rle <- function(x, digits = getOption("digits"), ...)
{
    if(is.null(digits)) digits <- getOption("digits")
    cat("Run Length Encoding\n  lengths:")
    str(x$lengths)
    cat("  values :")
    str(x$values, digits = digits)
    invisible(x)
}

inverse.rle <- function(x, ...)
{
    if(is.null(le <- x$lengths) ||
       is.null(v  <- x$values) || length(le) != length(v))
        stop("invalid `rle' structure")
    rep(v, le)
}

rm <-
    function (..., list = character(0), pos = -1, envir = as.environment(pos),
              inherits = FALSE)
{
    names <- sapply(match.call(expand.dots=FALSE)$..., as.character)
    if (length(names)==0) names<-character(0)
    list <- .Primitive("c")(list, names)
    .Internal(remove(list, envir, inherits))
}

remove <- rm
rowsum<-function(x,group,reorder=TRUE,...)
    UseMethod("rowsum")

rowsum.default <-function(x,group,reorder=TRUE,...){
    if (!is.numeric(x)) 
        stop("x must be numeric")
    if (length(group) != NROW(x)) 
        stop("Incorrect length for 'group'")
    if (any(is.na(group))) 
        warning("Missing values for 'group'")
    ugroup<-unique(group)
    if (reorder) ugroup<-sort(ugroup,na.last=TRUE)
    
    rval<-.Call("Rrowsum_matrix",x,NCOL(x),group,ugroup,PACKAGE="base")
    
    dimnames(rval)<-list(as.character(ugroup),dimnames(x)[[2]])
    rval
}

rowsum.data.frame<-function(x,group,reorder=TRUE,...){
    if (!is.data.frame(x)) stop("not a data frame") ## make MM happy
    if (length(group) != NROW(x)) 
        stop("Incorrect length for 'group'")
    if (any(is.na(group))) 
        warning("Missing values for 'group'")
    ugroup<-unique(group)
    if (reorder) ugroup<-sort(ugroup,na.last=TRUE)
    
    rval<-.Call("Rrowsum_df",x,NCOL(x),group,ugroup,PACKAGE="base")
    
    as.data.frame(rval,row.names=as.character(ugroup))
}
sample <- function(x, size, replace=FALSE, prob=NULL)
{
    if(length(x) == 1 && x >= 1) {
	if(missing(size)) size <- x
	.Internal(sample(x, size, replace, prob))
    }
    else {
	if(missing(size)) size <- length(x)
	x[.Internal(sample(length(x), size, replace, prob))]
    }
}
sapply <- function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE)
{
    FUN <- match.fun(FUN)
    answer <- lapply(as.list(X), FUN, ...)
    if(USE.NAMES && is.character(X) && is.null(names(answer)))
                names(answer) <- X
    if(simplify && length(answer) &&
       length(common.len <- unique(unlist(lapply(answer, length)))) == 1) {
	if(common.len == 1)
	    unlist(answer, recursive = FALSE)
	else if(common.len > 1)
	    array(unlist(answer, recursive = FALSE),
		  dim= c(common.len, length(X)),
		  dimnames= if(!(is.null(n1 <- names(answer[[1]])) &
			         is.null(n2 <- names(answer)))) list(n1,n2))
	else answer
    } else answer
}

scale <- function(x, center = TRUE, scale = TRUE) UseMethod("scale")

scale.default <- function(x, center = TRUE, scale = TRUE)
{
    x <- as.matrix(x)
    nc <- ncol(x)
    if (is.logical(center)) {
	if (center) {
            center <- colMeans(x, na.rm=TRUE)
	    x <- sweep(x, 2, center)
        }
    }
    else if (is.numeric(center) && (length(center) == nc))
	x <- sweep(x, 2, center)
    else
	stop("Length of center must equal the number of columns of x")
    if (is.logical(scale)) {
	if (scale) {
	    f <- function(v) {
		v <- v[!is.na(v)]
		sqrt(sum(v^2) / max(1, length(v) - 1))
	    }
            scale <- apply(x, 2, f)
	    x <- sweep(x, 2, scale, "/")
	}
    }
    else if (is.numeric(scale) && length(scale) == nc)
	x <- sweep(x, 2, scale, "/")
    else
	stop("Length of scale must equal the number of columns of x")
    if(is.numeric(center)) attr(x, "scaled:center") <- center
    if(is.numeric(scale)) attr(x, "scaled:scale") <- scale
    x
}
scan <-
    function(file = "", what = double(0), nmax = -1, n = -1, sep = "",
	     quote = if (sep=="\n") "" else "'\"",
             dec = ".", skip = 0, nlines = 0,
	     na.strings = "NA", flush = FALSE, fill = FALSE,
             strip.white = FALSE, quiet = FALSE, blank.lines.skip = TRUE,
             multi.line = TRUE, comment.char = "")
{
    na.strings <- as.character(na.strings)# allow it to be NULL
    if(!missing(n)) {
        if(missing(nmax))
            nmax <- n / pmax(length(what), 1)
        else
            stop("Either specify `nmax' or `n', but not both.")
    }
    if(is.character(file))
        if(file == "") file <- stdin()
        else {
            file <- file(file, "r")
            on.exit(close(file))
        }
    if(!inherits(file, "connection"))
        stop("argument `file' must be a character string or connection")
    .Internal(scan(file, what, nmax, sep, dec, quote, skip, nlines,
                   na.strings, flush, fill, strip.white, quiet,
                   blank.lines.skip, multi.line, comment.char))
}
seq <- function(...) UseMethod("seq")

seq.default <-
    function(from = 1, to = 1, by = ((to - from)/(length.out - 1)),
             length.out = NULL, along.with = NULL, ...)
{
    if((One <- nargs() == 1) && !missing(from)) {
	lf <- length(from)
	return(if(mode(from) == "numeric" && lf == 1) 1:from else
	       if(lf) 1:lf else integer(0))
    }
    if(!missing(along.with)) {
	length.out <- length(along.with)
	if(One) return(if(length.out) 1:length.out else integer(0))
    }
    else if(!missing(length.out))
	length.out <- ceiling(length.out)
    if(is.null(length.out))
	if(missing(by))
	    from:to
	else { # dealing with 'by'
	    del <- to - from
	    if(del == 0 && to == 0) return(to)
	    n <- del/by
	    if(!(length(n) && is.finite(n))) {
		if(length(by) && by == 0 && length(del) && del == 0)
		    return(from)
		stop("invalid (to - from)/by in seq(.)")
	    }
	    if(n < 0)
		stop("Wrong sign in 'by' argument")
	    if(n > .Machine$integer.max)
		stop("'by' argument is much too small")

	    dd <- abs(del)/max(abs(to), abs(from))
	    if (dd < 100*.Machine$double.eps) return(from)
	    n <- as.integer(n + 1e-7)
	    from + (0:n) * by
	}
    else if(!is.finite(length.out) || length.out < 0)
	stop("Length must be non-negative number")
    else if(length.out == 0)
	integer(0)
    else if(missing(by)) {
	if(from == to || length.out < 2)
	    by <- 1
	if(missing(to))
	    to <- from + length.out - 1
	if(missing(from))
	    from <- to - length.out + 1
	if(length.out > 2)
	    if(from == to)
		rep.int(from, length.out)
	    else as.vector(c(from, from + (1:(length.out - 2)) * by, to))
	else as.vector(c(from, to))[1:length.out]
    }
    else if(missing(to))
	from + (0:(length.out - 1)) * by
    else if(missing(from))
	to - ((length.out - 1):0) * by
    else stop("Too many arguments")
}

sequence <- function(nvec)
{
    s <- integer(0)
    for(i in nvec)
	s <- c(s, 1:i)
    return(s)
}
.saveRDS <-
function(object, file = "", ascii = FALSE, version = NULL,
         compress = FALSE, refhook = NULL)
{
    if(is.character(file)) {
        if(file == "") stop("'file' must be non-empty string")
        mode <- if(ascii) "w" else "wb"
        con <- if(compress) gzfile(file, mode) else file(file, mode)
        on.exit(close(con))
    }
    else if (inherits(file, "connection")) {
        con <- file
        if(missing(ascii)) ascii <- summary(con)$text == "text"
    }
    else stop("bad 'file' argument")
    invisible(.Internal(serializeToConn(object, con, ascii, version, refhook)))
}

.readRDS <-
function(file, refhook = NULL)
{
    if(is.character(file)) {
        con <- gzfile(file, "rb")
        on.exit(close(con))
    } else if (inherits(file, "connection")) con <- file
    else stop("bad 'file' argument")
    .Internal(unserializeFromConn(con, refhook))
}

serialize <- function(object, connection, ascii = FALSE, refhook = NULL) {
    if (! is.null(connection)) {
        if (!inherits(connection, "connection"))
            stop("`connection' must be a connection")
        if (missing(ascii)) ascii <- summary(connection)$text == "text"
    }
    if (! ascii && inherits(connection, "sockconn"))
        .Call("R_serializeb", object, connection, refhook, PACKAGE="base")
    else
        .Call("R_serialize", object, connection, ascii, refhook,
              PACKAGE="base")
}

unserialize <- function(connection, refhook = NULL) {
    if (! is.character(connection) && !inherits(connection, "connection"))
        stop("`connection' must be a connection")
    .Call("R_unserialize", connection, refhook, PACKAGE="base")
}
union <- function(x, y) unique(c(x, y))

intersect <- function(x, y) unique(y[match(x, y, 0)])

setdiff <- function(x, y)
    unique(if(length(x) || length(y)) x[match(x, y, 0) == 0] else x)

## Faster versions, see R-devel, Jan.4-6, 2000;  optimize later...
setequal <- function(x, y) all(c(match(x, y, 0) > 0, match(y, x, 0) > 0))

##  same as %in% ( ./match.R ) but different arg names:
is.element <- function(el, set) match(el, set, 0) > 0
sink <- function(file=NULL, append = FALSE, type = c("output", "message"), split=FALSE)
{
    type <- match.arg(type)
    if(type == "message") {
        if(is.null(file)) file <- stderr()
        else if(!inherits(file, "connection") || !isOpen(file))
           stop("`file' must be NULL or an already open connection")
        if (split) stop("Can't split the message connection")
        .Internal(sink(file, FALSE, TRUE, FALSE))
    } else {
        closeOnExit <- FALSE
        if(is.null(file)) file <- -1
        else if(is.character(file)) {
            file <- file(file, ifelse(append, "a", "w"))
            closeOnExit <- TRUE
        } else if(!inherits(file, "connection"))
            stop("`file' must be NULL, a connection or a character string")
        .Internal(sink(file, closeOnExit, FALSE,split))
    }
}

sink.number <- function(type = c("output", "message"))
{
    type <- match.arg(type)
    .Internal(sink.number(type != "message"))
}
solve.qr <- function(a, b, ...)
{
    if( !is.qr(a) )
	stop("this is the qr method for the solve generic")
    nc <- ncol(a$qr)
    if( a$rank != nc )
	stop("singular matrix `a' in solve")
    if( missing(b) ) {
	if( nc != nrow(a$qr) )
	    stop("only square matrices can be inverted")
	b <- diag(1, nc)
    }
    return(qr.coef(a, b))
}

solve.default <-
    function(a, b, tol = ifelse(LINPACK, 1e-7, .Machine$double.eps),
             LINPACK = FALSE, ...)
{
    if(is.complex(a) || (!missing(b) && is.complex(b))) {
        a <- as.matrix(a)
        if(missing(b)) {
            b <- diag(1+0i, nrow(a))
            colnames(b) <- rownames(a)
        } else if(!is.complex(b)) b[] <- as.complex(b)
        if(!is.complex(a)) a[] <- as.complex(a)
        return (if (is.matrix(b)) {
            rownames(b) <- colnames(a)
	    .Call("La_zgesv", a, b, PACKAGE = "base")
	} else
	    drop(.Call("La_zgesv", a, as.matrix(b), PACKAGE = "base")))
    }
    if(is.qr(a)) {
        warning("solve.default called with a qr object: use qr.solve")
        return(solve.qr(a, b, tol))
    }
    
    if(!LINPACK) {
        a <- as.matrix(a)
        if(missing(b)) {
            b <- diag(1.0, nrow(a))
            colnames(b) <- rownames(a)
        } else storage.mode(b) <- "double"
        storage.mode(a) <- "double"
        return (if (is.matrix(b)) {
            rownames(b) <- colnames(a)
	    .Call("La_dgesv", a, b, tol, PACKAGE = "base")
	} else
	    drop(.Call("La_dgesv", a, as.matrix(b), tol, PACKAGE = "base")))
    }
    a <- qr(a, tol = tol)
    nc <- ncol(a$qr)
    if( a$rank != nc )
	stop("singular matrix `a' in solve")
    if( missing(b) ) {
	if( nc != nrow(a$qr) )
	    stop("only square matrices can be inverted")
        ## preserve dimnames
	b <- diag(1, nc)
        colnames(b) <- rownames(a$qr)
    }
    qr.coef(a, b)
}

solve <- function(a, b, ...) UseMethod("solve")

qr.solve <- function(a, b, tol = 1e-7)
{
    if( !is.qr(a) )
	a <- qr(a, tol = tol)
    nc <- ncol(a$qr)
    if( a$rank != nc )
	stop("singular matrix `a' in solve")
    if( missing(b) ) {
	if( nc != nrow(a$qr) )
	    stop("only square matrices can be inverted")
	b <- diag(1, nc)
    }
    return(qr.coef(a, b))
}

sort <- function(x, partial = NULL, na.last = NA, decreasing = FALSE,
                 method = c("shell", "quick"), index.return = FALSE)
{
    if(isfact <- is.factor(x)) {
        if(index.return) stop("index.return only for non-factors")
	lev <- levels(x)
	nlev <- nlevels(x)
 	isord <- is.ordered(x)
        x <- c(x)
    } else
    if(!is.atomic(x))
        stop("`x' must be atomic")
    if(has.na <- any(ina <- is.na(x))) {
        nas <- x[ina]
        x <-  x[!ina]
    }
    if(index.return && !is.na(na.last))
        stop("index.return only for na.last = NA")
    if(!is.null(partial)) {
        if(!all(is.finite(partial))) stop("non-finite `partial'")
	y <- .Internal(psort(x, partial))
    }
    else {
        nms <- names(x)
        method <- if(is.numeric(x)) match.arg(method) else "shell"
        switch(method,
               "quick" = {
                   if(!is.null(nms)) {
                       if(decreasing) x <- -x
                       y <- .Internal(qsort(x, TRUE))
                       if(decreasing) y$x <- -y$x
                       names(y$x) <- nms[y$ix]
                       if (!index.return) y <- y$x
                   } else {
                       if(decreasing) x <- -x
                       y <- .Internal(qsort(x, index.return))
                       if(decreasing)
                           if(index.return) y$x <- -y$x else y <- -y
                   }
               },
               "shell" = {
                   if(index.return || !is.null(nms)) {
                       o <- sort.list(x, decreasing = decreasing)
                       y <- if (index.return) list(x = x[o], ix = o) else x[o]
                       ## names(y) <- nms[o] # pointless!
                   }
                   else
                       y <- .Internal(sort(x, decreasing))
               })
    }
    if(!is.na(na.last) && has.na)
	y <- if(!na.last) c(nas, y) else c(y, nas)
    if(isfact)
        y <- (if (isord) ordered else factor)(y, levels=seq(len=nlev),
                                              labels=lev)
    y
}

order <- function(..., na.last = TRUE, decreasing = FALSE)
{
    if(!is.na(na.last))
        .Internal(order(na.last, decreasing, ...))
    else{ ## remove nas
        z <- list(...)
        if(any(diff(sapply(z, length)) != 0))
            stop("Argument lengths differ")
        ans <- sapply(z, is.na)
        ok <- if(is.matrix(ans)) !apply(ans, 1, any) else !any(ans)
        if(all(!ok)) return(integer(0))
        z[[1]][!ok] <- NA
        ans <- do.call("order", c(z, decreasing=decreasing))
        keep <- seq(along=ok)[ok]
        ans[ans %in% keep]
    }
}

sort.list <- function(x, partial = NULL, na.last = TRUE, decreasing = FALSE,
                      method = c("shell", "quick", "radix"))
{
    method <- match.arg(method)
    if(!is.atomic(x))
        stop("`x' must be atomic")
    if(!is.null(partial))
        .NotYetUsed("partial != NULL")
    if(method == "quick") {
        if(is.factor(x)) x <- as.integer(x) # sort the internal codes
        if(is.numeric(x))
            return(sort(x, na.last = na.last, decreasing = decreasing,
                        method = "quick", index.return = TRUE)$ix)
        else stop("method=\"quick\" is only for numeric x")
    }
    if(method == "radix") {
        if(!is.integer(x)) stop("method=\"radix\" is only for integer x")
        if(is.na(na.last))
            return(.Internal(radixsort(x[!is.na(x)], TRUE, decreasing)))
        else
            return(.Internal(radixsort(x, na.last, decreasing)))
    }
    ## method == "shell"
    if(is.na(na.last)) .Internal(order(TRUE, decreasing, x[!is.na(x)]))
    else .Internal(order(na.last, decreasing, x))
}
source <-
function(file, local = FALSE, echo = verbose, print.eval = echo,
	 verbose = getOption("verbose"),
	 prompt.echo = getOption("prompt"),
	 max.deparse.length = 150, chdir = FALSE)
{
    eval.with.vis <-
	function (expr, envir = parent.frame(),
		  enclos = if (is.list(envir) || is.pairlist(envir))
		  parent.frame())
	.Internal(eval.with.vis(expr, envir, enclos))

    envir <- if (local) parent.frame() else .GlobalEnv
    if (!missing(echo)) {
	if (!is.logical(echo))
	    stop("echo must be logical")
	if (!echo && verbose) {
	    warning(paste("verbose is TRUE, echo not; ... coercing",
			  sQuote("echo <- TRUE")))
	    echo <- TRUE
	}
    }
    if (verbose) {
	cat(sQuote("envir"), "chosen:")
	print(envir)
    }
    Ne <- length(exprs <- parse(n = -1, file = file))
    if (verbose)
	cat("--> parsed", Ne, "expressions; now eval(.)ing them:\n")
    if (Ne == 0)
	return(invisible())
    if (chdir && (path <- dirname(file)) != ".") {
	owd <- getwd()
	on.exit(setwd(owd))
	setwd(path)
    }

    if (echo) {
	## Reg.exps for string delimiter/ NO-string-del /
	## odd-number-of-str.del needed, when truncating below
	sd <- "\""
	nos <- "[^\"]*"
	oddsd <- paste("^", nos, sd, "(", nos, sd, nos, sd, ")*",
		       nos, "$", sep = "")
    }
    for (i in 1:Ne) {
	if (verbose)
	    cat("\n>>>> eval(expression_nr.", i, ")\n\t	 =================\n")
	ei <- exprs[i]
	if (echo) {
	    # drop "expression("
	    dep <- substr(paste(deparse(ei), collapse = "\n"),
			  12, 1e+06)
	    # -1: drop ")"
	    nd <- nchar(dep) - 1
	    do.trunc <- nd > max.deparse.length
	    dep <- substr(dep, 1, if (do.trunc) max.deparse.length else nd)
	    cat("\n", prompt.echo, dep, if (do.trunc)
		paste(if (length(grep(sd, dep)) && length(grep(oddsd, dep)))
		      " ...\" ..."
		      else " ....", "[TRUNCATED] "), "\n", sep = "")
	}
	yy <- eval.with.vis(ei, envir)
	i.symbol <- mode(ei[[1]]) == "name"
	if (!i.symbol) {
	    ## ei[[1]] : the function "<-" or other
	    curr.fun <- ei[[1]][[1]]
	    if (verbose) {
		cat("curr.fun:")
		str(curr.fun)
	    }
	}
	if (verbose >= 2) {
	    cat(".... mode(ei[[1]])=", mode(ei[[1]]), "; paste(curr.fun)=")
	    str(paste(curr.fun))
	}
	if (print.eval && yy$visible)
	    print(yy$value)
	if (verbose)
	    cat(" .. after ", sQuote(deparse(ei)), "\n", sep = "")
    }
    invisible(yy)
}

sys.source <-
function(file, envir = NULL, chdir = FALSE,
	 keep.source = getOption("keep.source.pkgs"))
{
    if(!(is.character(file) && file.exists(file)))
	stop(paste(sQuote(file), "is not an existing file"))
    oop <- options(keep.source = as.logical(keep.source),
		   topLevelEnvironment = as.environment(envir))
    on.exit(options(oop))
    exprs <- parse(n = -1, file = file)
    if (length(exprs) == 0)
	return(invisible())
    if (chdir && (path <- dirname(file)) != ".") {
	owd <- getwd()
	on.exit(setwd(owd), add = TRUE)
	setwd(path)
    }
    for (i in exprs) eval(i, envir)
    invisible()
}
split <- function(x, f) UseMethod("split")

split.default <- function(x, f)
{
    if (is.list(f)) f <- interaction(f)
    f <- factor(f)                  # drop extraneous levels
    if (is.null(attr(x, "class")) && is.null(names(x)))
        return(.Internal(split(x, f)))
    ## else
    lf <- levels(f)
    y <- vector("list", length(lf))
    names(y) <- lf
    for(k in lf) y[[k]] <- x[f %in% k]
    y
}

split.data.frame <- function(x, f)
    lapply(split(seq(length=nrow(x)), f), function(ind) x[ind, , drop = FALSE ])

"split<-" <- function(x, f, value) UseMethod("split<-")

"split<-.default" <- function(x, f, value)
{
    x[unlist(split(seq(along=x), f))] <- unlist(value)
    x
}

"split<-.data.frame" <- function(x, f, value)
{
    x[unlist(split(seq(length=nrow(x)), f)),] <- do.call("rbind", value)
    x
}

unsplit <- function(value, f)
{
    len <- length(if (is.list(f)) f[[1]] else f)
    x <- vector(mode = typeof(value[[1]]), length = len)
    split(x, f) <- value
    x
}
stop <- function(..., call. = TRUE)
{
    args <- list(...)
    if (length(args) == 1 && inherits(args[[1]], "condition")) {
        cond <- args[[1]]
        message <- conditionMessage(cond)
        call = conditionCall(cond)
        .Internal(.signalCondition(cond, message, call))
        .Internal(.dfltStop(message, call))
    }
    else {
        if (length(args) > 0)
            message <- paste(..., sep = "")
        else message <- ""
        .Internal(stop(as.logical(call.), message))
    }
}

stopifnot <- function(...)
{
    n <- length(ll <- list(...))
    if(n == 0)
        return(invisible())
    mc <- match.call()
    for(i in 1:n)
        if(!(is.logical(r <- eval(ll[[i]])) && all(r)))
            stop(paste(deparse(mc[[i+1]]), "is not TRUE"), call. = FALSE)
}

warning <- function(..., call. = TRUE)
{
    args <- list(...)
    if (length(args) == 1 && inherits(args[[1]], "condition")) {
        cond <- args[[1]]
        message <- conditionMessage(cond)
        call = conditionCall(cond)
        withRestarts({
                .Internal(.signalCondition(cond, message, call))
                .Internal(.dfltStop(message, call))
            }, muffleWarning = function() NULL) #**** allow simpler form??
        invisible(message)
    }
    else {
        if (length(args) > 0)
            message <- paste(..., sep = "")
        else message <- ""
        .Internal(warning(as.logical(call.), message))
    }
}
"structure" <-
    function (.Data, ...)
{
    specials <- c(".Dim", ".Dimnames", ".Names", ".Tsp", ".Label")
    replace <- c("dim", "dimnames", "names", "tsp", "levels")
    attrib <- list(...)
    if(length(attrib) > 0) {
	m <- match(names(attrib), specials)
	ok <- (!is.na(m) & m > 0)
	names(attrib)[ok] <- replace[m[ok]]
	if(any(names(attrib) == "tsp"))
	    attrib$class <- unique(c("ts", attrib$class))
	if(is.numeric(.Data) && any(names(attrib) == "levels"))
	    .Data <- factor(.Data,levels=seq(along=attrib$levels))
	attributes(.Data) <- c(attributes(.Data), attrib)
    }
    return(.Data)
}
strwrap <-
function(x, width = 0.9 * getOption("width"), indent = 0, exdent = 0,
         prefix = "", simplify = TRUE) {

    ## Useful variables.
    indentString <- paste(rep.int(" ", indent), collapse = "")
    exdentString <- paste(rep.int(" ", exdent), collapse = "")
    y <- list()                         # return value
    z <- lapply(strsplit(x, "\n[ \t\n]*\n"), strsplit, "[ \t\n]")
    ## Now z[[i]][[j]] is a character vector of all "words" in
    ## paragraph j of x[i].

    for(i in seq(along = z)) {
        yi <- character(0)
        for(j in seq(along = z[[i]])) {
            ## Format paragraph j in x[i].
            words <- z[[i]][[j]]
            nc <- nchar(words)

            ## Remove extra white space unless after a period which
            ## hopefully ends a sentence.
            if(any(nc == 0)) {
                zLenInd <- which(nc == 0)
                zLenInd <- zLenInd[!(zLenInd %in%
                                     (grep("\\.$", words) + 1))]
                if(length(zLenInd) > 0) {
                    words <- words[-zLenInd]
                    nc <- nc[-zLenInd]
                }
            }

            if(length(words) == 0) {
                yi <- c(yi, "", prefix)
                next
            }

            currentIndex <- 0
            lowerBlockIndex <- 1
            upperBlockIndex <- integer(0)
            lens <- cumsum(nc + 1)

            first <- TRUE
            maxLength <- width - nchar(prefix) - indent

            ## Recursively build a sequence of lower and upper indices
            ## such that the words in line k are the ones in the k-th
            ## index block.
            while(length(lens) > 0) {
                k <- max(sum(lens < maxLength), 1)
                if(first) {
                    first <- FALSE
                    maxLength <- maxLength + indent - exdent
                }
                currentIndex <- currentIndex + k
                if(nc[currentIndex] == 0)
                    ## Are we sitting on a space?
                    upperBlockIndex <- c(upperBlockIndex,
                                         currentIndex - 1)
                else
                    upperBlockIndex <- c(upperBlockIndex,
                                         currentIndex)
                if(length(lens) > k) {
                    ## Are we looking at a space?
                    if(nc[currentIndex + 1] == 0) {
                        currentIndex <- currentIndex + 1
                        k <- k + 1
                    }
                    lowerBlockIndex <- c(lowerBlockIndex,
                                         currentIndex + 1)
                }
                if(length(lens) > k)
                    lens <- lens[-(1:k)] - lens[k]
                else
                    lens <- NULL
            }

            nBlocks <- length(upperBlockIndex)
            s <- paste(prefix,
                       c(indentString, rep.int(exdentString, nBlocks - 1)),
                       sep = "")
            for(k in (1 : nBlocks))
                s[k] <- paste(s[k], paste(words[lowerBlockIndex[k] :
                                                upperBlockIndex[k]],
                                          collapse = " "),
                              sep = "")
            yi <- c(yi, s, prefix)
        }
        y <- c(y, list(yi[-length(yi)]))
    }

    if(simplify) y <- unlist(y)
    y
}

formatDL <-
function(x, y, style = c("table", "list"),
         width = 0.9 * getOption("width"), indent = NULL)
{
    if(is.list(x)) {
        if((length(x) == 2) && (diff(sapply(x, length)) == 0)) {
            y <- x[[2]]; x <- x[[1]]
        }
        else
            stop("incorrect value for x")
    }
    else if(is.matrix(x)) {
        if(NCOL(x) == 2) {
            y <- x[, 2]; x <- x[, 1]
        }
        else
            stop("incorrect value for x")
    }
    else if(length(x) != length(y))
        stop("x and y must have the same length")
    x <- as.character(x)
    if(length(x) == 0) return(x)
    y <- as.character(y)

    style <- match.arg(style)

    if(is.null(indent))
        indent <- switch(style, table = width / 3, list = width / 9)
    if(indent > 0.5 * width)
        stop("incorrect values of indent and width")

    indentString <- paste(rep.int(" ", indent), collapse = "")

    if(style == "table") {
        i <- (nchar(x) > indent - 3)
        if(any(i))
            x[i] <- paste(x[i], "\n", indentString, sep = "")
        i <- !i
        if(any(i))
            x[i] <- formatC(x[i], width = indent, flag = "-")
        y <- lapply(strwrap(y, width = width - indent,
                            simplify = FALSE),
                    paste,
                    collapse = paste("\n", indentString, sep = ""))
        r <- paste(x, unlist(y), sep = "")
    }
    else if(style == "list") {
        y <- strwrap(paste(x, ": ", y, sep = ""), exdent = indent,
                     width = width, simplify = FALSE)
        r <- unlist(lapply(y, paste, collapse = "\n"))
    }
    r
}
sum <- function(..., na.rm = FALSE)
    .Internal(sum(..., na.rm = na.rm))

min <- function(..., na.rm = FALSE)
    .Internal(min(..., na.rm = na.rm))

max <- function(..., na.rm = FALSE)
    .Internal(max(..., na.rm = na.rm))

prod <- function(..., na.rm = FALSE)
    .Internal(prod(..., na.rm = na.rm))

all <- function(..., na.rm = FALSE)
    .Internal(all(..., na.rm = na.rm))

any <- function(..., na.rm = FALSE)
    .Internal(any(..., na.rm = na.rm))
summary <- function (object, ...) UseMethod("summary")

summary.default <-
    function(object, ..., digits = max(3, getOption("digits") - 3))
{
    if(is.factor(object))
	return(summary.factor(object, ...))
    else if(is.matrix(object))
	return(summary.matrix(object, digits = digits, ...))

    value <- if(is.logical(object))# scalar or array!
	c(Mode = "logical",
          {tb <- table(object, exclude=NULL)# incl. NA s
           if(!is.null(n <- dimnames(tb)[[1]]) && any(iN <- is.na(n)))
               dimnames(tb)[[1]][iN] <- "NA's"
           tb
           })
    else if(is.numeric(object)) {
	nas <- is.na(object)
	object <- object[!nas]
	qq <- stats::quantile(object)
	qq <- signif(c(qq[1:3], mean(object), qq[4:5]), digits)
	names(qq) <- c("Min.", "1st Qu.", "Median", "Mean", "3rd Qu.", "Max.")
	if(any(nas))
	    c(qq, "NA's" = sum(nas))
	else qq
    } else if(is.recursive(object) && !is.language(object) &&
	      (n <- length(object))) {
	sumry <- array("", c(n, 3), list(names(object),
					 c("Length", "Class", "Mode")))
	ll <- numeric(n)
	for(i in 1:n) {
	    ii <- object[[i]]
	    ll[i] <- length(ii)
	    cls <- oldClass(ii)
	    sumry[i, 2] <- if(length(cls)>0) cls[1] else "-none-"
	    sumry[i, 3] <- mode(ii)
	}
	sumry[, 1] <- format(as.integer(ll))
	sumry
    }
    else c(Length= length(object), Class= class(object), Mode= mode(object))
    class(value) <- "table"
    value
}

summary.factor <- function(object, maxsum = 100, ...)
{
    nas <- is.na(object)
    ll <- levels(object)
    if(any(nas)) maxsum <- maxsum - 1
    tbl <- table(object)
    tt <- c(tbl) # names dropped ...
    names(tt) <- dimnames(tbl)[[1]]
    if(length(ll) > maxsum) {
	drop <- maxsum:length(ll)
	o <- sort.list(tt, decreasing = TRUE)
	tt <- c(tt[o[ - drop]], "(Other)" = sum(tt[o[drop]]))
    }
    if(any(nas)) c(tt, "NA's" = sum(nas)) else tt
}

summary.matrix <- function(object, ...)
    summary.data.frame(data.frame(object), ...)

summary.data.frame <-
    function(object, maxsum = 7, digits = max(3, getOption("digits") - 3), ...)
{
    # compute results to full precision.
    z <- lapply(as.list(object), summary, maxsum = maxsum, digits = 12, ...)
    nv <- length(object)
    nm <- names(object)
    lw <- numeric(nv)
    nr <- max(unlist(lapply(z, NROW)))
    for(i in 1:nv) {
        sms <- z[[i]]
        if(is.matrix(sms)) {
            ## need to produce a single column, so collapse matrix
            ## across rows
            cn <- paste(nm[i], gsub("^ +", "", colnames(sms)), sep=".")
            tmp <- format(sms)
            if(nrow(sms) < nr)
                tmp <- rbind(tmp, matrix("", nr - nrow(sms), ncol(sms)))
            sms <- apply(tmp, 1, function(x) paste(x, collapse="  "))
            ## produce a suitable colname: undoing padding
            wid <- sapply(tmp[1,], nchar)
            blanks <- paste(character(max(wid)), collapse = " ")
            pad0 <- floor((wid-nchar(cn))/2); pad1 <- wid - nchar(cn) - pad0
            cn <- paste(substring(blanks, 1, pad0), cn,
                        substring(blanks, 1, pad1), sep = "")
            nm[i] <- paste(cn, collapse="  ")
            z[[i]] <- sms
        } else {
            lbs <- format(names(sms))
            sms <- paste(lbs, ":", format(sms, digits = digits), "  ",
                         sep = "")
            lw[i] <- nchar(lbs[1])
            length(sms) <- nr
            z[[i]] <- sms
        }
    }
    z <- unlist(z, use.names=TRUE)
    dim(z) <- c(nr, nv)
    blanks <- paste(character(max(lw) + 2), collapse = " ")
    pad <- floor(lw-nchar(nm)/2)
    nm <- paste(substring(blanks, 1, pad), nm, sep = "")
    dimnames(z) <- list(rep.int("", nr), nm)
    attr(z, "class") <- c("table") #, "matrix")
    z
}
svd <- function(x, nu = min(n,p), nv = min(n,p), LINPACK = FALSE)
{
    x <- as.matrix(x)
    if (any(!is.finite(x))) stop("infinite or missing values in x")
    dx <- dim(x)
    n <- dx[1]
    p <- dx[2]
    if(!n || !p) stop("0 extent dimensions")
    if (is.complex(x)) {
        res <- La.svd(x, nu, nv)
        return(list(d = res$d, u = if(nu) res$u, v = if(nv) Conj(t(res$vt))))
    }
    if (!LINPACK) {
        res <- La.svd(x, nu, nv)
        return(list(d = res$d, u = if(nu) res$u, v = if(nv) t(res$vt)))
    }
    if(!is.numeric(x))
	stop("argument to svd must be numeric")

    if(nu == 0) {
	job <- 0
	u <- double(0)
    }
    else if(nu == n) {
	job <- 10
	u <- matrix(0, n, n)
    }
    else if(nu == p) {
	job <- 20
	u <- matrix(0, n, p)
    }
    else
	stop("nu must be 0, nrow(x) or ncol(x)")

    job <- job +
	if(nv == 0) 0 else if(nv == p || nv == n) 1 else
    stop("nv must be 0 or ncol(x)")

    v <- if(job == 0) double(0) else matrix(0, p, p)

    mn <- min(n,p)
    mm <- min(n+1,p)
    z <- .Fortran("dsvdc",
		  as.double(x),
		  n,
		  n,
		  p,
		  d=double(mm),
		  double(p),
		  u=u,
		  n,
		  v=v,
		  p,
		  double(n),
		  as.integer(job),
		  info=integer(1),
		  DUP=FALSE, PACKAGE="base")[c("d","u","v","info")]
    if(z$info)
	stop(paste("error ",z$info," in dsvdc"))
    z$d <- z$d[1:mn]
    if(nv && nv < p) z$v <- z$v[, 1:nv, drop = FALSE]
    z[c("d", if(nu) "u", if(nv) "v")]
}
sweep <- function(x, MARGIN, STATS, FUN = "-", ...)
{
    FUN <- match.fun(FUN)
    dims <- dim(x)
    perm <- c(MARGIN, (1:length(dims))[ - MARGIN])
    FUN(x, aperm(array(STATS, dims[perm]), order(perm)), ...)
}
switch <- function(EXPR,...)
    .Internal(switch(EXPR,...))
sys.call <-function(which = 0)
    .Internal(sys.call(which))

sys.calls <-function()
    .Internal(sys.calls())

sys.frame <-function(which = 0)
    .Internal(sys.frame(which))

sys.function <-function(n = 0)
    .Internal(sys.function(n))

sys.frames <-function()
    .Internal(sys.frames())

sys.nframe <- function()
    .Internal(sys.nframe())

sys.parent <- function(n = 1)
    .Internal(sys.parent(n))

sys.parents <- function()
    .Internal(sys.parents())

sys.status <- function()
    list(sys.calls=sys.calls(), sys.parents=sys.parents(), sys.frames=sys.frames())

sys.on.exit <- function()
    .Internal(sys.on.exit())
table <- function (..., exclude = c(NA, NaN),
		   dnn = list.names(...), deparse.level = 1)
{
    list.names <- function(...) {
	l <- as.list(substitute(list(...)))[-1]
	nm <- names(l)
	fixup <- if (is.null(nm)) seq(along = l) else nm == ""
	dep <- sapply(l[fixup], function(x)
	    switch (deparse.level + 1,
		    "", ## 0
		    if (is.symbol(x)) as.character(x) else "", ## 1
		    deparse(x)[1]) ## 2
		      )
	if (is.null(nm))
	    dep
	else {
	    nm[fixup] <- dep
	    nm
	}
    }

    args <- list(...)
    if (length(args) == 0)
	stop("nothing to tabulate")
    if (length(args) == 1 && is.list(args[[1]])) {
	args <- args[[1]]
	if (length(dnn) != length(args))
	    dnn <- if (!is.null(argn <- names(args)))
		 argn
	    else
		 paste(dnn[1], 1:length(args), sep = '.')
    }
    bin <- 0
    lens <- NULL
    dims <- integer(0)
    pd <- 1
    dn <- NULL
    for (a in args) {
	if (is.null(lens)) lens <- length(a)
	else if (length(a) != lens)
	    stop("all arguments must have the same length")
        cat <-
            if (is.factor(a)) {
                if (!missing(exclude)) {
                    ll <- levels(a)
                    factor(a, levels = ll[!(ll %in% exclude)],
                           exclude = if(is.null(exclude)) NULL else NA)
                } else a
            } else factor(a, exclude = exclude)

	nl <- length(ll <- levels(cat))
	dims <- c(dims, nl)
	dn <- c(dn, list(ll))
	## requiring   all(unique(as.integer(cat)) == 1:nlevels(cat))  :
	bin <- bin + pd * (as.integer(cat) - 1)
	pd <- pd * nl
    }
    names(dn) <- dnn
    bin <- bin[!is.na(bin)]
    if (length(bin)) bin <- bin + 1 # otherwise, that makes bin NA
    y <- array(tabulate(bin, pd), dims, dimnames = dn)
    class(y) <- "table"
    y
}

## From  1999-12-19 till 2003-03-27:
## print.table <-
## function(x, digits = getOption("digits"), quote = FALSE, na.print = "", ...)
## {
##     print.default(unclass(x), digits = digits, quote = quote,
## 		  na.print = na.print, ...)
##     ## this does *not* return x !
## }

## Better (NA in dimnames *should* be printed):
print.table <-
function (x, digits = getOption("digits"), quote = FALSE, na.print = "",
	  zero.print = "0",
	  justify = "none", ...)
{
    xx <- format(unclass(x), digits = digits, justify = justify)
    ## na.print handled here
    if(any(ina <- is.na(x)))
	xx[ina] <- na.print
    if(is.integer(x) && zero.print != "0" && any(i0 <- !ina & x == 0))
	## MM thinks this should be an option for many more print methods...
	xx[i0] <- sub("0", zero.print, xx[i0])
    print(xx, quote = quote, ...)
    invisible(x)
}

summary.table <- function(object, ...)
{
    if(!inherits(object, "table"))
	stop("object must inherit from class table")
    n.cases <- sum(object)
    n.vars <- length(dim(object))
    y <- list(n.vars = n.vars,
	      n.cases = n.cases)
    if(n.vars > 1) {
	m <- vector("list", length = n.vars)
	relFreqs <- object / n.cases
	for(k in 1:n.vars)
	    m[[k]] <- apply(relFreqs, k, sum)
	expected <- apply(do.call("expand.grid", m), 1, prod) * n.cases
	statistic <- sum((c(object) - expected)^2 / expected)
	parameter <-
	    prod(sapply(m, length)) - 1 - sum(sapply(m, length) - 1)
	y <- c(y, list(statistic = statistic,
		       parameter = parameter,
		       approx.ok = all(expected >= 5),
		       p.value = pchisq(statistic, parameter, lower.tail=FALSE),
		       call = attr(object, "call")))
    }
    class(y) <- "summary.table"
    y
}

print.summary.table <-
function(x, digits = max(1, getOption("digits") - 3), ...)
{
    if(!inherits(x, "summary.table"))
	stop(paste("x must inherit from class", sQuote("summary.table")))
    if(!is.null(x$call)) {
	cat("Call: "); print(x$call)
    }
    cat("Number of cases in table:", x$n.cases, "\n")
    cat("Number of factors:", x$n.vars, "\n")
    if(x$n.vars > 1) {
	cat("Test for independence of all factors:\n")
	ch <- x$statistic
	cat("\tChisq = ",	format(round(ch, max(0, digits - log10(ch)))),
	    ", df = ",		x$parameter,
	    ", p-value = ",	format.pval(x$p.value, digits, eps = 0),
	    "\n", sep = "")
	if(!x$approx.ok)
	    cat("\tChi-squared approximation may be incorrect\n")
    }
    invisible(x)
}

as.data.frame.table <- function(x, row.names = NULL, optional = FALSE, ...)
{
    x <- as.table(x)
    data.frame(do.call("expand.grid", dimnames(x)), Freq = c(x),
	       row.names = row.names)
}

is.table <- function(x) inherits(x, "table")
as.table <- function(x, ...) UseMethod("as.table")
as.table.default <- function(x, ...)
{
    if(is.table(x))
	return(x)
    else if(is.array(x) || is.numeric(x)) {
	x <- as.array(x)
	if(any(dim(x) == 0))
	    stop("cannot coerce into a table")
	## Try providing dimnames where missing.
	dnx <- dimnames(x)
	if(is.null(dnx))
	    dnx <- vector("list", length(dim(x)))
	for(i in which(sapply(dnx, is.null)))
	    dnx[[i]] <- LETTERS[seq(length = dim(x)[i])]
	dimnames(x) <- dnx
	class(x) <- c("table", oldClass(x))
	return(x)
    }
    else
	stop("cannot coerce into a table")
}

prop.table <- function(x, margin = NULL)
{
    if(length(margin))
	sweep(x, margin, margin.table(x, margin), "/")
    else
	x / sum(x)
}

margin.table <- function(x, margin = NULL)
{
    if(!is.array(x)) stop("x is not an array")
    if (length(margin)) {
	z <- apply(x, margin, sum)
	dim(z) <- dim(x)[margin]
	dimnames(z) <- dimnames(x)[margin]
    }
    else return(sum(x))
    class(z) <- oldClass(x) # avoid adding "matrix"
    z
}

r2dtable <- function(n, r, c) {
    if(length(n) == 0 || (n < 0) || is.na(n))
	stop("invalid argument 'n'")
    if((length(r) <= 1) || any(r < 0) || any(is.na(r)))
	stop("invalid argument 'r'")
    if((length(c) <= 1) || any(c < 0) || any(is.na(c)))
	stop("invalid argument 'c'")
    if(sum(r) != sum(c))
	stop("arguments 'r' and 'c' must have the same sums")
    .Call("R_r2dtable",
	  as.integer(n),
	  as.integer(r),
	  as.integer(c),
	  PACKAGE = "base")
}
tabulate <- function(bin, nbins = max(1,bin))
{
    if(!is.numeric(bin) && !is.factor(bin))
	stop("tabulate: bin must be numeric or a factor")
    .C("R_tabulate",
       as.integer(bin),
       as.integer(length(bin)),
       as.integer(nbins),
       ans = integer(nbins),
       PACKAGE="base")$ans
}
tapply <- function (X, INDEX, FUN=NULL, ..., simplify=TRUE)
{
    FUN <- if (!is.null(FUN)) match.fun(FUN)
    if (!is.list(INDEX)) INDEX <- list(INDEX)
    nI <- length(INDEX)
    namelist <- vector("list", nI)
    names(namelist) <- names(INDEX)
    extent <- integer(nI)
    nx <- length(X)
    one <- as.integer(1)
    group <- rep.int(one, nx)#- to contain the splitting vector
    ngroup <- one
    for (i in seq(INDEX)) {
	index <- as.factor(INDEX[[i]])
	if (length(index) != nx)
	    stop("arguments must have same length")
	namelist[[i]] <- levels(index)#- all of them, yes !
	extent[i] <- nlevels(index)
	group <- group + ngroup * (as.integer(index) - one)
	ngroup <- ngroup * nlevels(index)
    }
    if (is.null(FUN)) return(group)
    ans <- lapply(split(X, group), FUN, ...)
    index <- as.numeric(names(ans))
    if (simplify && all(unlist(lapply(ans, length)) == 1)) {
	ansmat <- array(dim=extent, dimnames=namelist)
	ans <- unlist(ans, recursive = FALSE)
    }
    else  {
	ansmat <- array(vector("list", prod(extent)),
			dim=extent, dimnames=namelist)
    }
    ## old : ansmat[as.numeric(names(ans))] <- ans
    names(ans) <- NULL
    ansmat[index] <- ans
    ansmat
}





addTaskCallback <- function(f, data = NULL, name = character(0))
{
    if(!is.function(f))
        stop("handler must be a function")
    val <- .Call("R_addTaskCallback", f, data, !missing(data),
                 as.character(name), PACKAGE="base")

    val + 1
}

removeTaskCallback <- function(id)
{
    if(!is.character(id))
        id <- as.integer(id)

    .Call("R_removeTaskCallback", id, PACKAGE="base")
}

getTaskCallbackNames <-
function()
{
    .Call("R_getTaskCallbackNames", PACKAGE="base")
}


taskCallbackManager <-
  #
  #
  #
function(handlers = list(), registered = FALSE, verbose = FALSE)
{
    suspended <- FALSE
    .verbose <- verbose

    add <-
    #
    # this is used to register a callback.
    # It has the same call sequence and semantics
    # as addTaskCallback but provides an optional
    # name by which to identify the element.
    # This can be used to remove the value in the future.
    # The default name is the next available position in the
    # list.
    # The result is stored in the `handlers' list using the
    # name.
    #
    # The element in the list contains the function
    # in the `f' slot,  and optionally a data field
    # to store the `data' argument.
    #
    # This could arrange to register itself using
    # addTaskCallback() if the size of the handlers list
    # becomes 1.
        function(f, data = NULL, name = NULL, register = TRUE)
        {

      # generate default name if none supplied
            if(is.null(name))
                name <- as.character(length(handlers) + 1)

      # Add to handlers, replacing any element with that name
      # if needed.
            handlers[[name]] <<- list(f = f)

      # If data was specified, add this to the new element
      # so that it will be included in the call for this function
            if(!missing(data))
                handlers[[name]][["data"]] <<- data

      # We could arrange to register the evaluate function
      # so that the handlers list would be active. However,
      # we would have to unregister it in the remove()
      # function when there were no handlers.
            if(!registered && register) {
                register()
            }

            name
        }

    remove <- function(which)
    {
        if(is.character(which)) {
            tmp <- (1:length(handlers))[!is.na(match(which, names(handlers)))]
            if(length(tmp))
                stop(paste("No such element", which))
            which <- tmp
        } else
        which <- as.integer(which)

        handlers <<- handlers[-which]

        return(TRUE)
    }


    evaluate <-
    #
    # This is the actual callback that is registered with the C-level
    # mechanism. It is invoked by R when a top-level task is completed.
    # It then calls each of the functions in the handlers list
    # passing these functions the arguments it received and any
    # user-level data for those functions registered in the call to
    # add() via the `data' argument.
    #
    # At the end of the evaluation, any function that returned FALSE
    # is discarded.
        function(expr, value, ok, visible)
        {
            if(suspended)
                return(TRUE)
            discard <- character(0)
            for(i in names(handlers)) {
                h <- handlers[[i]]
                if(length(h) > 1) {
                    val <- h[["f"]](expr, value, ok, visible, i[["data"]])
                } else {
                    val <- h[["f"]](expr, value, ok, visible)
                }
                if(!val) {
                    discard <- c(discard, i)
                }
            }
            if(length(discard) > 0) {
                if(.verbose)
                    cat("Removing", paste(discard, collapse=", "), "\n")
                idx <- is.na(match(names(handlers), discard))
                if(length(idx))
                    handlers <<- handlers[idx]
                else
                    handlers <<- list()
            }
            return(TRUE)
        }

    suspend <-
        function(status = TRUE) {
            suspended <<- status
        }

    register <-
        function(name = "R-taskCallbackManager", verbose = .verbose)
        {
            if(verbose)
                cat("Registering evaluate as low-level callback\n")
            id <- addTaskCallback(evaluate, name = name)
            registered <<- TRUE
            id
        }

    list(add = add,
         evaluate = evaluate,
         remove = remove,
         register = register,
         suspend = suspend,
         callbacks = function()
         handlers
         )
}

tempfile <- function(pattern = "file", tmpdir = tempdir()) .Internal(tempfile(pattern, tmpdir))

tempdir <- function() .Internal(tempdir())
system.time <- function(expr) {
    if(!exists("proc.time")) return(rep(as.numeric(NA), 5))
    loc.frame <- parent.frame()
    on.exit(cat("Timing stopped at:", proc.time() - time, "\n"))
    expr <- substitute(expr)
    time <- proc.time()
    eval(expr, envir = loc.frame)
    new.time <- proc.time()
    on.exit()
    if(length(new.time) == 3)	new.time <- c(new.time, 0, 0)
    if(length(time) == 3)	time	 <- c(	  time, 0, 0)
    new.time - time
}
unix.time <- system.time

date <- function().Internal(date())
#functions to convert their first argument to strings
toString <- function(x, ...)
    UseMethod("toString")

toString.default <- function(x, width, ...) {
  string <- paste(x, collapse=", ")
  if( missing(width) )
    return( string )
  if( width <= 0 )
    stop("width must be positive")
  if(nchar(string) > width) {
    if(width < 6)
      width <- 6  ## Leave something!
    string <- paste(substring(string, 1, width-4), "....", sep="")
  }
  string
}

traceback <- function()
{
    if (exists(".Traceback", env = .GlobalEnv))
	.Traceback <- get(".Traceback", env = .GlobalEnv)
    else .Traceback <- NULL
    if(is.null(.Traceback) || length(.Traceback) == 0)
        cat("No traceback available\n")
    else {
        n <- length(.Traceback)
        for(i in 1:n) {
            label <- paste(n-i+1, ": ", sep="")
            if((m <- length(.Traceback[[i]])) > 1)
                label <- c(label, rep(substr("          ", 1, nchar(label)),
                                      m - 1))
            cat(paste(label, .Traceback[[i]], sep=""), sep="\n")
        }
    }
    invisible()
}
## Commented by KH on 1999/01/30.
## trunc() should really be in the `Math' group.

##trunc <- function(x, ...) UseMethod("trunc")
##trunc.default <- function(x) {
##    a <- attributes(x)
##    x <- ifelse(x < 0, ceiling(x), floor(x))
##    attributes(x) <- a
##    x
##}
cm <- function(x) 2.54*x

xinch <- function(x=1, warn.log=TRUE) {
    if(warn.log && par("xlog")) warning("x log scale:  xinch() is non-sense")
    x * diff(par("usr")[1:2])/par("pin")[1]
}
yinch <- function(y=1, warn.log=TRUE) {
    if(warn.log && par("ylog")) warning("y log scale:  yinch() is non-sense")
    y * diff(par("usr")[3:4])/par("pin")[2]
}

xyinch <- function(xy=1, warn.log=TRUE) {
    if(warn.log && (par("xlog") || par("ylog")))
	warning("log scale:  xyinch() is non-sense")
    u <- par("usr"); xy * c(u[2]-u[1], u[4]-u[3]) / par("pin")
}
system <- function(command, intern = FALSE, ignore.stderr = FALSE)
    .Internal(system(if(ignore.stderr) paste(command, "2>/dev/null") else
		     command, intern))

unix <- function(call, intern = FALSE) {
    .Deprecated("system")
    system(call, intern)
}

##--- The following should/could really be done in C [platform !] :
unlink <- function(x, recursive = FALSE) {
    if(!is.character(x)) stop("argument must be character")
    if(recursive)
        system(paste("rm -rf ", paste(x, collapse = " ")))
    else
        system(paste("rm -f ", paste(x, collapse = " ")))
}
zip.file.extract <- function(file, zipname = "R.zip")
{
    ## somewhat system-specific.
    unzip <- getOption("unzip")
    if(!nchar(unzip)) unzip <- "internal"
    path <- dirname(file)
    topic <- basename(file)
    if(file.exists(file.path(path, zipname))) {
        tmpd <- tempdir()
        if(unzip != "internal") {
            if(!system(paste(unzip, "-o",
                             file.path(path, zipname), topic, "-d", tmpd,
                             " > /dev/null")))
                file <- file.path(tmpd, topic)
        } else {
            rc <- .Internal(int.unzip(file.path(path, zipname),
                                      topic, tmpd))
            if (rc == 0)
                file <- file.path(tmpd, topic)
        }
    }
    file
}
unlist <- function(x, recursive=TRUE, use.names=TRUE)
    .Internal(unlist(x, recursive, use.names))
unname <- function (obj, force= FALSE) {
    if (length(names(obj)))
        names(obj) <- NULL
    if (length(dimnames(obj)) && (force || !is.data.frame(obj)))
        dimnames(obj) <- NULL
    obj
}
upper.tri <- function(x, diag = FALSE)
{
    x <- as.matrix(x)
    if(diag) row(x) <= col(x)
    else row(x) < col(x)
}
.userHooksEnv <- new.env(hash = FALSE, parent = NULL)

packageEvent <-
    function(pkgname, event=c("onLoad", "attach", "detach", "onUnload"))
{
    event <- match.arg(event)
    pkgname <- strsplit(pkgname, "_", fixed=TRUE)[[1]][1]
    paste("UserHook", pkgname, event, sep = "::")
}

getHook <- function(hookName)
{
    if (exists(hookName, envir = .userHooksEnv, inherits = FALSE))
        get(hookName, envir = .userHooksEnv, inherits = FALSE)
    else list()
}

setHook <- function(hookName, value,
                    action = c("append", "prepend", "replace"))
{
    action <- match.arg(action)
    old <- getHook(hookName)
    new <- switch(action,
                  "append" = c(old, value),
                  "prepend" = c(value, old),
                  "replace" = value)
    if (length(new))
        assign(hookName, new, envir = .userHooksEnv, inherits = FALSE)
    else if(exists(hookName, envir = .userHooksEnv, inherits = FALSE))
        remove(list=hookName, envir = .userHooksEnv, inherits = FALSE)
    invisible()
}
mat.or.vec <- function(nr,nc)
    if(nc==1) numeric(nr) else matrix(0,nr,nc)

## Use  'version' since that exists in all S dialects :
is.R <-
    function() exists("version") && !is.null(vl <- version$language) && vl == "R"

vector <- function(mode = "logical", length = 0).Internal(vector(mode,length))
logical <- function(length = 0) vector("logical", length)
character <- function(length = 0) vector("character", length)
integer <- function(length = 0) vector("integer", length)
double <- function(length = 0) vector("double", length)
real <- double
numeric <- double
complex <- function(length.out = 0,
		    real = numeric(), imaginary = numeric(),
		    modulus = 1, argument = 0) {
    if(missing(modulus) && missing(argument)) {
	## assume 'real' and 'imaginary'
	.Internal(complex(length.out, real, imaginary))
    } else {
	n <- max(length.out, length(argument), length(modulus))
	rep(modulus,length.out=n) *
	    exp(1i * rep(argument, length.out=n))
    }
}

single <- function(length = 0)
    structure(vector("double", length), Csingle=TRUE)
warnings <- function(...)
{
    if(!exists("last.warning") || !(n <- length(last.warning)))
	return()
    names <- names(last.warning)
    cat("Warning message", if(n > 1)"s", ":\n", sep="")
    for(i in 1:n) {
	out <- if(n == 1) names[i] else paste(i,": ", names[i], sep="")
	if(length(last.warning[[i]])) {
	    temp <- deparse(last.warning[[i]])
	    out <- paste(out, "in:", temp[1], if(length(temp) > 1) " ...")
	}
	cat(out, ..., fill = TRUE)
    }
}
which <- function(x, arr.ind = FALSE)
{
    if(!is.logical(x))
	stop("argument to \"which\" is not logical")
    wh <- seq(along=x)[ll <- x & !is.na(x)]
    if ((m <- length(wh)) > 0) {
	dl <- dim(x)
	if (is.null(dl) || !arr.ind) {
	    names(wh) <- names(x)[ll]
	}
	else { ##-- return a matrix  length(wh) x rank
	    rank <- length(dl)
	    wh1 <- wh - 1
	    wh <- 1 + wh1 %% dl[1]
	    wh <- matrix(wh, nrow = m, ncol = rank,
			 dimnames =
			 list(dimnames(x)[[1]][wh],
			      if(rank == 2) c("row", "col")# for matrices
			      else paste("dim", 1:rank, sep="")))
	    if(rank >= 2) {
		denom <- 1
		for (i in 2:rank) {
		    denom <- denom * dl[i-1]
		    nextd1 <- wh1 %/% denom# (next dim of elements) - 1
		    wh[,i] <- 1 + nextd1 %% dl[i]
		}
	    }
	    storage.mode(wh) <- "integer"
	}
    }
    wh
}

which.min <- function(x) .Internal(which.min(x))
which.max <- function(x) .Internal(which.max(x))

write <- function(x, file="data",ncolumns=if(is.character(x)) 1 else 5, append=FALSE)
    cat(x, file=file, sep=c(rep.int(" ",ncolumns-1), "\n"), append=append)
write.table <-
function (x, file = "", append = FALSE, quote = TRUE, sep = " ",
    eol = "\n", na = "NA", dec = ".", row.names = TRUE,
    col.names = TRUE, qmethod = c("escape", "double"))
{
    qmethod <- match.arg(qmethod)

    if(!is.data.frame(x))
	x <- data.frame(x)
	
    if(is.logical(quote) && quote)
	quote <- which(unlist(lapply(x, function(x)
                                     is.character(x) || is.factor(x))))
    if(dec != ".") {
        ## only need to consider numeric non-integer columns
    	num <- which(unlist(lapply(x, is.double)))
	if(length(num))
           x[num] <- lapply(x[num],
                            function(z) gsub("\\.", ",", as.character(z)))
    }
    i <- is.na(x)
    x <- as.matrix(x)
    if(any(i))
        x[i] <- na
    p <- ncol(x)
    d <- dimnames(x)

    if(is.logical(quote))
	quote <- if(quote) 1 : p else NULL
    else if(is.numeric(quote)) {
	if(any(quote < 1 | quote > p))
	    stop(paste("invalid numbers in", sQuote("quote")))
    }
    else
	stop(paste("invalid", sQuote("quote"), "specification"))

    rn <- FALSE
    if(is.logical(row.names)) {
	if(row.names) {
	    x <- cbind(d[[1]], x)
            rn <- TRUE
        }
    }
    else {
	row.names <- as.character(row.names)
	if(length(row.names) == nrow(x))
	    x <- cbind(row.names, x)
	else
	    stop(paste("invalid", sQuote("row.names"),
                       "specification"))
    }
    if(!is.null(quote) && (p < ncol(x)))
	quote <- c(0, quote) + 1

    if(is.logical(col.names))
        col.names <- if(is.na(col.names) && rn) c("", d[[2]])
        else if(col.names) d[[2]] else NULL
    else {
	col.names <- as.character(col.names)
	if(length(col.names) != p)
	    stop(paste("invalid", sQuote("col.names"), "specification"))
    }

    if(file == "")
        file <- stdout()
    else if(is.character(file)) {
        file <- file(file, ifelse(append, "a", "w"))
        on.exit(close(file))
    }
    if(!inherits(file, "connection"))
        stop(paste("argument", sQuote("file"),
                   "must be a character string or connection"))

    if(!is.null(col.names)) {
	if(append)
	    warning("appending column names to file")
	if(!is.null(quote))
	    col.names <- paste("\"", col.names, "\"", sep = "")
        writeLines(paste(col.names, collapse = sep), file, sep = eol)
    }

    qstring <-                          # quoted embedded quote string
        switch(qmethod,
               "escape" = '\\\\"',
               "double" = '""')
    for(i in quote)
	x[, i] <- paste('"', gsub('"', qstring, as.character(x[, i])),
                        '"', sep = "")

    writeLines(paste(c(t(x)), c(rep.int(sep, ncol(x) - 1), eol),
                     sep = "", collapse = ""),
               file, sep = "")
}
xor <- function(x, y) { (x | y) & !(x & y) }
zapsmall <- function(x, digits = getOption("digits"))
{
    if (length(digits) == 0)
        stop("invalid digits")
    if (all(ina <- is.na(x)))
        return(x)
    mx <- max(abs(x[!ina]))
    round(x, digits = if(mx > 0) max(0, digits - log10(mx)) else digits)
}
## needs to run after paste()
.leap.seconds <- local({
    .leap.seconds <-
        c("1972-6-30", "1972-12-31", "1973-12-31", "1974-12-31",
          "1975-12-31", "1976-12-31", "1977-12-31", "1978-12-31",
          "1979-12-31", "1981-6-30", "1983-6-30", "1985-6-30",
          "1986-6-30", "1987-12-31", "1989-12-31", "1990-12-31",
          "1992-6-30", "1993-6-30", "1994-6-30","1995-12-31",
          "1997-6-30", "1998-12-31")
    .leap.seconds <- strptime(paste(.leap.seconds , "23:59:60"),
                              "%Y-%m-%d %H:%M:%S")
    c(as.POSIXct(.leap.seconds, "GMT")) # lose the timezone
})
## Need to ensure this comes late enough ...
## Perhaps even merge it into the common profile?

.dynLibs <- local({
    ## <NOTE>
    ## Versions of R prior to 1.4.0 had .Dyn.libs in .AutoloadEnv
    ## (and did not always ensure getting it from there).
    ## Until 1.6.0, we consistently used the base environment.
    ## Now we have a dynamic variable instead.
    ## </NOTE>
    .Dyn.libs <- character(0)
    function(new) {
        if(!missing(new))
            .Dyn.libs <<- new
        else
            .Dyn.libs
    }
})

.libPaths <- local({
    .lib.loc <- character(0)            # Profiles need to set this.
    function(new) {
        if(!missing(new)) {
            paths <- unique(c(new, .Library))
            .lib.loc <<- paths[file.exists(paths)]
        }
        else
            .lib.loc
    }
})
## extracted from existing NAMESPACE files in Dec 2003
.knownS3Generics <- local({

    ## include the S3 group generics here
    baseGenerics <- c("Math", "Ops", "Summary", "Complex",
        "as.character", "as.data.frame", "as.matrix", "as.vector",
        "labels", "print", "solve", "summary", "t")

    utilsGenerics <- c("edit", "str")

    graphicsGenerics <- c("contour", "hist", "identify", "image",
        "lines", "pairs", "plot", "points", "text")

    statsGenerics <- c( "add1", "AIC", "anova", "biplot", "coef",
        "confint", "deviance", "df.residual", "drop1", "extractAIC",
        "fitted", "formula", "logLik", "model.frame", "model.matrix",
        "predict", "profile", "qqnorm", "residuals", "se.contrast",
        "terms", "update", "vcov")

    tmp <- rep.int(c("base", "utils", "graphics", "stats"),
                   c(length(baseGenerics), length(utilsGenerics),
                     length(graphicsGenerics), length(statsGenerics)))
    names(tmp) <-
        c(baseGenerics, utilsGenerics, graphicsGenerics, statsGenerics)
    tmp
})
