.packageName <- "MASS"
# file MASS/add.q
# copyright (C) 1994-2000 W. N. Venables and B. D. Ripley
#
addterm <-
    function(object, ...) UseMethod("addterm")

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

addterm.lm <-
  function(object, scope, scale = 0, test = c("none", "Chisq", "F"),
           k = 2, sorted = FALSE, ...)
{
    Fstat <- function(table, RSS, rdf) {
        dev <- table$"Sum of Sq"
        df <- table$Df
        rms <- (RSS - dev)/(rdf - df)
        Fs <- (dev/df)/rms
        Fs[df < 1e-4] <- NA
        P <- Fs
        nnas <- !is.na(Fs)
	P[nnas] <- pf(Fs[nnas], df[nnas], rdf - df[nnas], lower.tail=FALSE)
        list(Fs=Fs, P=P)
    }

    if(missing(scope) || is.null(scope)) stop("no terms in scope")
    aod <- stats:::add1.lm(object, scope=scope, scale=scale)[ , -4]
    dfs <- c(0, aod$Df[-1]) + object$rank; RSS <- aod$RSS
    n <- length(object$residuals)
    if(scale > 0) aic <- RSS/scale - n + k*dfs
    else aic <- n * log(RSS/n) + k*dfs
    aod$AIC <- aic
    o <- if(sorted) order(aod$AIC) else seq(along=aod$AIC)
    if(scale > 0) names(aod) <- c("Df", "Sum of Sq", "RSS", "Cp")
    test <- match.arg(test)
    if(test == "Chisq") {
        dev <- aod$"Sum of Sq"
        if(scale == 0) {
            dev <- n * log(RSS/n)
            dev <- dev[1] - dev
            dev[1] <- NA
        } else dev <- dev/scale
        df <- aod$Df
        nas <- !is.na(df)
        dev[nas] <- pchisq(dev[nas], df[nas], lower.tail=FALSE)
        aod[, "Pr(Chi)"] <- dev
    } else if(test == "F") {
        rdf <- object$df.resid
        aod[, c("F Value", "Pr(F)")] <- Fstat(aod, aod$RSS[1], rdf)
    }
    aod <- aod[o, ]
    head <- c("Single term additions", "\nModel:",
              deparse(as.vector(formula(object))))
    if(scale > 0)
        head <- c(head, paste("\nscale: ", format(scale), "\n"))
    class(aod) <- c("anova", "data.frame")
    attr(aod, "heading") <- head
    aod
}

addterm.negbin <- addterm.survreg <-
  function(object, ...)  addterm.default(object, ...)

addterm.glm <-
  function(object, scope, scale = 0, test = c("none", "Chisq", "F"),
           k = 2, sorted = FALSE, trace = FALSE, ...)
{
    Fstat <- function(table, rdf) {
	dev <- table$Deviance
	df <- table$Df
	diff <- pmax(0, (dev[1] - dev)/df)
	Fs <- (diff/df)/(dev/(rdf-df))
	Fs[df < .Machine$double.eps] <- NA
	P <- Fs
	nnas <- !is.na(Fs)
	P[nnas] <- pf(Fs[nnas], df[nnas], rdf - df[nnas], lower.tail=FALSE)
	list(Fs=Fs, P=P)
    }
    if(missing(scope) || is.null(scope)) stop("no terms in scope")
    if(!is.character(scope))
        scope <- add.scope(object, update.formula(object, scope))
    if(!length(scope))
        stop("no terms in scope for adding to object")
    oTerms <- attr(terms(object), "term.labels")
    int <- attr(object$terms, "intercept")
    ns <- length(scope)
    dfs <- dev <- numeric(ns+1)
    names(dfs) <- names(dev) <- c("<none>", scope)
    dfs[1] <- object$rank
    dev[1] <- object$deviance
    add.rhs <- paste(scope, collapse = "+")
    add.rhs <- eval(parse(text = paste("~ . +", add.rhs)))
    new.form <- update.formula(object, add.rhs)
    oc <- object$call
    Terms <- terms(new.form)
    oc$formula <- Terms
    fob <- list(call = oc)
    class(fob) <- class(object)
    x <- model.matrix(Terms, model.frame(fob, xlev = object$xlevels),
                      contrasts = object$contrasts)
    n <- nrow(x)
    oldn <- length(object$residuals)
    y <- object$y
    newn <- length(y)
    if(newn < oldn)
        warning(paste("using the", newn, "/", oldn ,
                      "rows from a combined fit"))
    wt <- object$prior.weights
    if(is.null(wt)) wt <- rep(1, n)
    Terms <- attr(Terms, "term.labels")
    asgn <- attr(x, "assign")
    ousex <- match(asgn, match(oTerms, Terms), 0) > 0
    if(int) ousex[1] <- TRUE
    for(tt in scope) {
        if(trace) cat("trying +", tt, "\n")
        usex <- match(asgn, match(tt, Terms), 0) > 0
        X <- x[, usex|ousex, drop = FALSE]
        z <-  glm.fit(X, y, wt, offset=object$offset,
                      family=object$family, control=object$control)
        dfs[tt] <- z$rank
        dev[tt] <- z$deviance
    }
    if (is.null(scale) || scale == 0)
        dispersion <- summary(object, dispersion = NULL)$dispersion
    else dispersion <- scale
    if(object$family$family == "gaussian") {
        if(scale > 0) loglik <- dev/scale - n
        else loglik <- n * log(dev/n)
    } else loglik <- dev/dispersion
    aic <- loglik + k * dfs
    aic <- aic + (extractAIC(object, k = k)[2] - aic[1]) # same baseline for AIC
    dfs <- dfs - dfs[1]
    dfs[1] <- NA
    aod <- data.frame(Df = dfs, Deviance = dev, AIC = aic,
                      row.names = names(dfs))
    o <- if(sorted) order(aod$AIC) else seq(along=aod$AIC)
    if(all(is.na(aic))) aod <- aod[, -3]
    test <- match.arg(test)
    if(test == "Chisq") {
        dev <- pmax(0, loglik[1] - loglik)
        dev[1] <- NA
        LRT <- if(dispersion == 1) "LRT" else "scaled dev."
        aod[, LRT] <- dev
        nas <- !is.na(dev)
        dev[nas] <- pchisq(dev[nas], aod$Df[nas], lower.tail=FALSE)
        aod[, "Pr(Chi)"] <- dev
    } else if(test == "F") {
	rdf <- object$df.residual
	aod[, c("F value", "Pr(F)")] <- Fstat(aod, rdf)
    }
    aod <- aod[o, ]
    head <- c("Single term additions", "\nModel:",
              deparse(as.vector(formula(object))))
    if(scale > 0)
        head <- c(head, paste("\nscale: ", format(scale), "\n"))
    class(aod) <- c("anova", "data.frame")
    attr(aod, "heading") <- head
    aod
}

addterm.mlm <- function(object, ...)
    stop("no addterm method implemented for mlm models")

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

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

dropterm.lm <-
  function(object, scope = drop.scope(object), scale = 0,
           test = c("none", "Chisq", "F"), k = 2, sorted = FALSE, ...)
{
    aod <- stats:::drop1.lm(object, scope=scope, scale=scale)[, -4]
    dfs <-  object$rank - c(0, aod$Df[-1]); RSS <- aod$RSS
    n <- length(object$residuals)
    aod$AIC <- if(scale > 0)RSS/scale - n + k*dfs
    else n * log(RSS/n) + k*dfs
    o <- if(sorted) order(aod$AIC) else seq(along=aod$AIC)
    if(scale > 0) names(aod) <- c("Df", "Sum of Sq", "RSS", "Cp")
    test <- match.arg(test)
    if(test == "Chisq") {
        dev <- aod$"Sum of Sq"
        nas <- !is.na(dev)
        dev[nas] <- pchisq(dev[nas]/scale, aod$Df[nas], lower.tail = FALSE)
        aod[, "Pr(Chi)"] <- dev
    } else if(test == "F") {
        rdf <- object$df.resid
        dev <- aod$"Sum of Sq"
        dfs <- aod$Df
        rms <- aod$RSS[1]/rdf
        Fs <- (dev/dfs)/rms
        Fs[dfs < 1e-4] <- NA
        P <- Fs
        nas <- !is.na(Fs)
	P[nas] <- pf(Fs[nas], dfs[nas], rdf, lower.tail=FALSE)
        aod[, c("F Value", "Pr(F)")] <- list(Fs, P)
    }
    aod <- aod[o, ]
    head <- c("Single term deletions", "\nModel:",
              deparse(as.vector(formula(object))))
    if(scale > 0)
        head <- c(head, paste("\nscale: ", format(scale), "\n"))
    class(aod) <- c("anova", "data.frame")
    attr(aod, "heading") <- head
    aod
}

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

dropterm.glm <-
  function(object, scope, scale = 0, test = c("none", "Chisq", "F"),
           k = 2, sorted = FALSE, trace = FALSE, ...)
{
    x <- model.matrix(object)
    n <- nrow(x)
    asgn <- attr(x, "assign")
    tl <- attr(object$terms, "term.labels")
    if(missing(scope)) scope <- drop.scope(object)
    else {
        if(!is.character(scope))
            scope <- attr(terms(update.formula(object, scope)), "term.labels")
        if(!all(match(scope, tl, FALSE)))
            stop("scope is not a subset of term labels")
  }
    ns <- length(scope)
    ndrop <- match(scope, tl)
    rdf <- object$df.resid
    chisq <- object$deviance
    dfs <- numeric(ns)
    dev <- numeric(ns)
    y <- object$y
    if(is.null(y)) y <- model.response(model.frame(object), "numeric")
    wt <- object$prior.weights
    if(is.null(wt)) wt <- rep(1, n)
    for(i in 1:ns) {
        if(trace) cat("trying -", scope[i], "\n")
        ii <- seq(along=asgn)[asgn == ndrop[i]]
        jj <- setdiff(seq(ncol(x)), ii)
        z <-  glm.fit(x[, jj, drop = FALSE], y, wt, offset=object$offset,
                      family=object$family, control=object$control)
        dfs[i] <- z$rank
        dev[i] <- z$deviance
    }
    scope <- c("<none>", scope)
    dfs <- c(object$rank, dfs)
    dev <- c(chisq, dev)
    if (is.null(scale) || scale == 0)
        dispersion <- summary(object, dispersion = NULL)$dispersion
    else dispersion <- scale
    if(object$family$family == "gaussian") {
        if(scale > 0) loglik <- dev/scale - n
        else loglik <- n * log(dev/n)
    } else loglik <- dev/dispersion
    aic <- loglik + k * dfs
    dfs <- dfs[1] - dfs
    dfs[1] <- NA
    aic <- aic + (extractAIC(object, k = k)[2] - aic[1])
    aod <- data.frame(Df = dfs, Deviance = dev, AIC = aic, row.names = scope)
    o <- if(sorted) order(aod$AIC) else seq(along=aod$AIC)
    if(all(is.na(aic))) aod <- aod[, -3]
    test <- match.arg(test)
    if(test == "Chisq") {
        dev <- pmax(0, loglik - loglik[1])
        dev[1] <- NA
        nas <- !is.na(dev)
        LRT <- if(dispersion == 1) "LRT" else "scaled dev."
        aod[, LRT] <- dev
        dev[nas] <- pchisq(dev[nas], aod$Df[nas], lower.tail=FALSE)
        aod[, "Pr(Chi)"] <- dev
    } else if(test == "F") {
        fam <- object$family$family  ## extra line needed
        if(fam == "binomial" || fam == "poisson")
            warning(paste("F test assumes quasi", fam, " family", sep=""))
	dev <- aod$Deviance
	rms <- dev[1]/rdf
        dev <- pmax(0, dev - dev[1])
	dfs <- aod$Df
	rdf <- object$df.residual
	Fs <- (dev/dfs)/rms
	Fs[dfs < 1e-4] <- NA
	P <- Fs
	nas <- !is.na(Fs)
	P[nas] <- pf(Fs[nas], dfs[nas], rdf, lower.tail=FALSE)
	aod[, c("F value", "Pr(F)")] <- list(Fs, P)
    }
    aod <- aod[o, ]
    head <- c("Single term deletions", "\nModel:",
              deparse(as.vector(formula(object))))
    if(scale > 0)
        head <- c(head, paste("\nscale: ", format(scale), "\n"))
    class(aod) <- c("anova", "data.frame")
    attr(aod, "heading") <- head
    aod
}

dropterm.negbin <- dropterm.survreg <-
    function(object, ...) dropterm.default(object, ...)
# file MASS/area.q
# copyright (C) 1994-9 W. N. Venables and B. D. Ripley
#
"area"<-
function(f, a, b, ..., fa = f(a, ...), fb = f(b, ...), limit
	 = 10, eps = 1e-5)
{
    h <- b - a
    d <- (a + b)/2
    fd <- f(d, ...)
    a1 <- ((fa + fb) * h)/2
    a2 <- ((fa + 4 * fd + fb) * h)/6
    if(abs(a1 - a2) < eps)
        return(a2)
    if(limit == 0) {
        warning(paste("iteration limit reached near x = ",
                      d))
        return(a2)
    }
    Recall(f, a, d, ..., fa = fa, fb = fd, limit = limit - 1,
           eps = eps) + Recall(f, d, b, ..., fa = fd, fb =
           fb, limit = limit - 1, eps = eps)
}
"fbeta"<-
function(x, alpha, beta)
{
    x^(alpha - 1) * (1 - x)^(beta - 1)
}
"print.abbrev"<-
function(x, ...)
{
    if(is.list(x))
        x <- unlist(x)
    NextMethod("print")
}
# file MASS/boxcox.q
# copyright (C) 1994-2004 W. N. Venables and B. D. Ripley
#
"boxcox" <- function(object, ...)
UseMethod("boxcox")

"boxcox.formula" <-
function(object, lambda = seq(-2, 2, 1/10), plotit =  TRUE,
         interp = (plotit && (m < 100)), eps = 1/
	50, xlab = expression(lambda), ylab = "log-Likelihood", ...)
{
    object <- lm(object, y = TRUE, qr = TRUE, ...)
    result <- NextMethod()
    if(plotit) invisible(result)
    else result
}

"boxcox.lm" <-
function(object, lambda = seq(-2, 2, 1/10), plotit = TRUE,
         interp = (plotit && (m < 100)), eps = 1/
	50, xlab = expression(lambda), ylab = "log-Likelihood", ...)
{
    if(is.null(object$y) || is.null(object$qr))
        object <- update(object, y = TRUE, qr = TRUE, ...)
    result <- NextMethod()
    if(plotit) invisible(result)
    else result
}

"boxcox.default" <-
function(object, lambda = seq(-2, 2, 1/10), plotit = TRUE,
         interp = (plotit && (m < 100)), eps = 1/
         50, xlab = expression(lambda), ylab = "log-Likelihood", ...)
{
    if(is.null(object$y) || is.null(object$qr))
        stop(paste(deparse(substitute(object)),
                   "does not have both 'qr' and 'y' components"
                   ))
    y <- object$y
    n <- length(y)
    if(any(y <= 0))
        stop("Response variable must be positive")
    xqr <- object$qr
    logy <- log(y)
    ydot <- exp(mean(logy))
    xl <- loglik <- as.vector(lambda)
    m <- length(xl)
    for(i in 1:m) {
        if(abs(la <- xl[i]) > eps)
            yt <- (y^la - 1)/la
        else yt <- logy * (1 + (la * logy)/2 *
                           (1 + (la * logy)/3 * (1 + (la * logy)/4)))
        loglik[i] <-  - n/2 * log(sum(qr.resid(xqr, yt/ydot^(la - 1))^2))
    }
    if(interp) {
        sp <- spline(xl, loglik, n = 100)
        xl <- sp$x
        loglik <- sp$y
        m <- length(xl)
    }
    if(plotit) {
        mx <- (1:m)[loglik == max(loglik)][1]
        Lmax <- loglik[mx]
        lim <- Lmax - qchisq(19/20, 1)/2
        plot(xl, loglik, xlab = xlab, ylab = ylab, type
             = "l", ylim = range(loglik, lim))
        plims <- par("usr")
        abline(h = lim, lty = 3)
        y0 <- plims[3]
        scal <- (1/10 * (plims[4] - y0))/par("pin")[2]
        scx <- (1/10 * (plims[2] - plims[1]))/par("pin")[1]
        text(xl[1] + scx, lim + scal, " 95%")
        la <- xl[mx]
        if(mx > 1 && mx < m)
            segments(la, y0, la, Lmax, lty = 3)
        ind <- range((1:m)[loglik > lim])
        if(loglik[1] < lim) {
            i <- ind[1]
            x <- xl[i - 1] + ((lim - loglik[i - 1]) *
                              (xl[i] - xl[i - 1]))/(loglik[i] - loglik[i - 1])
            segments(x, y0, x, lim, lty = 3)
        }
        if(loglik[m] < lim) {
            i <- ind[2] + 1
            x <- xl[i - 1] + ((lim - loglik[i - 1]) *
                              (xl[i] - xl[i - 1]))/(loglik[i] - loglik[i - 1])
            segments(x, y0, x, lim, lty = 3)
        }
    }
    list(x = xl, y = loglik)
}

# file MASS/confint.q
# copyright (C) 1994-2000 W. N. Venables and B. D. Ripley
#

confint.glm <- function(object, parm, level = 0.95, trace = FALSE, ...)
{
    pnames <- names(coef(object))
    if(missing(parm)) parm <- seq(along=pnames)
    else if(is.character(parm))  parm <- match(parm, pnames, nomatch = 0)
    cat("Waiting for profiling to be done...\n")
    object <- profile(object, which = parm, alpha = (1. - level)/4.,
                      trace = trace)
    confint(object, parm=parm, level=level, trace=trace, ...)
}

confint.profile.glm <-
  function(object, parm = seq(along=pnames), level = 0.95, ...)
{
    of <- attr(object, "original.fit")
    pnames <- names(coef(of))
    if(is.character(parm))  parm <- match(parm, pnames, nomatch = 0)
    a <- (1-level)/2
    a <- c(a, 1-a)
    pct <- paste(round(100*a, 1), "%")
    ci <- array(NA, dim = c(length(parm), 2),
                dimnames = list(pnames[parm], pct))
    cutoff <- qnorm(a)
    for(pm in parm) {
        pro <- object[[ pnames[pm] ]]
        if(length(pnames) > 1)
            sp <- spline(x = pro[, "par.vals"][, pm], y = pro[, 1])
        else sp <- spline(x = pro[, "par.vals"], y = pro[, 1])
        ci[pnames[pm], ] <- approx(sp$y, sp$x, xout = cutoff)$y
    }
    drop(ci)
}

confint.nls <-
  function(object, parm = seq(along=pnames), level = 0.95, ...)
{
  pnames <- names(coef(object))
  if(is.character(parm))  parm <- match(parm, pnames, nomatch = 0)
  cat("Waiting for profiling to be done...\n")
  object <- profile(object, which = parm, alphamax = (1. - level)/4.)
  confint(object, parm=parm, level=level, ...)
}

confint.profile.nls <-
  function(object, parm = seq(along=pnames), level = 0.95, ...)
{
  of <- attr(object, "original.fit")
  pnames <- names(coef(of))
  if(is.character(parm))  parm <- match(parm, pnames, nomatch = 0)
  n <- length(fitted(of)) - length(of$m$getPars())
  a <- (1-level)/2
  a <- c(a, 1-a)
  pct <- paste(round(100*a, 1), "%", sep = "")
  ci <- array(NA, dim = c(length(parm), 2),
              dimnames = list(pnames[parm], pct))
  cutoff <- qt(a, n)
  for(pm in parm) {
    pro <- object[[pm]]
    if(length(pnames) > 1)
        sp <- spline(x = pro[, "par.vals"][, pm], y = pro$tau)
    else sp <- spline(x = pro[, "par.vals"], y = pro$tau)
    ci[pnames[pm], ] <- approx(sp$y, sp$x, xout = cutoff)$y
  }
  drop(ci)
}

# file MASS/contr.sdif.q
# copyright (C) 1994-9 W. N. Venables and B. D. Ripley
#
contr.sdif <- function(n, contrasts = TRUE)
{
    # contrasts generator giving 'successive difference' contrasts.
    if(is.numeric(n) && length(n) == 1) {
        if(n %% 1 || n < 2)
            stop("invalid degree")
        lab <- as.character(seq(n))
    } else {
        lab <- as.character(n)
        n <- length(n)
        if(n < 2)
            stop("invalid number of levels")
    }
    if(contrasts) {
        contr <- col(matrix(nrow = n, ncol = n - 1))
        upper.tri <- !lower.tri(contr)
        contr[upper.tri] <- contr[upper.tri] - n
        structure(contr/n,
                  dimnames = list(lab, paste(lab[-1], lab[-n], sep="-")))
    } else structure(diag(n), dimnames = list(lab, lab))
}
# file MASS/corresp.q
# copyright (C) 1994-2004 W. N. Venables and B. D. Ripley
#
corresp <- function(x, ...) UseMethod("corresp")

corresp.xtabs <- function(x, ...)
{
  if((m <- length(dim(x))) > 2)
    stop(paste("Frequency table is", m, "dimensional"))
  corresp.matrix(x, ...)
}

corresp.data.frame <- function(x, ...)
    corresp.matrix(as.matrix(x), ...)

corresp.default <- function(x, ...)
    stop("invalid table specification")

corresp.factor <- function(x, y, ...)
    corresp.matrix(table(x, y), ...)

corresp.formula <- function(formula, data = parent.frame(), ...)
{
    rhs <- formula[[length(formula)]]
    if(length(rhs[[2]]) > 1 || length(rhs[[3]]) > 1)
        stop("higher way table requested.  Only 2 way allowed")
    tab <- table(eval(rhs[[2]], data), eval(rhs[[3]], data))
    names(dimnames(tab)) <- as.character(c(rhs[[2]], rhs[[3]]))
    corresp.matrix(tab, ...)
}

corresp.matrix <- function(x, nf = 1, ...)
{
    if(any(x < 0 | x %% 1 > 10 * sqrt(.Machine$double.eps)))
        warning("negative or non-integer entries in table")
    if((N <- sum(x)) == 0) stop("all frequencies are zero")
    Dr <- drop(x %*% (rep(1/N, ncol(x))))
    Dc <- drop((rep(1/N, nrow(x))) %*% x)
    if(any(Dr == 0) || any(Dc == 0)) stop("empty row or column in table")
    x1 <- x/N - outer(Dr, Dc)
    Dr <- 1/sqrt(Dr)
    Dc <- 1/sqrt(Dc)
    if(is.null(dimnames(x)))
        dimnames(x) <- list(Row = paste("R", 1:nrow(x)),
                            Col = paste("C", 1:ncol(x)))
    if(is.null(names(dimnames(x))))
        names(dimnames(x)) <- c("Row", "Column")
    X.svd <- svd(t(t(x1 * Dr) * Dc))
    dimnames(X.svd$u) <- list(rownames(x), NULL)
    dimnames(X.svd$v) <- list(colnames(x), NULL)
    res <- list(cor = X.svd$d[1:nf], rscore = X.svd$u[, 1:nf] * Dr,
                cscore = X.svd$v[, 1:nf] * Dc, Freq = x)
    class(res) <- "correspondence"
    res
}

plot.correspondence <- function(x, scale=1, ...)
{
    if(length(x$cor) > 1) return(invisible(biplot(x, ...)))
    Fr <- x$Freq
    rs <- x$rscore
    cs <- x$cscore
    xs <- range(cs)
    xs <- xs + diff(xs) * c(-1/5, 1/5)
    ys <- range(rs)
    ys <- ys + diff(ys) * c(-1/5, 1/5)
    x <- cs[col(Fr)]
    y <- rs[row(Fr)]
    rcn <- names(dimnames(Fr))
    plot(x, y, xlim = xs, ylim = ys, xlab = rcn[2], ylab = rcn[1], pch = 3)
    size <- min(par("pin"))/20 * scale
    symbols(x, y, circles = as.vector(sqrt(Fr)), inches = size, add = TRUE)
    x0 <- (min(cs) + min(xs))/2
    y0 <- (min(rs) + min(ys))/2
    text(cs, y0, names(cs))
    text(x0, rs, names(rs), adj = 1)
    invisible()
}

