## file biplot.R
## copyright (C) 1998 W. N. Venables and B. D. Ripley
##
biplot <- function(x, ...) UseMethod("biplot")

biplot.default <-
    function(x, y, var.axes = TRUE, col, cex = rep(par("cex"), 2),
	     xlabs = NULL, ylabs = NULL, expand=1, xlim = NULL, ylim = NULL,
	     arrow.len = 0.1, ...)
{
    n <- nrow(x)
    p <- nrow(y)
    if(missing(xlabs)) {
	xlabs <- dimnames(x)[[1]]
	if(is.null(xlabs)) xlabs <- 1:n
    }
    xlabs <- as.character(xlabs)
    dimnames(x) <- list(xlabs, dimnames(x)[[2]])
    if(missing(ylabs)) {
	ylabs <- dimnames(y)[[1]]
	if(is.null(ylabs)) ylabs <- paste("Var", 1:p)
    }
    ylabs <- as.character(ylabs)
    dimnames(y) <- list(ylabs, dimnames(y)[[2]])

    if(length(cex) == 1) cex <- c(cex, cex)
    if(missing(col)) {
	col <- par("col")
	if (!is.numeric(col)) col <- match(col, palette())
	col <- c(col, col + 1)
    }
    else if(length(col) == 1) col <- c(col, col)

    unsigned.range <- function(x) c(-abs(min(x)), abs(max(x)))
    rangx1 <- unsigned.range(x[, 1])
    rangx2 <- unsigned.range(x[, 2])
    rangy1 <- unsigned.range(y[, 1])
    rangy2 <- unsigned.range(y[, 2])

    if(missing(xlim) && missing(ylim))
	xlim <- ylim <- rangx1 <- rangx2 <- range(rangx1, rangx2)
    else if(missing(xlim)) xlim <- rangx1 else ylim <- rangx2
    ratio <- max(rangy1/rangx1, rangy2/rangx2)/expand
    on.exit(par(oldpar))
    oldpar <- par(pty = "s")
    plot(x, type = "n", xlim = xlim, ylim = ylim, col = col[1], ...)
    text(x, xlabs, cex = cex[1], col = col[1], ...)
    par(new = TRUE)
    plot(y, axes = FALSE, type = "n", xlim = xlim*ratio, ylim = ylim*ratio,
	 xlab = "", ylab = "", col = col[1], ...)
    axis(3, col = col[2])
    axis(4, col = col[2])
    box(col = col[1])
    text(y, labels=ylabs, cex = cex[2], col = col[2], ...)
    if(var.axes)
	arrows(0, 0, y[,1] * 0.8, y[,2] * 0.8, col = col[2], length=arrow.len)
    invisible()
}

biplot.princomp <- function(x, choices = 1:2, scale = 1, pc.biplot=FALSE, ...)
{
    if(length(choices) != 2) stop("length of choices must be 2")
    if(!length(scores <- x$scores))
	stop(paste("object", deparse(substitute(x)), "has no scores"))
    lam <- x$sdev[choices]
    if(is.null(n <- x$n.obs)) n <- 1
    lam <- lam * sqrt(n)
    if(scale < 0 || scale > 1) warning("scale is outside [0, 1]")
    if(scale != 0) lam <- lam^scale else lam <- 1
    if(pc.biplot) lam <- lam / sqrt(n)
    biplot.default(t(t(scores[, choices]) / lam),
		   t(t(x$loadings[, choices]) * lam), ...)
    invisible()
}
## Seber pages 506-507, after a Golub original

cancor <- function(x, y, xcenter=TRUE, ycenter=TRUE)
{
    x <- as.matrix(x)
    y <- as.matrix(y)
    if((nr <- nrow(x)) != nrow(y)) stop("unequal number of rows in cancor")
    ncx <- ncol(x)
    ncy <- ncol(y)
    if(!nr || !ncx || !ncy) stop("dimension 0 in x or y")
    if(is.logical(xcenter)) {
	if(xcenter) {
	    xcenter <- apply(x, 2, mean)
	    x <- x - rep(xcenter, rep(nr, ncx))
	}
	else xcenter <- rep(0, ncx)
    }
    else {
	xcenter <- rep(xcenter, length = ncx)
	x <- x - rep(xcenter, rep(nr, ncx))
    }
    if(is.logical(ycenter)) {
	if(ycenter) {
	    ycenter <- apply(y, 2, mean)
	    y <- y - rep(ycenter, rep(nr, ncy))
	}
	else ycenter <- rep(0, ncy)
    }
    else {
	ycenter <- rep(ycenter, length = ncy)
	y <- y - rep(ycenter, rep(nr,ncy))
    }
    qx <- qr(x)
    qy <- qr(y)
    dx <- qx$rank;	if(!dx) stop("`x' has rank 0")
    dy <- qy$rank;	if(!dy) stop("`y' has rank 0")
    ## compute svd(Qx'Qy)
    z <- La.svd(qr.qty(qx, qr.qy(qy, diag(1, nr, dy)))[1:dx,, drop = FALSE],
                dx, dy)
    xcoef <- backsolve((qx$qr)[1:dx, 1:dx, drop = FALSE], z$u)
    rownames(xcoef) <- colnames(x)[qx$pivot][1:dx]
    ycoef <-  backsolve((qy$qr)[1:dy, 1:dy, drop = FALSE], t(z$vt))
    rownames(ycoef) <- colnames(y)[qy$pivot][1:dy]
    list(cor = z$d, xcoef = xcoef, ycoef = ycoef, xcenter = xcenter,
	 ycenter = ycenter)
}
cmdscale <- function (d, k = 2, eig = FALSE) {
    if (any(is.na(d)))
	stop("NA values not allowed in d")
    if (is.null(n <- attr(d, "Size"))) {
	x <- as.matrix(d^2)
	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^2
	x <- x + t(x)
    }
    if((k <- as.integer(k)) > n - 1 || k < 1)
        stop("`k' must be in {1, 2, ..  n - 1}")
    storage.mode(x) <- "double"
    Tmat <- -0.5 * .C("dblcen", x, as.integer(n), PACKAGE="mva")[[1]]
    e <- La.eigen(Tmat, symmetric = TRUE)
    ev <- e$values[1:k]
    points <- e$vectors[, 1:k, drop = FALSE] %*% diag(sqrt(ev), k)
    dimnames(points) <- list(dimnames(d)[[1]], NULL)
    if (eig) list(points = points, eig = ev)
    else points
}
cutree <- function(tree, k=NULL, h=NULL)
{
    if(is.null(n1 <- nrow(tree$merge)) || n1 < 1)
        stop("invalid tree (merge component)")
    n <- n1 + 1
    if(is.null(k) && is.null(h))
        stop("Either k or h must be specified")
    if(is.null(k)) {
        ## h |--> k
        k <- integer(length(h))
        ## S+6 help(cutree) says k(h) = k(h+), but does k(h-) [continuity]
        ## h < min() should give k = n;
        k <- n+1 - apply(outer(c(tree$height,Inf), h, ">"), 2, which.max)
        if(getOption("verbose")) cat("cutree(): k(h) = ",k,"\n")
    }
    else {
        k <- as.integer(k)
        if(min(k) < 1 || max(k) > n)
            stop(paste("Elements of k must be between 1 and", n))
    }

    ans <- .Call("R_cutree", tree$merge, k, PACKAGE = "mva")

    if(length(k) == 1) {
        ans <- as.vector(ans)
        names(ans) <- tree$labels
    }
    else{
        colnames(ans) <- if(!is.null(h)) h else k
        rownames(ans) <- tree$labels
    }
    return(ans)
}
as.dendrogram <- function(object, ...) UseMethod("as.dendrogram")

as.dendrogram.hclust <- function(object, ...)
{
    if(is.null(object$labels))
        object$labels <- object$order

    z <- list()
    for(k in 1:nrow(object$merge)){
        x <- sort(object$merge[k,])
        k <- as.character(k)
        if(all(x<0)){  # two leaves
            z[[k]] <- as.list(object$labels[-x])
            attr(z[[k]],"members") <- 2
            attr(z[[k]],"midpoint") <- 0.5
            attr(z[[k]][[1]], "members") <-
              attr(z[[k]][[2]], "members") <- 1
            attr(z[[k]][[1]], "height") <-
              attr(z[[k]][[2]], "height") <- 0

        }
        else if(x[1]<0){ # one leave, one node
            z[[k]] <- list(object$labels[-x[1]],
                           z[[as.character(x[2])]])
            x <- as.character(x)
            attr(z[[k]],"members") <-
                attr(z[[x[2]]],"members")+1
            attr(z[[k]], "midpoint") <-
                (1+attr(z[[x[2]]],"midpoint"))/2
            attr(z[[k]][[1]], "members") <- 1
            attr(z[[k]][[1]], "height") <- 0
        }
        else{ # two nodes
            x <- as.character(x)
            z[[k]] <- list(z[[x[1]]],
                           z[[x[2]]])
            attr(z[[k]],"members") <-
                attr(z[[x[1]]], "members")+
                    attr(z[[x[2]]], "members")
            attr(z[[k]],"midpoint") <-
                (attr(z[[x[1]]], "members")+
                 attr(z[[x[1]]], "midpoint")+
                 attr(z[[x[2]]], "midpoint"))/2
        }
        attr(z[[k]],"height") <- object$height[as.integer(k)]
    }
    z <- z[[k]]
    class(z) <- "dendrogram"
    z
}

plot.dendrogram <-
    function(x, type=c("rectangle", "triangle"),
             center=FALSE, xlab="", ylab="", ...) {

    type <- match.arg(type)
    plot(0, xlim=c(0, attr(x, "members")+1),
         ylim=c(0, attr(x, "height")), type="n",
         xlab=xlab, ylab=ylab, ...)

    if(center)
        plotNode(0.5, attr(x, "members")+.5,
                 x, type, center)
    else
        plotNode(1, attr(x, "members"),
                 x, type, center)
}

### the work horse: plots lines from a node to all
### children
plotNode <- function(x1, x2, subtree, type, center){

    if(is.recursive(subtree) & (x1!=x2)){
        K <- length(subtree)
        topy <- attr(subtree, "height")

        bx <- plotNodeLimit(x1, x2, subtree, center)
        topx <- bx$x

        for(k in 1:K){
            boty <- attr(subtree[[k]], "height")
            if(is.null(boty)) boty <- 0

            if(center){
                botx <- mean(c(bx$limit[k], bx$limit[k+1]))
            }
            else{
                mid <- attr(subtree[[k]],"midpoint")
                if(is.null(mid)) mid <- 0
                botx <- bx$limit[k] + mid

            }

            if(type=="triangle")
                lines(c(topx, botx), c(topy, boty))
            else{
                lines(c(topx, botx), c(topy, topy))
                lines(c(botx, botx), c(topy, boty))
            }

            plotNode(bx$limit[k], bx$limit[k+1],
                     subtree[[k]], type, center)
        }
    }
}