print.correspondence <- function(x, ...)
{
    cat("First canonical correlation(s):", format(x$cor, ...), "\n")
    rcn <- names(dimnames(x$Freq))
    cat("\n", rcn[1], "scores:\n")
    print(x$rscore)
    cat("\n", rcn[2], "scores:\n")
    print(x$cscore)
    invisible(x)
}

biplot.correspondence <-
    function(x, type = c("symmetric", "rows", "columns"), ...)
{
    if(length(x$cor) < 2) stop("biplot is only possible if nf >= 2")
    type <- match.arg(type)
    X <- x$rscore[, 1:2]
    if(type != "columns") X <- X %*% diag(x$cor[1:2])
    colnames(X) <- rep("", 2)
    Y <- x$cscore[, 1:2]
    if(type != "rows")  Y <- Y %*% diag(x$cor[1:2])
    colnames(Y) <- rep("", 2)
    switch(type, "symmetric" = biplot(X, Y, var.axes = FALSE, ...),
           "rows" = biplot.bdr(X, Y, ...),
           "columns" = biplot.bdr(Y, X, ...))
    points(0, 0, pch = 3, cex = 3)
    invisible()
}

biplot.bdr <-
    function(obs, bivars, col, cex = rep(par("cex"), 2),
             olab = NULL, vlab = NULL, xlim = NULL, ylim = NULL, ...)
{
  # for cases where we need equal scales for the two sets of vars.
    expand.range <- function(x)
    {
        if(x[1] > 0) x[1] <-  - x[1]
        else if(x[2] < 0) x[2] <-  - x[2]
        x
    }
    n <- dim(obs)[1]
    p <- dim(bivars)[1]
    vlab.real <- rownames(bivars)
    if(is.logical(vlab)) vlab <- vlab.real[vlab]
    else if(length(vlab) != p) vlab <- vlab.real
    else vlab <- as.character(vlab)
    if(!length(vlab)) {
        vlab.real <- vlab <- paste("Var", 1:p)
        dimnames(bivars) <- list(vlab, colnames(bivars))
    }
    if(length(olab)) olab <- rep(as.character(olab), length.out = n)
    else {
        olab <- rownames(obs)
        if(length(olab) != n) olab <- as.character(1:n)
    }
    if(length(cex) != 2) cex <- rep(cex, length.out = 2)
    if(missing(col)) {
        col <- par("col")
        if (!is.numeric(col)) col <- match(col, palette())
        col <- c(col, col + 1)
    }
    else if(length(col) != 2) col <- rep(col, length.out = 2)
    ro1 <- expand.range(range(obs[, 1]))
    ro2 <- expand.range(range(obs[, 2]))
    rv1 <- expand.range(range(bivars[, 1]))
    rv2 <- expand.range(range(bivars[, 2]))
    if(!(length(xlim) || length(ylim)))
        xlim <- ylim <- range(ro1, ro2, rv1, rv2)
    else if(!length(xlim)) xlim <- range(ro1, rv1)
    else if(!length(ylim)) ylim <- range(ro2, rv2)
    on.exit(par(oldpar))
    oldpar <- par(pty = "s")
    plot(obs, type = "n", xlim = xlim, ylim = ylim, col = col[1], ...)
    text(obs, labels=olab, cex = cex[1], col = col[1], ...)
    par(new = TRUE)
    plot(bivars, axes = FALSE, type = "n", xlim = xlim, ylim =
         ylim, xlab = "", ylab = "", col = col[1], ...)
    axis(3, col = col[2])
    axis(4, col = col[2])
    box(col = col[1])
    text(bivars, labels=vlab, cex = cex[2], col = col[2], ...) #
    invisible()
}

# file MASS/cov.trob.q
# copyright (C) 1994-2004 W. N. Venables and B. D. Ripley
#
cov.trob <- function(x, wt = rep(1, n), cor = FALSE, center = TRUE, nu = 5,
                     maxit = 25, tol = 0.01)
{
    test.values <- function(x)
    {
        if(any(is.na(x)) || any(is.infinite(x)))
            stop(paste("error in cov.trob: missing or infinite values in",
                       deparse(substitute(x))))
    }
    scale.simp <- function(x, center, n, p) x - rep(center, rep(n, p))

    x <- as.matrix(x)
    n <- nrow(x)
    p <- ncol(x)
    dn <- colnames(x)
    test.values(x)
    if(!(miss.wt <- missing(wt))) {
        test.values(wt)
        if(length(wt) != n)
            stop("length of wt must equal number of observations")
        if(any(wt < 0)) stop("negative weights not allowed")
        if(!sum(wt)) stop("no positive weights")
    }
#    loc <- apply(wt * x, 2, sum)/sum(wt)
    loc <- colSums(wt * x)/sum(wt)
    if(is.numeric(center)) {
        if(length(center) != p) stop("center is not the right length")
        loc <- center
    } else if(is.logical(center) && !center) loc <- rep(0, p)
    use.loc <- is.logical(center) && center
    w <- wt * (1 + p/nu)
    endit <- 0
    for(iter in 1:maxit) {
        w0 <- w
        X <- scale.simp(x, loc, n, p)
        sX <- svd(sqrt(w/sum(w)) * X, nu = 0)
        wX <- X %*% sX$v %*% diag(1/sX$d,  , p)
        Q <- drop(wX^2 %*% rep(1, p))
        w <- (wt * (nu + p))/(nu + Q)
        #    print(summary(w))
        if(use.loc) loc <- colSums(w * x)/sum(w)
        if(all(abs(w - w0) < tol)) break
        endit <- iter
    }
    if(endit == maxit || abs(mean(w) - mean(wt)) > tol ||
       abs(mean(w * Q)/p - 1) > tol)
        warning("Probable convergence failure")
    cov <- crossprod(sqrt(w) * X)/sum(wt)
    if(length(dn)) {
        dimnames(cov) <- list(dn, dn)
        names(loc) <- dn
    }
    if(miss.wt)
        ans <- list(cov = cov, center = loc, n.obs = n)
    else ans <- list(cov = cov, center = loc, wt = wt, n.obs = n)
    if(cor) {
        sd <- sqrt(diag(cov))
        cor <- (cov/sd)/rep(sd, rep.int(p, p))
        if(length(dn)) dimnames(cor) <- list(dn, dn)
        ans <- c(ans, list(cor = cor))
    }
    ans$call <- match.call()
    ans$iter <- endit
    ans
}
datanames <-
c("abbey", "accdeaths", "Aids2", "Animals", "anorexia", "austres",
"bacteria", "beav1", "beav2", "biopsy", "birthwt", "Boston",
"cabbages", "caith", "Cars93", "cats", "cement", "chem", "coop",
"cpus", "crabs", "Cushings", "DDT", "deaths", "drivers", "eagles",
"epil", "farms", "fdeaths", "fgl", "forbes", "GAGurine", "galaxies",
"gehan", "genotype", "geyser", "gilgais", "hills", "housing",
"immer", "Insurance", "leuk", "lh", "mammals", "mcycle", "mdeaths",
"Melanoma", "menarche", "michelson", "minn38", "motors", "muscle",
"newcomb", "nlschools", "nottem", "npk", "npr1", "oats", "OME",
"painters", "petrol", "phones", "Pima.te", "Pima.tr", "Pima.tr2",
"quine", "Rabbit", "road", "rock", "rotifer", "Rubber", "ships",
"shoes", "shrimp", "shuttle", "Sitka", "Sitka89", "Skye", "snails",
"SP500", "steam", "stormer", "survey", "synth.te", "synth.tr",
"topo", "Traffic", "UScereal", "UScrime", "VA", "waders", "whiteside",
"wtloss")

for(i in datanames)
    eval(substitute(obj <- delay(MASS.data.load(obj)), list(obj=i)))
rm(datanames,i)

MASS.data.load <- function(i)
{
    file <- file.path(system.file("data", package="MASS"),
                      paste(i, ".rda", sep=""))
    zfile <- zip.file.extract(file, "Rdata.zip")
    ## this *has* to be a temp environment, not the package.
    env <- new.env()
    load(zfile, envir=env)
    get(i, env)
}
# file MASS/dose.p.q
# copyright (C) 1994-9 W. N. Venables and B. D. Ripley
#
dose.p <- function(obj, cf = 1:2, p = 0.5) {
  eta <- family(obj)$linkfun(p)
  b <- coef(obj)[cf]
  x.p <- (eta - b[1])/b[2]
  names(x.p) <- paste("p = ", format(p), ":", sep = "")
  pd <-  -cbind(1, x.p)/b[2]
  SE <- sqrt(((pd %*% vcov(obj)[cf, cf]) * pd) %*% c(1, 1))
  res <- structure(x.p, SE = SE, p = p)
  class(res) <- "glm.dose"
  res
}

print.glm.dose <- function(x, ...)
{
  M <- cbind(x, attr(x, "SE"))
  dimnames(M) <- list(names(x), c("Dose", "SE"))
  x <- M
  NextMethod("print")
}
# file MASS/enlist.q
# copyright (C) 1994-9 W. N. Venables and B. D. Ripley
#
"enlist"<-
function(vec)
{
    x <- as.list(vec)
    names(x) <- names(vec)
    x
}
# file MASS/eqscplot.q
# copyright (C) 1994-2001 W. N. Venables and B. D. Ripley
#
eqscplot <- function(x, y, ratio = 1, tol = 0.04, uin,
                     xlim = range(x[is.finite(x)]),
                     ylim = range(y[is.finite(y)]),
		     xlab, ylab,
		     ...)
{
  if(is.matrix(x)) {
    y <- x[, 2]
    x <- x[, 1]
    if(!is.null(dn <- colnames(x))) {
      xlab0 <- dn[1]
      ylab0 <- dn[2]
    } else {
      xlab0 <- ""
      ylab0 <- ""
    }
  } else if(is.list(x)) {
    y <- x$y
    x <- x$x
    xlab0 <- "x"; ylab0 <- "y"
  } else {
    xlab0 <- deparse(substitute(x))
    ylab0 <- deparse(substitute(y))
  }
  if(missing(xlab)) xlab <- xlab0
  if(missing(ylab)) ylab <- ylab0
  midx <- 0.5 * (xlim[2] + xlim[1])
  xlim <- midx + (1 + tol) * 0.5 * c(-1, 1) * (xlim[2] - xlim[1])
  midy <- 0.5 * (ylim[2] + ylim[1])
  ylim <- midy + (1 + tol) * 0.5 * c(-1, 1) * (ylim[2] - ylim[1])
  oldpin <- par("pin")
  xuin <- oxuin <- oldpin[1]/diff(xlim)
  yuin <- oyuin <- oldpin[2]/diff(ylim)
  if(missing(uin)) {
    if(yuin > xuin*ratio) yuin <- xuin*ratio
    else xuin <- yuin/ratio
  } else {
    if(length(uin) == 1) uin <- uin * c(1, ratio)
    if(any(c(xuin, yuin) < uin)) stop("uin is too large to fit plot in")
    xuin <- uin[1]; yuin <- uin[2]
  }
  xlim <- midx + oxuin/xuin * c(-1, 1) * diff(xlim) * 0.5
  ylim <- midy + oyuin/yuin * c(-1, 1) * diff(ylim) * 0.5
  plot(x, y, xlim = xlim, ylim = ylim, xaxs = "i", yaxs = "i",
       xlab = xlab, ylab = ylab, ...)
}
fitdistr <- function(x, densfun, start, ...)
{
    myfn <- function(parm, ...) -sum(log(dens(parm, ...)))
    mylogfn <- function(parm, ...) -sum(dens(parm, ..., log = TRUE))
    mydt <- function(x, m, s, df, log) dt((x-m)/s, df, log = TRUE) - log(s)

    if(missing(start)) start <- NULL
    dots <- names(list(...))
    dots <- dots[!is.element(dots, c("upper", "lower"))]
    if(missing(x) || length(x) == 0 || mode(x) != "numeric")
        stop("'x' must be a non-empty numeric vector")
    if(missing(densfun) || !(is.function(densfun) || is.character(densfun)))
        stop("'densfun' must be supplied as a function or name")
    if(is.character(densfun)) {
        distname <- tolower(densfun)
        densfun <-
            switch(distname,
                   "beta" = dbeta,
                   "cauchy" = dcauchy,
                   "chi-squared" = dchisq,
                   "exponential" = dexp,
                   "f" = df,
                   "gamma" = dgamma,
                   "log-normal" = dlnorm,
                   "lognormal" = dlnorm,
                   "logistic" = dlogis,
                   "negative binomial" = dnbinom,
                   "normal" = dnorm,
                   "t" = mydt,
                   "uniform" = dunif,
                   "weibull" = dweibull,
                   NULL)
        if(is.null(densfun)) stop("unsupported distribution")
        if(distname == "normal") {
            if(!is.null(start))
                stop("supplying pars for the Normal is not supported")
            n <- length(x)
            sd0 <- sqrt((n-1)/n)*sd(x)
            estimate <- c(mean(x), sd0)
            sds <- c(sd0/sqrt(n), sd0/sqrt(2*n))
            names(estimate) <- names(sds) <- c("mean", "sd")
            return(structure(list(estimate = estimate, sd = sds),
                             class = "fitdistr"))
        }
        if(distname == "weibull" && is.null(start)) {
            ## log-Weibull is Gumbel, so start from that
            m <- mean(log(x)); v <- var(log(x))
            shape <- 1.2/sqrt(v); scale <- exp(m + 0.572/shape)
            start <- list(shape = shape, scale = scale)
            start <- start[!is.element(names(start), dots)]
        }
        if(distname == "gamma" && is.null(start)) {
            m <- mean(x); v <- var(x)
            start <- list(shape = m^2/v, rate = m/v)
            start <- start[!is.element(names(start), dots)]
        }
        if(distname == "uniform" && is.null(start)) {
            start <- list(min = min(x), max = max(x))
            start <- start[!is.element(names(start), dots)]
        }
        if(distname == "negative binomial" && is.null(start)) {
            m <- mean(x); v <- var(x)
            size <- if(v > m) m^2/(v - m) else 100
            start <- list(size = size, mu = m)
            start <- start[!is.element(names(start), dots)]
        }
        if(is.element(distname, c("cauchy", "logistic")) && is.null(start)) {
            start <- list(location = median(x), scale = IQR(x)/2)
            start <- start[!is.element(names(start), dots)]
        }
        if(distname == "t" && is.null(start)) {
            start <- list(m = median(x), s = IQR(x)/2, df = 10)
            start <- start[!is.element(names(start), dots)]
        }
    }
    if(is.null(start) || !is.list(start))
        stop("'start' must be a named list")
    nm <- names(start)
    ## reorder arguments to densfun
    f <- formals(densfun)
    args <- names(f)
    m <- match(nm, args)
    if(any(is.na(m)))
        stop("'start' specifies names which are not arguments to 'densfun'")
    formals(densfun) <- c(f[c(1, m)], f[-c(1, m)])
    dens <- function(parm, x, ...) densfun(x, parm, ...)
    if((l <- length(nm)) > 1)
        body(dens) <-
            parse(text = paste("densfun(x,",
                  paste("parm[", 1:l, "]", collapse = ", "),
                  ", ...)"))
    if("log" %in% args)
        res <- optim(start, mylogfn, x = x, hessian = TRUE, ...)
    else
        res <- optim(start, myfn, x = x, hessian = TRUE, ...)
    if(res$convergence > 0) stop("optimization failed")
    sds <- sqrt(diag(solve(res$hessian)))
    structure(list(estimate = res$par, sd = sds), class = "fitdistr")
}

print.fitdistr <-
    function(x, digits = getOption("digits"), ...)
{
    ans <- format(rbind(x$estimate, x$sd), digits=digits)
    ans[1, ] <- sapply(ans[1, ], function(x) paste("", x))
    ans[2, ] <- sapply(ans[2, ], function(x) paste("(", x, ")", sep=""))
    dn <- dimnames(ans)
    dn[[1]] <- rep("", 2)
    dn[[2]] <- paste(substring("      ", 1, (nchar(ans[2,]) - nchar(dn[[2]])) %/% 2), dn[[2]])
    dn[[2]] <- paste(dn[[2]], substring("      ", 1, (nchar(ans[2,]) - nchar(dn[[2]])) %/% 2))
    dimnames(ans) <- dn
    print(ans, quote = FALSE)
    x
}

coef.fitdistr <- function(object, ...) object$estimate

# file MASS/fractions.q
# copyright (C) 1994-2000 W. N. Venables and B. D. Ripley
#
.rat <- function(x, cycles = 10, max.denominator = 2000)
{
  a0 <- rep(0, length(x))
  A <- matrix(b0 <- rep(1, length(x)))
  fin <- is.finite(x)
  B <- matrix(floor(x))
  r <- as.vector(x) - drop(B)
  len <- 0
  while(any(which <- fin & (r > 1/max.denominator)) &&
	(len <- len + 1) <= cycles) {
    a <- a0
    b <- b0
    a[which] <- 1
    r[which] <- 1/r[which]
    b[which] <- floor(r[which])
    r[which] <- r[which] - b[which]
    A <- cbind(A, a)
    B <- cbind(B, b)
  }
  pq1 <- cbind(b0, a0)
  pq <- cbind(B[, 1], b0)
  len <- 1
  while((len <- len + 1) <= ncol(B)) {
    pq0 <- pq1
    pq1 <- pq
    pq <- B[, len] * pq1 + A[, len] * pq0
  }
  pq[!fin, 1] <- x[!fin]
  list(rat = pq, x = x)
}

rational <- function(x, ...) {
  ans <- .rat(x, ...)$rat
  do.call("structure", c(list(ans[,1]/ans[,2]), attributes(x)))
}

fractions <- function(x, ...) {
  ans <- .rat(x, ...)
  ndc <- paste(ans$rat[, 1], ans$rat[, 2], sep = "/")
  int <- ans$rat[, 2] == 1
  ndc[int] <- as.character(ans$rat[int, 1])
  ans <- structure(ans$x, fracs = ndc)
  class(ans) <- c("fractions", class(ans$x))
  ans
}

"t.fractions"<- function(x)
{
  xt <- NextMethod()
  class(xt) <- class(x)
  attr(xt, "fracs") <- t(array(attr(x, "fracs"), dim(x)))
  xt
}

"Math.fractions"<- function(x, ...)
{
  x <- unclass(x)
  fractions(NextMethod())
}

"Ops.fractions"<- function(e1, e2)
{
  e1 <- unclass(e1)
  if(!missing(e2))
    e2 <- unclass(e2)
  fractions(NextMethod(.Generic))
}

"Summary.fractions"<- function(x, ...)
{
  x <- unclass(x)
  fractions(NextMethod())
}

"[.fractions"<- function(x, ...)
{
  x <- unclass(x)
  fractions(NextMethod())
}

"[<-.fractions"<- function(x, ..., value)
{
  x <- unclass(x)
  fractions(NextMethod())
}

"as.character.fractions"<- function(x)
structure(attr(x, "fracs"), dim = dim(x), dimnames = dimnames(x))

"as.fractions"<- function(x)
if(is.fractions(x)) x else fractions(x)

"is.fractions"<- function(f)
inherits(f, "fractions")

"print.fractions"<- function(x, ...)
{
  y <- attr(x, "fracs")
  mc <- max(ncy <- nchar(y))
  if(any(small <- ncy < mc)) {
    blanks <- "    "
    while(nchar(blanks) < mc) blanks <- paste(blanks, blanks)
    blanks <- rep(blanks, sum(small))
    blanks <- substring(blanks, 1, mc - ncy)
    y[small] <- paste(blanks[small], y[small], sep = "")
  }
  att <- attributes(x)
  att$fracs <- att$class <- NULL
  x <- do.call("structure", c(list(y), att))
  NextMethod("print", quote = FALSE)
}

# file MASS/gamma.shape.q
# copyright (C) 1994-9 W. N. Venables and B. D. Ripley
#
gamma.shape <- function(object, ...) UseMethod("gamma.shape")

gamma.shape.glm <- function(object, it.lim = 10,
                            eps.max = .Machine$double.eps^0.25,
			    verbose = FALSE, ...)
{
    if(is.null(object$y)) object <- update(object, y = TRUE)
    y <- object$y
    A <- object$prior.weights
    if(is.null(A)) A <- rep(1, length(y))
    u <- object$fitted
    Dbar <- object$deviance/object$df.residual
    alpha <- (6 + 2*Dbar)/(Dbar*(6 + Dbar))
    if(verbose) cat("Initial estimate:", format(alpha), "\n")
    fixed <-  -y/u - log(u) + log(A) + 1 + log(y + (y == 0))
    eps <- 1
    itr <- 0
    while(abs(eps) > eps.max && (itr <- itr + 1) <= it.lim) {
        sc <- sum(A * (fixed + log(alpha) - digamma(A * alpha)))
        inf <- sum(A * (A * trigamma(A * alpha) - 1/alpha))
        alpha <- alpha + (eps <- sc/inf)
        if(verbose) cat("Iter. ", itr, " Alpha:", alpha, "\n")
    }
    if(itr > it.lim) warning("Iteration limit reached")
    res <- list(alpha = alpha, SE = sqrt(1/inf))
    class(res) <- "gamma.shape"
    res
}

gamma.dispersion <- function(object, ...)
    1/gamma.shape(object, ...)[[1]]

print.gamma.shape <- function(x, ...)
{
    y <- x
    x <- array(unlist(x), dim = 2:1,
               dimnames = list(c("Alpha:", "SE:"), ""))
    NextMethod("print")
    invisible(y)
}
glmmPQL <- function(fixed, random, family, data, correlation, weights,
                    control, niter = 10, verbose = TRUE, ...)
{
    if(!require("nlme")) stop("package nlme is essential")
    ## family
    if(is.character(family)) family <- get(family)
    if(is.function(family)) family <- family()
    if(is.null(family$family)) {
	print(family)
	stop("'family' not recognized")
    }
    m <- mcall <- Call <- match.call()
    nm <- names(m)[-1]
    keep <- is.element(nm, c("weights", "data", "subset", "na.action"))
    for(i in nm[!keep]) m[[i]] <- NULL
    allvars <-
        if (is.list(random))
            allvars <- c(all.vars(fixed), names(random),
                         unlist(lapply(random, function(x) all.vars(formula(x)))))
        else c(all.vars(fixed), all.vars(random))
    ## allvars does not contain offset term.
    Terms <- terms(fixed, data=data)
    off <- attr(Terms, "offset")
    if(length(off<- attr(Terms, "offset"))) allvars <-
        c(allvars, as.character(attr(Terms, "variables"))[off+1])
    m$formula <- as.formula(paste("~", paste(allvars, collapse="+")))
    environment(m$formula) <- environment(fixed)
    m$drop.unused.levels <- TRUE
    m[[1]] <- as.name("model.frame")
    mf <- eval.parent(m)
    off <- model.offset(mf)
    if(is.null(off)) off <- 0
    w <-  model.weights(mf)
    if(is.null(w)) w <- rep(1, nrow(mf))
    mf$wts <- w
    fit0 <- glm(formula=fixed, family=family, data=mf, weights = wts, ...)
    w <- fit0$prior.weights
    eta <- fit0$linear.predictor
    zz <- eta + fit0$residuals - off
    wz <- fit0$weights
    fam <- family

    nm <- names(mcall)[-1]
    keep <- is.element(nm, c("fixed", "random", "data", "subset",
                             "na.action", "control"))
    for(i in nm[!keep]) mcall[[i]] <- NULL
    fixed[[2]] <- quote(zz)
    mcall[["fixed"]] <- fixed
    mcall[[1]] <- as.name("lme")
    mcall$random <- random
    mcall$method <- "ML"
    if(!missing(correlation))
        mcall$correlation <- correlation
    mcall$weights <- quote(varFixed(~invwt))
    mf$zz <- zz
    mf$invwt <- 1/wz
    mcall$data <- mf

    for(i in 1:niter) {
        if(verbose) cat("iteration", i, "\n")
        fit <- eval(mcall)
        etaold <- eta
        ##update zz and invwt
        eta <- fitted(fit) + off
        if(sum((eta-etaold)^2) < 1e-6*sum(eta^2)) break;
        mu <- fam$linkinv(eta)
        mu.eta.val <- fam$mu.eta(eta)
        mf$zz <- eta + (fit0$y - mu)/mu.eta.val - off
        wz <- w * mu.eta.val^2 / fam$variance(mu)
        mf$invwt <- 1/wz
        mcall$data <- mf
    }
    attributes(fit$logLik) <- NULL # needed for some versions of nlme
    fit$call <- Call
    fit$family <- family
    oldClass(fit) <- c("glmmPQL", oldClass(fit))
    fit
}