### get the left borders of all children and the
### handle point for the edge connecting to
### the parent.
plotNodeLimit <- function(x1, x2, subtree, center){

    limit <- c(x1, x2)
    x <- mean(c(x1,x2))
    if(is.recursive(subtree) & (x1!=x2)){
        K <- length(subtree)
        topm <- attr(subtree, "members")
        limit <- integer(K)
        xx1 <- x1
        for(k in 1:K){
            m <- attr(subtree[[k]], "members")
            if(is.null(m)) m <- 1
            if(center)
                limit[k] <- xx1 + (x2-x1) * m/topm
            else
                limit[k] <- xx1 + m
            xx1 <- limit[k]
        }
        limit <- c(x1, limit)
        if(!center){
            x <- x1 + attr(subtree, "midpoint")
        }
    }
    list(x=x, limit=limit)
}

cut.dendrogram <- function(x, h, ...)
{
    LOWER <- NULL
    X <- 1

    assignNodes <- function(subtree, h){

        if(is.recursive(subtree)){
            for(k in 1:length(subtree)){
                if(attr(subtree[[k]], "height")<=h){
                    sub <- subtree[[k]]
                    class(sub) <- "dendrogram"
                    LOWER[[X]] <<- sub
                    at <- attributes(subtree[[k]])
                    subtree[[k]] <- paste("Branch", X)
                    attributes(subtree[[k]]) <- at
                    X <<- X+1
                }
                else
                    subtree[[k]] <- assignNodes(subtree[[k]], h)
            }
        }
        subtree
    }

    list(upper=assignNodes(x, h), lower=LOWER)
}




dist <- function(x, method="euclidean", diag=FALSE, upper=FALSE)
{
    ## account for possible spellings of euclid?an
    if(!is.na(pmatch(method, "euclidian")))
	method <- "euclidean"

    METHODS <- c("euclidean", "maximum",
                 "manhattan", "canberra", "binary")
    method <- pmatch(method, METHODS)
    if(is.na(method))
	stop("invalid distance method")
    if(method == -1)
	stop("ambiguous distance method")

    N <- nrow(x <- as.matrix(x))
    d <- .C("R_distance",
	    x = as.double(x),
	    nr= N,
	    nc= ncol(x),
	    d = double(N*(N - 1)/2),
	    diag  = as.integer(FALSE),
	    method= as.integer(method),
	    DUP = FALSE, NAOK=TRUE, PACKAGE="mva")$d
    attr(d, "Size") <- N
    attr(d, "Labels") <- dimnames(x)[[1]]
    attr(d, "Diag") <- diag
    attr(d, "Upper") <- upper
    attr(d, "method") <- METHODS[method]
    attr(d, "call") <- match.call()
    class(d) <- "dist"
    return(d)
}

names.dist <- function(x) attr(x, "Labels")

"names<-.dist" <- function(x, value)
{
    if(length(value) != attr(x, "Size"))
	stop("invalid names for dist object")
    attr(x, "Labels") <- value
    x
}

## Because names(d) != length(d) for "dist"-object d, we need
format.dist <- function(x, ...) format(as.vector(x), ...)

as.matrix.dist <- function(x)
{
    size <- attr(x, "Size")
    df <- matrix(0, size, size)
    df[row(df) > col(df)] <- x
    df <- df + t(df)
    labels <- attr(x, "Labels")
    dimnames(df) <-
	if(is.null(labels)) list(1:size,1:size) else list(labels,labels)
    df
}


as.dist <- function(m, diag = FALSE, upper=FALSE)
{
    m <- as.matrix(m)

    retval <-  m[row(m) > col(m)]

    attributes(retval) <- NULL

    if(!is.null(rownames(m)))
        attr(retval,"Labels") <- rownames(m)
    else if(!is.null(colnames(m)))
        attr(retval,"Labels") <- colnames(m)

    attr(retval,"Size") <- nrow(m)
    attr(retval,"Diag") <- diag
    attr(retval,"Upper") <- upper
    attr(retval, "call") <- match.call()
    class(retval) <- "dist"
    retval
}