predict.glmmPQL <-
  function(object, newdata = NULL, type = c("link", "response"),
           level = Q, na.action = na.pass, ...)
{
    type <- match.arg(type)
    Q <- object$dims$Q
    if(missing(newdata)) {
        pred <- fitted(object, level = level)
        pred <- switch(type,
                       link = pred,
                       response = object$family$linkinv(pred))
        if(!is.null(na.act)) pred <- napredict(object$na.action, pred)
    } else {
        class(object) <- class(object)[-1]
        pred <- predict(object, newdata, level = level,
                        na.action = na.action)
        switch(type,
               response = {pred <- object$family$linkinv(pred)},
               link =)
    }
    pred
}
# file MASS/hist.scott.q
# copyright (C) 1994-9 W. N. Venables and B. D. Ripley
#

hist.scott <- function(x, prob = TRUE, xlab = deparse(substitute(x)), ...)
   invisible(hist(x, nclass.scott(x), prob=prob, xlab=xlab, ...))
hist.FD <- function(x, prob = TRUE, xlab = deparse(substitute(x)), ...)
   invisible(hist(x, nclass.FD(x), prob=prob, xlab=xlab, ...))

frequency.polygon <- function(x, nclass = nclass.freq(x),
    xlab="", ylab="", ...)
{
    hst <- hist(x, nclass, probability=TRUE, plot=FALSE, ...)
    midpoints <- 0.5 * (hst$breaks[-length(hst$breaks)]
                        + hst$breaks[-1])
    plot(midpoints, hst$counts, type="l", xlab=xlab, ylab=ylab)
}

nclass.freq <- function(x)
{
    h <- 2.15 * sqrt(var(x)) * length(x)^(-1/5)
    ceiling(diff(range(x))/h)
}

bandwidth.nrd <- function(x)
{
    r <- quantile(x, c(0.25, 0.75))
    h <- (r[2] - r[1])/1.34
    4 * 1.06 * min(sqrt(var(x)), h) * length(x) ^ (-1/5)
}
# file MASS/huber.q
# copyright (C) 1994-9 W. N. Venables and B. D. Ripley
#
huber <- function(y, k=1.5, tol = 1.0e-6)
{
    y <- y[!is.na(y)]
    n <- length(y)
    mu <- median(y)
    s <- mad(y)
    if(s == 0) stop("cannot estimate scale: MAD is zero for this sample")
    repeat{
        yy <- pmin(pmax(mu-k*s,y),mu+k*s)
        mu1 <- sum(yy)/n
        if(abs(mu-mu1) < tol*s) break
        mu <- mu1
    }
    list(mu=mu,s=s)
}
# file MASS/hubers.q
# copyright (C) 1994-9 W. N. Venables and B. D. Ripley
#
hubers <- function(y, k = 1.5, mu, s, initmu = median(y), tol = 1.0e-6)
{
    y <- y[!is.na(y)]
    n <- length(y)
    if(missing(mu)) {
        mu0 <- initmu
        n1 <- n - 1
    } else {
        mu0 <- mu
        mu1 <- mu
        n1 <- n
    }
    if(missing(s)) s0 <- mad(y) else {s0 <- s;s1 <- s}
    th <- 2*pnorm(k)-1
    beta <- th + k^2*(1-th) - 2*k*dnorm(k)
    repeat{
        yy <- pmin(pmax(mu0-k*s0,y), mu0+k*s0)
        if(missing(mu)) mu1 <- sum(yy)/n
        if(missing(s)) {
            ss <- sum((yy-mu1)^2)/n1
            s1 <- sqrt(ss/beta)
        }
        if((abs(mu0-mu1) < tol*s0) && abs(s0-s1) < tol*s0) break
        mu0 <- mu1; s0 <- s1
    }
    list(mu=mu0, s=s0)
}
# file MASS/R/isoMDS.R
# copyright (C) 1994-2004 W. N. Venables and B. D. Ripley
#
isoMDS <- function(d, y = cmdscale(d, k), k = 2, maxit = 50, trace = TRUE,
                   tol = 1e-3, p = 2)
{
    if(any(!is.finite(d)) && missing(y))
        stop("An initial configuration must be supplied with NA/Infs in d")
    if(!is.matrix(y)) stop("y must be a matrix")

    if(is.null(n <- attr(d, "Size"))) {
        x <- as.matrix(d)
        if((n <- nrow(x)) != ncol(x))
            stop("Distances must be result of dist or a square matrix")
    } else {
        x <- matrix(0, n, n)
        x[row(x) > col(x)] <- d
        x <- x + t(x)
    }
    ab <- x[row(x) < col(x)] <= 0
    if (any(ab)) {
        ab <- !is.na(ab) & ab
        aa <- cbind(as.vector(row(x)), as.vector(col(x)))[row(x) < col(x),]
        aa <- aa[ab, , drop=FALSE]
        stop(paste("zero or negative distance between objects", aa[1,1],
                   "and", aa[1,2]))
    }
    if(any(dim(y) != c(n, k)) ) stop("invalid initial configuration")
    if(any(!is.finite(y))) stop("initial configuration must be complete")
    nas <- is.na(x)
    diag(nas) <- FALSE  # diag never used
    if(any(rowSums(!nas) < 2)) stop("not enough non-missing data")

    dis <- x[row(x) > col(x)]
    ord <- order(dis)
    nd <- sum(!is.na(ord))

    on.exit(.C("VR_mds_unload", PACKAGE = "MASS"))
    .C("VR_mds_init_data",
       as.integer(nd),
       as.integer(k),
       as.integer(n),
       as.integer(ord - 1),
       as.integer(order(ord) - 1),
       as.double(y),
       as.double(p),
       PACKAGE = "MASS"
       )
    tmp <- .C("VR_mds_dovm",
              val = double(1), as.integer(maxit), as.integer(trace),
              y = as.double(y), as.double(tol), PACKAGE = "MASS")
    points <- matrix(tmp$y,,k)
    rn <- if(is.matrix(d)) rownames(d) else names(d)
    dimnames(points) <- list(rn, NULL)
    list(points = points, stress = tmp$val)
}

Shepard <- function(d, x, p = 2)
{
#
# Given a dissimilarity d and configuration x, compute Shepard plot
#
  n <- nrow(x)
  k <- ncol(x)
  y <- dist(x, method="minkowski", p = p)
  ord <- order(d)
  y <- y[ord]
  nd <- length(ord)
  Z <- .C("VR_mds_fn",
	  as.double(y),
	  yf=as.double(y),
	  as.integer(nd),
	  ssq = double(1),
	  as.integer(order(ord)-1),
	  as.double(x),
	  as.integer(n),
	  as.integer(k),
	  g=double(n*k),
	  as.integer(1),
          as.double(2.0),
          PACKAGE = "MASS"
	  )
  list(x = d[ord], y = y, yf = Z$yf)
}

# file MASS/kde2d.q
# copyright (C) 1994-9 W. N. Venables and B. D. Ripley
#
kde2d <- function(x, y, h, n = 25, lims=c(range(x), range(y)) )
{
    nx <- length(x)
    if(length(y) != nx)
        stop("Data vectors must be the same length")
    gx <- seq(lims[1], lims[2], length = n)
    gy <- seq(lims[3], lims[4], length = n)
    if (missing(h))
        h <- c(bandwidth.nrd(x), bandwidth.nrd(y))
    h <- h/4                            # for S's bandwidth scale
    ax <- outer(gx, x, "-" )/h[1]
    ay <- outer(gy, y, "-" )/h[2]
    z <- matrix(dnorm(ax), n, nx) %*%
        t(matrix(dnorm(ay),n, nx))/ (nx * h[1] * h[2])
    return(list(x = gx, y = gy, z = z))
}
# file MASS/lda.q
# copyright (C) 1994-2004 W. N. Venables and B. D. Ripley
#
lda <- function(x, ...) UseMethod("lda")


lda.formula <- function(formula, data, ..., subset, na.action)
{
    m <- match.call(expand.dots = FALSE)
#    if(is.matrix(eval.parent(m$data))) # done in model.frame.default
#        m$data <- as.data.frame(data)
    m$... <- NULL
    m[[1]] <- as.name("model.frame")
    m <- eval.parent(m)
    Terms <- attr(m, "terms")
    grouping <- model.response(m)
    x <- model.matrix(Terms, m)
    xint <- match("(Intercept)", colnames(x), nomatch=0)
    if(xint > 0) x <- x[, -xint, drop=FALSE]
    res <- lda.default(x, grouping, ...)
    res$terms <- Terms
    ## fix up call to refer to the generic, but leave arg name as `formula'
    cl <- match.call()
    cl[[1]] <- as.name("lda")
    res$call <- cl
    res$contrasts <- attr(x, "contrasts")
    res$xlevels <- .getXlevels(Terms, m)
    res$na.action <- attr(m, "na.action")
    res
}

lda.data.frame <- function(x, ...)
{
    res <- lda(structure(data.matrix(x), class="matrix"), ...)
    cl <- match.call()
    cl[[1]] <- as.name("lda")
    res$call <- cl
    res
}


lda.matrix <- function(x, grouping, ..., subset, na.action)
{
    if(!missing(subset)) {
        x <- x[subset, , drop = FALSE]
        grouping <- grouping[subset]
    }
    if(!missing(na.action)) {
        dfr <- na.action(structure(list(g = grouping, x = x),
                                   class = "data.frame"))
        grouping <- dfr$g
        x <- dfr$x
    }
#    res <- NextMethod("lda")
    res <- lda.default(x, grouping, ...)
    cl <- match.call()
    cl[[1]] <- as.name("lda")
    res$call <- cl
    res
}

lda.default <-
  function(x, grouping, prior = proportions, tol = 1.0e-4,
           method = c("moment", "mle", "mve", "t"),
           CV = FALSE, nu = 5, ...)
{
    if(is.null(dim(x))) stop("x is not a matrix")
    x <- as.matrix(x)
    n <- nrow(x)
    p <- ncol(x)
    if(n != length(grouping))
        stop("nrow(x) and length(grouping) are different")
    g <- as.factor(grouping)
    lev <- lev1 <- levels(g)
    counts <- as.vector(table(g))
    if(!missing(prior)) {
        if(any(prior < 0) || round(sum(prior), 5) != 1) stop("invalid prior")
        if(length(prior) != nlevels(g)) stop("prior is of incorrect length")
        prior <- prior[counts > 0]
    }
    if(any(counts == 0)) {
        warning(paste("group(s)", paste(lev[counts == 0], collapse=" "),
                      "are empty"))
        lev1 <- lev[counts > 0]
        g <- factor(g, levels=lev1)
        counts <- as.vector(table(g))
    }
    proportions <- counts/n
    ng <- length(proportions)
    names(prior) <- names(counts) <- lev1
    method <- match.arg(method)
    if(CV && !(method == "moment" || method == "mle"))
        stop(paste("Cannot use leave-one-out CV with method", method))
    group.means <- tapply(x, list(rep(g, p), col(x)), mean)
    f1 <- sqrt(diag(var(x - group.means[g,  ])))
    if(any(f1 < tol))
        stop(paste("variable(s)",
                   paste(format((1:p)[f1 < tol]), collapse = " "),
                   "appear to be constant within groups"))
    # scale columns to unit variance before checking for collinearity
    scaling <- diag(1/f1,,p)
    if(method == "mve") {
        # adjust to "unbiased" scaling of covariance matrix
        cov <- n/(n-ng) * cov.rob((x - group.means[g,  ]) %*% scaling)$cov
        sX <- svd(cov, nu = 0)
        rank <- sum(sX$d > tol^2)
        if(rank < p) warning("variables are collinear")
        scaling <- scaling %*% sX$v[, 1:rank] %*%
            diag(sqrt(1/sX$d[1:rank]),,rank)
    } else if(method == "t") {
        if(nu <= 2) stop("nu must exceed 2")
        w <- rep(1, n)
        repeat {
            w0 <- w
            X <- x - group.means[g, ]
            sX <- svd(sqrt((1 + p/nu)*w/n) * X, nu=0)
            X <- X %*% sX$v %*% diag(1/sX$d,, p)
            w <- 1/(1 + drop(X^2 %*% rep(1, p))/nu)
            print(summary(w))
            group.means <- tapply(w*x, list(rep(g, p), col(x)), sum)/
                rep(tapply(w, g, sum), p)
            if(all(abs(w - w0) < 1e-2)) break
        }
        X <-  sqrt(nu/(nu-2)*(1 + p/nu)/n * w) * (x - group.means[g,  ]) %*% scaling
        X.s <- svd(X, nu = 0)
        rank <- sum(X.s$d > tol)
        if(rank < p) warning("variables are collinear")
        scaling <- scaling %*% X.s$v[, 1:rank] %*% diag(1/X.s$d[1:rank],,rank)
    } else {
        if(method == "moment") fac <- 1/(n-ng) else fac <- 1/n
        X <- sqrt(fac) * (x - group.means[g,  ]) %*% scaling
        X.s <- svd(X, nu = 0)
        rank <- sum(X.s$d > tol)
        if(rank < p) warning("variables are collinear")
        scaling <- scaling %*% X.s$v[, 1:rank] %*% diag(1/X.s$d[1:rank],,rank)
    }
    # now have variables scaled so that W is the identity
    if(CV) {
        x <- x %*% scaling
        dm <- group.means %*% scaling
        K <- if(method == "moment") ng else 0
        dist <- matrix(0, n, ng)
        for(i in 1:ng) {
            dev <- x - matrix(dm[i,  ], n, rank, byrow = TRUE)
            dist[, i] <- rowSums(dev^2)
        }
        ind <- cbind(1:n, g)
        nc <- counts[g]
        cc <- nc/((nc-1)*(n-K))
        dist2 <- dist
        for(i in 1:ng) {
            dev <- x - matrix(dm[i,  ], n, rank, byrow = TRUE)
            dev2 <- x - dm[g, ]
            tmp <- rowSums(dev*dev2)
            dist[, i] <- (n-1-K)/(n-K) * (dist2[, i] +  cc*tmp^2/(1 - cc*dist2[ind]))
        }
        dist[ind] <- dist2[ind] * (n-1-K)/(n-K) * (nc/(nc-1))^2 /
            (1 - cc*dist2[ind])
        dist <- 0.5 * dist - matrix(log(prior), n, ng, byrow=TRUE)
        dist <- exp(-(dist - min(dist, na.rm=TRUE)))
        cl <- factor(lev1[max.col(dist)], levels=lev)
        #  convert to posterior probabilities
        posterior <- dist/drop(dist %*% rep(1, length(prior)))
        dimnames(posterior) <- list(rownames(x), lev1)
        return(list(class = cl, posterior = posterior))
    }
    xbar <- colSums(prior %*% group.means)
    if(method == "mle") fac <-  1/ng else fac <- 1/(ng - 1)
    X <- sqrt((n * prior)*fac) * scale(group.means, center=xbar, scale=FALSE) %*% scaling
    X.s <- svd(X, nu = 0)
    rank <- sum(X.s$d > tol * X.s$d[1])
    scaling <- scaling %*% X.s$v[, 1:rank]
    if(is.null(dimnames(x)))
        dimnames(scaling) <- list(NULL, paste("LD", 1:rank, sep = ""))
    else {
        dimnames(scaling) <- list(colnames(x), paste("LD", 1:rank, sep = ""))
        dimnames(group.means)[[2]] <- colnames(x)
    }
    cl <- match.call()
    cl[[1]] <- as.name("lda")
    structure(list(prior = prior, counts = counts, means = group.means,
                   scaling = scaling, lev = lev, svd = X.s$d[1:rank],
                   N = n, call = cl),
              class = "lda")
}

predict.lda <- function(object, newdata, prior = object$prior, dimen,
			method = c("plug-in", "predictive", "debiased"), ...)
{
    if(!inherits(object, "lda")) stop("object not of class lda")
    if(!is.null(Terms <- object$terms)) { #
    # formula fit
        Terms <- delete.response(Terms)
        if(missing(newdata)) newdata <- model.frame(object)
        else {
            newdata <- model.frame(Terms, newdata, na.action=na.pass,
                                   xlev = object$xlevels)
            if (!is.null(cl <- attr(Terms, "dataClasses")) &&
                exists(".checkMFClasses", envir=NULL))
                .checkMFClasses(cl, newdata)
        }
        x <- model.matrix(Terms, newdata, contrasts = object$contrasts)
        xint <- match("(Intercept)", colnames(x), nomatch=0)
        if(xint > 0) x <- x[, -xint, drop=FALSE]
    } else { #
    # matrix or data-frame fit
        if(missing(newdata)) {
            if(!is.null(sub <- object$call$subset))
                newdata <-
                    eval.parent(parse(text=paste(deparse(object$call$x,
                                      backtick=TRUE),
                                      "[", deparse(sub, backtick=TRUE),",]")))
            else newdata <- eval.parent(object$call$x)
            if(!is.null(nas <- object$call$na.action))
                newdata <- eval(call(nas, newdata))
        }
        if(is.null(dim(newdata)))
            dim(newdata) <- c(1, length(newdata))  # a row vector
        x <- as.matrix(newdata)		# to cope with dataframes
    }

    if(ncol(x) != ncol(object$means)) stop("wrong number of variables")
    if(length(colnames(x)) > 0 &&
      any(colnames(x) != dimnames(object$means)[[2]]))
         warning("Variable names in newdata do not match those in object")
    ng <- length(object$prior)
    if(!missing(prior)) {
        if(any(prior < 0) || round(sum(prior), 5) != 1) stop("invalid prior")
        if(length(prior) != ng) stop("prior is of incorrect length")
    }
#   remove overall means to keep distances small
    means <- colSums(prior*object$means)
    scaling <- object$scaling
    x <- scale(x, center=means, scale=FALSE) %*% scaling
    dm <- scale(object$means, center=means, scale=FALSE) %*% scaling
    method <- match.arg(method)
    if(missing(dimen)) dimen <- length(object$svd)
    else dimen <- min(dimen, length(object$svd))
    N <- object$N
    if(method == "plug-in") {
        dm <- dm[, 1:dimen, drop=FALSE]
        dist <- matrix(0.5 * rowSums(dm^2) - log(prior), nrow(x),
                       length(prior), byrow = TRUE) - x[, 1:dimen, drop=FALSE] %*% t(dm)
        dist <- exp( -(dist - apply(dist, 1, min, na.rm=TRUE)))
    } else if (method == "debiased") {
        dm <- dm[, 1:dimen, drop=FALSE]
        dist <- matrix(0.5 * rowSums(dm^2), nrow(x), ng, byrow = TRUE) -
            x[, 1:dimen, drop=FALSE] %*% t(dm)
        dist <- (N - ng - dimen - 1)/(N - ng) * dist -
            matrix(log(prior) - dimen/object$counts , nrow(x), ng, byrow=TRUE)
        dist <- exp( -(dist - apply(dist, 1, min, na.rm=TRUE)))
    } else {                            # predictive
        dist <- matrix(0, nrow = nrow(x), ncol = ng)
        p <- ncol(object$means)
        # adjust to ML estimates of covariances
        X <- x * sqrt(N/(N-ng))
        for(i in 1:ng) {
            nk <- object$counts[i]
            dev <- scale(X, center=dm[i, ], scale=FALSE)
            dev <- 1 + rowSums(dev^2) * nk/(N*(nk+1))
            dist[, i] <- prior[i] * (nk/(nk+1))^(p/2) * dev^(-(N - ng + 1)/2)
        }
    }
    posterior <- dist / drop(dist %*% rep(1, ng))
    nm <- names(object$prior)
    cl <- factor(nm[max.col(posterior)], levels=object$lev)
    dimnames(posterior) <- list(rownames(x), nm)
    list(class = cl, posterior = posterior, x = x[, 1:dimen, drop=FALSE])
}

print.lda <- function(x, ...)
{
    if(!is.null(cl <- x$call)) {
        names(cl)[2] <- ""
        cat("Call:\n")
        dput(cl)
    }
    cat("\nPrior probabilities of groups:\n")
    print(x$prior, ...)
    cat("\nGroup means:\n")
    print(x$means, ...)
    cat("\nCoefficients of linear discriminants:\n")
    print(x$scaling, ...)
    svd <- x$svd
    names(svd) <- dimnames(x$scaling)[[2]]
    if(length(svd) > 1) {
        cat("\nProportion of trace:\n")
        print(round(svd^2/sum(svd^2), 4), ...)
    }
    invisible(x)
}

plot.lda <- function(x, panel = panel.lda, ..., cex=0.7,
                     dimen, abbrev = FALSE,
                     xlab = "LD1", ylab = "LD2")
{
    panel.lda <- function(x, y, ...) {
        text(x, y, as.character(g.lda), cex=tcex, ...)
    }
    if(!is.null(Terms <- x$terms)) { #
    # formula fit
        data <- model.frame(x)
        X <- model.matrix(delete.response(Terms), data)
        g <- model.response(data)
        xint <- match("(Intercept)", colnames(X), nomatch=0)
        if(xint > 0) X <- X[, -xint, drop=FALSE]
    } else { #
    # matrix or data-frame fit
        xname <- x$call$x
        gname <- x$call[[3]]
        if(!is.null(sub <- x$call$subset)) {
            X <- eval.parent(parse(text=paste(deparse(xname, backtick=TRUE),
                                   "[", deparse(sub, backtick=TRUE),",]")))
            g <- eval.parent(parse(text=paste(deparse(gname, backtick=TRUE),
                                   "[", deparse(sub, backtick=TRUE),"]")))
        } else {
            X <- eval.parent(xname)
            g <- eval.parent(gname)
        }
        if(!is.null(nas <- x$call$na.action)) {
            df <- data.frame(g = g, X = X)
            df <- eval(call(nas, df))
            g <- df$g
            X <- df$X
        }
    }
    if(abbrev) levels(g) <- abbreviate(levels(g), abbrev)
    assign("g.lda", g)
    assign("tcex", cex)
    means <- colMeans(x$means)
    X <- scale(X, center=means, scale=FALSE) %*% x$scaling
    if(!missing(dimen) && dimen < ncol(X)) X <- X[, 1:dimen, drop=FALSE]
    if(ncol(X) > 2) {
        pairs(X, panel=panel, ...)
    } else if(ncol(X) == 2)  {
        eqscplot(X[, 1:2], xlab=xlab, ylab=ylab, type="n", ...)
        panel(X[, 1], X[, 2], ...)
    } else ldahist(X[,1], g, xlab=xlab, ...)
    invisible(NULL)
}

ldahist <-
function(data, g, nbins = 25, h, x0 = -h/1000, breaks,
	 xlim = range(breaks), ymax = 0, width,
         type = c("histogram", "density", "both"), sep = (type != "density"),
         col = 5,
	 xlab = deparse(substitute(data)), bty = "n", ...)
{
    xlab
    type <- match.arg(type)
    data <- data[!is.na(data)]
    g <- g[!is.na(data)]
    counts <- table(g)
    groups <- names(counts)[counts > 0]
    if(missing(breaks)) {
        if(missing(h)) h <- diff(pretty(data, nbins))[1]
        first <- floor((min(data) - x0)/h)
        last <- ceiling((max(data) - x0)/h)
        breaks <- x0 + h * c(first:last)
    }
    if(type=="histogram" || type=="both") {
        if(any(diff(breaks) <= 0)) stop("breaks must be strictly increasing")
        if(min(data) < min(breaks) || max(data) > max(breaks))
            stop("breaks do not cover the data")
        est <- vector("list", length(groups))
        for (grp in groups){
            bin <- cut(data[g==grp], breaks, include.lowest = TRUE)
            est1 <- tabulate(bin, length(levels(bin)))
            est1 <- est1/(diff(breaks) * length(data[g==grp]))
            ymax <- max(ymax, est1)
            est[[grp]] <- est1
        }
    }
    if(type=="density" || type == "both"){
        xd <- vector("list", length(groups))
        for (grp in groups){
            if(missing(width)) width <- width.SJ(data[g==grp])
            xd1 <- density(data[g==grp], n=200, width=width,
                           from=xlim[1], to=xlim[2])
            ymax <- max(ymax, xd1$y)
            xd[[grp]] <- xd1
        }
    }
    if(!sep) plot(xlim, c(0, ymax), type = "n", xlab = xlab, ylab = "",
                  bty = bty)
    else {
        oldpar <- par(mfrow=c(length(groups), 1))
        on.exit(par(oldpar))
    }
    for (grp in groups) {
        if(sep) plot(xlim, c(0, ymax), type = "n",
                     xlab = paste("group", grp), ylab = "", bty = bty)
        if(type=="histogram" || type=="both") {
            n <- length(breaks)
            rect(breaks[-n], 0, breaks[-1], est[[grp]], col = col, ...)
        }
        if(type=="density" || type == "both") lines(xd[[grp]])
    }
    invisible()
}