print.dist <- function(x, diag = NULL, upper = NULL, ...)
{
    if(is.null(diag))
	diag <-  if(is.null(a <- attr(x, "Diag"))) FALSE else a
    if(is.null(upper))
	upper <- if(is.null(a <- attr(x,"Upper"))) FALSE else a

    size <- attr(x, "Size")
    df <- as.matrix.dist(x)
    if(!upper)
	df[row(df) < col(df)] <- NA
    if(!diag)
	df[row(df) == col(df)] <- NA
    print(if(diag || upper) df else df[-1, -size], na = "", ...)
    invisible(x)
}
factanal <-
    function (x, factors, data = NULL, covmat = NULL, n.obs = NA,
              subset, na.action, start = NULL,
              scores = c("none", "regression", "Bartlett"),
              rotation = "varimax",
              control = NULL, ...)
{
    sortLoadings <- function(Lambda)
    {
        cn <- colnames(Lambda)
        Phi <- attr(Lambda, "covariance")
        ssq <- apply(Lambda, 2, function(x) -sum(x^2))
        Lambda <- Lambda[, order(ssq), drop = FALSE]
        colnames(Lambda) <- cn
        neg <- apply(Lambda, 2, sum) < 0
        Lambda[, neg] <- -Lambda[, neg]
        if(!is.null(Phi)) {
            unit <- ifelse(neg, -1, 1)
            attr(Lambda, "covariance") <-
                unit %*% Phi[order(ssq), order(ssq)] %*% unit
        }
        Lambda
    }
    cl <- match.call()
    na.act <- NULL
    if (is.list(covmat)) {
        if (any(is.na(match(c("cov", "n.obs"), names(covmat)))))
            stop("covmat is not a valid covariance list")
        cv <- covmat$cov
        n.obs <- covmat$n.obs
        have.x <- FALSE
    }
    else if (is.matrix(covmat)) {
        cv <- covmat
        cen <- NULL
        have.x <- FALSE
    }
    else if (is.null(covmat)) {
        if(missing(x)) stop("neither x nor covmat supplied")
        have.x <- TRUE
        if(inherits(x, "formula")) {
            mt <- terms(x, data = data)
            if(attr(mt, "response") > 0)
                stop("response not allowed in formula")
            attr(mt, "intercept") <- 0
            mf <- match.call(expand.dots = FALSE)
            names(mf)[names(mf) == "x"] <- "formula"
            mf$factors <- mf$covmat <- mf$scores <- mf$start <-
                mf$rotation <- mf$control <- mf$... <- NULL
            mf[[1]] <- as.name("model.frame")
            mf <- eval(mf, parent.frame())
            na.act <- attr(mf, "na.action")
            z <- model.matrix(mt, mf)
        } else {
            z <- as.matrix(x)
            if(!missing(subset)) z <- z[subset, , drop = FALSE]
        }
        covmat <- cov.wt(z)
        cv <- covmat$cov
        n.obs <- covmat$n.obs
    }
    else stop("covmat is of unknown type")
    scores <- match.arg(scores)
    if(scores != "none" && !have.x)
        stop("requested scores without an x matrix")
    sds <- sqrt(diag(cv))
    cv <- cv/(sds %o% sds)
    p <- ncol(cv)
    dof <- 0.5 * ((p - factors)^2 - p - factors)
    if(dof < 0)
        stop(paste(factors, "factors is too many for", p, "variables"))

    cn <- list(nstart = 1, trace = FALSE, lower = 0.005)
    cn[names(control)] <- control
    more <- list(...)[c("nstart", "trace", "lower", "opt", "rotate")]
    if(length(more)) cn[names(more)] <- more

    if(is.null(start)) {
        start <- (1 - 0.5*factors/p)/diag(solve(cv))
        if((ns <- cn$nstart) > 1)
            start <- cbind(start, matrix(runif(ns-1), p, ns-1, byrow=TRUE))
    }
    start <- as.matrix(start)
    if(nrow(start) != p) stop(paste("start must have", p, "rows"))
    nc <- ncol(start)
    if(nc < 1) stop("no starting values supplied")

    best <- Inf
    for (i in 1:nc) {
        nfit <- factanal.fit.mle(cv, factors, start[, i],
                                 max(cn$lower, 0), cn$opt)
        if(cn$trace)
            cat("start", i, "value:", format(nfit$criteria[1]),
                "uniqs:", format(as.vector(round(nfit$uniquenesses, 4))), "\n")
        if(nfit$converged && nfit$criteria[1] < best) {
            fit <- nfit
            best <- fit$criteria[1]
        }
    }
    if(best == Inf) stop("Unable to optimize from these starting value(s)")
    load <- fit$loadings
    if(rotation != "none") {
        rot <- do.call(rotation, c(list(load), cn$rotate))
        load <- if(is.list(rot)) rot$loadings else rot
    }
    fit$loadings <- sortLoadings(load)
    class(fit$loadings) <- "loadings"
    fit$na.action <- na.act
    if(have.x && scores != "none") {
        Lambda <- fit$loadings
        zz <- scale(z, TRUE, TRUE)
        switch(scores,
               regression = {
                   sc <- zz %*% solve(cv, Lambda)
                   if(!is.null(Phi <- attr(Lambda, "covariance")))
                       sc <- sc %*% Phi
               },
               Bartlett = {
                   d <- 1/fit$uniquenesses
                   tmp <- t(Lambda * d)
                   sc <- t(solve(tmp %*% Lambda, tmp %*% t(zz)))
               })
        rownames(sc) <- rownames(z)
        colnames(sc) <- colnames(Lambda)
        if(!is.null(na.act)) sc <- napredict(na.act, sc)
        fit$scores <- sc
    }
    fit$n.obs <- n.obs
    fit$call <- cl
    fit
}

factanal.fit.mle <-
    function(cmat, factors, start=NULL, lower = 0.005, control = NULL, ...)
{
    FAout <- function(Psi, S, q)
    {
        sc <- diag(1/sqrt(Psi))
        Sstar <- sc %*% S %*% sc
        E <- La.eigen(Sstar, symmetric = TRUE)
        L <- E$vectors[, 1:q, drop = FALSE]
        load <- L %*% diag(sqrt(pmax(E$values[1:q] - 1, 0)), q)
        diag(sqrt(Psi)) %*% load
    }
    FAfn <- function(Psi, S, q)
    {
        sc <- diag(1/sqrt(Psi))
        Sstar <- sc %*% S %*% sc
        E <- La.eigen(Sstar, symmetric = TRUE, only.values = TRUE)
        e <- E$values[-(1:q)]
        e <- sum(log(e) - e) - q + nrow(S)
##        print(round(c(Psi, -e), 5))  # for tracing
        -e
    }
    FAgr <- function(Psi, S, q)
    {
        sc <- diag(1/sqrt(Psi))
        Sstar <- sc %*% S %*% sc
        E <- La.eigen(Sstar, symmetric = TRUE)
        L <- E$vectors[, 1:q, drop = FALSE]
        load <- L %*% diag(sqrt(pmax(E$values[1:q] - 1, 0)), q)
        load <- diag(sqrt(Psi)) %*% load
        g <- load %*% t(load) + diag(Psi) - S
        diag(g)/Psi^2
    }
    p <- ncol(cmat)
    if(is.null(start))
        start <- (1 - 0.5*factors/p)/diag(solve(cmat))
    res <- optim(start, FAfn, FAgr, method = "L-BFGS-B",
                 lower = lower, upper = 1,
                 control = c(list(fnscale=1,
                 parscale = rep(0.01, length(start))), control),
                 q = factors, S = cmat)
    Lambda <- FAout(res$par, cmat, factors)
    dimnames(Lambda) <- list(dimnames(cmat)[[1]],
                             paste("Factor", 1:factors, sep = ""))
    p <- ncol(cmat)
    dof <- 0.5 * ((p - factors)^2 - p - factors)
    un <- res$par
    names(un) <- colnames(cmat)
    class(Lambda) <- "loadings"
    ans <- list(converged = res$convergence == 0,
                loadings = Lambda, uniquenesses = un,
                correlation = cmat,
                criteria = c(objective = res$value, counts = res$counts),
                factors = factors, dof = dof, method = "mle")
    class(ans) <- "factanal"
    ans
}

print.loadings <- function(x, digits = 3, cutoff = 0.1, sort = FALSE, ...)
{
    Lambda <- unclass(x)
    p <- nrow(Lambda)
    factors <- ncol(Lambda)
    if (sort) {
        mx <- max.col(abs(Lambda))
        ind <- cbind(1:p, mx)
        mx[abs(Lambda[ind]) < 0.5] <- factors + 1
        Lambda <- Lambda[order(mx, 1:p),]
    }
    cat("\nLoadings:\n")
    fx <- format(round(Lambda, digits))
    names(fx) <- NULL
    nc <- nchar(fx[1])
    fx[abs(Lambda) < cutoff] <- paste(rep(" ", nc), collapse = "")
    print(fx, quote = FALSE, ...)
    vx <- apply(x^2, 2, sum)
    varex <- rbind("SS loadings" = vx)
    if(is.null(attr(x, "covariance"))) {
        varex <- rbind(varex, "Proportion Var" = vx/p)
        if(factors > 1)
            varex <- rbind(varex, "Cumulative Var" = cumsum(vx/p))
    }
    cat("\n")
    print(round(varex, digits))
    invisible(x)
}

print.factanal <- function(x, digits = 3, ...)
{
    cat("\nCall:\n", deparse(x$call), "\n\n", sep = "")
    cat("Uniquenesses:\n")
    print(round(x$uniquenesses, digits), ...)
    print(x$loadings, digits = digits, ...)
    p <- nrow(x$loadings); factors <- x$factors
    if(!is.na(x$n.obs) && x$dof > 0) {
        dof <- x$dof
        stat <- (x$n.obs - 1 - (2 * p + 5)/6 -
                 (2 * factors)/3) * x$criteria["objective"]
        cat("\nTest of the hypothesis that", factors, if(factors == 1)
            "factor is" else "factors are", "sufficient.\n")
        cat("The chi square statistic is", round(stat, 2), "on", dof,
            if(dof == 1) "degree" else "degrees",
            "of freedom.\nThe p-value is",
            signif(1 - pchisq(stat, dof), 3), "\n")
    } else {
        cat(paste("\nThe degrees of freedom for the model is",
                  x$dof, "and the fit was", round(x$criteria["objective"], 4),
                  "\n"))
    }
    invisible(x)
}

varimax <- function(x, normalize = TRUE, eps = 1e-5)
{
    nc <- ncol(x)
    dn <- dimnames(x)
    if(nc < 2) return(x)
    if(normalize) {
        sc <- sqrt(drop(apply(x, 1, function(x) sum(x^2))))
        x <- x/sc
    }
    p <- nrow(x)
    TT <- diag(nc)
    d <- 0
    for(i in 1:1000) {
        z <- x %*% TT
        B  <- t(x) %*% (z^3 - z %*% diag(drop(rep(1, p) %*% z^2))/p)
        sB <- La.svd(B)
        TT <- sB$u %*% sB$vt
        dpast <- d
        d <- sum(sB$d)
        if(d < dpast * (1 + eps)) break
    }
    z <- x %*% TT
    if(normalize) z <- z * sc
    dimnames(z) <- dimnames(x)
    list(loadings = z, rotmat = TT)
}

promax <- function(x, m = 4)
{
    if(ncol(x) < 2) return(x)
    dn <- dimnames(x)
    Phi <- attr(x, "covariance")
    xx <- varimax(x)
    x <- xx$loadings
    Q <- x * abs(x)^(m-1)
    U <- lm.fit(x, Q)$coefficients
    d <- diag(solve(t(U) %*% U))
    U <- U %*% diag(sqrt(d))
    dimnames(U) <- NULL
    z <- x %*% U
    U <- xx$rotmat %*% U
    dimnames(z) <- dn
    attr(z, "covariance") <- crossprod(U)
    list(loadings = z, rotmat = U)
}
## Hierarchical clustering, on raw input data; we will use Euclidean
## distance.  A range of criteria are supported; also there is a
## storage-economic option.
##
## We use the general routine, `hc', which caters for 7 criteria,
## using a half dissimilarity matrix; (BTW, this uses the very efficient
## nearest neighbor chain algorithm, which makes this algorithm of
## O(n^2) computational time, and differentiates it from the less
## efficient -- i.e. O(n^3) -- implementations in all commercial
## statistical packages -- as far as I am aware -- except Clustan.)
##
## Clustering Methods:
##
## 1. Ward's minimum variance or error sum of squares method.
## 2. single linkage or nearest neighbor method.
## 3. complete linkage or diameter.
## 4. average linkage, group average, or UPGMA method.
## 5. McQuitty's or WPGMA method.
## 6. median, Gower's or WPGMC method.
## 7. centroid or UPGMC method (7).
##
## Original author: F. Murtagh, May 1992
## R Modifications: Ross Ihaka, Dec 1996
##		    Friedrich Leisch, Apr 1998, Jun 2000