pairs.lda <- function(x, labels = colnames(x), panel = panel.lda,
                      dimen, abbrev = FALSE, ..., cex = 0.7,
                      type = c("std", "trellis"))
{
    panel.lda <- function(x,y, ...) {
        text(x, y, as.character(g.lda), cex=tcex, ...)
    }
    type <- match.arg(type)
    if(!is.null(Terms <- x$terms)) { #
    # formula fit
        data <- model.frame(x)
        X <- model.matrix(delete.response(Terms), data)
        g <- model.response(data)
        xint <- match("(Intercept)", colnames(X), nomatch=0)
        if(xint > 0) X <- X[, -xint, drop=FALSE]
    } else { #
    # matrix or data-frame fit
        xname <- x$call$x
        gname <- x$call[[3]]
        if(!is.null(sub <- x$call$subset)) {
            X <- eval.parent(parse(text=paste(deparse(xname, backtick=TRUE),
                                   "[", deparse(sub, backtick=TRUE),",]")))
            g <- eval.parent(parse(text=paste(deparse(gname, backtick=TRUE),
                                   "[", deparse(sub, backtick=TRUE),"]")))
        } else {
            X <- eval.parent(xname)
            g <- eval.parent(gname)
        }
        if(!is.null(nas <- x$call$na.action)) {
            df <- data.frame(g = g, X = X)
            df <- eval(call(nas, df))
            g <- df$g
            X <- df$X
        }
    }
    g <- as.factor(g)
    if(abbrev) levels(g) <- abbreviate(levels(g), abbrev)
    assign("g.lda", g)
    assign("tcex", cex)
    means <- colMeans(x$means)
    X <- scale(X, center=means, scale=FALSE) %*% x$scaling
    if(!missing(dimen) && dimen < ncol(X)) X <- X[, 1:dimen]
    if(type == "std") pairs.default(X, panel=panel, ...)
    else {
        print(lattice::splom(~X, groups = g, panel = lattice::panel.superpose,
                             key = list(
                             text=list(levels(g)),
                             points = lattice::Rows(lattice::trellis.par.get("superpose.symbol"),
                             seq(along=levels(g))),
                             columns = min(5, length(levels(g)))
                             )
                    ))
    }
    invisible(NULL)
}

model.frame.lda <- function(formula, ...)
{
    oc <- formula$call
    oc$prior <- oc$tol <- oc$method <- oc$CV <- oc$nu <- NULL
    oc[[1]] <- as.name("model.frame")
    if(length(dots<- list(...))) {
        nargs <- dots[match(c("data", "na.action", "subset"), names(dots), 0)]
        oc[names(nargs)] <- nargs
    }
    if (is.null(env <- environment(formula$terms))) env <- parent.frame()
    eval(oc, env)
}

coef.lda <- function(object, ...) object$scaling
# file MASS/lm.gls.q
# copyright (C) 1994-9 W. N. Venables and B. D. Ripley
#
lm.gls <-
    function(formula, data, W, subset, na.action, inverse = FALSE,
             method = "qr",
             model = FALSE, x = FALSE, y = FALSE, contrasts = NULL, ...)
{
    call <- match.call()
    m <- match.call(expand = FALSE)
    m$W <- m$inverse <- m$method <- m$model <- m$x <-
        m$y <- m$contrasts <- m$... <- NULL
    m[[1]] <- as.name("model.frame")
    m <- eval.parent(m)
    if(method == "model.frame") return(m)
    Terms <- attr(m, "terms")
    Y <- model.response(m)
    X <- model.matrix(Terms, m, contrasts)
    n <- nrow(X)
    if(any(dim(W) != c(n, n))) stop("dim(W) is not correct")
    eW <- eigen(W, TRUE)
    d <- eW$values
    if(any(d <= 0)) stop("W is not positive definite")
    A <- diag(d^ifelse(inverse, -0.5, 0.5)) %*% t(eW$vector)
    fit <- lm.fit(A %*% X, A %*% Y, method=method, ...)
    fit$terms <- Terms
    fit$call <- call
    if(model) fit$model <- m
    if(x) fit$x <- X
    if(y) fit$y <- Y
    fit$na.action <- attr(m, "na.action")
    class(fit) <- c("lm.gls", class(fit))
    fit$xlevels <- .getXlevels(Terms, m)
    fit$contrasts <- attr(X, "contrasts")
    fit
}
# file MASS/lm.ridge.q
# copyright (C) 1994-9 W. N. Venables and B. D. Ripley
#
lm.ridge <- function(formula, data, subset, na.action,
    lambda = 0, model = FALSE, x = FALSE, y = FALSE, contrasts = NULL, ...)
{
    m <- match.call(expand = FALSE)
    m$model <- m$x <- m$y <- m$contrasts <- m$... <- m$lambda <- NULL
    m[[1]] <- as.name("model.frame")
    m <- eval.parent(m)
    Terms <- attr(m, "terms")
    Y <- model.response(m)
    X <- model.matrix(Terms, m, contrasts)
    n <- nrow(X); p <- ncol(X)
    if(Inter <- attr(Terms, "intercept"))
    {
        Xm <- colMeans(X[, -Inter])
        Ym <- mean(Y)
        p <- p - 1
        X <- X[, -Inter] - rep(Xm, rep(n, p))
        Y <- Y - Ym
    } else Ym <- Xm <- NA
    Xscale <- drop(rep(1/n, n) %*% X^2)^0.5
    X <- X/rep(Xscale, rep(n, p))
    Xs <- svd(X)
    rhs <- t(Xs$u) %*% Y
    d <- Xs$d
    lscoef <-  Xs$v %*% (rhs/d)
    lsfit <- X %*% lscoef
    resid <- Y - lsfit
    s2 <- sum(resid^2)/(n - p - Inter)
    HKB <- (p-2)*s2/sum(lscoef^2)
    LW <- (p-2)*s2*n/sum(lsfit^2)
    k <- length(lambda)
    div <- d^2 + rep(lambda, rep(p,k))
    a <- drop(d*rhs)/div
    dim(a) <- c(p, k)
    coef <- Xs$v %*% a
    dimnames(coef) <- list(names(Xscale), format(lambda))
    GCV <- colSums((Y - X %*% coef)^2)/(n-colSums(matrix(d^2/div,p)))^2
    res <- list(coef = drop(coef), scales = Xscale,
                Inter = Inter, lambda = lambda, ym = Ym, xm = Xm,
                GCV = GCV, kHKB = HKB, kLW = LW)
    class(res) <- "ridgelm"
    res
}

print.ridgelm <- function(x, ...)
{
    scaledcoef <- t(as.matrix(x$coef / x$scales))
    if(x$Inter) {
        inter <- x$ym - scaledcoef %*% x$xm
        scaledcoef<- cbind(Intercept=inter, scaledcoef)
    }
    print(drop(scaledcoef), ...)
}

select <- function(obj) UseMethod("select")

select.ridgelm <- function(obj)
{
    cat("modified HKB estimator is", format(obj$kHKB), "\n")
    cat("modified L-W estimator is", format(obj$kLW), "\n")
    GCV <- obj$GCV
    if(length(GCV) > 0) {
        k <- seq(along=GCV)[GCV==min(GCV)]
        cat("smallest value of GCV  at",
            format(obj$lambda[k]), "\n")
    }
}

plot.ridgelm <- function(x, ...)
    matplot(x$lambda, t(x$coef), type = "l")
# file MASS/loglm.q
# copyright (C) 1994-9 W. N. Venables and B. D. Ripley
#
denumerate <- function(x) UseMethod("denumerate")

renumerate <- function(x) UseMethod("renumerate")

denumerate.formula <- function(x)
{
    if(length(x) == 1) {
        if(mode(x) == "numeric" ||
           (mode(x) == "name" &&
            any(substring(as.character(x), 1, 1) == as.character(1:9))))
            x <- as.name(paste(".v", x, sep = ""))
    } else {
        x[[2]] <- Recall(x[[2]])
        if(length(x) == 3 && x[[1]] != as.name("^"))
            x[[3]] <- Recall(x[[3]])
    }
    x
}

renumerate.formula <- function(x)
{
    if(length(x) == 1) {
        if(mode(x) == "name"
           && nchar(xx <- as.character(x)) > 2
           && substring(xx, 1, 2) == ".v")
            x <- as.name(substring(xx, 3))
    } else {
        x[[2]] <- Recall(x[[2]])
        if(length(x) == 3 && x[[1]] != as.name("^"))
           x[[3]] <- Recall(x[[3]])
    }
    x
}

loglm <-
  function(formula, data, subset, na.action, ...)
{
    assign(".call", match.call(), envir=.GlobalEnv)
    if(missing(data) || inherits(data, "data.frame")) {
        m <- match.call(expand = FALSE)
        m$... <- NULL
        m[[1]] <- as.name("model.frame")
        data <- eval.parent(m)
        assign(".formula", as.formula(attr(data, "terms")), envir=.GlobalEnv)
    } else {
        trms <- attr(data, "terms") <- terms(formula <- denumerate(formula))
        assign(".formula", renumerate(as.formula(trms)), envir=.GlobalEnv)
    }
    loglm1(formula, data, ...)
}

loglm1 <- function(formula, data, ...) UseMethod("loglm1", data)

loglm1.xtabs <-
function(formula, data, ...)
{
    attr(data, "marginals") <- attr(data, "call") <- class(data) <- NULL
    NextMethod("loglm1")
}

loglm1.data.frame <-
function(formula, data, ...)
{
    trms <- attr(data, "terms")
    if(is.null(trms)) stop("data has no terms attribute")
    if(attr(trms, "response") == 0) stop("Formula specifies no response")
    resp <- match(as.character(attr(trms, "variables"))[1+attr(trms, "response")],
                  names(data))
    off <- attr(trms, "offset")
    fac <- data.frame(lapply(data[, -c(resp, off)], as.factor))
    rsp <- data[, resp]
    tab <- table(fac)
    if(max(tab) > 1) {
#
# an extra factor needed for repeated frequencies
#
        i <- do.call("order", rev(fac))
        fac <- fac[i,  ]
        rsp <- rsp[i]
        fac$.Within. <-
            factor(unlist(sapply(tab,
                                 function(x) if(x > 0) seq(x) else NULL)))
    }
    dn <- lapply(fac, levels)
    dm <- sapply(dn, length)
    offset <- model.offset(data)
    if (is.null(offset)) offset <- 0
    offset <- rep(offset, length.out = nrow(data))
    data <- structure(array(-1, dm, dn), terms = trms)
    data[do.call("cbind", lapply(fac, as.numeric))] <- rsp
    st <- array(as.numeric(data >= 0), dm, dn)
    st[do.call("cbind", lapply(fac, as.numeric))] <- exp(offset)
    data[data < 0] <- 0
    loglm1.default(formula, data, ..., start = st)
}

loglm1.default <-
function(formula, data, start = rep(1, length(data)), fitted = FALSE,
	keep.frequencies = fitted, param = TRUE, eps =
	1/10, iter = 40, print = FALSE, ...)
{
    trms <- attr(data, "terms")
    if(is.null(trms)) stop("data has no terms attribute")
    factors <- attr(trms, "factors") > 0
    if((r <- attr(trms, "response")))
        factors <- factors[-r,  , drop = FALSE]
    nt <- ncol(factors)
    fo <- order(colSums(factors))
    factors <- factors[, fo, drop = FALSE]
    ff <- crossprod(factors)
    keep <- rep(TRUE, nt)
    j <- 0
    while((j <- j + 1) < nt) keep[j] <- ff[j, j] > max(ff[j, (j + 1):nt])
    factors <- factors[, keep, drop = FALSE]
    ldim <- length(dim(data))
    nnames <- paste(".v", 1:ldim, sep = "")
    which <- structure(1:ldim, names = nnames)
    if(!is.null(anames <- names(dimnames(data))))
        which <- c(which, structure(which, names = anames))
    margins <- apply(factors, 2, function(x, which, nam)
                     as.vector(which[nam[x]]), which, rownames(factors))
    if(is.matrix(margins))
        margins <- as.list(data.frame(margins))
    else margins <- structure(as.list(margins), names = names(margins))
    Fit <- loglin(data, margins, start = start, fit = fitted,
                  param = param, eps = eps, iter = iter, print = print)
    if(exists(".formula")) {
        Fit$call <- .call
        Fit$formula <- .formula
    }
    class(Fit) <- "loglm"
    if(keep.frequencies) Fit$frequencies <- structure(data, terms = NULL)
    if(fitted) {
        names(Fit)[match("fit", names(Fit))] <- "fitted"
        attr(Fit$fitted, "terms") <- NULL
    }
    Fit$deviance <- Fit$lrt
    Fit$nobs <- length(data)
    Fit$df <- Fit$df - sum(start == 0)
    Fit$terms <- trms # for stepAIC
    Fit
}


anova.loglm <- function(object, ..., test = c("Chisq", "chisq", "LR"))
{
    test <- match.arg(test)
    margs <- function(...) nargs()
    if(!(k <- margs(...))) return(object)
    objs <- list(object, ...)
    dfs <- sapply(objs, "[[", "df")
    o <- order( - dfs)
    objs <- objs[o]
    dfs <- c(dfs[o], 0)
    forms <- lapply(objs, formula)
    dev <- c(sapply(objs, "[[", "lrt"), 0)
    M <- array(0, c(k + 2, 5),
               list(c(paste("Model", 1:(k + 1)), "Saturated"),
                    c("Deviance", "df", "Delta(Dev)", "Delta(df)", "P(> Delta(Dev)")))
    M[, 1] <- dev
    M[, 2] <- dfs
    M[-1, 3] <- dev[1:(k + 1)] - dev[2:(k + 2)]
    M[-1, 4] <- dfs[1:(k + 1)] - dfs[2:(k + 2)]
    M[-1, 5] <- 1 - pchisq(M[-1, 3], M[-1, 4])
    res <- structure(M, formulae = forms)
    class(res) <- "anova.loglm"
    res
}

print.anova.loglm <- function(x, ...)
{
    rjustify <- function(str) {
        m <- max(n <- nchar(str))
        blanks <- format(c("", str[n == m][1]))[1]
        paste(substring(blanks, 0, m - n), str, sep = "")
    }
    y <- x
    y[, 5] <- round(y[, 5], 5)
    R <- array("", dim(x), dimnames(x))
    for(j in 1:5) {
        colj <- rjustify(c(colnames(x)[j], format(y[, j])))
        R[, j] <- colj[-1]
        colnames(R)[j] <- colj[1]
    }
    R[1, 3:5] <- ""
    pform <- function(form)
        if(length(form) == 2) form else form[c(2, 1, 3)]
    forms <- attr(x, "formulae")
    cat("LR tests for hierarchical log-linear models\n\n")
    for(i in seq(along=forms))
        cat(paste("Model ", i, ":\n", sep = ""),
            deparse(pform(forms[[i]])), "\n")
    cat("\n")
    print(R, quote = FALSE)
    invisible(x)
}

print.loglm <- function(x, ...)
{
    cat("Call:\n")
    print(x$call)
    ts.array <- rbind(c(x$lrt, x$df,
                        if(x$df > 0) 1 - pchisq(x$lrt, x$df) else 1),
                      c(x$pearson, x$df,
                        if(x$df > 0) 1 - pchisq(x$pearson, x$df)
                        else 1))
    dimnames(ts.array) <- list(c("Likelihood Ratio",
                                 "Pearson"), c("X^2", "df", "P(> X^2)"))
    cat("\nStatistics:\n")
    print(ts.array)
    invisible(x)
}

summary.loglm <- function(object, fitted = FALSE, ...)
{
    ts.array <- rbind(c(object$lrt, object$df,
                        if(object$df > 0) 1 - pchisq(object$lrt, object$df)
                        else 1), c(object$pearson, object$df,
                                   if(object$df > 0)
                                   1 - pchisq(object$pearson, object$df)
                                   else 1))
    dimnames(ts.array) <- list(c("Likelihood Ratio", "Pearson"),
                               c("X^2", "df", "P(> X^2)"))
    if(fitted) {
        if(is.null(object$fitted) || is.null(object$freqencies)) {
            cat("Re-fitting to find fitted values\n")
            object <- update(object, fitted = TRUE, keep.frequencies = TRUE)
        }
        fit <- format(round(object$fit, 1))
        OE <- array(paste(format(object$freq), " (", fit, ")", sep = ""),
                    dim(fit), dimnames(object$freq))
    }  else OE <- NULL
    structure(list(formula = formula(object), tests = ts.array, oe = OE),
              class = "summary.loglm")
}

print.summary.loglm <- function(x, ...)
{
    cat("Formula:\n")
    print(formula(x))
    cat("\nStatistics:\n")
    print(x$tests)
    if(!is.null(x$oe)) {
        cat("\nObserved (Expected):\n")
        print(x$oe, quote = FALSE)
    }
    invisible(x)
}

update.loglm <- function (object, formula, ...)
{
    if (is.null(call <- object$call))
        stop("object has no call component.  Updating not possible")
    if (fix <- !missing(formula)) {
        object$formula <- denumerate(object$formula)
        formula <- denumerate(as.formula(formula))
        call$formula <- update.formula(formula(object), formula)
    }
    extras <- match.call(expand.dots = FALSE)$...
    if (length(extras) > 0) {
        existing <- !is.na(match(names(extras), names(call)))
        ## do these individually to allow NULL to remove entries.
        for (a in names(extras)[existing]) call[[a]] <- extras[[a]]
        if (any(!existing)) {
            call <- c(as.list(call), extras[!existing])
            call <- as.call(call)
        }
    }
    result <- eval.parent(call)
    if (fix) {
        form <- renumerate(result$formula)
        result$call$formula <- unclass(result$formula <- form)
    }
    result
}

fitted.loglm <- function(object, ...)
{
    if(!is.null(object$fit))
        return(unclass(object$fit))
    cat("Re-fitting to get fitted values\n")
    unclass(update(object, fitted = TRUE, keep.frequencies = FALSE)$fitted)
}

residuals.loglm <-
    function(object, type = c("deviance", "pearson", "response"), ...)
{
    type <- match.arg(type)
    if(is.null(object$fit) || is.null(object$freq)) {
        cat("Re-fitting to get frequencies and fitted values\n")
        object <- update(object, fitted = TRUE, keep.frequencies = TRUE)
    }
    y <- object$freq
    mu <- object$fit
    res <- y - mu
    nz <- mu > 0
    y <- y[nz]
    mu <- mu[nz]
    res[nz] <-
        switch(type,
               deviance = sign(y - mu) *
                 sqrt(2*abs(y*log((y + (y == 0))/mu) - (y - mu))),
               pearson = (y - mu)/sqrt(mu),
               response = y - mu)
    res
}

coef.loglm <- function(object, ...)
{
    if(!is.null(cf <- object$param)) return(cf)
    cat("Re-fitting to calculate missing coefficients\n")
    update(object, param = TRUE)$param
}
# file MASS/logtrans.q
# copyright (C) 1994-9 W. N. Venables and B. D. Ripley
#
logtrans <- function(object, ...) UseMethod("logtrans")

logtrans.default<-
function(object, ..., alpha = seq(0.5, 6, by = 0.25) - min(y),
	plotit = TRUE, interp = (plotit && (m <
	100)), xlab = "alpha", ylab = "log Likelihood")
{
    if(is.null(object$y) || is.null(object$qr))
        stop(paste(deparse(substitute(object)),
                   "does not have both 'qr' and 'y' components"))
    y <- object$y
    n <- length(y)
    if(any(y + min(alpha) <= 0))
        stop("Response variable must be positive after additions")
    xqr <- object$qr
    xl <- loglik <- as.vector(alpha)
    m <- length(xl)
    for(i in 1:m) {
        rs <- qr.resid(xqr, yt <- log(y + alpha[i]))
        loglik[i] <-  - n/2 * log(sum(rs^2)) - sum(yt)
    }
    if(interp) {
        sp <- spline(alpha, loglik, n = 100)
        xl <- sp$x
        loglik <- sp$y
        m <- length(xl)
    }
    if(plotit) {
        mx <- (1:m)[loglik == max(loglik)][1]
        Lmax <- loglik[mx]
        lim <- Lmax - qchisq(19/20, 1)/2
        plot(xl, loglik, xlab = xlab, ylab = ylab, type
             = "l", ylim = range(loglik, lim))
        plims <- par("usr")
        abline(h = lim, lty = 3)
        y0 <- plims[3]
        scal <- (1/10 * (plims[4] - y0))/par("pin")[2]
        scx <- (1/10 * (plims[2] - plims[1]))/par("pin")[1]
        text(xl[1] + scx, lim + scal, " 95%")
        la <- xl[mx]
        if(mx > 1 && mx < m)
            segments(la, y0, la, Lmax, lty = 3)
        ind <- range((1:m)[loglik > lim])
        if(loglik[1] < lim) {
            i <- ind[1]
            x <- xl[i - 1] + ((lim - loglik[i - 1]) *
                              (xl[i] - xl[i - 1]))/(loglik[i] - loglik[i - 1])
            segments(x, y0, x, lim, lty = 3)
        }
        if(loglik[m] < lim) {
            i <- ind[2] + 1
            x <- xl[i - 1] + ((lim - loglik[i - 1]) *
                              (xl[i] - xl[i - 1]))/(loglik[i] - loglik[i - 1])
            segments(x, y0, x, lim, lty = 3)
        }
    }
    invisible(list(x = xl, y = loglik))
}

logtrans.formula <-
function(object, data, ...)
{
  object <- if(missing(data)) aov(object,y = TRUE, qr = TRUE)
  else aov(object, data = data, y = TRUE, qr = TRUE)
  invisible(NextMethod("logtrans"))
}

logtrans.lm <- function(object, ...)
{
    if(is.null(object$y) || is.null(object$qr))
        object <- update(object, y = TRUE, qr = TRUE)
    invisible(NextMethod("logtrans"))
}
### file lqs/R/lqs.R
### copyright (C) 1998-2003 B. D. Ripley

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

lqs.formula <-
    function(formula, data, ...,
	     method = c("lts" ,"lqs", "lms", "S", "model.frame"),
	     subset, na.action,
	     model = TRUE, x.ret = FALSE, y.ret = FALSE, contrasts = NULL)
{
    method <- match.arg(method)
    mf <- match.call(expand.dots = FALSE)
    mf$method <- mf$contrasts <- mf$model <- mf$x.ret <- mf$y.ret <- mf$... <- NULL
    mf[[1]] <- as.name("model.frame")
    mf <- eval.parent(mf)
    if (method == "model.frame") return(mf)
    mt <- attr(mf, "terms")
    y <- model.extract(mf, "response")
    x <- model.matrix(mt, mf, contrasts)
    xint <- match("(Intercept)", colnames(x), nomatch = 0)
    if(xint) x <- x[, -xint, drop = FALSE]
    fit <- lqs.default(x, y, intercept = (xint > 0), method = method, ...)
    fit$terms <- mt
    fit$call <- match.call()
    fit$contrasts <- attr(x, "contrasts")
    fit$xlevels <- .getXlevels(mt, mf)
    fit$na.action <- attr(mf, "na.action")
    if(model) fit$model <- mf
    if(x.ret) fit$x <- x
    if(y.ret) fit$y <- y
    fit
}