hclust <- function(d, method="complete", members=NULL)
{
    METHODS <- c("ward", "single",
                 "complete", "average", "mcquitty",
                 "median", "centroid")
    method <-  pmatch(method, METHODS)
    if(is.na(method))
	stop("invalid clustering method")
    if(method == -1)
	stop("ambiguous clustering method")

    n <- as.integer(attr(d, "Size"))
    if(is.null(n))
	stop("invalid dissimilarities")
    if(n < 2)
        stop("Must have n >= 2 objects to cluster")
    labels <- attr(d, "Labels")

    len <- n*(n-1)/2

    if(is.null(members))
        members <- rep(1, n)
    if(length(members) != n)
        stop("Invalid length of members")

    hcl <- .Fortran("hclust",
		    n = as.integer(n),
		    len = as.integer(len),
		    method = as.integer(method),
		    ia = integer(n),
		    ib = integer(n),
		    crit = double(n),
		    members = as.double(members),
		    nn = integer(n),
		    disnn = double(n),
		    flag = logical(n),
		    diss = as.double(d), PACKAGE="mva")

    ## 2nd step: interpret the information that we now have
    ## as merge, height, and order lists.

    hcass <- .Fortran("hcass2",
		      n = as.integer(n),
		      ia = as.integer(hcl$ia),
		      ib = as.integer(hcl$ib),
  		      order = integer(n),
		      iia = integer(n),
		      iib = integer(n), PACKAGE="mva")

    tree <- list(merge = cbind(hcass$iia[1:(n-1)], hcass$iib[1:(n-1)]),
		 height= hcl$crit[1:(n-1)],
		 order = hcass$order,
		 labels=attr(d, "Labels"),
                 method=METHODS[method],
                 call=match.call())

    if(!is.null(attr(d, "method"))){
        tree$dist.method <- attr(d, "method")
    }
    class(tree) <- "hclust"
    tree
}

plot.hclust <-
    function (x, labels = NULL, hang = 0.1,
              axes = TRUE, frame.plot = FALSE, ann = TRUE,
              main = "Cluster Dendrogram",
              sub = NULL, xlab = NULL, ylab = "Height", ...)
{
    merge <- x$merge
    if (!is.matrix(merge) || ncol(merge) != 2)
	stop("invalid dendrogram")
    n <- nrow(merge)
    height <- as.double(x$height)
    order <- as.double(order(x$order))

    labels <-
	if(missing(labels)){
	    if (is.null(x$labels))
		paste(1:(n+1))
	    else
		as.character(x$labels)
	} else {
	    if(is.logical(labels) && !labels)# FALSE
		character(n+1)
	    else
		as.character(labels)
	}

    plot.new()
    .Internal(dend.window(n, merge, height, order, hang, labels, ...))
    .Internal(dend       (n, merge, height, order, hang, labels, ...))
    if(axes)
        axis(2, at=pretty(range(height)))
    if (frame.plot)
        box(...)
    if (ann) {
        if(!is.null(cl <- x$call) && is.null(sub))
            sub <- paste(deparse(cl[[1]])," (*, \"", x$method,"\")",sep="")
        if(is.null(xlab) && !is.null(cl))
            xlab <- deparse(cl[[2]])
        title(main = main, sub = sub, xlab = xlab, ylab = ylab, ...)
    }
    invisible()
}

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

as.hclust.twins <- function(x, ...)
{
    retval <- list(merge = x$merge,
                   height = sort(x$height),
                   order = x$order,
                   call = match.call(),
                   method = NA,
                   dist.method = attr(x$diss, "Metric"),
                   labels = rownames(x$data))
    class(retval) <- "hclust"
    retval
}

print.hclust <- function(x, ...)
{
    if(!is.null(x$call))
        cat("\nCall:\n",deparse(x$call),"\n\n",sep="")
    if(!is.null(x$method))
        cat("Cluster method   :", x$method, "\n")
    if(!is.null(x$dist.method))
        cat("Distance         :", x$dist.method, "\n")
        cat("Number of objects:", length(x$height)+1, "\n")
    cat("\n")
}