lqs.default <-
    function(x, y, intercept=TRUE, method = c("lts", "lqs", "lms", "S"),
	     quantile, control = lqs.control(...), k0 = 1.548, seed, ...)
{
    lqs.control <- function(psamp = NA, nsamp = "best", adjust = TRUE)
	list(psamp = psamp, nsamp = nsamp, adjust = adjust)

    n <- length(y)
    nmx <- deparse(substitute(x))
    if(is.null(dim(x))) {
	x <- as.matrix(x)
	colnames(x) <- nmx
    } else x <- as.matrix(x)
    p <- ncol(x)
    if(any(is.na(x)) || any(is.na(y)))
	stop("missing values are not allowed")
    nm <- colnames(x)
    if(is.null(nm))
	nm <- if(p > 1) paste("X", 1:p, sep="") else if(p == 1) "X" else NULL
    if(intercept) {
	x <- cbind(1, x)
	nm <- c("(Intercept)", nm)
    }
    p <- ncol(x)
    if(nrow(x) != n) stop("x and y must have the same number of rows")
    method <- match.arg(method)
    lts <- 0; beta <- 0
    if(method == "lqs" && missing(quantile)) quantile <- floor((n+p+1)/2)
    if(method == "lms") quantile <- floor((n+1)/2)
    if(method == "lts") {
	lts <- 1
	if(missing(quantile)) quantile <- floor(n/2) + floor((p+1)/2)
    }
    if(method == "S") {
	lts <- 2
	beta <- 0.5
	quantile <- ceiling(n/2)
	chi <- function(u, k0)
	{ u <- (u/k0)^2; ifelse(u < 1, 3*u - 3*u^2 + u^3, 1) }
    }
    if(quantile > n-1) stop(paste("quantile must be at most", n-1))
    ps <- control$psamp
    if(is.na(ps)) ps <- p
    if(ps < p) {
	ps <- p
	warning("ps must be at least p")
    }
    adj <- control$adjust & intercept
    nsamp <- eval(control$nsamp)
    nexact <- choose(n, ps)
    if(is.character(nsamp) && nsamp == "best") {
	nsamp <- if(nexact < 5000) "exact" else "sample"
    } else if(is.numeric(nsamp) && nsamp > nexact) {
	warning(paste("only", nexact, "sets, so all sets will be tried"))
	nsamp <- "exact"
    }
    samp <- nsamp != "exact"
    if(samp) {
	if(nsamp == "sample") nsamp <- min(500*ps, 3000)
    } else
	nsamp <- nexact

    if(samp && !missing(seed)) {
	if(exists(".Random.seed", envir=.GlobalEnv, inherits=FALSE))  {
	    seed.keep <- get(".Random.seed", envir=.GlobalEnv, inherits=FALSE)
	    on.exit(assign(".Random.seed", seed.keep, envir=.GlobalEnv))
	}
	assign(".Random.seed", seed, envir=.GlobalEnv)
    }
    z <-  .C("lqs_fitlots",
	     as.double(x), as.double(y), as.integer(n), as.integer(p),
	     as.integer(quantile), as.integer(lts), as.integer(adj),
	     as.integer(samp), as.integer(ps), as.integer(nsamp),
	     crit=double(1), sing=integer(1), bestone=integer(ps),
	     coefficients=double(p), as.double(k0), as.double(beta),
	     PACKAGE="MASS"
	     )[c("crit", "sing", "coefficients", "bestone")]
    if(z$sing == nsamp)
        stop("lqs failed: all the samples were singular", call.=FALSE)
    z$sing <- paste(z$sing, "singular samples of size", ps, "out of", nsamp)
    z$bestone <- sort(z$bestone)
    names(z$coefficients) <- nm
    fitted <- drop(x %*% z$coefficients)
    z$fitted.values <- fitted
    z$residuals <- y - fitted
    c1 <- 1/qnorm((n + quantile)/(2*n))
    s <-
        if(lts == 1)
            sqrt(z$crit/quantile)/sqrt(1 - 2*n*dnorm(1/c1)/(quantile*c1))
        else if(lts == 0) sqrt(z$crit)*c1 else z$crit
    res <- z$residual
    ind <- abs(res) <= 2.5*s
    s2 <- sum(res[ind]^2)/(sum(ind) - p)
    z$scale <- c(s, sqrt(s2))
    if(method == "S") { # IWLS refinement
	psi <- function(u, k0) (1  - pmin(1, abs(u/k0))^2)^2
	resid <- z$residuals
	scale <- s
	for(i in 1:30) {
	    w <- psi(resid/scale, k0)
	    temp <- lm.wfit(x, y, w, method="qr")
	    resid <- temp$residuals
	    s2 <- scale*sqrt(sum(chi(resid/scale, k0))/((n-p)*beta))
	    if(abs(s2/scale - 1) < 1e-5) break
	    scale <- s2
	}
	z$coef <- temp$coef
	z$fitted.values <- temp$fitted.values
	z$residuals <- resid
	z$scale <- scale
    }
    class(z) <- "lqs"
    z
}

print.lqs <- function (x, digits = max(3, getOption("digits") - 3), ...)
{
    if(!is.null(cl <- x$call)) {
	cat("Call:\n")
	dput(cl)
	cat("\n")
    }
    cat("Coefficients:\n")
    print.default(format(coef(x), digits = digits), print.gap = 2,
		  quote = FALSE)
    cat("\nScale estimates", format(x$scale, digits = digits) ,"\n\n")
    invisible(x)
}

predict.lqs <- function (object, newdata, na.action = na.pass, ...)
{
    if (missing(newdata)) return(fitted(object))
    ## work hard to predict NA for rows with missing data
    Terms <- delete.response(terms(object))
    m <- model.frame(Terms, newdata, na.action = na.action,
                     xlev = object$xlevels)
    if(!is.null(cl <- attr(Terms, "dataClasses"))) .checkMFClasses(cl, m)
    X <- model.matrix(Terms, m, contrasts = object$contrasts)
    drop(X %*% object$coefficients)
}


cov.rob <- function(x, cor = FALSE, quantile.used = floor((n+p+1)/2),
		    method = c("mve", "mcd", "classical"), nsamp = "best", seed)
{
    method <- match.arg(method)
    x <- as.matrix(x)
    if(any(is.na(x)) || any(is.infinite(x)))
	stop("missing or infinite values are not allowed")
    n <- nrow(x); p <- ncol(x)
    if(n < p+1) stop(paste("At least", p+1, "cases are needed"))
    if(method == "classical") {
	ans <- list(center = colMeans(x), cov = var(x))
    } else {
	if(quantile.used < p+1) stop(paste("quantile must be at least", p+1))
	if(quantile.used > n-1) stop(paste("quantile must be at most", n-1))
	## re-scale to roughly common scale
	divisor <- apply(x, 2, IQR)
        if(any(divisor == 0)) stop("at least one column has IQR 0")
	x <- x /rep(divisor, rep(n,p))
	qn <- quantile.used
	ps <- p + 1
	nexact <- choose(n, ps)
	if(is.character(nsamp) && nsamp == "best")
	    nsamp <- if(nexact < 5000) "exact" else "sample"
	if(is.numeric(nsamp) && nsamp > nexact) {
	    warning(paste("only", nexact, "sets, so all sets will be tried"))
	    nsamp <- "exact"
	}
	samp <- nsamp != "exact"
	if(samp) {
	    if(nsamp == "sample") nsamp <- min(500*ps, 3000)
	} else nsamp <- nexact

	if(samp && !missing(seed)) {
	    if(exists(".Random.seed", envir=.GlobalEnv, inherits=FALSE))  {
		seed.keep <- get(".Random.seed", envir=.GlobalEnv, inherits=FALSE)
		on.exit(assign(".Random.seed", seed.keep, envir=.GlobalEnv))
	    }
            assign(".Random.seed", seed, envir=.GlobalEnv)
	}
	z <-  .C("mve_fitlots",
		 as.double(x), as.integer(n), as.integer(p),
		 as.integer(qn), as.integer(method=="mcd"),
		 as.integer(samp), as.integer(ps), as.integer(nsamp),
		 crit=double(1), sing=integer(1), bestone=integer(n),
		 PACKAGE="MASS"
		 )
	z$sing <- paste(z$sing, "singular samples of size", ps,
                        "out of", nsamp)
	crit <- z$crit + 2*sum(log(divisor)) +
	    if(method=="mcd") - p * log(qn - 1) else 0
	best <- seq(n)[z$bestone != 0]
        if(!length(best)) stop("x is probably collinear")
	means <- colMeans(x[best, , drop = FALSE])
	rcov <- var(x[best, , drop = FALSE]) * (1 + 15/(n - p))^2
	dist <- mahalanobis(x, means, rcov)
	cut <- qchisq(0.975, p) * quantile(dist, qn/n)/qchisq(qn/n, p)
	cov <- divisor * var(x[dist < cut, , drop = FALSE]) *
	    rep(divisor, rep(p, p))
	attr(cov, "names") <- NULL
	ans <- list(center =
		    colMeans(x[dist < cut, , drop = FALSE]) * divisor,
		    cov = cov, msg = z$sing, crit = crit, best = best)
    }
    if(cor) {
	sd <- sqrt(diag(ans$cov))
	ans <- c(ans, list(cor = (ans$cov/sd)/rep(sd, rep(p, p))))
    }
    ans$n.obs <- n
    ans
}

## compatibility functions for R users.

lmsreg <- function(...)
{
    oc <- sys.call()
    oc$method <- "lms"
    oc[[1]] <- as.name("lqs")
    eval(oc, parent.frame())
}

ltsreg <- function(...)
{
    oc <- sys.call()
    oc$method <- "lts"
    oc[[1]] <- as.name("lqs")
    eval(oc, parent.frame())
}

cov.mve <- function(...)
{
    oc <- sys.call()
    oc$method <- "mve"
    oc[[1]] <- as.name("cov.rob")
    eval(oc, parent.frame())
}

cov.mcd <- function(...)
{
    oc <- sys.call()
    oc$method <- "mcd"
    oc[[1]] <- as.name("cov.rob")
    eval(oc, parent.frame())
}
# file MASS/mca.q
# copyright (C) 1994-9 W. N. Venables and B. D. Ripley
#
mca <- function(df, nf = 2, abbrev = FALSE)
{
  class.ind <- function(cl)
  {
    n <- length(cl); cl <- as.factor(cl)
    x <- matrix(0, n, length(levels(cl)))
    x[(1:n) + n * (unclass(cl) - 1)] <- 1
    dimnames(x) <- list(names(cl), levels(cl))
    x
  }
  if(!all(unlist(lapply(df, is.factor))))
    stop("All variables must be factors")
  n <- nrow(df); p <- length(df)
  G <- as.matrix(do.call("data.frame", c(lapply(df, class.ind),
                                         check.names=FALSE)))
  Dc <- drop((rep(1, n)) %*% G)
  X <- t(t(G)/(sqrt(p*Dc)))
  X.svd <- svd(X)
  sec <- 1 + (1:nf)
  rs <- X %*% X.svd$v[, sec]/p
  cs <- diag(1/(sqrt(p*Dc))) %*% X.svd$v[, sec]
  fs <- X.svd$u[, sec]/rep(p*X.svd$d[sec], rep(n, nf))
  dimnames(rs) <- list(row.names(df), as.character(1:nf))
  dimnames(fs) <- dimnames(rs)
  varnames <- if(abbrev) unlist(lapply(df, levels))
              else colnames(G)
  dimnames(cs) <- list(varnames, as.character(1:nf))
  structure(list(rs=rs, cs=cs, fs=fs, d=X.svd$d[sec], p=p,
                 call=match.call()), class="mca")
}

print.mca <- function(x, ...)
{
  if(!is.null(cl <- x$call)) {
    cat("Call:\n")
    dput(cl)
  }
  cat("\nMultiple correspondence analysis of",
            nrow(x$rs), "cases of", x$p,
            "factors\n")
  cat("\nCorrelations", format(round(x$d,3), ...))
  p <- 100 * cumsum(x$d)/(x$p - 1)
  cat("  cumulative % explained", format(round(p,2), ...), "\n")
  invisible(x)
}

plot.mca <- function(x, rows = TRUE,
                     col, cex = par("cex"), ...)
{
  if(length(cex) == 1) cex <- rep(cex, 2)
  eqscplot(x$cs, type="n", xlab="", ...)
  if(missing(col)) {
    col <- par("col")
    if (!is.numeric(col)) col <- match(col, palette())
    col <- c(col, col + 1)
  } else if(length(col) != 2) col <- rep(col, length = 2)
  if(rows) text(x$rs, cex=cex[1], col=col[1])
  text(x$cs, labels=dimnames(x$cs)[[1]], cex=cex[2], col=col[2])
  invisible(x)
}

predict.mca <- function(object, newdata, type=c("row", "factor"), ...)
{
  class.ind <- function(cl)
  {
    n <- length(cl); cl <- as.factor(cl)
    x <- matrix(0, n, length(levels(cl)))
    x[(1:n) + n * (unclass(cl) - 1)] <- 1
    dimnames(x) <- list(names(cl), levels(cl))
    x
  }

  type <- match.arg(type)
  if(is.null(abbrev <- object$call$abbrev)) abbrev <- FALSE
  if(!all(unlist(lapply(newdata, is.factor))))
    stop("All variables must be factors")
  G <- as.matrix(do.call("data.frame", c(lapply(newdata, class.ind),
                                         check.names=FALSE)))
  if(abbrev) colnames(G) <- unlist(lapply(newdata, levels))
  if(type == "row") {
    # predict new row(s)
    if(!all(colnames(G) == dimnames(object$cs)[[1]]))
       stop("factors in newdata do not match those for fit")
    G %*% object$cs/object$p
  } else {
    # predict positions of new factor(s)
    n <- nrow(G)
    Dc <- drop((rep(1, n)) %*% G)
    if(n != nrow(object$fs))
      stop("newdata is not of the right length")
    (t(G)/Dc) %*% object$fs
  }
}
# file MASS/misc.q
# copyright (C) 1994-9 W. N. Venables and B. D. Ripley
#

con2tr <- function(obj)
{
    data.frame(expand.grid(x=obj$x,y=obj$y),z=as.vector(obj$z))
}

Null <- function(M)
{
    tmp <- qr(M)
    set <- if(tmp$rank == 0) 1:ncol(M) else  - (1:tmp$rank)
    qr.Q(tmp, complete = TRUE)[, set, drop = FALSE]
}

ginv <- function(X, tol = sqrt(.Machine$double.eps))
{
#
# based on suggestions of R. M. Heiberger, T. M. Hesterberg and WNV
#
    if(length(dim(X)) > 2 || !(is.numeric(X) || is.complex(X)))
        stop("X must be a numeric or complex matrix")
    if(!is.matrix(X)) X <- as.matrix(X)
    Xsvd <- svd(X)
    if(is.complex(X)) Xsvd$u <- Conj(Xsvd$u)
    Positive <- Xsvd$d > max(tol * Xsvd$d[1], 0)
    if (all(Positive)) Xsvd$v %*% (1/Xsvd$d * t(Xsvd$u))
    else if(!any(Positive)) array(0, dim(X)[2:1])
    else Xsvd$v[, Positive, drop=FALSE] %*% ((1/Xsvd$d[Positive]) * t(Xsvd$u[, Positive, drop=FALSE]))
}
# file MASS/mvrnorm.q
# copyright (C) 1994-2004 W. N. Venables and B. D. Ripley
#
mvrnorm <- function(n = 1, mu, Sigma, tol=1e-6, empirical = FALSE)
{
    p <- length(mu)
    if(!all(dim(Sigma) == c(p,p))) stop("incompatible arguments")
    eS <- eigen(Sigma, sym = TRUE, EISPACK = TRUE)
    ev <- eS$values
    if(!all(ev >= -tol*abs(ev[1]))) stop("Sigma is not positive definite")
    X <- matrix(rnorm(p * n), n)
    if(empirical) {
        X <- scale(X, TRUE, FALSE) # remove means
        X <- X %*% svd(X, nu = 0)$v # rotate to PCs
        X <- scale(X, FALSE, TRUE) # rescale PCs to unit variance
    }
    X <- drop(mu) + eS$vectors %*% diag(sqrt(pmax(ev, 0)), p) %*% t(X)
    nm <- names(mu)
    if(is.null(nm) && !is.null(dn <- dimnames(Sigma))) nm <- dn[[1]]
    dimnames(X) <- list(nm, NULL)
    if(n == 1) drop(X) else t(X)
}
# file MASS/neg.bin.q
# copyright (C) 1994-2003 W. N. Venables and B. D. Ripley
#
neg.bin <- function(theta = stop("theta must be given"))
{
  env <- new.env(parent=.GlobalEnv)
  assign(".Theta", theta, envir=env)
  stats <- make.link("log")
  variance <- function(mu)
    mu + mu^2/.Theta
  validmu <- function(mu)
    all(mu > 0)
  dev.resids <- function(y, mu, wt)
    2 * wt * (y * log(pmax(1, y)/mu) - (y + .Theta) *
              log((y + .Theta)/ (mu + .Theta)))
  aic <- function(y, n, mu, wt, dev) {
    term <- (y + .Theta) * log((y + .Theta)/ (mu + .Theta)) - y * log(mu) +
      lgamma(y + 1) - .Theta * log(.Theta) + lgamma(.Theta) - lgamma(.Theta+y)
    2 * sum(term * wt)
  }
  initialize <- expression({
    if (any(y < 0)) stop(paste("Negative values not allowed for",
                               "the Poisson family"))
    n <- rep(1, nobs)
    mustart <- y + (y == 0)/6
  })
  environment(variance) <- environment(validmu) <-
    environment(dev.resids) <- environment(aic) <- env
  structure(list(family = "Negative Binomial", link = "log", linkfun = stats$linkfun,
                 linkinv = stats$linkinv, variance = variance, dev.resids = dev.resids,
                 aic = aic, mu.eta = stats$mu.eta, initialize = initialize,
                 validmu = validmu, valideta = stats$valideta), class = "family")
}
# file MASS/negbin.q
# copyright (C) 1994-2000 W. N. Venables and B. D. Ripley
#
anova.negbin <- function(object, ..., test = "Chisq")
{
  dots <- list(...)
  if(length(dots) == 0) {
    warning("tests made without re-estimating theta")
    object$call[[1]] <- as.name("glm")
    if(is.null(object$link))
      object$link <- as.name("log")
    object$call$family <- call("negative.binomial", theta = object$
                               theta, link = object$link)
    anova.glm(object, test = test)
  } else {
    if(test != "Chisq")
      warning("only Chi-squared LR tests are implemented")
    mlist <- list(object, ...)
    nt <- length(mlist)
    dflis <- sapply(mlist, function(x) x$df.resid)
    s <- sort.list(-dflis)
    mlist <- mlist[s]
    if(any(!sapply(mlist, inherits, "negbin")))
      stop("not all objects are of class 'negbin'")
    rsp <- unique(sapply(mlist, function(x) paste(formula(x)[2])))
    mds <- sapply(mlist, function(x) paste(formula(x)[3]))
    ths <- sapply(mlist, function(x) x$theta)
    dfs <- dflis[s]
    lls <- sapply(mlist, function(x) x$twologlik)
    tss <- c("", paste(1:(nt - 1), 2:nt, sep = " vs "))
    df <- c(NA,  - diff(dfs))
    x2 <- c(NA, diff(lls))
    pr <- c(NA, 1 - pchisq(x2[-1], df[-1]))
    out <- data.frame(Model = mds, theta = ths, Resid.df = dfs,
                      "2 x log-lik." = lls, Test = tss, df = df, LRtest = x2,
                      Prob = pr)
    names(out) <- c("Model", "theta", "Resid. df",
                    "   2 x log-lik.", "Test", "   df", "LR stat.", "Pr(Chi)")
    class(out) <- c("Anova", "data.frame")
    attr(out, "heading") <-
      c("Likelihood ratio tests of Negative Binomial Models\n",
        paste("Response:", rsp))
    out
  }
}

print.Anova <- function(x, ...)
{
    heading <- attr(x, "heading")
    if(!is.null(heading)) cat(heading, sep = "\n")
    attr(x, "heading") <- NULL
    res <- format.data.frame(x, ...)
    nas <- is.na(x) # format loses this
    res[] <- sapply(seq(len=ncol(res)), function(i){
        x <- as.character(res[[i]])
        x[nas[, i]] <- ""
        x
    })
    print.data.frame(res)
    invisible(x)
}

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

glm.convert <- function(object)
{
    object$call[[1]] <- as.name("glm")
    if(is.null(object$link))
        object$link <- as.name("log")
    object$call$family <- call("negative.binomial", theta = object$theta,
                               link = object$link)
    object$call$init.theta <- object$call$link <- NULL
    class(object) <- c("glm", "lm")
    object
}

glm.nb <- function(formula, data, weights,
		   subset, na.action, start = NULL, etastart,
		   control = glm.control(...), method = "glm.fit",
		   model = TRUE, x = FALSE, y = TRUE, contrasts = NULL, ...,
		   init.theta, link = log)
{
    loglik <- function(n, th, mu, y)
    {
        sum(lgamma(th + y) - lgamma(th) - lgamma(y + 1) + th * log(th) +
            y * log(mu + (y == 0)) - (th + y) * log(th + mu))
    }
    link <- substitute(link)
    if(missing(init.theta)) {
        fam0 <- do.call("poisson", list(link = link))
    } else {
        fam0 <- do.call("negative.binomial", list(theta = init.theta, link = link))
    }
    Call <- match.call()
    mf <- match.call(expand.dots = FALSE)
    mf$method <- mf$model <- mf$x <- mf$y <- mf$control <- mf$contrasts <-
        mf$init.theta <- mf$link <- mf$start <- mf$... <-  NULL
    mf$drop.unused.levels <- TRUE
    mf[[1]] <- as.name("model.frame")
    mf <- eval.parent(mf)
    Terms <- attr(mf, "terms")
    if(method == "model.frame") return(mf)
    Y <- model.response(mf, "numeric")
    ## null model support
    X <- if (!is.empty.model(Terms)) model.matrix(Terms, mf, contrasts) else matrix(,NROW(Y),0)
    w <- model.weights(mf)
    if(!length(w)) w <- rep(1, nrow(mf))
    else if(any(w < 0)) stop("negative weights not allowed")
    offset <- model.offset(mf)
    ## these allow starting values to be expressed in terms of other vars.
    etastart <- model.extract(mf, "etastart")
    n <- length(Y)
    if(!is.null(method)) {
        if(!exists(method, mode = "function"))
            stop(paste("unimplemented method:", method))
    }
    else method <- "glm.fit"
    glm.fitter <- get(method)
    if(control$trace > 1) cat("Initial fit:\n")
    fit <- glm.fitter(x = X, y = Y, w = w, start = start,
                      etastart = etastart,
                      offset = offset, family = fam0,
                      control = list(maxit=control$maxit,
                      epsilon = control$epsilon,
                      trace = control$trace > 1))
    class(fit) <- c("glm", "lm")
    mu <- fit$fitted
    th <- as.vector(theta.ml(Y, mu, n, limit=control$maxit, trace =
                             control$trace> 2))
    if(control$trace > 1)
        cat("Initial value for theta:", signif(th), "\n")
    fam <- do.call("negative.binomial", list(theta = th, link = link))
    iter <- 0
    d1 <- sqrt(2 * max(1, fit$df.residual))
    d2 <- del <- 1
    g <- fam$linkfun
    Lm <- loglik(n, th, mu, Y)
    Lm0 <- Lm + 2 * d1
    while((iter <- iter + 1) <= control$maxit &&
          (abs(Lm0 - Lm)/d1 + abs(del)/d2) > control$epsilon) {
        eta <- g(mu)
        fit <- glm.fitter(x = X, y = Y, w = w, etastart =
                          eta, offset = offset, family = fam,
                          control = list(maxit=control$maxit,
                          epsilon = control$epsilon,
                          trace = control$trace > 1),
                          intercept = attr(Terms, "intercept") > 0)
        t0 <- th
        th <- theta.ml(Y, mu, n, limit=control$maxit, trace = control$trace > 2)
        fam <- do.call("negative.binomial", list(theta = th, link = link))
        mu <- fit$fitted
        del <- t0 - th
        Lm0 <- Lm
        Lm <- loglik(n, th, mu, Y)
        if(control$trace) {
            Ls <- loglik(n, th, Y, Y)
            Dev <- 2 * (Ls - Lm)
            cat("Theta(", iter, ") =", signif(th),
                ", 2(Ls - Lm) =", signif(Dev), "\n")
        }
    }
    if(!is.null(attr(th, "warn"))) fit$th.warn <- attr(th, "warn")
    if(iter > control$maxit) {
        warning("alternation limit reached")
        fit$th.warn <- "alternation limit reached"
    }

  # If an offset and intercept are present, iterations are needed to
  # compute the Null deviance; these are done here, unless the model
  # is NULL, in which case the computations have been done already
  #
    if(any(offset) && attr(Terms, "intercept")) {
        null.deviance <-
            if(length(Terms))
                glm.fitter(X[, "(Intercept)", drop = FALSE], Y, w,
                           offset = offset, family = fam,
                           control = list(maxit=control$maxit,
                           epsilon = control$epsilon, trace = control$trace > 1)
                           )$deviance
           else fit$deviance
        fit$null.deviance <- null.deviance
    }
    class(fit) <- c("negbin", "glm", "lm")
    fit$terms <- Terms
    fit$formula <- as.vector(attr(Terms, "formula"))
    Call$init.theta <- as.vector(th)
    Call$link <- link
    fit$call <- Call
    if(model) fit$model <- mf
    fit$na.action <- attr(mf, "na.action")
    if(x) fit$x <- X
    if(!y) fit$y <- NULL
    fit$theta <- as.vector(th)
    fit$SE.theta <- attr(th, "SE")
    fit$twologlik <- as.vector(2 * Lm)
    fit$aic <- -fit$twologlik + 2*fit$rank + 2
    fit$contrasts <- attr(X, "contrasts")
    fit$xlevels <- .getXlevels(Terms, mf)
    fit$method <- method
    fit$control <- control
    fit
}

negative.binomial <-
    function(theta = stop("theta must be specified"), link = "log")
{
    linktemp <- substitute(link)
    if (!is.character(linktemp)) {
        linktemp <- deparse(linktemp)
        if (linktemp == "link")
            linktemp <- eval(link)
    }
    if (any(linktemp == c("log", "identity", "sqrt")))
        stats <- make.link(linktemp)
    else stop(paste(linktemp, "link not available for negative binomial",
                    "family; available links are", "\"identity\", \"log\" and \"sqrt\""))
    env <- new.env(parent=.GlobalEnv)
    assign(".Theta", theta, envir=env)
    variance <- function(mu)
        mu + mu^2/.Theta
    validmu <- function(mu)
        all(mu > 0)
    dev.resids <- function(y, mu, wt)
        2 * wt * (y * log(pmax(1, y)/mu) - (y + .Theta) *
                  log((y + .Theta)/ (mu + .Theta)))
    aic <- function(y, n, mu, wt, dev) {
        term <- (y + .Theta) * log((y + .Theta)/ (mu + .Theta)) - y * log(mu) +
            lgamma(y + 1) - .Theta * log(.Theta) + lgamma(.Theta) - lgamma(.Theta+y)
        2 * sum(term * wt)
    }
    initialize <- expression({
        if (any(y < 0)) stop(paste("Negative values not allowed for",
                                   "the negative binomial family"))
        n <- rep(1, nobs)
        mustart <- y + (y == 0)/6
    })
    environment(variance) <- environment(validmu) <-
        environment(dev.resids) <- environment(aic) <- env
    famname <- paste("Negative Binomial(", format(round(theta, 4)), ")",
                     sep = "")
    structure(list(family = famname, link = linktemp, linkfun = stats$linkfun,
                   linkinv = stats$linkinv, variance = variance, dev.resids = dev.resids,
                   aic = aic, mu.eta = stats$mu.eta, initialize = initialize,
                   validmu = validmu, valideta = stats$valideta), class = "family")
}

rnegbin <- function(n, mu = n, theta = stop("theta must be given"))
{
    k <- if(length(n) > 1) length(n) else n
    rpois(k, (mu * rgamma(k, theta))/theta)
}

summary.negbin <- function(object, dispersion = 1, correlation = TRUE, ...)
{
    if(is.null(dispersion)) dispersion <- 1
    summ <- c(summary.glm(object, dispersion = dispersion,
                          correlation = correlation),
              object[c("theta", "SE.theta", "twologlik", "th.warn")])
    class(summ) <- c("summary.negbin", "summary.glm")
    summ
}

print.summary.negbin <- function(x, ...)
{
    NextMethod()
    dp <- 2 - floor(log10(x$SE.theta))
    cat("\n              Theta: ", format(round(x$theta, dp), nsmall=dp),
        "\n          Std. Err.: ", format(round(x$SE.theta, dp), nsmall=dp),
        "\n")
    if(!is.null(x$th.warn))
        cat("Warning while fitting theta:", x$th.warn,"\n")
    cat("\n 2 x log-likelihood: ", format(round(x$twologlik, 3), nsmall=dp), "\n")
    invisible(x)
}

theta.md <-
    function(y, u, dfr, limit = 20, eps = .Machine$double.eps^0.25)
{
    if(inherits(y, "lm")) {
        u <- y$fitted
        dfr <- y$df.residual
        y <- if(is.null(y$y)) u + residuals(y) else y$y
    }
    n <- length(y)
    t0 <- n/sum((y/u - 1)^2)
    a <- 2 * sum(y * log(pmax(1, y)/u)) - dfr
    it <- 0
    del <- 1
    while((it <- it + 1) < limit && abs(del) > eps) {
        t0 <- abs(t0)
        top <- a - 2 * sum((y + t0) * log((y + t0)/(u + t0)))
        bot <- 2 * sum((y - u)/(u + t0) - log((y + t0)/(u + t0)))
        del <- top/bot
        t0 <- t0 - del
    }
    if(t0 < 0) {
        t0 <- 0
        warning("estimator truncated at zero")
        attr(t0, "warn") <- "estimate truncated at zero"
    }
    t0
}

theta.ml <-
    function(y, mu, n = length(y), limit = 10, eps = .Machine$double.eps^0.25,
             trace=FALSE)
{
    score <- function(n, th, mu, y)
        sum(digamma(th + y) - digamma(th) + log(th) +
            1 - log(th + mu) - (y + th)/(mu + th))
    info <- function(n, th, mu, y)
        sum( - trigamma(th + y) + trigamma(th) - 1/th +
            2/(mu + th) - (y + th)/(mu + th)^2)
    if(inherits(y, "lm")) {
        mu <- y$fitted
        y <- if(is.null(y$y)) mu + residuals(y) else y$y
    }
    t0 <- n/sum((y/mu - 1)^2)
    it <- 0
    del <- 1
    if(trace) cat("theta.ml: initial theta =", signif(t0), "\n")
    while((it <- it + 1) < limit && abs(del) > eps) {
        t0 <- abs(t0)
        del <- score(n, t0, mu, y)/(i <- info(n, t0, mu, y))
        t0 <- t0 + del
        if(trace) cat("theta.ml: iter", it," theta =", signif(t0), "\n")
    }
    if(t0 < 0) {
        t0 <- 0
        warning("estimator truncated at zero")
        attr(t0, "warn") <- "estimate truncated at zero"
    }
    if(it == limit) {
        warning("iteration limit reached")
        attr(t0, "warn") <- "iteration limit reached"
    }
    attr(t0, "SE") <- sqrt(1/i)
    t0
}

theta.mm <- function(y, u, dfr, limit = 10, eps = .Machine$double.eps^0.25)
{
  if(inherits(y, "lm")) {
    u <- y$fitted
    dfr <- y$df.residual
    y <- if(is.null(y$y)) u + residuals(y) else y$y
  }
  n <- length(y)
  t0 <- n/sum((y/u - 1)^2)
  it <- 0
  del <- 1
  while((it <- it + 1) < limit && abs(del) > eps) {
    t0 <- abs(t0)
    del <- (sum((y - u)^2/(u + u^2/t0)) - dfr)/sum((y - u)^2/(u + t0)^2)
    t0 <- t0 - del
  }
  if(t0 < 0) {
    t0 <- 0
    warning("estimator truncated at zero")
    attr(t0, "warn") <- "estimate truncated at zero"
  }
  t0
}

logLik.negbin <- function(object, ...)
{
    if (length(list(...)))
        warning("extra arguments discarded")
    p <- object$rank + 1 # for theta
    val <- object$twologlik/2
    attr(val, "df") <- p
    class(val) <- "logLik"
    val

}
# file MASS/negexp.q
# copyright (C) 1994-9 W. N. Venables and B. D. Ripley
#

negexp.SSival <- function(mCall, data, LHS)
{
    x <- eval(mCall[["x"]], data)
    if(length(x) < 3)
        stop("at least 3 distinct x values are needed")
    y <- eval(LHS, data)
    mx <- mean(x)
    b <- as.vector(lsfit(cbind(x - mx,  - (x - mx)^2/2), y)$coef)
    rx <- range(x)
    xh <- mx + b[2]/b[3]
    if(prod(xh - rx) < 0)
        if(xh - rx[1] > rx[2] - xh)
            rx[2] <- xh
        else rx[1] <- xh
    x0 <- c(rx[1], sum(rx)/2, rx[2])
    dy <- diff(b[1] + b[2] * (x0 - mx) - (b[3] * (x0 - mx)^2)/2)
    th <- (x0[2] - x0[1])/log(dy[1]/dy[2])
    b <- as.vector(lsfit(exp( - x/th), y)$coef)
    pars <- list(b[1], b[2], th)
    names(pars) <- mCall[c("b0", "b1", "th")]
    print(unlist(pars))
    pars
}
parcoord <- function(x, col = 1, lty = 1, ...)
{
    x <- apply(x, 2, function(x) (x - min(x))/(max(x) - min(x)))
    matplot(1:ncol(x), t(x), type = "l", col = col, lty = lty,
            xlab="", ylab = "",
            axes = FALSE, ...)
    axis(1, at = 1:ncol(x), labels = colnames(x))
    for(i in 1:ncol(x)) lines(c(i, i), c(0, 1), col = "grey70")
    invisible()
}
# file MASS/polr.q
# copyright (C) 1994-2003 W. N. Venables and B. D. Ripley
#
polr <- function(formula, data, weights, start, ..., subset,
                 na.action, contrasts = NULL, Hess = FALSE,
                 model = TRUE)
{
    logit <- function(p) log(p/(1-p))

    fmin <- function(beta) {
        gamm <- c(-100, beta[pc+1:q], 100)
        eta <- offset
        if(pc > 0) eta <- eta + drop(x %*% beta[1:pc])
        pr <- plogis(gamm[y+1] - eta) - plogis(gamm[y] - eta)
        if(all(pr > 0)) -sum(wt * log(pr)) else Inf
    }

    gmin <- function(beta) {
        gamm <- c(-100, beta[pc+1:q], 100)
        eta <- offset
        if(pc > 0) eta <- eta + drop(x %*% beta[1:pc])
        pr <- plogis(gamm[y+1] - eta) - plogis(gamm[y] - eta)
        p1 <- dlogis(gamm[y+1] - eta)
        p2 <- dlogis(gamm[y] - eta)
        g1 <- if(pc > 0) t(x) %*% (wt*(p1-p2)/pr) else numeric(0)
        xx <- .polrY1*p1 - .polrY2*p2
        g2 <- - t(xx) %*% (wt/pr)
        if(all(pr) > 0) c(g1, g2) else rep(NA, pc+q)
    }

    m <- match.call(expand.dots = FALSE)
    if(is.matrix(eval.parent(m$data)))
        m$data <- as.data.frame(data)
    m$start <- m$Hess <- m$... <- NULL
    m[[1]] <- as.name("model.frame")
    m <- eval.parent(m)
    Terms <- attr(m, "terms")
    x <- model.matrix(Terms, m, contrasts)
    xint <- match("(Intercept)", colnames(x), nomatch=0)
    n <- nrow(x)
    pc <- ncol(x)
    cons <- attr(x, "contrasts") # will get dropped by subsetting
    if(xint > 0) {
        x <- x[, -xint, drop=FALSE]
        pc <- pc - 1
    } else warning("an intercept is needed and assumed")
    wt <- model.weights(m)
    if(!length(wt)) wt <- rep(1, n)
    offset <- model.offset(m)
    if(length(offset) <= 1) offset <- rep(0, n)
    y <- model.response(m)
    if(!is.factor(y)) stop("response must be a factor")
    lev <- levels(y)
    if(length(lev) <= 2) stop("response must have 3 or more levels")
    y <- unclass(y)
    q <- length(lev) - 1
    Y <- matrix(0, n, q)
    assign(".polrY1", col(Y) == y)
    assign(".polrY2", col(Y) == y-1)
    if(missing(start)) {
        # try logistic regression on 'middle' cut
        q1 <- length(lev) %/% 2
        y1 <- (y > q1)
        X <- cbind(Intercept = rep(1, n), x)
        fit <- glm.fit(X, y1, wt, family = binomial(), offset = offset)
        coefs <- fit$coefficients
        spacing <- logit((1:q)/(q+1))
        start <- c(coefs[-1], -coefs[1] + spacing - spacing[q1])
    }
    res <- optim(start, fmin, gmin, method="BFGS", hessian = Hess, ...)
    beta <- res$par[seq(len=pc)]
    zeta <- res$par[pc + 1:q]
    deviance <- 2 * res$value
    niter <- c(f.evals=res$counts[1], g.evals=res$counts[2])
    names(zeta) <- paste(lev[-length(lev)], lev[-1], sep="|")
    if(pc > 0) {
        names(beta) <- colnames(x)
        eta <- drop(x %*% beta)
    } else {
        eta <- rep(0, n)
    }
    cumpr <- matrix(plogis(matrix(zeta, n, q, byrow=TRUE) - eta), , q)
    fitted <- t(apply(cumpr, 1, function(x) diff(c(0, x, 1))))
    dimnames(fitted) <- list(row.names(m), lev)
    fit <- list(coefficients = beta, zeta = zeta, deviance = deviance,
                fitted.values = fitted, lev = lev, terms = Terms,
                df.residual = sum(wt) - pc - q, edf = pc + q, n = sum(wt),
                call = match.call(), convergence = res$convergence, niter=niter)
    if(Hess) {
        dn <- c(names(beta), names(zeta))
        H <- res$hessian
        dimnames(H) <- list(dn, dn)
        fit$Hessian <- H
    }
    if(model) fit$model <- m
    fit$na.action <- attr(m, "na.action")
    fit$contrasts <- cons
    fit$xlevels <- .getXlevels(Terms, m)
    class(fit) <- "polr"
    fit
}

print.polr <- function(x, ...)
{
    if(!is.null(cl <- x$call)) {
        cat("Call:\n")
        dput(cl)
    }
    if(length(coef(x))) {
        cat("\nCoefficients:\n")
        print(coef(x), ...)
    } else {
        cat("\nNo coefficients\n")
    }
    cat("\nIntercepts:\n")
    print(x$zeta, ...)
    cat("\nResidual Deviance:", format(x$deviance, nsmall=2), "\n")
    cat("AIC:", format(x$deviance + 2*x$edf, nsmall=2), "\n")
    if(x$convergence > 0)
        cat("Warning: did not converge as iteration limit reached\n")
    invisible(x)
}

vcov.polr <- function(object, ...)
{
    if(is.null(object$Hessian)) {
        cat("\nRe-fitting to get Hessian\n\n")
        object <- update(object, Hess=TRUE,
                         start=c(object$coef, object$zeta))
    }
    structure(ginv(object$Hessian), dimnames = dimnames(object$Hessian))

}

summary.polr <- function(object, digits = max(3, .Options$digits - 3),
                         correlation = FALSE, ...)
{
    cc <- c(coef(object), object$zeta)
    pc <- length(coef(object))
    q <- length(object$zeta)
    coef <- matrix(0, pc+q, 3, dimnames=list(names(cc),
                               c("Value", "Std. Error", "t value")))
    coef[, 1] <- cc
    vc <- vcov(object)
    coef[, 2] <- sd <- sqrt(diag(vc))
    coef[, 3] <- coef[, 1]/coef[, 2]
    object$coefficients <- coef
    object$pc <- pc
    object$digits <- digits
    if(correlation)
        object$correlation <- (vc/sd)/rep(sd, rep(pc+q, pc+q))
    class(object) <- "summary.polr"
    object
}

print.summary.polr <- function(x, digits = x$digits, ...)
{
    if(!is.null(cl <- x$call)) {
        cat("Call:\n")
        dput(cl)
    }
    coef <- format(round(x$coef, digits=digits))
    pc <- x$pc
    if(pc > 0) {
        cat("\nCoefficients:\n")
        print(x$coef[seq(len=pc), , drop=FALSE], quote = FALSE, ...)
    } else {
        cat("\nNo coefficients\n")
    }
    cat("\nIntercepts:\n")
    print(coef[(pc+1):nrow(coef), , drop=FALSE], quote = FALSE, ...)
    cat("\nResidual Deviance:", format(x$deviance, nsmall=2), "\n")
    cat("AIC:", format(x$deviance + 2*x$edf, nsmall=2), "\n")
    if(!is.null(correl <- x$correlation)) {
        cat("\nCorrelation of Coefficients:\n")
        ll <- lower.tri(correl)
        correl[ll] <- format(round(correl[ll], digits))
        correl[!ll] <- ""
        print(correl[-1, -ncol(correl)], quote = FALSE, ...)
    }
    invisible(x)
}

predict.polr <- function(object, newdata, type=c("class","probs"), ...)
{
    if(!inherits(object, "polr")) stop("Not a polr fit")
    type <- match.arg(type)
    if(missing(newdata)) Y <- object$fitted
    else {
        newdata <- as.data.frame(newdata)
        Terms <- delete.response(object$terms)
        m <- model.frame(Terms, newdata, na.action = function(x) x,
                         xlev = object$xlevels)
        if (!is.null(cl <- attr(Terms, "dataClasses")) &&
            exists(".checkMFClasses", envir=NULL)) .checkMFClasses(cl, m)
        X <- model.matrix(Terms, m, contrasts = object$contrasts)
        xint <- match("(Intercept)", colnames(X), nomatch=0)
        if(xint > 0) X <- X[, -xint, drop=FALSE]
        n <- nrow(X)
        q <- length(object$zeta)
        eta <- drop(X %*% object$coef)
        cumpr <- matrix(plogis(matrix(object$zeta, n, q, byrow=TRUE) - eta), , q)
        Y <- t(apply(cumpr, 1, function(x) diff(c(0, x, 1))))
        dimnames(Y) <- list(rownames(X), object$lev)
    }
    if(missing(newdata) && !is.null(object$na.action))
        Y <- napredict(object$na.action, Y)
    switch(type, class={
        Y <- factor(max.col(Y), levels=seq(along=object$lev),
                    labels=object$lev)
    }, probs = {})
    drop(Y)
}

extractAIC.polr <- function(fit, scale = 0, k = 2, ...)
{
    edf <- fit$edf
    c(edf, deviance(fit) + k * edf)
}

model.frame.polr <- function(formula, ...)
{
    dots <- list(...)
    nargs <- dots[match(c("data", "na.action", "subset"), names(dots), 0)]
    if(length(nargs) || is.null(formula$model)) {
        m <- formula$call
        m$start <- m$Hess <- m$... <- NULL
        m[[1]] <- as.name("model.frame")
        m[names(nargs)] <- nargs
        if (is.null(env <- environment(formula$terms))) env <- parent.frame()
        data <- eval(m, env)
        if(!is.null(mw <- m$weights)) {
            nm <- names(data)
            nm[match("(weights)", nm)] <- as.character(mw)
            names(data) <- nm
        }
        data
    } else formula$model
}
# File MASS/profiles.q copyright (C) 1996 D. M. Bates and W. N. Venables.
#
# port to R by B. D. Ripley copyright (C) 1998
#
#corrections copyright (C) 2000, 3 B. D. Ripley
profile.glm <- function(fitted, which = 1:p, alpha = 0.01,
			maxsteps = 10, del = zmax/5, trace = FALSE, ...)
{
    Pnames <- names(B0 <- coefficients(fitted))
    pv0 <- t(as.matrix(B0))
    p <- length(Pnames)
    if(is.character(which)) which <- match(which, Pnames)
    summ <- summary(fitted)
    std.err <- summ$coefficients[, "Std. Error"]
    mf <- update(fitted, method = "model.frame")
    n <- length(Y <- model.response(mf))
    O <- model.offset(mf)
    if(!length(O)) O <- rep(0, n)
    W <- model.weights(mf)
    if(length(W) == 0) W <- rep(1, n)
    OriginalDeviance <- deviance(fitted)
    DispersionParameter <- summ$dispersion
    X <- model.matrix(fitted)
    fam <- family(fitted)
    switch(fam$family,
           binomial = {
               if(!is.null(dim(Y))) {
                   n <- n/2
                   O <- O[1:n]
                   Y <- Y[, 1]/(W <- drop(Y %*% c(1, 1)))
               }
               zmax <- sqrt(qchisq(1 - alpha/2, p))
               profName <- "z"
           },
           poisson = ,
           "Negative Binomial" = {
               zmax <- sqrt(qchisq(1 - alpha/2, p))
               profName <- "z"
           }
           ,
           gaussian = ,
           quasi = ,
           "inverse.gaussian" = ,
           quasibinomial = ,
           quasipoisson = ,
       {
	   zmax <- sqrt(p * qf(1 - alpha/2, p, n - p))
	   profName <- "tau"
       }
           )
    prof <- vector("list", length=length(which))
    names(prof) <- Pnames[which]
    for(i in which) {
        zi <- 0
        pvi <- pv0
        Xi <- X[,  - i, drop = FALSE]
        pi <- Pnames[i]
        for(sgn in c(-1, 1)) {
            if(trace) cat("\nParameter:", pi, c("down", "up")[(sgn + 1)/2 + 1], "\n")
            step <- 0
            z <- 0
            ## LP is the linear predictor including offset.
            LP <- X %*% fitted$coef + O
            while((step <- step + 1) < maxsteps && abs(z) < zmax) {
                bi <- B0[i] + sgn * step * del * std.err[i]
                o <- O + X[, i] * bi
                ## call to glm.fit.null not needed from 1.4.1 on
                fm <- glm.fit(x = Xi, y = Y, weights = W, etastart = LP,
                              offset = o, family = fam,
                              control = fitted$control)
                LP <- Xi %*% fm$coef + o
                ri <- pv0
                ri[, names(coef(fm))] <- coef(fm)
                ri[, pi] <- bi
                pvi <- rbind(pvi, ri)
                zz <- (fm$deviance - OriginalDeviance)/DispersionParameter
                if(zz > - 1e-3) zz <- max(zz, 0)
                else stop("profiling has found a better solution, so original fit had not converged")
                z <- sgn * sqrt(zz)
                zi <- c(zi, z)
            }
        }
        si <- order(zi)
        prof[[pi]] <- structure(data.frame(zi[si]), names = profName)
        prof[[pi]]$par.vals <- pvi[si, ]
    }
    val <- structure(prof, original.fit = fitted, summary = summ)
    class(val) <- c("profile.glm", "profile")
    val
}

plot.profile <-
  ## R version: non-Trellis-based replacement for plot.profile
  function(x, nseg, ...)
{
    nulls <- sapply(x, is.null)
    if (all(nulls)) return(NULL)
    x <- x[!nulls]
    nm <- names(x)
    nr <- ceiling(sqrt(length(nm)))
    oldpar <- par(mfrow = c(nr, nr))
    on.exit(par(oldpar))
    for(nm in names(x)) {
        tau <- x[[nm]][[1]]
        parval <- x[[nm]][[2]][, nm]
        plot(parval, tau, xlab = nm, ylab = "tau", type="n")
        ## allow for profiling failures
        if(sum(tau == 0) == 1) points(parval[tau == 0], 0, pch = 3)
        splineVals <- spline(parval, tau)
        lines(splineVals$x, splineVals$y)
    }
}

pairs.profile <-
  ## Another plot method for profile objects showing pairwise traces.
  ## Recommended only for diagnostic purposes.