rect.hclust <- function(tree, k=NULL, which=NULL,
                        x=NULL, h=NULL, border=2, cluster=NULL)
{
    if(length(h)>1 | length(k)>1)
        stop("k and h must be a scalar")

    if(!is.null(h)){
        if(!is.null(k))
            stop("specify exactly one of k and h")
        k <- min(which(rev(tree$height)<h))
        k <- max(k, 2)
    }
    else
        if(is.null(k))
            stop("specify exactly one of k and h")

    if(k < 2 | k > length(tree$height))
        stop(paste("k must be between 2 and", length(tree$height)))

    if(is.null(cluster))
        cluster <- cutree(tree, k=k)
    ## cutree returns classes sorted by data, we need classes
    ## as occurring in the tree (from left to right)
    clustab <- table(cluster)[unique(cluster[tree$order])]
    m <- c(0, cumsum(clustab))

    if(!is.null(x)){
        if(!is.null(which))
            stop("specify exactly one of which and x")
        which <- x
        for(n in 1:length(x))
            which[n] <- max(which(m<x[n]))
    }
    else
        if(is.null(which))
            which <- 1:k

    if(any(which>k))
        stop(paste("all elements of which must be between 1 and", k))

    border <- rep(border, length=length(which))

    retval <- list()
    for(n in 1:length(which)){
        rect(m[which[n]]+0.66, par("usr")[3],
             m[which[n]+1]+0.33, mean(rev(tree$height)[(k-1):k]),
             border = border[n])
        retval[[n]] <- which(cluster==as.integer(names(clustab)[which[n]]))
    }
    invisible(retval)
}

identify.hclust <- function(x, FUN=NULL, N=20, MAXCLUSTER=20,
                            DEV.FUN=NULL, ...)
{
  cluster <- cutree(x, k=2:MAXCLUSTER)

  retval <- list()
  oldk <- NULL
  oldx <- NULL
  DEV.x <- dev.cur()

  for(n in 1:N){

    dev.set(DEV.x)
    x <- locator(1)
    if(is.null(x))
      break

    k <- min(which(rev(x$height)<x$y), MAXCLUSTER)
    k <- max(k, 2)
    if(!is.null(oldx)){
      rect.hclust(x, k=oldk, x=oldx, cluster=cluster[,oldk-1],
                  border="grey")
    }
    retval[[n]] <- unlist(rect.hclust(x, k=k, x=x$x,
                                      cluster=cluster[,k-1],
                                      border="red"))
    if(!is.null(FUN)){
      if(!is.null(DEV.FUN)){
        dev.set(DEV.FUN)
      }
      retval[[n]] <- FUN(retval[[n]], ...)
    }

    oldx <- x$x
    oldk <- k
  }
  dev.set(DEV.x)
  invisible(retval)
}




kmeans <- function(x, centers, iter.max = 10)
{
    x <- as.matrix(x)
    m <- nrow(x)
    if(missing(centers))
	stop("centers must be a number or a matrix")
    if(length(centers) == 1) {
	k <- centers
	if(m < k)
	    stop("more cluster centers than data points.")
	centers <- x[sample(1:m, k), , drop=FALSE]
    } else {
	centers <- as.matrix(centers)
	k <- nrow(centers)
    }
    if(iter.max < 1) stop("iter.max must be positive.")
    if(m < k)
	stop("more cluster centers than data points.")
    if(ncol(x) != ncol(centers))
	stop("must have same number of columns in x and centers.")
    Z <- .Fortran("kmns",
		  as.double(x),
		  as.integer(m),
		  as.integer(ncol(x)),
		  centers = as.double(centers),
		  as.integer(k),
		  c1 = integer(m),
		  integer(m),
		  nc =integer(k),
		  double(k),
		  double(k),
		  integer(k),
		  double(m),
		  integer(k),
		  integer(k),
		  as.integer(iter.max),
		  wss = double(k),
		  ifault = as.integer(0), PACKAGE="mva")
    switch(Z$ifault,
	   stop("empty cluster: try a better set of initial centers"),
	   warning("did not converge in iter.max iterations"),
	   stop("number of cluster centres must lie between 1 and nrow(x)")
	   )
    centers <- matrix(Z$centers, k)
    dimnames(centers) <- list(1:k, dimnames(x)[[2]])
    list(cluster = Z$c1, centers = centers, withinss = Z$wss, size = Z$nc)
}

prcomp <- function(x, retx = TRUE, center = TRUE, scale. = FALSE,
                   tol = NULL) {
    x <- as.matrix(x)
    x <- scale(x, center = center, scale = scale.)
    s <- svd(x, nu = 0)
    if (!is.null(tol)) {
        rank <- sum(s$d > (s$d[1]*tol))
        if (rank < ncol(x))
            s$v <- s$v[, 1:rank, drop = FALSE]
    }
    s$d <- s$d / sqrt(max(1, nrow(x) - 1))
    dimnames(s$v) <-
        list(colnames(x), paste("PC", seq(len = ncol(s$v)), sep = ""))
    r <- list(sdev = s$d, rotation = s$v)
    if (retx) r$x <- x %*% s$v
    class(r) <- "prcomp"
    r
}

plot.prcomp <- function(x, main = deparse(substitute(x)), ...)
    screeplot(x, main = main, ...)

print.prcomp <- function(x, print.x = FALSE, ...) {
    cat("Standard deviations:\n")
    print(x$sdev, ...)
    cat("\nRotation:\n")
    print(x$rotation, ...)
    if (print.x && length(x$x)) {
        cat("\nRotated variables:\n")
        print(x$x, ...)
    }
    invisible(x)
}

summary.prcomp <- function(object, ...)
{
    vars <- object$sdev^2
    vars <- vars/sum(vars)
    importance <- rbind("Standard deviation" = object$sdev,
                        "Proportion of Variance" = round(vars, 5),
                        "Cumulative Proportion" = round(cumsum(vars), 5))
    colnames(importance) <- colnames(object$rotation)
    object$importance <- importance
    class(object) <- "summary.prcomp"
    object
}