function(x, colours = 2:3, ...)
{
    parvals <- lapply(x, "[[", "par.vals")
    rng <- apply(do.call("rbind", parvals), 2, range, na.rm = TRUE)
    Pnames <- colnames(rng)
    npar <- length(Pnames)
    coefs <- coef(attr(x, "original.fit"))
    form <- paste(as.character(attr(x, "original.fit")$formula)[c(2, 1, 3)],
                  collapse = "")
    oldpar <- par(mar = c(0, 0, 0, 0), mfrow = c(1, 1),
                  oma = c(3, 3, 6, 3), las = 1)
    on.exit(par(oldpar))
    ##
    ## The following dodge ensures that the plot region is square
    ##
    fin <- par("fin")
    dif <- (fin[2] - fin[1])/2
    if(dif > 0) adj <- c(dif, 0, dif, 0)
    else adj <- c(0,  - dif, 0,  - dif)
    par(omi = par("omi") + adj)
    ##
    ##
    cex <- 1 + 1/npar
    frame()
    mtext(form, side = 3, line = 3, cex = 1.5, outer = TRUE)
    del <- 1/npar
    for(i in 1:npar) {
        ci <- npar - i
        pi <- Pnames[i]
        for(j in 1:npar) {
            pj <- Pnames[j]
            par(fig = del * c(j - 1, j, ci, ci + 1))
            if(i == j) {
                par(new=TRUE)
                plot(rng[, pj], rng[, pi], axes = FALSE,
                     xlab = "", ylab = "", type = "n")
                op <- par(usr = c(-1, 1, -1, 1))
                text(0, 0, pi, cex = cex, adj = 0.5)
                par(op)
            } else {
                col <- colours
                if(i < j) col <- col[2:1]
                if(!is.null(parvals[[pj]])) {
                    par(new=TRUE)
                    plot(spline(x <- parvals[[pj]][, pj],
                                y <- parvals[[pj]][, pi]),
                         type = "l", xlim = rng[, pj],
                         ylim = rng[, pi], axes = FALSE,
                         xlab = "", ylab = "", col = col[2])
                    pu <- par("usr")
                    smidge <- 2/100 * (pu[4] - pu[3])
                    segments(x, pmax(pu[3], y - smidge), x,
                             pmin(pu[4], y + smidge))
                } else
                plot(rng[, pj], rng[, pi], axes = FALSE,
                     xlab = "", ylab = "", type = "n")
                if(!is.null(parvals[[pi]])) {
                    lines(x <- parvals[[pi]][, pj], y <- parvals[[pi]][, pi],
                          type = "l", col = col[1])
                    pu <- par("usr")
                    smidge <- 2/100 * (pu[2] - pu[1])
                    segments(pmax(pu[1], x - smidge), y, pmin(pu[2], x + smidge), y)
                }
                points(coefs[pj], coefs[pi], pch = 3, cex = 3)
            }
            if(i == npar) axis(1)
            if(j == 1) axis(2)
            if(i == 1) axis(3)
            if(j == npar) axis(4)
        }
    }
    par(fig = c(0, 1, 0, 1))
    invisible(x)
}
# file MASS/qda.q
# copyright (C) 1994-2003 W. N. Venables and B. D. Ripley
#
qda <- function(x, ...) UseMethod("qda")

qda.formula <- function(formula, data, ..., subset, na.action)
{
    m <- match.call(expand.dots = FALSE)
#    if(is.matrix(eval.parent(m$data)))
#        m$data <- as.data.frame(data)
    m$... <- NULL
    m[[1]] <- as.name("model.frame")
    m <- eval.parent(m)
    Terms <- attr(m, "terms")
    grouping <- model.response(m)
    x <- model.matrix(Terms, m)
    xvars <- as.character(attr(Terms, "variables"))[-1]
    if ((yvar <- attr(Terms, "response")) > 0) xvars <- xvars[-yvar]
    xlev <- if (length(xvars) > 0) {
        xlev <- lapply(m[xvars], levels)
        xlev[!sapply(xlev, is.null)]
    }
    xint <- match("(Intercept)", colnames(x), nomatch=0)
    if(xint > 0) x <- x[, -xint, drop=FALSE]
    res <- qda.default(x, grouping, ...)
    res$terms <- Terms
    cl <- match.call()
    cl[[1]] <- as.name("qda")
    res$call <- cl
    res$contrasts <- attr(x, "contrasts")
    res$xlevels <- .getXlevels(Terms, m)
    res$na.action <- attr(m, "na.action")
    res
}

qda.data.frame <- function(x, ...)
{
    res <- qda(structure(data.matrix(x), class="matrix"), ...)
    cl <- match.call()
    cl[[1]] <- as.name("qda")
    res$call <- cl
    res
}


qda.matrix <- function(x, grouping, ..., subset, na.action)
{
    if(!missing(subset)) {
        x <- x[subset, , drop = FALSE]
        grouping <- grouping[subset]
    }
    if(!missing(na.action)) {
        dfr <- na.action(structure(list(g = grouping, x = x),
                                   class = "data.frame"))
        grouping <- dfr$g
        x <- dfr$x
    }
#    res <- NextMethod("qda")
    res <- qda.default(x, grouping, ...)
    cl <- match.call()
    cl[[1]] <- as.name("qda")
    res$call <- cl
    res
}

qda.default <-
  function(x, grouping, prior = proportions,
           method = c("moment", "mle", "mve", "t"),
           CV = FALSE, nu = 5, ...)
{
    if(is.null(dim(x))) stop("x is not a matrix")
    x <- as.matrix(x)
    n <- nrow(x)
    p <- ncol(x)
    if(n != length(grouping)) stop("nrow(x) and length(grouping) are different")
    g <- as.factor(grouping)
    lev <- levels(g)
    counts <- as.vector(table(g))
    names(counts) <- lev
    if(any(counts < p+1)) stop("some group is too small for qda")
    proportions <- counts/length(g)
    ng <- length(proportions)
# allow for supplied prior
    if(any(prior < 0) || round(sum(prior), 5) != 1) stop("invalid prior")
    if(length(prior) != ng) stop("prior is of incorrect length")
    names(prior) <- lev
# means by group (rows) and variable (columns)
    group.means <- tapply(x, list(rep(g, ncol(x)), col(x)), mean)
    scaling <- array(dim=c(p,p,ng))
    ldet <- numeric(ng)
    method <- match.arg(method)
    if(CV && !(method == "moment" || method == "mle"))
        stop(paste("Cannot use leave-one-out CV with method", method))
    for (i in 1:ng){
        if(method == "mve") {
            cX <- cov.mve(x[unclass(g) == i, ])
            group.means[i,] <- cX$center
            sX <- svd(cX$cov, nu=0)
            scaling[, , i] <- sX$v %*% diag(sqrt(1/sX$d),,p)
            ldet[i] <- sum(log(sX$d))
        } else if(method == "t") {
            if(nu <= 2) stop("nu must exceed 2")
            m <- counts[i]
            X <- x[unclass(g) == i, ]
            w <- rep(1, m)
            repeat {
                w0 <- w
                W <- scale(X, center=group.means[i, ], scale=FALSE)
                sX <- svd(sqrt((1 + p/nu) * w/m) * W, nu=0)
                W <- W %*% sX$v %*% diag(1/sX$d,, p)
                w <- 1/(1 + drop(W^2 %*% rep(1, p))/nu)
                #         print(summary(w))
                group.means[i,] <- colSums(w*X)/sum(w)
                if(all(abs(w - w0) < 1e-2)) break
            }
            qx <- qr(sqrt(w)*scale(X, center=group.means[i, ], scale=FALSE))
            if(qx$rank < p) stop(paste("Rank deficiency in group", lev[i]))
            qx <- qx$qr* sqrt((1 + p/nu)/m)
            scaling[, , i] <- backsolve(qx[1:p,  ], diag(p))
            ldet[i] <- 2*sum(log(abs(diag(qx))))
        } else {
            if(method == "moment") nk <- counts[i] - 1 else nk <- counts[i]
            X <- scale(x[unclass(g) == i, ], center=group.means[i, ], scale=FALSE)/sqrt(nk)
            qx <- qr(X)
            if(qx$rank < p) stop(paste("Rank deficiency in group", lev[i]))
            qx <- qx$qr
            scaling[, , i] <- backsolve(qx[1:p, ], diag(p))
            ldet[i] <- 2*sum(log(abs(diag(qx))))
        }
    }
    if(CV) {
        NG <- if(method == "mle") 0 else 1
        dist <- matrix(0, n, ng)
        Ldet <- matrix(0, n, ng)
        for(i in 1:ng) {
            dev <- ((x - matrix(group.means[i,  ], nrow(x),
                                p, byrow = TRUE)) %*% scaling[,,i])
            dist[, i] <- rowSums(dev^2)
            Ldet[, i] <- ldet[i]
        }
        nc <- counts[g]
        ind <- cbind(1:n, g)
        fac <- 1 - nc/(nc-1)/(nc-NG) * dist[ind]
        fac[] <- pmax(fac, 1e-10)  # possibly degenerate dsn
        Ldet[ind] <- log(fac) + p * log((nc-NG)/(nc-1-NG)) + Ldet[ind]
        dist[ind] <- dist[ind] * (nc^2/(nc-1)^2) * (nc-1-NG)/(nc-NG) / fac
        dist <- 0.5 * dist + 0.5 * Ldet - matrix(log(prior), n, ng, byrow=TRUE)
        dist <- exp(-(dist - min(dist, na.rm=TRUE)))
        posterior <- dist/drop(dist %*% rep(1, length(prior)))
        cl <- factor(max.col(posterior), levels=seq(along=lev), labels=lev)
        dimnames(posterior) <- list(rownames(x), lev)
        return(list(class = cl, posterior = posterior))
    }
    if(is.null(dimnames(x)))
        dimnames(scaling) <- list(NULL, as.character(1:p), lev)
    else {
        dimnames(scaling) <- list(colnames(x), as.character(1:p), lev)
        dimnames(group.means)[[2]] <- colnames(x)
    }
    cl <- match.call()
    cl[[1]] <- as.name("qda")
    res <- list(prior = prior, counts = counts, means = group.means,
                scaling = scaling, ldet = ldet, lev = lev, N = n, call = cl)
    class(res) <- "qda"
    res
}

predict.qda <- function(object, newdata, prior = object$prior,
			method = c("plug-in", "predictive", "debiased",
                          "looCV"), ...)
{
    if(!inherits(object, "qda")) stop("object not of class qda")
    method <- match.arg(method)
    if(method == "looCV" && !missing(newdata))
        stop("Cannot have leave-one-out CV with newdata")
    if(is.null(mt <- object$call$method)) mt <- "moment"
    if(method == "looCV" && !(mt == "moment" || mt == "mle"))
        stop(paste("Cannot use leave-one-out CV with method", mt))
    if(!is.null(Terms <- object$terms)) {
    # formula fit
        if(missing(newdata)) newdata <- model.frame(object)
        else {
            newdata <- model.frame(as.formula(delete.response(Terms)),
                                   newdata, na.action=function(x) x,
                                   xlev = object$xlevels)
        }
        x <- model.matrix(delete.response(Terms), newdata,
                          contrasts = object$contrasts)
        xint <- match("(Intercept)", colnames(x), nomatch=0)
        if(xint > 0) x <- x[, -xint, drop=FALSE]
        if(method == "looCV") g <- model.response(newdata)
    } else { #
    # matrix or data-frame fit
        if(missing(newdata)) {
            if(!is.null(sub <- object$call$subset)) {
                newdata <-
                    eval.parent(parse(text=paste(deparse(object$call$x,
                                      backtick=TRUE),
                                      "[", deparse(sub, backtick=TRUE),",]")))
                g <- eval.parent(parse(text=paste(deparse(object$call[[3]],
                                       backtick=TRUE),
                                       "[", deparse(sub, backtick=TRUE),"]")))
            } else {
                newdata <- eval.parent(object$call$x)
                g <- eval.parent(object$call[[3]])
            }
            if(!is.null(nas <- object$call$na.action)) {
                df <- data.frame(g = g, X = newdata)
                df <- eval(call(nas, df))
                g <- df$g
                newdata <- df$X
            }
            g <- as.factor(g)
        }
        if(is.null(dim(newdata)))
            dim(newdata) <- c(1, length(newdata))  # a row vector
        x <- as.matrix(newdata)		# to cope with dataframes
    }
    p <- ncol(object$means)
    if(ncol(x) != p) stop("wrong number of variables")
    if(length(colnames(x)) > 0 &&
       any(colnames(x) != dimnames(object$means)[[2]]))
        warning("Variable names in newdata do not match those in object")
    ngroup <- length(object$prior)
    dist <- matrix(0, nrow = nrow(x), ncol = ngroup)
    if(method == "plug-in") {
        for(i in 1:ngroup) {
            dev <- ((x - matrix(object$means[i,  ], nrow(x),
                                ncol(x), byrow = TRUE)) %*% object$scaling[,,i])
            dist[, i] <- 0.5 * rowSums(dev^2) + 0.5 * object$ldet[i] - log(object$prior[i])
        }
#        dist <- exp( -(dist - min(dist, na.rm=T)))
        dist <- exp( -(dist - apply(dist, 1, min, na.rm=TRUE)))
    } else if(method == "looCV") {
        n <- nrow(x)
        NG <- 1
        if(mt == "mle") NG <- 0
        ldet <- matrix(0, n, ngroup)
        for(i in 1:ngroup) {
            dev <- ((x - matrix(object$means[i,  ], nrow(x), p, byrow = TRUE))
                    %*% object$scaling[,,i])
            dist[, i] <- rowSums(dev^2)
            ldet[, i] <- object$ldet[i]
        }
        nc <- object$counts[g]
        ind <- cbind(1:n, g)
        fac <- 1 - nc/(nc-1)/(nc-NG) * dist[ind]
        fac[] <- pmax(fac, 1e-10)  # possibly degenerate dsn
        ldet[ind] <- log(fac) + p * log((nc-NG)/(nc-1-NG)) + ldet[ind]
        dist[ind] <- dist[ind] * (nc^2/(nc-1)^2) * (nc-1-NG)/(nc-NG) / fac
        dist <- 0.5 * dist + 0.5 * ldet -
            matrix(log(object$prior), n, ngroup, byrow=TRUE)
        dist <- exp( -(dist - apply(dist, 1, min, na.rm=TRUE)))
    } else if(method == "debiased") {
        for(i in 1:ngroup) {
            nk <- object$counts[i]
            Bm <- p * log((nk-1)/2) - sum(digamma(0.5 * (nk - 1:ngroup)))
            dev <- ((x - matrix(object$means[i,  ], nrow = nrow(x),
                                ncol = ncol(x), byrow = TRUE)) %*% object$scaling[,,i])
            dist[, i] <- 0.5 * (1 - (p-1)/(nk-1)) * rowSums(dev^2) +
                0.5 * object$ldet[i] - log(object$prior[i]) + 0.5 * Bm - p/(2*nk)
        }
        dist <- exp( -(dist - apply(dist, 1, min, na.rm=TRUE)))
    } else {
        for(i in 1:ngroup) {
            nk <- object$counts[i]
            dev <- ((x - matrix(object$means[i,  ], nrow = nrow(x),
                                ncol = ncol(x), byrow = TRUE))
                    %*% object$scaling[,,i])
            dev <- 1 + rowSums(dev^2)/(nk+1)
            dist[, i] <- object$prior[i] * exp(-object$ldet[i]/2) *
                dev^(-nk/2) * (1 + nk)^(-p/2)
        }
    }
    posterior <- dist/drop(dist %*% rep(1, length(object$prior)))
    cl <- factor(max.col(posterior), levels=seq(along=object$lev),
                 labels=object$lev)
    dimnames(posterior) <- list(rownames(x), object$lev)
    list(class = cl, posterior = posterior)
}

print.qda <- function(x, ...)
{
    if(!is.null(cl <- x$call)) {
        names(cl)[2] <- ""
        cat("Call:\n")
        dput(cl)
    }
    cat("\nPrior probabilities of groups:\n")
    print(x$prior, ...)
    cat("\nGroup means:\n")
    print(x$means, ...)
    invisible(x)
}

model.frame.qda <-  model.frame.lda
# file MASS/rlm.q
# copyright (C) 1994-2004 W. N. Venables and B. D. Ripley
#
rlm <- function(x, ...) UseMethod("rlm")

rlm.formula <-
    function(formula, data, weights, ..., subset, na.action,
             method = c("M", "MM", "model.frame"),
             wt.method = c("inv.var", "case"),
             model = TRUE, x.ret = TRUE, y.ret = FALSE, contrasts = NULL)
{
    mf <- match.call(expand.dots = FALSE)
    mf$method <- mf$wt.method <- mf$model <- mf$x.ret <- mf$y.ret <- mf$contrasts <- mf$... <- NULL
    mf[[1]] <- as.name("model.frame")
    mf <- eval.parent(mf)
    method <- match.arg(method)
    wt.method <- match.arg(wt.method)
    if(method == "model.frame") return(mf)
    mt <- attr(mf, "terms")
    y <- model.response(mf)
    x <- model.matrix(mt, mf, contrasts)
    xvars <- as.character(attr(mt, "variables"))[-1]
    if ((yvar <- attr(mt, "response")) > 0)
        xvars <- xvars[-yvar]
    xlev <- if (length(xvars) > 0) {
        xlev <- lapply(mf[xvars], levels)
        xlev[!sapply(xlev, is.null)]
    }
    weights <- model.weights(mf)
    if(!length(weights)) weights <- rep(1, nrow(x))
    fit <- rlm.default(x, y, weights, method = method,
                       wt.method = wt.method, ...)
    fit$terms <- mt
    ## fix up call to refer to the generic, but leave arg name as `formula'
    cl <- match.call()
    cl[[1]] <- as.name("rlm")
    fit$call <- cl
    fit$contrasts <- attr(x, "contrasts")
    fit$xlevels <- .getXlevels(mt, mf)
    fit$na.action <- attr(mf, "na.action")
    if(model) fit$model <- mf
    if(!x.ret) fit$x <- NULL
    if(y.ret) fit$y <- y
    fit
}

rlm.default <-
  function(x, y, weights, ..., w = rep(1, nrow(x)),
           init = "ls", psi = psi.huber,
           scale.est = c("MAD", "Huber", "proposal 2"), k2 = 1.345,
           method = c("M", "MM"), wt.method = c("inv.var", "case"),
           maxit = 20, acc = 1e-4, test.vec = "resid")
{
    irls.delta <- function(old, new)
        sqrt(sum((old - new)^2)/max(1e-20, sum(old^2)))
    irls.rrxwr <- function(x, w, r)
    {
        w <- sqrt(w)
        max(abs((matrix(r * w, 1, length(r)) %*% x)/
                sqrt(matrix(w, 1, length(r)) %*% (x^2))))/sqrt(sum(w * r^2))
    }

    method <- match.arg(method)
    wt.method <- match.arg(wt.method)
    nmx <- deparse(substitute(x))
    if(is.null(dim(x))) {
        x <- as.matrix(x)
        colnames(x) <- nmx
    } else x <- as.matrix(x)
    if(is.null(colnames(x)))
        colnames(x) <- paste("X", seq(ncol(x)), sep="")
    if(qr(x)$rank < ncol(x))
        stop("x is singular: singular fits are not implemented in rlm")

    if(!(any(test.vec == c("resid", "coef", "w", "NULL"))
         || is.null(test.vec))) stop("invalid testvec")
    ## deal with weights
    xx <- x
    if(!missing(weights)) {
        if(length(weights) != nrow(x))
            stop("Length of weights must equal number of observations")
        if(any(weights < 0)) stop("Negative weights value")
        if(wt.method == "inv.var") {
            fac <- sqrt(weights)
            y <- y*fac; x <- x* fac
            wt <- NULL
        } else {
            w <- w * weights
            wt <- weights
        }
    } else wt <- NULL

    if(method == "M") {
        scale.est <- match.arg(scale.est)
        if(!is.function(psi)) psi <- get(psi, mode="function")
        ## match any ... args to those of psi.
        arguments <- list(...)
        if(length(arguments)) {
            pm <- pmatch(names(arguments), names(formals(psi)), nomatch = 0)
            if(any(pm == 0)) warning(paste("some of ... do not match"))
            pm <- names(arguments)[pm> 0]
            formals(psi)[pm] <- unlist(arguments[pm])
        }
        if(is.character(init)) {
            temp <- if(init == "ls") lm.wfit(x, y, w, method="qr")
            else if(init == "lts") lqs(x, y, intercept=FALSE, nsamp=200)
            else stop("init method is unknown")
            coef <- temp$coef
            resid <- temp$resid
        } else {
            if(is.list(init)) coef <- init$coef
            else coef <- init
            resid <- y - x %*% coef
        }
    } else if(method == "MM") {
        scale.est <- "MM"
        temp <- lqs(x, y, intercept=FALSE, method="S", k0 = 1.548)
        coef <- temp$coef
        resid <- temp$resid
        psi <- psi.bisquare
        if(length(arguments <- list(...)))
            if(match("c", names(arguments),
                     nomatch = FALSE)) {
                c0 <- arguments$c
                if (c0 > 1.548) {
                    formals(psi)$c <- c0
                } else warning("c must be at least 1.548 and has been ignored")
            }
        scale <- temp$scale
    } else stop("method is unknown")

    done <- FALSE
    conv <- NULL
    n1 <- (if(is.null(wt)) nrow(x) else sum(wt)) - ncol(x)
    if(scale.est != "MM") scale <- mad(resid, 0)
    theta <- 2*pnorm(k2)-1
    gamma <- theta + k2^2 * (1 - theta) - 2 * k2 * dnorm(k2)
    for(iiter in 1:maxit) {
        if(!is.null(test.vec)) testpv <- get(test.vec)
        if(scale.est != "MM") {
            if(scale.est == "MAD") scale <- median(abs(resid))/0.6745
            else scale <- if(is.null(wt))
                sqrt(sum(pmin(resid^2, (k2 * scale)^2))/(n1*gamma))
            else sqrt(sum(wt*pmin(resid^2, (k2 * scale)^2))/(n1*gamma))
            if(scale == 0) {
                done <- TRUE
                break
            }
        }
        w <- psi(resid/scale)
        if(!is.null(wt)) w <- w * weights
        temp <- lm.wfit(x, y, w, method="qr")
        coef <- temp$coef
        resid <- temp$residuals
        if(!is.null(test.vec)) convi <- irls.delta(testpv, get(test.vec))
        else convi <- irls.rrxwr(x, w, resid)
        conv <- c(conv, convi)
        done <- (convi <= acc)
        if(done) break
    }
    if(!done) warning(paste("rlm failed to converge in", maxit, "steps"))
    if(!missing(weights)) {
        tmp <- (weights != 0)
        w[tmp] <- w[tmp]/weights[tmp]
    }
    ## fix up call to refer to the generic, but leave arg name as `formula'
    cl <- match.call()
    cl[[1]] <- as.name("rlm")
    fit <- list(coefficients = coef, residuals = resid, effects = temp$effects,
                rank = temp$rank, fitted.values = temp$fitted.values,
                assign = temp$assign,  qr = temp$qr, df.residual = NA, w = w,
                s = scale, psi = psi, k2 = k2,
                weights = if(!missing(weights)) weights,
                conv = conv, converged = done, x = xx, call = cl)
    class(fit) <- c("rlm", "lm")
    fit
}

print.rlm <- function(x, ...)
{
    if(!is.null(cl <- x$call)) {
        cat("Call:\n")
        dput(cl)
    }
    if(x$converged)
        cat("Converged in", length(x$conv), "iterations\n")
    else cat("Ran", length(x$conv), "iterations without convergence\n")
    coef <- x$coef
    cat("\nCoefficients:\n")
    print(coef, ...)
    nobs <- length(x$resid)
    rdf <- nobs - length(coef)
    cat("\nDegrees of freedom:", nobs, "total;", rdf, "residual\n")
    cat("Scale estimate:", format(signif(x$s,3)), "\n")
    invisible(x)
}

summary.rlm <- function(object, method=c("XtX", "XtWX"),
                        correlation = TRUE, ...)
{
    method <- match.arg(method)
    s <- object$s
    coef <- object$coef
    ptotal <- length(coef)
    resid <- object$resid
    n <- length(resid)
    if(any(na <- is.na(coef))) coef <- coef[!na]
    cnames <- names(coef)
    p <- length(coef)
    rdf <- n - p
    rinv <- diag(p)
    dimnames(rinv) <- list(cnames, cnames)
    w <- object$psi(resid/s)
    S <- sum((resid*w)^2)/rdf
    psiprime <- object$psi(resid/s, deriv=1)
    mn <- mean(psiprime)
    kappa <- 1 + p*var(psiprime)/(n*mn^2)
    stddev <- sqrt(S)*(kappa/mn)
    X <- object$x * sqrt(object$weights)
    if(method == "XtWX")  X <- X * sqrt(w/mean(w))
    R <- qr(X)$qr
    R <- R[1:p, 1:p, drop = FALSE]
    R[lower.tri(R)] <- 0
    rinv <- solve(R, rinv)
    dimnames(rinv) <- list(cnames, cnames)
    rowlen <- (rinv^2 %*% rep(1, p))^0.5
    names(rowlen) <- cnames
    if(correlation) {
        correl <- rinv * array(1/rowlen, c(p, p))
        correl <- correl %*% t(correl)
    } else correl <- NULL
    coef <- array(coef, c(p, 3))
    dimnames(coef) <- list(cnames, c("Value", "Std. Error", "t value"))
    coef[, 2] <- rowlen %o% stddev
    coef[, 3] <- coef[, 1]/coef[, 2]
    object <- object["call"]
    object$residuals <- resid
    object$coefficients <- coef
    object$sigma <- s
    object$stddev <- stddev
    object$df <- c(p, rdf, ptotal)
    object$r.squared <- NA
    object$cov.unscaled <- rinv %*% t(rinv)
    object$correlation <- correl
    object$terms <- NA
    class(object) <- "summary.rlm"
    object
}

print.summary.rlm <-
function(x, digits = max(3, .Options$digits - 3), ...)
{
    cat("\nCall: ")
    dput(x$call)
    resid <- x$residuals
    df <- x$df
    rdf <- df[2]
    if(rdf > 5) {
        cat("Residuals:\n")
        if(length(dim(resid)) == 2) {
            rq <- apply(t(resid), 1, quantile)
            dimnames(rq) <- list(c("Min", "1Q", "Median", "3Q", "Max"),
                                 colnames(resid))
        } else {
            rq <- quantile(resid)
            names(rq) <- c("Min", "1Q", "Median", "3Q", "Max")
        }
        print(rq, digits = digits, ...)
    } else if(rdf > 0) {
        cat("Residuals:\n")
        print(resid, digits = digits, ...)
    }
    if(nsingular <- df[3] - df[1])
        cat("\nCoefficients: (", nsingular,
            " not defined because of singularities)\n", sep = "")
    else cat("\nCoefficients:\n")
    print(format(round(x$coef, digits = digits)), quote = FALSE, ...)
    cat("\nResidual standard error:", format(signif(x$sigma, digits)),
        "on", rdf, "degrees of freedom\n")
    if(!is.null(correl <- x$correlation)) {
        p <- dim(correl)[2]
        if(p > 1) {
            cat("\nCorrelation of Coefficients:\n")
            ll <- lower.tri(correl)
            correl[ll] <- format(round(correl[ll], digits))
            correl[!ll] <- ""
            print(correl[-1, -p, drop = FALSE], quote = FALSE, digits = digits, ...)
        }
    }
    invisible(x)
}

psi.huber <- function(u, k = 1.345, deriv=0)
{
    if(!deriv) return(pmin(1, k / abs(u)))
    abs(u) <= k
}

psi.hampel <- function(u, a = 2, b = 4, c = 8, deriv=0)
{
    U <- pmin(abs(u) + 1e-50, c)
    if(!deriv) return(ifelse(U <= a, U, ifelse(U <= b, a, a*(c-U)/(c-b) ))/U)
    ifelse(abs(u) <= c, ifelse(U <= a, 1, ifelse(U <= b, 0, -a/(c-b))), 0)
}

psi.bisquare <- function(u, c = 4.685, deriv=0)
{
    if(!deriv) return((1  - pmin(1, abs(u/c))^2)^2)
    t <- (u/c)^2
    ifelse(t < 1, (1 - t)*(1 - 5*t), 0)
}

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

predict.rlm <- function (object, newdata = NULL, scale = NULL, ...)
{
    ## problems with using predict.lm are the scale and
    ## the QR decomp which has been done on down-weighted values.
    object$qr <- qr(sqrt(object$weights) * object$x)
    predict.lm(object, newdata = newdata, scale = object$s, ...)
}
# file MASS/rms.curv.q
# copyright (C) 1994-2002 W. N. Venables and B. D. Ripley
#
"rms.curv"<-
function(obj)
{
  fit.val <- obj$m$fitted()
  v <- attr(fit.val, "gradient")
  if(is.null(v)) stop("gradient attribute missing")
  a <- attr(fit.val, "hessian")
  if(is.null(a)) stop("hessian attribute missing")
  p <- ncol(v)
  n <- nrow(v)
  s <- sqrt(deviance(obj)/(n - p))
  sp <- s * sqrt(p)
  D <- v
  for(j in 1:p) D <- cbind(D, a[, 1:j, j])
  qrd <- qr(D)
  Q <- qr.Q(qrd)
  rnk <- qrd$rank
  if(rnk <= p) warning("regression apparently linear")
  Q1 <- Q[, 1:rnk]
  C <- array(0, c(rnk, p, p))
  for(j in 1:p) C[,  , j] <- crossprod(Q1, a[,  , j])
  C <- aperm(C, c(2, 3, 1))
  r11i <- solve(qr.R(qrd)[1:p, 1:p])
  ct <- 0
  for(j in 1:p) {
    C[,  , j] <- crossprod(r11i, C[,  , j]) %*% r11i * sp
    ct <- ct + 2 * sum(C[,  , j]^2) + sum(diag(C[,  , j]))^2
  }
  ci <- 0
  for(j in (p + 1):rnk) {
    C[,  , j] <- crossprod(r11i, C[,  , j]) %*% r11i * sp
    ci <- ci + 2 * sum(C[,  , j]^2) + sum(diag(C[,  , j]))^2
  }
  ct <- sqrt(ct/(p * (p + 2)))
  ci <- sqrt(ci/(p * (p + 2)))
  pe <- ct * sqrt(qf(19/20, p, n - p))
  ic <- ci * sqrt(qf(19/20, p, n - p))
  val <- list(pe = pe, ic = ic, ct = ct, ci = ci, C = C)
  class(val) <- "rms.curv"
  val
}
"print.rms.curv"<- function(x, ...)
{
  cat("Parameter effects: c^theta x sqrt(F) =", round(x$pe, 4), "\n",
      "       Intrinsic: c^iota  x sqrt(F) =", round(x$ic, 4), "\n",
      ...)
  invisible(x)
}
# file MASS/sammon.q
# copyright (C) 1994-2003 W. N. Venables and B. D. Ripley
#
sammon <- function(d, y= cmdscale(d, k), k=2, niter=100, trace=TRUE,
                   magic=0.2, tol=1e-4)
{
    call <- match.call()
    if(any(is.infinite(as.vector(d))))
        stop("Infs not allowed in d")
    if(any(is.na(d)) && missing(y))
        stop("An initial configuration must be supplied with NAs in d")
    if(is.null(n <- attr(d, "Size"))) {
        x <- as.matrix(d)
        if((n <- nrow(x)) != ncol(x))
            stop("Distances must be result of dist or a square matrix")
    }
    else {
        x <- matrix(0, n, n)
        x[row(x) > col(x)] <- d
        x <- x + t(x)
    }
    ab <- x[row(x) < col(x)]<=0
    if (any(ab)) {
        ab <- !is.na(ab) & ab
        aa <- cbind(as.vector(row(x)), as.vector(col(x)))[row(x) < col(x),]
        aa <- aa[ab,,drop=FALSE]
        stop(paste("zero or negative distance between objects", aa[1,1],
                   "and", aa[1,2]))
    }
    nas <- is.na(x)
    diag(nas) <- FALSE  # diag never used
    if(any(rowSums(!nas) < 2)) stop("not enough non-missing data")

    if(!is.matrix(y)) stop("y must be a matrix")
    if(any(dim(y) != c(n, k)) ) stop("invalid initial configuration")
    if(any(!is.finite(y))) stop("initial configuration must be complete")
    storage.mode(x) <- "double"
    storage.mode(y) <- "double"
    if(!is.loaded(symbol.C("VR_sammon")))
        stop("Compiled code has not been dynamically loaded")
    z <- .C("VR_sammon",
            x = x,
            as.integer(n),
            as.integer(k),
            y = y,
            as.integer(niter),
            e = double(1),
            as.integer(trace),
            as.double(magic),
            as.double(tol),
            NAOK = TRUE, PACKAGE = "MASS"
            )
    points <- z$y
    rn <- if(is.matrix(d)) rownames(d) else names(d)
    dimnames(points) <- list(rn, NULL)
    list(points=points, stress=z$e, call=call)
}
# file MASS/stdres.q
# copyright (C) 1994-9 W. N. Venables and B. D. Ripley
#
lmwork <- function(object)
{
    resid <- object$resid
    hat <- lm.influence(object, do.coef = FALSE)$hat
    hat <- hat[hat > 0]
    ok <- !(is.na(resid))
    n.miss <- sum(!ok)
    switch(ifelse(n.miss > 2, 2, n.miss),
           warning("1 missing observation deleted"),
           warning(paste(n.miss, "missing observations deleted")))
    resid <- resid[ok]
    n <- length(resid)
    p <- object$rank
    rdf <- object$df.resid
    if(is.null(rdf))
        rdf <- n - p
    if(!is.null(object$weights)) {
        wt <- object$weights[ok]
        resid <- resid * wt^0.5
        excl <- wt == 0
        if(any(excl)){
            warning(paste(sum(excl),
                          "rows with zero weights not counted"))
            resid <- resid[!excl]
            if(is.null(object$df.resid))
                rdf <- rdf - sum(excl)
        }
    }
    stdres <- studres <- resid
    if(n > p) {
        stddev <- sqrt(sum(resid^2)/rdf)
        sr <- resid/(sqrt(1 - hat) * stddev)
        stdres <- sr
        studres <- sr/sqrt((n-p-sr^2)/(n-p-1))
        if(!is.null(object$na.action)) {
            stdres <- naresid(object$na.action, stdres)
            studres <- naresid(object$na.action, studres)
        }
    }
    else stddev <- stdres[] <- studres[]<- NA
    list(stdedv=stddev, stdres=stdres, studres=studres)
}
stdres <- function(object) lmwork(object)$stdres
studres <- function(object) lmwork(object)$studres
# file MASS/stepAIC.q
# copyright (C) 1994-2003 W. N. Venables and B. D. Ripley
#
stepAIC <-
  function(object, scope, scale = 0,
           direction = c("both", "backward", "forward"),
           trace = 1, keep = NULL, steps = 1000, use.start = FALSE, k = 2, ...)
{
    mydeviance <- function(x, ...)
    {
        dev <- deviance(x)
        if(!is.null(dev)) dev else extractAIC(x, k=0)[2]
    }

    cut.string <- function(string)
    {
        if(length(string) > 1)
            string[-1] <- paste("\n", string[-1], sep = "")
        string
    }

    re.arrange <- function(keep)
    {
        namr <- names(k1 <- keep[[1]])
        namc <- names(keep)
        nc <- length(keep)
        nr <- length(k1)
        array(unlist(keep, recursive = FALSE), c(nr, nc), list(namr, namc))
    }

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

    Terms <- terms(object)
    object$formula <- Terms
    if(inherits(object, "lme")) object$call$fixed <- Terms
    else if(inherits(object, "gls")) object$call$model <- Terms
    else object$call$formula <- Terms
    if(use.start) warning("use.start cannot be used with R's version of glm")
    md <- missing(direction)
    direction <- match.arg(direction)
    backward <- direction == "both" | direction == "backward"
    forward <- direction == "both" | direction == "forward"
    if(missing(scope)) {
        fdrop <- numeric(0)
        fadd <- attr(Terms, "factors")
        if(md) forward <- FALSE
    } else {
        if(is.list(scope)) {
            fdrop <- if(!is.null(fdrop <- scope$lower))
                attr(terms(update.formula(object, fdrop)), "factors")
            else numeric(0)
            fadd <- if(!is.null(fadd <- scope$upper))
                attr(terms(update.formula(object, fadd)), "factors")
        } else {
            fadd <- if(!is.null(fadd <- scope))
                attr(terms(update.formula(object, scope)), "factors")
            fdrop <- numeric(0)
        }
    }
    models <- vector("list", steps)
    if(!is.null(keep)) keep.list <- vector("list", steps)
    ## watch out for partial matching here.
    if(is.list(object) && (nmm <- match("nobs", names(object), 0)) > 0)
        n <- object[[nmm]]
    else n <- length(residuals(object))
    fit <- object
    bAIC <- extractAIC(fit, scale, k = k, ...)
    edf <- bAIC[1]
    bAIC <- bAIC[2]
    if(is.na(bAIC))
        stop("AIC is not defined for this model, so stepAIC cannot proceed")
    nm <- 1
    Terms <- terms(fit)
    if(trace)
        cat("Start:  AIC=", format(round(bAIC, 2)), "\n",
            cut.string(deparse(as.vector(formula(fit)))), "\n\n")

    models[[nm]] <- list(deviance = mydeviance(fit), df.resid = n - edf,
                         change = "", AIC = bAIC)
    if(!is.null(keep)) keep.list[[nm]] <- keep(fit, bAIC)
    usingCp <- FALSE
    while(steps > 0) {
        steps <- steps - 1
        AIC <- bAIC
        ffac <- attr(Terms, "factors")
        ## don't drop strata terms
        if(!is.null(sp <- attr(Terms, "specials")) &&
           !is.null(st <- sp$strata)) ffac <- ffac[-st,]
        scope <- factor.scope(ffac, list(add = fadd, drop = fdrop))
        aod <- NULL
        change <- NULL
        if(backward && length(scope$drop)) {
            aod <- dropterm(fit, scope$drop, scale = scale,
                            trace = max(0, trace - 1), k = k, ...)
            rn <- row.names(aod)
            row.names(aod) <- c(rn[1], paste("-", rn[-1], sep=" "))
            ## drop all zero df terms first.
            if(any(aod$Df == 0, na.rm=TRUE)) {
                zdf <- aod$Df == 0 & !is.na(aod$Df)
                nc <- match(c("Cp", "AIC"), names(aod))
                nc <- nc[!is.na(nc)][1]
                ch <- abs(aod[zdf, nc] - aod[1, nc]) > 0.01
                if(any(ch)) {
                    warning("0 df terms are changing AIC")
                    zdf <- zdf[!ch]
                }
                ## drop zero df terms first: one at time since they
                ## may mask each other
                if(length(zdf) > 0)
                    change <- rev(rownames(aod)[zdf])[1]
            }
        }
        if(is.null(change)) {
            if(forward && length(scope$add)) {
                aodf <- addterm(fit, scope$add, scale = scale,
                                trace = max(0, trace - 1), k = k, ...)
                rn <- row.names(aodf)
                row.names(aodf) <- c(rn[1], paste("+", rn[-1], sep=" "))
                aod <-
                    if(is.null(aod)) aodf
                    else rbind(aod, aodf[-1, , drop=FALSE])
            }
            attr(aod, "heading") <- NULL
            if(is.null(aod) || ncol(aod) == 0) break
            ## need to remove any terms with zero df from consideration
            nzdf <- if(!is.null(aod$Df)) aod$Df != 0 | is.na(aod$Df)
            aod <- aod[nzdf, ]
            if(is.null(aod) || ncol(aod) == 0) break
            nc <- match(c("Cp", "AIC"), names(aod))
            nc <- nc[!is.na(nc)][1]
            o <- order(aod[, nc])
            if(trace) print(aod[o,  ])
            if(o[1] == 1) break
            change <- rownames(aod)[o[1]]
        }
        usingCp <- match("Cp", names(aod), 0) > 0
        ## may need to look for a 'data' argument in parent
	fit <- update(fit, paste("~ .", change), evaluate = FALSE)
        fit <- eval.parent(fit)
        if(is.list(fit) && (nmm <- match("nobs", names(fit), 0)) > 0)
            nnew <- fit[[nmm]]
        else nnew <- length(residuals(fit))
        if(nnew != n)
            stop("number of rows in use has changed: remove missing values?")
        Terms <- terms(fit)
        bAIC <- extractAIC(fit, scale, k = k, ...)
        edf <- bAIC[1]
        bAIC <- bAIC[2]
        if(trace)
            cat("\nStep:  AIC=", format(round(bAIC, 2)), "\n",
                cut.string(deparse(as.vector(formula(fit)))), "\n\n")
        ## add a tolerance as dropping 0-df terms might increase AIC slightly
        if(bAIC >= AIC + 1e-7) break
        nm <- nm + 1
        models[[nm]] <-
            list(deviance = mydeviance(fit), df.resid = n - edf,
                 change = change, AIC = bAIC)
        if(!is.null(keep)) keep.list[[nm]] <- keep(fit, bAIC)
    }
    if(!is.null(keep)) fit$keep <- re.arrange(keep.list[seq(nm)])
    step.results(models = models[seq(nm)], fit, object, usingCp)
}

extractAIC.loglm <- function(fit, scale, k = 2, ...)
{
    edf <- fit$n - fit$df
    c(edf,  fit$deviance + k * edf)
}

extractAIC.lme <- function(fit, scale, k = 2, ...)
{
    if(fit$method != "ML") stop("AIC undefined for REML fit")
    res <- logLik(fit)
    edf <- attr(res, "df")
    c(edf,  -2*res + k * edf)
}

extractAIC.gls <- function(fit, scale, k = 2, ...)
{
    if(fit$method != "ML") stop("AIC undefined for REML fit")
    res <- logLik(fit)
    edf <- attr(res, "df")
    c(edf,  -2*res + k * edf)
}

terms.gls <- terms.lme <- function(x, ...) terms(formula(x), ...)
# file MASS/truehist.q
# copyright (C) 1994-2003 W. N. Venables and B. D. Ripley
#
"truehist"<-
function(data, nbins = "Scott", h, x0 = -h/1000, breaks,
         prob = TRUE, xlim = range(breaks), ymax = max(est),
	 col = 5,
	 xlab = deparse(substitute(data)), bty = "n", ...)
{
    plot.truehist <-
        function(breaks, est, xlim, ymax, bty, xlab, ylab = "",
                 density = NULL, angle = 45,
                 col = NULL, border = NULL, lty = NULL, lwd = par("lwd"), ...)
    {
        n <- length(breaks)
        plot(xlim, c(0, ymax), type = "n", xlab = xlab, ylab = ylab,
             bty = bty, ...)
        rect(breaks[-n], 0, breaks[-1], est,
             density = density, angle = angle,
             col = col, border = border, lty = lty, lwd = lwd)
    }
    xlab  # force evaluation
    data <- data[!is.na(data)]
    if(missing(breaks)) {
        if(missing(h)) {
            if(is.character(nbins))
                nbins <- switch(casefold(nbins),
                                scott = nclass.scott(data),
                                "freedman-diaconis" = , fd = nclass.FD(data)
                                )
            h <- diff(pretty(data, nbins))[1]
        }
        first <- floor((min(data) - x0)/h)
        last <- ceiling((max(data) - x0)/h)
        breaks <- x0 + h * c(first:last)
    }
    if(any(diff(breaks) <= 0)) stop("breaks must be strictly increasing")
    if(min(data) < min(breaks) || max(data) > max(breaks))
        stop("breaks do not cover the data")
    db <- diff(breaks)
    if(!prob && sqrt(var(db)) > mean(db)/1000)
        warning("Uneven breaks with prob = FALSE will give a misleading plot")
    bin <- cut(data, breaks, include.lowest = TRUE)
    est <- tabulate(bin, length(levels(bin)))
    if(prob) est <- est/(diff(breaks) * length(data))
    plot.truehist(breaks, est, xlim, ymax, bty=bty, xlab=xlab,
                  col = col, ...)
#     n <- length(breaks)
#     plot(xlim, c(0, ymax), type = "n", xlab = xlab, ylab = "", bty = bty, ...)
#     rect(breaks[-n], 0, breaks[-1], est, col = col, ...)
    invisible()
}
# file MASS/ucv.q
# copyright (C) 1994-9 W. N. Venables and B. D. Ripley
#

width.SJ <- function(x, nb=1000, lower=0.1*hmax, upper=hmax,
		     method = c("ste", "dpi"))
{
    fSD <- function(h, x, alph2, c1, n, d)
        (c1/SDh(x, alph2 * h^(5/7), n, d))^(1/5) - h
    SDh <- function(x, h, n, d)
        .C("VR_phi4_bin",
           as.integer(n),
           as.integer(length(x)),
           as.double(d),
           x,
           as.double(h),
           u = double(1), PACKAGE = "MASS")$u
    TDh <- function(x, h, n, d)
        .C("VR_phi6_bin",
           as.integer(n),
           as.integer(length(x)),
           as.double(d),
           x,
           as.double(h),
           u = double(1), PACKAGE = "MASS")$u

    method <- match.arg(method)
    n <- length(x)
    if(!n) stop("'x' has length zero")
    storage.mode(x) <- "double"
    Z <- .C("VR_den_bin",
            as.integer(n),
            as.integer(nb),
            d = double(1),
            x,
            cnt = integer(nb), PACKAGE = "MASS"
            )
    d <- Z$d; cnt <- as.integer(Z$cnt)
    hmax <- 1.144 * sqrt(var(x)) * n^(-1/5)
    scale <- min(sqrt(var(x)), IQR(x)/1.349)
    a <- 1.24 * scale * n^(-1/7)
    b <- 1.23 * scale * n^(-1/9)
    c1 <- 1/(2*sqrt(pi)*n)
    TD  <- -TDh(cnt, b, n, d)
    alph2 <- 1.357*(SDh(cnt, a, n, d)/TD)^(1/7)
    if(method == "dpi")
        res <- (c1/SDh(cnt,(2.394/(n * TD))^(1/7) , n, d))^(1/5)
    else {
        if (fSD(lower, cnt, alph2, c1, n, d) *
            fSD(upper, cnt, alph2, c1, n, d) > 0)
            stop("No solution in the specified range of bandwidths")
        res <- uniroot(fSD, c(lower, upper), tol=0.1*lower,
                       x=cnt, alph2=alph2, c1=c1, n=n, d=d)$root
    }
    4 * res
}


ucv <- function(x, nb=1000, lower=0.1*hmax, upper=hmax)
{
    fucv <- function(h, x, n, d)
        .C("VR_ucv_bin",
           as.integer(n),
           as.integer(length(x)),
           as.double(d),
           x,
           as.double(h),
           u = double(1), PACKAGE = "MASS")$u

    n <- length(x)
    if(!n) stop("'x' has length zero")
    hmax <- 1.144 * sqrt(var(x)) * n^(-1/5) * 4
    storage.mode(x) <- "double"
    Z <- .C("VR_den_bin",
            as.integer(n),
            as.integer(nb),
            d = double(1),
            x,
            cnt = integer(nb), PACKAGE = "MASS"
            )
    d <- Z$d; cnt <- as.integer(Z$cnt)
    h <- optimize(fucv, c(lower, upper), tol=0.1*lower,
                  x=cnt, n=n, d=d)$minimum
    if(h < 1.1*lower | h > upper-0.1*lower)
        warning("minimum occurred at one end of the range")
    h
}

bcv <- function(x, nb=1000, lower=0.1*hmax, upper=hmax)
{
    fbcv <- function(h, x, n, d)
        .C("VR_bcv_bin",
           as.integer(n),
           as.integer(length(x)),
           as.double(d),
           x,
           as.double(h),
           u = double(1), PACKAGE = "MASS")$u

    n <- length(x)
    if(!n) stop("'x' has length zero")
    hmax <- 1.144 * sqrt(var(x)) * n^(-1/5) * 4
    storage.mode(x) <- "double"
    Z <- .C("VR_den_bin",
            as.integer(n),
            as.integer(nb),
            d = double(1),
            x,
            cnt = integer(nb), PACKAGE = "MASS"
            )
    d <- Z$d; cnt <- as.integer(Z$cnt)
    h<- optimize(fbcv, c(lower, upper), tol=0.1*lower,
                 x=cnt, n=n, d=d)$minimum
    if(h < 1.1*lower | h > upper-0.1*lower)
        warning("minimum occurred at one end of the range")
    h
}
# file MASS/write.matrix.q
# copyright (C) 1994-2001 W. N. Venables and B. D. Ripley
#
write.matrix <- function(x, file = "", sep = " ", blocksize)
{
    x <- as.matrix(x)
    p <- ncol(x)
    cn <- colnames(x)
    if(!missing(blocksize) && blocksize > 0) {
        cat(cn, file=file, sep=c(rep(sep, p-1), "\n"))
        nlines <- 0
        nr <- nrow(x)
        while (nlines < nr) {
            nb <- min(blocksize, nr - nlines)
            cat(format(t(x[nlines + (1:nb), ])),
                file = file, append = TRUE,
                sep = c(rep(sep, p-1), "\n"))
            nlines <- nlines + nb
        }
    } else
        cat(c(cn, format(t(x))), file=file, sep=c(rep(sep, p-1), "\n"))
}
.noGenerics <- TRUE

.onAttach <- function(...) require(stats)

.onUnload <- function(libpath)
    library.dynam.unload("MASS", libpath)