print.summary.prcomp <-
function(x, digits = min(3, getOption("digits")-3), ...) {
    cat("Importance of components:\n")
    print(x$importance, digits = digits)
    invisible(x)
}
## copyright (C) 1998 W. N. Venables and B. D. Ripley
##
predict.princomp <- function(object, newdata, ...) {
    if (missing(newdata)) return(object$scores)
    scale(newdata, object$center, object$scale) %*% object$loadings
}

summary.princomp <-
function(object, loadings = FALSE, cutoff = 0.1, digits = 3, ...) {
    vars <- object$sdev^2
    vars <- vars/sum(vars)
    cat("Importance of components:\n")
    print(rbind("Standard deviation" = object$sdev,
                "Proportion of Variance" = vars,
                "Cumulative Proportion" = cumsum(vars)))
    if(loadings) {
        cat("\nLoadings:\n")
        cx <- format(round(object$loadings, digits = digits))
        cx[abs(object$loadings) < cutoff] <-
            substring("       ", 1, nchar(cx[1,1]))
        print(cx, quote = FALSE, ...)
    }
    invisible(object)
}

plot.princomp <- function(x, main = deparse(substitute(x)), ...)
    screeplot(x, main = main, ...)

screeplot <-
function(x, npcs = min(10, length(x$sdev)),
         type = c("barplot", "lines"),
         main = deparse(substitute(x)), ...)
{
    main
    type <- match.arg(type)
    pcs <- x$sdev^2
    xp <- seq(length=npcs)
    if(type=="barplot")
        barplot(pcs[xp], names = names(pcs[xp]), main = main,
                ylab = "Variances", ...)
    else {
        plot(xp, pcs[xp], type = "b", axes = FALSE, main = main,
             xlab = "", ylab = "Variances", ...)
        axis(2)
        axis(1, at = xp, labels = names(pcs[xp]))
    }
    invisible()
}

loadings <- function(x) x$loadings
princomp <- function(x, ...) UseMethod("princomp")

princomp.formula <- function(x, data = NULL, subset, na.action, ...)
{
    mt <- terms(x, data = data)
    if(attr(mt, "response") > 0) stop("response not allowed in formula")
    attr(mt, "intercept") <- 0
    cl <- match.call()
    mf <- match.call(expand.dots = FALSE)
    mf$... <- NULL
    mf[[1]] <- as.name("model.frame")
    names(mf)[names(mf) == "x"] <- "formula"
    mf <- eval(mf, parent.frame())
    na.act <- attr(mf, "na.action")
    x <- model.matrix(mt, mf)
    res <- princomp.default(x, ...)
    res$call <- cl
    if(!is.null(na.act)) {
        res$na.action <- na.act
        if(!is.null(sc <- res$scores))
            res$scores <- napredict(na.act, sc)
    }
    res
}

princomp.default <-
    function(x, cor = FALSE, scores = TRUE, covmat = NULL,
             subset = rep(TRUE, nrow(as.matrix(x))), ...)
{
    z <- if(!missing(x)) as.matrix(x)[subset, , drop = FALSE]
    if (is.list(covmat)) {
        if(any(is.na(match(c("cov", "n.obs"), names(covmat)))))
            stop("covmat is not a valid covariance list")
        cv <- covmat$cov
        n.obs <- covmat$n.obs
        cen <- covmat$center
    } else if(is.matrix(covmat)) {
        cv <- covmat
        n.obs <- NA
        cen <- NULL
    } else if(is.null(covmat)){
        covmat <- cov.wt(z)             # returns list, cov() does not
        n.obs <- covmat$n.obs
        cv <- covmat$cov * (1 - 1/n.obs)# for S-PLUS compatibility
        cen <- covmat$center
    } else stop("covmat is of unknown type")
    if (cor) {
        sds <- sqrt(diag(cv))
        cv <- cv/(sds %o% sds)
    }
    edc <- La.eigen(cv, symmetric = TRUE)
    ev <- edc$values
    if (any(neg <- ev < 0)) { # S-PLUS sets all := 0
        ## 9 * : on Solaris found case where 5.59 was needed (MM)
        if (any(ev[neg] < - 9 * .Machine$double.eps * ev[1]))
            stop("covariance matrix is not non-negative definite")
        else
            ev[neg] <- 0
    }
    cn <- paste("Comp.", 1:ncol(cv), sep = "")
    names(ev) <- cn
    dimnames(edc$vectors) <- if(missing(x))
        list(dimnames(cv)[[2]], cn) else list(dimnames(x)[[2]], cn)
    sdev <- sqrt(ev)
    sc <- if (cor) sds else rep(1, ncol(cv))
    names(sc) <- colnames(cv)
    scr <- if (scores && !missing(x))
        scale(z, center = TRUE, scale = sc) %*% edc$vectors
    if (is.null(cen)) cen <- rep(NA, nrow(cv))
    edc <- list(sdev = sdev,
                loadings = structure(edc$vectors, class="loadings"),
                center = cen, scale = sc, n.obs = n.obs,
                scores = scr, call = match.call())
    ## The Splus function also return list elements factor.sdev,
    ## correlations and coef, but these are not documented in the help.
    ## coef seems to equal load.  The Splus function also returns list
    ## element terms which is not supported here.
    class(edc) <- "princomp"
    edc
}

print.princomp <- function(x, ...)
{
    cat("Call:\n"); dput(x$call)
    cat("\nStandard deviations:\n")
    print(x$sdev, ...)
    cat("\n", length(x$scale), " variables and ", x$n.obs,
        "observations.\n")
    invisible(x)
}
.First.lib <- function(lib, pkg) library.dynam("mva", pkg, lib)
