.packageName <- "vegan"
"AIC.radfit" <-
    function (object, k = 2, ...) 
{
    mods <- object$models
    unlist(lapply(mods, AIC, k = k))
}
"anosim" <-
    function (dis, grouping, permutations = 1000, strata) 
{
    if (!require(mva)) 
        stop("Requires library `mva'")
    x <- as.dist(dis)
    sol <- c(call = match.call())
    grouping <- as.factor(grouping)
    matched <- function(irow, icol, grouping) {
        grouping[irow] == grouping[icol]
    }
    x.rank <- rank(x)
    N <- attributes(x)$Size
    div <- length(x)/2
    irow <- as.vector(as.dist(row(matrix(nrow = N, ncol = N))))
    icol <- as.vector(as.dist(col(matrix(nrow = N, ncol = N))))
    within <- matched(irow, icol, grouping)
    aver <- tapply(x.rank, within, mean)
    statistic <- -diff(aver)/div
    cl.vec <- rep("Between", length(x))
    take <- as.numeric(irow[within])
    cl.vec[within] <- levels(grouping)[grouping[take]]
    cl.vec <- factor(cl.vec, levels = c("Between", levels(grouping)))
    if (permutations) {
        perm <- rep(0, permutations)
        for (i in 1:permutations) {
            take <- permuted.index(N, strata)
            cl.perm <- grouping[take]
            tmp.within <- matched(irow, icol, cl.perm)
            tmp.ave <- tapply(x.rank, tmp.within, mean)
            perm[i] <- -diff(tmp.ave)/div
        }
        p.val <- sum(perm >= statistic)/permutations
        sol$signif <- p.val
        sol$perm <- perm
    }
    sol$permutations <- permutations
    sol$statistic <- as.numeric(statistic)
    sol$class.vec <- cl.vec
    sol$dis.rank <- x.rank
    sol$dissimilarity <- attr(dis, "method") 
    if (!missing(strata)) {
        sol$strata <- deparse(substitute(strata))
        sol$stratum.values <- strata
    }
    class(sol) <- "anosim"
    sol
}
"anova.cca" <-
    function (object, alpha = 0.05, beta = 0.01, step = 100, perm.max = 10000, 
              ...) 
{
    betaq <- c(beta/2, 1 - beta/2)
    nperm <- 0
    unsure <- TRUE
    hits <- 0
    while (unsure && nperm < perm.max) {
        tst <- permutest.cca(object, step, ...)
        nperm <- nperm + step
        hits <- hits + sum(tst$F.perm >= tst$F.0)
        fork <- qbinom(betaq, nperm, alpha)
        if (hits < fork[1] || hits > fork[2]) 
            unsure <- FALSE
    }
    chi <- c(object$CCA$tot.chi, object$CA$tot.chi)
    df <- c(object$CCA$rank, object$CA$rank)
    Fval <- c(tst$F.0, NA)
    Pval <- c(hits/nperm, NA)
    nperm <- c(nperm, NA)
    table <- data.frame(df, chi, Fval, nperm, Pval)
    is.rda <- inherits(object, "rda")
    dimnames(table) <- list(c("Model", "Residual"), c("Df", ifelse(is.rda, 
                                                                   "Var", "Chisq"), "F", "N.Perm", "Pr(>F)"))
    head <- paste("Permutation test for", tst$method, "under", tst$model, "model\n")
    if (!is.null(tst$strata)) 
        head <- paste(head, "Permutations stratified within `", 
                      tst$strata, "'\n", sep = "")
    mod <- paste("Model:", c(object$call))
    structure(table, heading = c(head, mod), class = c("anova.cca", 
                                             "anova", "data.frame"))
}
"as.fisher" <-
    function(x, ...)
{
    if (inherits(x, "fisher"))
        return(x)
    freq <- x[x>0]
    freq <- table(freq, deparse.level=0)
    class(freq) <- "fisher"
    freq
}
"as.preston" <-
    function(x, ...)
{
    if (inherits(x, "preston"))
        return(x)
    freq <- x[x>0]
    freq <- ceiling(log2(freq))
    freq <- table(freq)
    class(freq) <- "preston"
    freq
}
"as.rad" <-
    function(x)
{
    if (inherits(x, "rad"))
        return(x)
    take <- x > 0
    nm <- names(x)
    comm <- x[take]
    names(comm) <- nm[take]
    comm <- rev(sort(comm))
    class(comm) <- "rad"
    comm
}
"bioenv" <-
    function(...)
{
    UseMethod("bioenv")
}
"bioenv.default" <-
    function (comm, env, method = "spearman", index = "bray", upto=ncol(env), ...) 
{
    n <- ncol(env)
    if (n > 8) {
        if (upto < n)
            cat("Studying", sum(choose(n, 1:upto)), "of ")
        cat(2^n-1, "possible subsets (this may take time...)\n")
    }
    x <- scale(env)
    best <- list()
    comdis <- vegdist(comm, method = index)
    for (i in 1:upto) {
        sets <- ripley.subs(i, 1:n)
        if (!is.matrix(sets)) 
            sets <- as.matrix(t(sets))
        est <- numeric(nrow(sets))
        for (j in 1:nrow(sets)) est[j] <- cor.test(comdis, dist(x[, 
                                                                  sets[j, ]]), method = method)$estimate
        best[[i]] <- list(best = sets[which.max(est), ], est = max(est))
    }
    out <- list(community = deparse(substitute(comm)), environemt = deparse(substitute(env)), 
                names = colnames(env), method = method, index = index, upto = upto, 
                models = best)
    class(out) <- "bioenv"
    out
}
"bioenv.formula" <-
    function(formula, data, ...)
{
    fla <- formula
    comm <- formula[[2]]
    comm <- eval(comm, data, parent.frame())
    formula[[2]] <- NULL
    mf <- model.frame(formula, data, na.action = na.fail)
    if (any(sapply(mf, function(x) is.factor(x) || !is.numeric(x))))
        stop("bioenv applies only to numeric variables")
    env <- attr(mf, "terms")
    attr(env, "intercept") <- 0
    env <- model.matrix(env, mf)
    out <- bioenv(comm, env, ...)
    out$formula <- fla
    out$call <- match.call()
    out
}

"boxplot.specaccum" <-
    function(x, add=FALSE, ...)
{
    if (x$method != "random")
        stop("boxplot available only for method=\"random\"")
    if (!add) {
        plot(x$sites, x$richness, type="n", xlab="Sites", ylab="Species",
             ylim=c(1, max(x$richness)),  ...)
    }
    tmp <- boxplot(data.frame(t(x$perm)), add=TRUE, at=x$sites, axes=FALSE, ...)
    invisible(tmp)
}
"capscale" <-
    function(formula, data, distance = "euclidean", comm=NULL, ...)
{
    if (!inherits(formula, "formula"))
        stop("Needs a model formula")
    if (missing(data)) {
        data <- parent.frame()
    }
    X <- formula[[2]]
    X <- eval(X)
    if (!inherits(X, "dist")) {
        comm <- X
        X <- vegdist(X, method=distance)
    }
    inertia <- attr(X, "method")
    inertia <- paste(toupper(substr(inertia,1,1)), substr(inertia,2,256), sep="")
    inertia <- paste("squared", inertia, "distance")
    k <- attr(X, "Size") - 1
    if (max(X) >= 4 + .Machine$double.eps) {
        inertia <- paste("mean", inertia)
        adjust <- 1
    } else {
        adjust <- k
    }
    X <- cmdscale(X, k = k, eig=TRUE)
    X$points <- adjust * X$points
    neig <- min(which(X$eig < 0) - 1, k) 
    sol <- X$points[, 1:neig]
    fla <- update(formula, sol ~ .)
    d <- ordiParseFormula(fla, data)
    sol <- rda.default(d$X, d$Y, d$Z, ...)
    sol$tot.chi <- sol$tot.chi 
    if (!is.null(sol$CCA)) {
        colnames(sol$CCA$u) <- colnames(sol$CCA$biplot) <- names(sol$CCA$eig) <- 
            colnames(sol$CCA$wa) <-  colnames(sol$CCA$v) <-
                paste("CAP", 1:ncol(sol$CCA$u), sep="")
    }
    if (!is.null(comm)) {
        comm <- scale(comm, center = TRUE, scale = FALSE)
        if (!is.null(sol$pCCA))
            comm <- qr.resid(sol$pCCA$QR, comm)
        if (!is.null(sol$CCA)) {
            sol$CCA$v.eig <- t(comm) %*% sol$CCA$u / sqrt(k)
            sol$CCA$v <- sweep(sol$CCA$v.eig, 2, sqrt(sol$CCA$eig), "/")
            comm <- qr.resid(sol$CCA$QR, comm) 
        }
        if (!is.null(sol$CA)) {
            sol$CA$v.eig <- t(comm) %*% sol$CA$u / sqrt(k)
            sol$CA$v <- sweep(sol$CA$v.eig, 2, sqrt(sol$CA$eig), "/")
        }
    }
    if (!is.null(sol$CCA))
        sol$CCA$centroids <- centroids.cca(sol$CCA$wa, d$modelframe)
    sol$call <- match.call()
    sol$call[[1]] <- as.name("capscale")
    sol$call$formula <- formula
    sol$method <- "capscale"
    sol$inertia <- inertia
    class(sol) <- c("capscale", class(sol))
    sol
}
"cca" <-
function (...) 
{
   UseMethod("cca")
}
"cca.default" <-
    function (X, Y, Z, ...) 
{
    CCA <- NULL
    pCCA <- NULL
    CA <- NULL
    weight.centre <- function(x, w) {
        w.c <- apply(x, 2, weighted.mean, w = w)
        x <- sweep(x, 2, w.c, "-")
        x <- sweep(x, 1, sqrt(w), "*")
        x
    }
    X <- as.matrix(X)
    if (any(rowSums(X) <= 0)) 
        stop("All row sums must be >0 in the community data matrix")
    if (any(colSums(X) <= 0)) {
        X <- X[, colSums(X) > 0]
        warning("Some species were removed because they were missing in the data")
    }
    gran.tot <- sum(X)
    X <- X/gran.tot
    rowsum <- apply(X, 1, sum)
    colsum <- apply(X, 2, sum)
    rc <- outer(rowsum, colsum)
    Xbar <- (X - rc)/sqrt(rc)
    tot.chi <- sum(svd(Xbar, nu = 0, nv = 0)$d^2)
    if (!missing(Z) && !is.null(Z)) {
        Z <- as.matrix(Z)
        Z.r <- weight.centre(Z, rowsum)
        Q <- qr(Z.r)
        Z <- qr.fitted(Q, Xbar)
        tmp <- sum(svd(Z, nu = 0, nv = 0)$d^2)
        pCCA <- list(rank = Q$rank, tot.chi = tmp, QR = Q, Fit = Z)
        Xbar <- qr.resid(Q, Xbar)
    }
    else Z.r <- NULL
    if (!missing(Y) && !is.null(Y)) {
        Y <- as.matrix(Y)
        rawmat <- Y
        Y.r <- weight.centre(Y, rowsum)
        Q <- qr(cbind(Y.r, Z.r))
        if (is.null(pCCA)) 
            rank <- Q$rank
        else rank <- Q$rank - pCCA$rank
        Y <- qr.fitted(Q, Xbar)
        sol <- svd(Y)
        rank <- min(rank, length(sol$d))
        ax.names <- paste("CCA", 1:length(sol$d), sep = "")
        colnames(sol$u) <- ax.names
        colnames(sol$v) <- ax.names
        names(sol$d) <- ax.names
        rownames(sol$u) <- rownames(X)
        rownames(sol$v) <- colnames(X)
        CCA <- list(eig = sol$d[1:rank]^2)
        CCA$u <- sweep(as.matrix(sol$u[, 1:rank, drop = FALSE]), 
                       1, 1/sqrt(rowsum), "*")
        CCA$v <- sweep(as.matrix(sol$v[, 1:rank, drop = FALSE]), 
                       1, 1/sqrt(colsum), "*")
        CCA$u.eig <- sweep(CCA$u, 2, sol$d[1:rank], "*")
        CCA$v.eig <- sweep(CCA$v, 2, sol$d[1:rank], "*")
        CCA$wa.eig <- sweep(Xbar %*% sol$v[, 1:rank, drop = FALSE], 
                            1, 1/sqrt(rowsum), "*")
        CCA$wa <- sweep(CCA$wa.eig, 2, 1/sol$d[1:rank], "*")
        CCA$biplot <- cor(Y.r, sol$u[, 1:rank, drop = FALSE])
        CCA$rank <- rank
        CCA$tot.chi <- sum(CCA$eig)
        CCA$QR <- Q
        CCA$Xbar <- Xbar
        Xbar <- qr.resid(Q, Xbar)
    }
    Q <- qr(Xbar)
    if (Q$rank > 0) {
        sol <- svd(Xbar)
        ax.names <- paste("CA", 1:length(sol$d), sep = "")
        colnames(sol$u) <- ax.names
        colnames(sol$v) <- ax.names
        names(sol$d) <- ax.names
        rownames(sol$u) <- rownames(X)
        rownames(sol$v) <- colnames(X)
        CA <- list(eig = sol$d[1:Q$rank]^2)
        CA$u <- sweep(as.matrix(sol$u[, 1:Q$rank, drop = FALSE]), 
                      1, 1/sqrt(rowsum), "*")
        CA$v <- sweep(as.matrix(sol$v[, 1:Q$rank, drop = FALSE]), 
                      1, 1/sqrt(colsum), "*")
        CA$u.eig <- sweep(CA$u, 2, sol$d[1:Q$rank], "*")
        CA$v.eig <- sweep(CA$v, 2, sol$d[1:Q$rank], "*")
        CA$rank <- Q$rank
        CA$tot.chi <- sum(CA$eig)
        CA$Xbar <- Xbar
    }
    call <- match.call()
    call[[1]] <- as.name("cca")
    sol <- list(call = call, grand.total = gran.tot, rowsum = rowsum, 
                colsum = colsum, tot.chi = tot.chi, pCCA = pCCA, CCA = CCA, 
                CA = CA)
    sol$method <- "cca"
    sol$inertia <- "mean squared contingency coefficient"
    class(sol) <- "cca"
    sol
}
"cca.formula" <-
    function (formula, data) 
{
    if (missing(data)) {
        data <- parent.frame()
    }
    d <- ordiParseFormula(formula, data)
    sol <- cca.default(d$X, d$Y, d$Z)
    if(!is.null(sol$CCA))
        sol$CCA$centroids <- centroids.cca(sol$CCA$wa.eig,
                                           d$modelframe, sol$rowsum)
    sol$terms <- d$terms
    sol$call <- match.call()
    sol$call[[1]] <- as.name("cca")
    sol$call$formula <- formula(d$terms, width.cutoff = 500)
    sol
}
"centroids.cca" <-
function (x, mf, wt) 
{
    mf <- mf[, unlist(lapply(mf, is.factor)), drop = FALSE]
    if (ncol(mf) == 0) 
        return(NA)
    if (missing(wt)) 
        wt <- rep(1, nrow(mf))
    x <- sweep(x, 1, wt, "*")
    workhorse <- function(mf, x, wt) {
        sw <- tapply(wt, mf, sum)
        swx <- apply(x, 2, tapply, mf, sum)
        sweep(swx, 1, sw, "/")
    }
    tmp <- lapply(mf, workhorse, x, wt)
    pnam <- labels(tmp)
    out <- NULL
    for (i in 1:length(tmp)) {
        rownames(tmp[[i]]) <- paste(pnam[i], rownames(tmp[[i]]), 
            sep = "")
        out <- rbind(out, tmp[[i]])
    }
    out
}
"coef.radfit" <-
    function (object, ...) 
{
    out <- sapply(object$models, function(x) if (length(coef(x)) < 
                                                 3) 
                  c(coef(x), rep(NA, 3 - length(coef(x))))
    else coef(x))
    out <- t(out)
    colnames(out) <- paste("par", 1:3, sep = "")
    out
}
"coverscale" <-
function (x, scale = c("Braun.Blanquet", "Domin", "Hult", "Hill", 
    "fix", "log")) 
{
    scale <- match.arg(scale)
    sol <- as.data.frame(x)
    x <- as.matrix(x)
    switch(scale, Braun.Blanquet = {
        codes <- c("r", "+", as.character(1:5))
        lims <- c(0, 0.1, 1, 5, 25, 50, 75, 100)
    }, Domin = {
        codes <- c("+", as.character(1:9), "X")
        lims <- c(0, 0.01, 0.1, 1, 5, 10, 25, 33, 50, 75, 90, 
            100)
    }, Hult = {
        codes <- as.character(1:5)
        lims <- c(0, 100/2^(4:1), 100)
    }, Hill = {
        codes <- as.character(1:5)
        lims <- c(0, 2, 5, 10, 20, 100)
    }, fix = {
        codes <- c("+",as.character(1:9),"X")
        lims <- c(0:10, 11 - 10*.Machine$double.eps)
    }, log = {
        codes <- c("+", as.character(1:9))
        mx <- max(x)
        lims <- c(0, mx/2^(9:1), mx)
    })
    for (i in 1:nrow(x)) {
        tmp <- x[i, ] > 0
        sol[i, tmp] <- cut(x[i, tmp], breaks = lims, labels = codes,
                           right = FALSE, include.lowest = TRUE)
    }
    sol
}
"decorana" <-
    function (veg, iweigh = 0, iresc = 4, ira = 0, mk = 26, short = 0, 
              before = NULL, after = NULL) 
{
    Const1 <- 1e-10
    Const2 <- 5
    Const3 <- 1e-11
    veg <- as.matrix(veg)
    if (any(rowSums(veg) <= 0) || any(colSums(veg) <= 0))
        stop("All row and column sums must be >0 in the community matrix")
    nr <- nrow(veg)
    nc <- ncol(veg)
    mk <- mk + 4
    if (mk < 14) 
        mk <- 14
    if (mk > 50) 
        mk <- 50
    if (ira) 
        iresc <- 0
    if (!is.null(before)) {
        if (is.unsorted(before)) 
            stop("`before' must be sorted")
        if (length(before) != length(after)) 
            stop("`before' and `after' must have same lengths")
        for (i in 1:nr) {
            tmp <- veg[i, ] > 0
            veg[i, tmp] <- approx(before, after, veg[i, tmp], 
                                  rule = 2)$y
        }
    }
    if (iweigh) {
        veg <- downweight(veg, Const2)
    }
    v <- attr(veg, "v")
    v.fraction <- attr(veg, "fraction")
    adotj <- apply(veg, 2, sum)
    adotj[adotj < Const3] <- Const3
    aidot <- apply(veg, 1, sum)
    tot <- sum(adotj)
    yeig1 <- rep(1, nc)
    xeig1 <- rep(1, nr)
    eig <- 1
    nid <- sum(veg > 0)
    cep <- .C("data2hill", as.double(veg), mi = as.integer(nr), 
              n = as.integer(nc), nid = as.integer(nid), ibegin = integer(nr), 
              iend = integer(nr), idat = integer(nid), qidat = double(nid), 
              PACKAGE = "vegan")[c("mi", "n", "nid", "ibegin", "iend", 
              "idat", "qidat")]
    ix1 <- ix2 <- ix3 <- rep(0, cep$mi)
    s1 <- .Fortran("eigy", x = as.double(xeig1), y = as.double(yeig1), 
                   eig = double(1), neig = as.integer(0), ira = as.integer(ira), 
                   iresc = as.integer(iresc), short = as.double(short), 
                   mi = as.integer(cep$mi), mk = as.integer(mk), n = as.integer(cep$n), 
                   nid = as.integer(cep$ni), ibegin = as.integer(cep$ibegin), 
                   iend = as.integer(cep$iend), idat = as.integer(cep$idat), 
                   qidat = as.double(cep$qidat), y2 = double(cep$n), y3 = double(cep$n), 
                   y4 = double(cep$n), y5 = double(cep$n), xeig1 = as.double(xeig1), 
                   xeig2 = double(cep$mi), xeig3 = double(cep$mi), ix1 = as.integer(ix1), 
                   ix2 = as.integer(ix2), ix3 = as.integer(ix3), aidot = as.double(aidot), 
                   adotj = as.double(adotj), PACKAGE = "vegan")[c("x", "y", 
                                             "eig")]
    if (!ira) 
        ix1 <- .Fortran("cutup", x = as.double(s1$x), ix = as.integer(ix1), 
                        mi = as.integer(cep$mi), mk = as.integer(mk), PACKAGE = "vegan")$ix
    s2 <- .Fortran("eigy", x = as.double(xeig1), y = as.double(yeig1), 
                   eig = double(1), neig = as.integer(1), ira = as.integer(ira), 
                   iresc = as.integer(iresc), short = as.double(short), 
                   mi = as.integer(cep$mi), mk = as.integer(mk), n = as.integer(cep$n), 
                   nid = as.integer(cep$ni), ibegin = as.integer(cep$ibegin), 
                   iend = as.integer(cep$iend), idat = as.integer(cep$idat), 
                   qidat = as.double(cep$qidat), y2 = double(cep$n), y3 = double(cep$n), 
                   y4 = double(cep$n), y5 = double(cep$n), xeig1 = as.double(s1$x), 
                   xeig2 = double(cep$mi), xeig3 = double(cep$mi), ix1 = as.integer(ix1), 
                   ix2 = as.integer(ix2), ix3 = as.integer(ix3), aidot = as.double(aidot), 
                   adotj = as.double(adotj), PACKAGE = "vegan")[c("x", "y", 
                                             "eig")]
    if (!ira) 
        ix2 <- .Fortran("cutup", x = as.double(s2$x), ix = as.integer(ix2), 
                        mi = as.integer(cep$mi), mk = as.integer(mk), PACKAGE = "vegan")$ix
    s3 <- .Fortran("eigy", x = as.double(xeig1), y = as.double(yeig1), 
                   eig = double(1), neig = as.integer(2), ira = as.integer(ira), 
                   iresc = as.integer(iresc), short = as.double(short), 
                   mi = as.integer(cep$mi), mk = as.integer(mk), n = as.integer(cep$n), 
                   nid = as.integer(cep$ni), ibegin = as.integer(cep$ibegin), 
                   iend = as.integer(cep$iend), idat = as.integer(cep$idat), 
                   qidat = as.double(cep$qidat), y2 = double(cep$n), y3 = double(cep$n), 
                   y4 = double(cep$n), y5 = double(cep$n), xeig1 = as.double(s1$x), 
                   xeig2 = as.double(s2$x), xeig3 = double(cep$mi), ix1 = as.integer(ix1), 
                   ix2 = as.integer(ix2), ix3 = as.integer(ix3), aidot = as.double(aidot), 
                   adotj = as.double(adotj), PACKAGE = "vegan")[c("x", "y", 
                                             "eig")]
    if (!ira) 
        ix3 <- .Fortran("cutup", x = as.double(s3$x), ix = as.integer(ix3), 
                        mi = as.integer(cep$mi), mk = as.integer(mk), PACKAGE = "vegan")$ix
    s4 <- .Fortran("eigy", x = as.double(xeig1), y = as.double(yeig1), 
                   eig = double(1), neig = as.integer(3), ira = as.integer(ira), 
                   iresc = as.integer(iresc), short = as.double(short), 
                   mi = as.integer(cep$mi), mk = as.integer(mk), n = as.integer(cep$n), 
                   nid = as.integer(cep$ni), ibegin = as.integer(cep$ibegin), 
                   iend = as.integer(cep$iend), idat = as.integer(cep$idat), 
                   qidat = as.double(cep$qidat), y2 = double(cep$n), y3 = double(cep$n), 
                   y4 = double(cep$n), y5 = double(cep$n), xeig1 = as.double(s1$x), 
                   xeig2 = as.double(s2$x), xeig3 = as.double(s3$x), ix1 = as.integer(ix1), 
                   ix2 = as.integer(ix2), ix3 = as.integer(ix3), aidot = as.double(aidot), 
                   adotj = as.double(adotj), PACKAGE = "vegan")[c("x", "y", 
                                             "eig")]
    s1$x <- .Fortran("yxmult", y = as.double(s1$y), x = as.double(s1$x), 
                     as.integer(cep$mi), as.integer(cep$n), as.integer(cep$nid), 
                     as.integer(cep$ibegin), as.integer(cep$iend), as.integer(cep$idat), 
                     as.double(cep$qidat), PACKAGE = "vegan")$x/aidot
    s2$x <- .Fortran("yxmult", y = as.double(s2$y), x = as.double(s2$x), 
                     as.integer(cep$mi), as.integer(cep$n), as.integer(cep$nid), 
                     as.integer(cep$ibegin), as.integer(cep$iend), as.integer(cep$idat), 
                     as.double(cep$qidat), PACKAGE = "vegan")$x/aidot
    s3$x <- .Fortran("yxmult", y = as.double(s3$y), x = as.double(s3$x), 
                     as.integer(cep$mi), as.integer(cep$n), as.integer(cep$nid), 
                     as.integer(cep$ibegin), as.integer(cep$iend), as.integer(cep$idat), 
                     as.double(cep$qidat), PACKAGE = "vegan")$x/aidot
    s4$x <- .Fortran("yxmult", y = as.double(s4$y), x = as.double(s1$x), 
                     as.integer(cep$mi), as.integer(cep$n), as.integer(cep$nid), 
                     as.integer(cep$ibegin), as.integer(cep$iend), as.integer(cep$idat), 
                     as.double(cep$qidat), PACKAGE = "vegan")$x/aidot
    rproj <- cbind(s1$x, s2$x, s3$x, s4$x)
    cproj <- cbind(s1$y, s2$y, s3$y, s4$y)
    evals <- c(s1$eig, s2$eig, s3$eig, s4$eig)
    if (ira) 
        dnames <- paste("RA", 1:4, sep = "")
    else dnames <- paste("DCA", 1:4, sep = "")
    rownames(rproj) <- rownames(veg)
    colnames(rproj) <- dnames
    rownames(cproj) <- colnames(veg)
    colnames(cproj) <- dnames
    names(evals) <- dnames
    origin <- apply(rproj, 2, weighted.mean, aidot)
    if (ira) {
        evals.decorana <- NULL
    }
    else {
        evals.decorana <- evals
        var.r <- cov.wt(rproj, aidot)
        var.r <- diag(var.r$cov) * (1 - sum(var.r$wt^2))
        var.c <- cov.wt(cproj, adotj)
        var.c <- diag(var.c$cov) * (1 - sum(var.c$wt^2))
        evals <- var.r/var.c
    }
    CA <- list(rproj = rproj, cproj = cproj, evals = evals, evals.decorana = evals.decorana, 
               origin = origin, v = v, fraction = v.fraction, adotj = adotj, 
               aidot = aidot, iweigh = iweigh, iresc = iresc, ira = ira, 
               mk = mk - 4, short = short, before = before, after = after, 
               call = match.call())
    class(CA) <- "decorana"
    CA
}
"decostand" <-
    function (x, method, MARGIN) 
{
    x <- as.matrix(x)
    METHODS <- c("total", "max", "frequency", "normalize", "range", 
                 "standardize", "pa", "chi.square")
    method <- match.arg(method, METHODS)
    switch(method, total = {
        if (missing(MARGIN)) 
            MARGIN <- 1
        tmp <- apply(x, MARGIN, sum)
        x <- sweep(x, MARGIN, tmp, "/")
    }, max = {
        if (missing(MARGIN)) 
            MARGIN <- 2
        tmp <- apply(x, MARGIN, max)
        x <- sweep(x, MARGIN, tmp, "/")
    }, frequency = {
        if (missing(MARGIN)) 
            MARGIN <- 2
        tmp <- apply(x, MARGIN, sum)
        fre <- apply(x > 0, MARGIN, sum)
        tmp <- fre/tmp
        x <- sweep(x, MARGIN, tmp, "*")
    }, normalize = {
        if (missing(MARGIN)) 
            MARGIN <- 1
        tmp <- apply(x^2, MARGIN, sum)
        tmp <- sqrt(tmp)
        x <- sweep(x, MARGIN, tmp, "/")
    }, range = {
        if (missing(MARGIN)) 
            MARGIN <- 2
        tmp <- apply(x, MARGIN, min)
        ran <- apply(x, MARGIN, max)
        ran <- ran - tmp
        x <- sweep(x, MARGIN, tmp, "-")
        x <- sweep(x, MARGIN, ran, "/")
    }, standardize = {
        if (!missing(MARGIN) && MARGIN == 1) 
            x <- t(scale(t(x)))
        else x <- scale(x)
    }, pa = {
        tmp <- dim(x)
        nam <- dimnames(x)
        x <- as.numeric(x > 0)
        dim(x) <- tmp
        dimnames(x) <- nam
    }, chi.square = {
        if (!missing(MARGIN) && MARGIN == 2) 
            x <- t(x)
        x <- sqrt(sum(x)) * x/outer(rowSums(x), sqrt(colSums(x)))
    })
    x <- as.data.frame(x)
    x
}
"deviance.capscale" <-
function(object, ...) NA
"deviance.cca" <-
function(object, ...) object$CA$tot.chi * object$grand.tot
"deviance.rda" <-
function(object, ...) object$CA$tot.chi * (nrow(object$CA$Xbar) - 1)
"distconnected" <-
    function(dis, toolong = 1, trace = TRUE)
{
    n <- attr(dis, "Size")
    out <- .C("stepabyss", dis = as.double(dis), n = as.integer(n),
              toolong = as.double(toolong), val = integer(n),
              NAOK = TRUE, PACKAGE = "vegan")$val
    if (trace) {
        cat("Connectivity of distance matrix with threshold dissimilarity",
            toolong,"\n")
        n <- length(unique(out))
        if (n == 1)
            cat("Data are connected\n")
        else {
            cat("Data are disconnected:", n, "groups\n")
            print(table(out, dnn="Groups sizes"))
        }
    }
    out
}
"diversity" <-
  function (x, index = "shannon", MARGIN = 1, base = exp(1)) 
{
  x <- as.matrix(x)
  INDICES <- c("shannon", "simpson", "invsimpson")
  index <- match.arg(index, INDICES)
  total <- apply(x, MARGIN, sum)
  x <- sweep(x, MARGIN, total, "/")
  if (index == "shannon")
    x <- -x * log(x, base)
  else
    x <- x^2
  H <- apply(x, MARGIN, sum, na.rm = TRUE)
  if (index == "simpson") 
    H <- 1 - H
  else if (index == "invsimpson") 
    H <- 1/H
  return(H)
}


"downweight" <-
function (veg, fraction = 5) 
{
    Const1 <- 1e-10
    if (fraction < 1) 
        fraction <- 1/fraction
    veg <- as.matrix(veg)
    yeig1 <- apply(veg, 2, sum)
    y2 <- apply(veg^2, 2, sum) + Const1
    y2 <- yeig1^2/y2
    amax <- max(y2)/fraction
    v <- rep(1, ncol(veg))
    downers <- y2 < amax
    v[downers] <- (y2/amax)[downers]
    veg <- sweep(veg, 2, v, "*")
    attr(veg, "v") <- v
    attr(veg, "fraction") <- fraction
    veg
}
"eigengrad" <-
function (x, w) 
{
    attr(wascores(x, w, expand=TRUE), "shrinkage")
}
"envfit" <-
    function (X, P, permutations = 0, strata, choices=c(1,2)) 
{
    vectors <- NULL
    factors <- NULL
    seed <- NULL
    if (is.data.frame(P)) {
        facts <- unlist(lapply(P, is.factor))
        if (sum(facts)) {
            Pfac <- P[, facts, drop=FALSE]
            P <- P[, !facts, drop=FALSE]
            if (length(P)) {
                if (permutations) {
                    if(!exists(".Random.seed", envir=.GlobalEnv,
                               inherits = FALSE)) { 
                        runif(1)
                    }
                    seed <- get(".Random.seed", envir=.GlobalEnv,
                                inherits = FALSE)
                }
                vectors <- vectorfit(X, P, permutations, strata, choices)
            }
            if (!is.null(seed)) {
                assign(".Random.seed",  seed, envir=.GlobalEnv)
            }
            factors <- factorfit(X, Pfac, permutations, strata, choices)
            sol <- list(vector = vectors, factors = factors)
        }
        else vectors <- vectorfit(X, P, permutations, strata, choices)
    }
    else vectors <- vectorfit(X, P, permutations, strata, choices)
    sol <- list(vectors = vectors, factors = factors)
    class(sol) <- "envfit"
    sol
}
"extractAIC.cca" <-
function (fit, scale = 0, k = 2, ...)
{
   n <- nrow(fit$CA$Xbar)
   edf <- 1
   if (!is.null(fit$CCA$rank)) edf <- edf + fit$CCA$rank
   if (!is.null(fit$pCCA$rank)) edf <- edf + fit$pCCA$rank
   #edf <- n - fit$CA$rank
   RSS <- deviance(fit)
   dev <- if(scale > 0)
       RSS/scale - n
   else n * log(RSS/n)
   c(edf, dev + k*edf)
}
"factorfit" <-
    function (X, P, permutations = 0, strata, choices = c(1, 2)) 
{
    GOF <- function(X, A) {
        n <- table(A)
        N <- sum(n) - 1
        n <- n - 1
        totvar <- N * sum(apply(X, 2, var))
        tmp <- apply(X, 2, tapply, A, var)
        invar <- sum(sweep(tmp, 1, n, "*"))
        r <- 1 - invar/totvar
        r
    }
    sol <- NULL
    r <- NULL
    pval <- NULL
    var.id <- NULL
    X <- scores(X, display = "sites", choices)
    P <- as.data.frame(P)
    for (i in 1:length(P)) {
        tmp <- apply(X, 2, tapply, P[[i]], mean)
        nam <- rownames(tmp)
        nam <- paste(names(P)[i], nam, sep = "")
        var.id <- c(var.id, rep(names(P)[i], length(nam)))
        rownames(tmp) <- nam
        sol <- rbind(sol, tmp)
        r.this <- GOF(X, P[[i]])
        r <- c(r, r.this)
        if (permutations) {
            A <- P[[i]]
            tmp <- rep(NA, permutations)
            for (i in 1:permutations) {
                indx <- permuted.index(length(A), strata)
                take <- A[indx]
                tmp[i] <- GOF(X, take)
            }
            pval.this <- sum(tmp > r.this)/permutations
            pval <- c(pval, pval.this)
        }
    }
    if (is.null(colnames(X))) 
        colnames(sol) <- paste("Dim", 1:ncol(sol), sep = "")
    else colnames(sol) <- colnames(X)
    names(r) <- names(P)
    if (!is.null(pval)) 
        names(pval) <- names(P)
    out <- list(centroids = sol, r = r, permutations = permutations, 
                pvals = pval, var.id = var.id)
    if (!missing(strata)) {
        out$strata <- deparse(substitute(strata))
        out$stratum.values <- strata
    }
    class(out) <- "factorfit"
    out
}
"fisher.alpha" <-
    function (x, MARGIN = 1, se = FALSE, ...) 
{
    x <- as.matrix(x)
    if(ncol(x) == 1)
        x <- t(x)
    sol <- apply(x, MARGIN, fisherfit)
    out <-  unlist(lapply(sol, function(x) x$estimate))
    if (se) {
        out <- list(alpha = out)
        out$se <- unlist(lapply(sol, function(x) sqrt(diag(solve(x$hessian)))[1]))
        out$df.residual <- unlist(lapply(sol, df.residual))
        out$code <- unlist(lapply(sol, function(x) x$code))
        out <- as.data.frame(out)
    }
    out
}
"fisherfit" <-
    function (x, ...) 
{
    Dev.logseries <- function(n.r, p, N) {
        r <- as.numeric(names(n.r))
        x <- N/(N + p)
        logmu <- log(p) + log(x) * r - log(r)
        lhood <- -sum(n.r * (logmu - log(n.r)) + 1) - p * log(1 - 
                                                              x)
        lhood
    }
    tmp <- as.rad(x)
    N <- sum(x)
    tmp <- tmp/N
    p <- 1/sum(tmp^2)
    n.r <- as.fisher(x)
    LSeries <- nlm(Dev.logseries, n.r = n.r, p = p, N = N, 
                   hessian = TRUE, ...)
    LSeries$df.residual <- sum(x > 0) - 1
    LSeries$nuisance <- N/(N + LSeries$estimate)
    LSeries$fisher <- n.r
    class(LSeries) <- "fisherfit"
    LSeries
}
"fitted.procrustes" <-
  function(object, truemean = TRUE, ...)
{
  fit <- object$Yrot
  if (truemean)
    fit <- sweep(fit, 2, object$translation, "+")
  fit
}
"fitted.radfit" <-
function(object, ...) sapply(object$models, fitted)
"humpfit" <-
    function(mass, spno, family = poisson)
{
    hump <- function(p, mass, spno, ...)
    {
        x <- ifelse(mass < p[1], mass/p[1], p[1]*p[1]/mass/mass)
        fv <- p[3]*log(1 + p[2]*x/p[3])
        n <- wt <- rep(1, length(x))
        dev <- sum(dev.resids(spno, fv, wt))
        aicfun(spno, n, fv, wt, dev)/2
    }
    fam <- family(link="identity")
    #fam$link = "fisher"
    #fam$linkinv = function(eta, alpha) alpha*log(1 + eta/alpha)
    #fam$linkfun = function(mu, alpha) alpha*(exp(mu/alpha) - 1)
    aicfun <- fam$aic
    dev.resids <- fam$dev.resids
    p <- c(mean(mass), 100, 10)
    fit <- nlm(hump, p = p, mass=mass, spno=spno, hessian=TRUE)
    p <- fit$estimate
    names(p) <- c("hump","scale","alpha")
    x <- ifelse(mass < p[1], mass/p[1], p[1]*p[1]/mass/mass)
    fv <- p[3]*log(1 + p[2]*x/p[3])
    res <- dev.resids(spno, fv, rep(1, length(x)))
    dev <- sum(res)
    residuals <- spno - fv
    aic <- fit$minimum*2 + 6
    rdf <- length(x) - 3
    out <- list(nlm = fit, family = fam, y = spno, x = mass,
                coefficients = p, fitted.values = fv,
                aic = aic, rank = 3, df.residual = rdf, deviance = dev,
                residuals = residuals, prior.weights = rep(1, length(x)))
    class(out) <- c("humpfit", "glm")
    out
}
"identify.ordiplot" <-
function (x, what, ...) 
{
    x <- scores(x, what)
    out <- identify(x, labels = rownames(x), ...)
    out
}
"initMDS" <-
  function(x, k=2)
{
  nr <- attributes(x)$Size
  res <- runif(nr*k)
  dim(res) <- c(nr,k)
  res
}
"lines.humpfit" <-
    function(x, segments=101,  ...)
{
    mass <- x$x
    if (!is.null(segments) && segments > 0) {
        mass <- seq(min(mass), max(mass), length=segments)
        fv <- predict(x, newdata = mass)
    }
    else {
        i <- order(mass)
        fv <- fitted(x)
        mass <- mass[i]
        fv <- fv[i]
    }
    lines(mass, fv, ...)
    invisible()
}
"lines.prestonfit" <-
    function(x, line.col = "red", lwd = 2, ...)
{
    p <- x$coefficients
    freq <- x$freq
    oct <- as.numeric(names(freq))
    curve(p[3] * exp(-(x-p[1])^2/2/p[2]^2), -1, max(oct), add = TRUE,
          col = line.col, lwd = lwd, ...)
        segments(p["mode"], 0, p["mode"], p["S0"], col = line.col, 
        ...)
    segments(p["mode"] - p["width"], p["S0"] * exp(-0.5), p["mode"] + 
        p["width"], p["S0"] * exp(-0.5), col = line.col, ...)
    invisible()
}
"lines.procrustes" <-
    function(x, type=c("segments", "arrows"),  choices=c(1,2), ...)
{
    type <- match.arg(type)
    X <- x$X[,choices, drop=FALSE]
    Y <- x$Yrot[, choices, drop=FALSE]
    if (type == "segments")
        segments(X[,1], X[,2], Y[,1], Y[,2], ...)
    else
        arrows(X[,1], X[,2], Y[,1], Y[,2], ...)
    invisible()
}
"lines.radline" <-
    function (x, ...) 
{
    lin <- fitted(x)
    rnk <- seq(along = lin)
    lines(rnk, lin, ...)
    invisible()
}
"make.cepnames" <-
function(names) {
   names <- make.names(names, unique=FALSE) 
   names <- lapply(strsplit(names, "\\."), function(x) substring(x, 1, 4))
   names <- unlist(lapply(names, function(x) paste(x[c(1,length(x))], collapse="")))
   names <- make.names(names, unique=TRUE)
   names
}
"mantel" <-
function (xdis, ydis, method = "pearson", permutations = 1000, strata) 
{
    if (!require(mva))
      stop("Requires library `mva'")
    xdis <- as.dist(xdis)
    ydis <- as.vector(as.dist(ydis))
    tmp <- cor.test(as.vector(xdis), ydis, method = method)
    statistic <- as.numeric(tmp$estimate)
    variant <- tmp$method
    if (permutations) {
        N <- attributes(xdis)$Size
        perm <- rep(0, permutations)
        for (i in 1:permutations) {
            take <- permuted.index(N, strata)
            permvec <- as.vector(as.dist(as.matrix(xdis)[take, 
                take]))
            perm[i] <- cor.test(permvec, ydis, method = method)$estimate
        }
        signif <- sum(perm >= statistic)/permutations
    }
    else {
        signif <- NA
        perm <- NULL
    }
    res <- list(call = match.call(), method = variant, statistic = statistic, 
        signif = signif, perm = perm, permutations = permutations)
    if (!missing(strata)) {
        res$strata <- deparse(substitute(strata))
        res$stratum.values <- strata
    }
    class(res) <- "mantel"
    res
}
"no.shared" <-
    function(x)
{
    N <- nrow(x <- as.matrix(x))
    d <- .C("veg_distance", x = as.double(x), nr = N, nc = ncol(x),
            d = double(N * (N - 1)/2), diag = as.integer(FALSE),
            method = as.integer(99), PACKAGE="vegan")$d
    d <- as.logical(d)
    attr(d, "Size") <- N
    attr(d, "Labels") <- dimnames(x)[[1]]
    attr(d, "Diag") <- FALSE
    attr(d, "Upper") <- FALSE
    attr(d, "method") <- "no.shared"
    attr(d, "call") <- match.call()
    class(d) <- "dist"
    d        
}
"ordiParseFormula" <-
    function (formula, data) 
{
    Terms <- terms(formula, "Condition", data = data)
    flapart <- fla <- formula <- formula(Terms, width.cutoff = 500)
    specdata <- formula[[2]]
    X <- eval(specdata, data, parent.frame())
    X <- as.matrix(X)
    indPartial <- attr(Terms, "specials")$Condition
    mf <- Z <- NULL
    if (!is.null(indPartial)) {
        partterm <- attr(Terms, "variables")[[1 + indPartial]]
        Pterm <- deparse(partterm[[2]])
        P.formula <- as.formula(paste("~", Pterm))
        mf <- model.frame(P.formula, data, na.action = na.fail)
        Z <- model.matrix(P.formula, mf)
        formula <- update(formula, paste(".~.-", deparse(partterm, 
                                                         width.cutoff = 500)))
        flapart <- update(formula, paste(". ~ . +", Pterm))
    }
    formula[[2]] <- NULL
    if (formula[[2]] == "1" || formula[[2]] == "0") 
        Y <- NULL
    else {
        mf <- model.frame(formula, data, na.action = na.fail)
        Y <- model.matrix(formula, mf)
        if (any(colnames(Y) == "(Intercept)")) {
            xint <- which(colnames(Y) == "(Intercept)")
            Y <- Y[, -xint, drop = FALSE]
        }
    }
    list(X = X, Y = Y, Z = Z, terms = terms(fla, width.cutoff = 500), 
         terms.expand = terms(flapart, width.cutoff = 500), modelframe=mf)
}
"ordiarrows" <-
function (ord, groups, levels, replicates, display = "sites", 
    ...) 
{
    pts <- scores(ord, display = display, ...)
    npoints <- nrow(pts)
    if (missing(groups)) 
        groups <- gl(levels, replicates, npoints)
    out <- seq(along = groups)
    inds <- names(table(groups))
    for (is in inds) {
        gr <- out[groups == is]
        if (length(gr) > 1) {
            X <- pts[gr, , drop=FALSE]
            X0 <- X[-nrow(X), , drop=FALSE]
            X1 <- X[-1, , drop=FALSE]
            arrows(X0[, 1], X0[, 2], X1[, 1], X1[, 2], ...)
        }
    }
    invisible()
}
"ordicluster" <-
    function (ord, cluster, prune=0, display="sites", w = weights(ord, display),  ...) 
{
    w <- eval(w)
    mrg <- cluster$merge
    ord <- scores(ord, display = display, ...)
    if (nrow(mrg) != nrow(ord) - 1)
        stop("Dimensions do not match in `ord' and `cluster'")
    if (length(w) == 1) w <- rep(w, nrow(ord))
    n <- if (is.null(w)) rep(1, nrow(ord)) else w
    go <- ord
    for (i in 1: (nrow(mrg) - prune)) {
        a <- mrg[i,1]
        b <- mrg[i,2]
        one <- if (a < 0) ord[-a,] else go[a,]
        two <- if (b < 0) ord[-b,] else go[b,]
        n1 <- if (a < 0) n[-a] else n[a]
        n2 <- if (b < 0) n[-b] else n[b]
        segments(one[1], one[2], two[1], two[2], ...)
        xm <- weighted.mean(c(one[1],two[1]), w=c(n1,n2))
        ym <- weighted.mean(c(one[2],two[2]), w=c(n1,n2))
        go[i,] <- c(xm,ym)
        n[i] <- n1 + n2
    }
    invisible(cbind(go, "w"=n))
}
"ordiellipse" <-
    function (ord, groups, display = "sites", kind = c("sd", "se"), 
              conf, draw = c("lines", "polygon"), w = weights(ord, display), 
              ...) 
{
    if (!require(ellipse)) 
        stop("Requires package `ellipse' (from CRAN)")
    kind <- match.arg(kind)
    draw <- match.arg(draw)
    pts <- scores(ord, display = display, ...)
    w <- eval(w)
    if (length(w) == 1) w <- rep(1, nrow(pts))
    if (is.null(w)) 
        w <- rep(1, nrow(pts))
    out <- seq(along = groups)
    inds <- names(table(groups))
    for (is in inds) {
        gr <- out[groups == is]
        if (length(gr) > 2) {
            X <- pts[gr, ]
            W <- w[gr]
            mat <- cov.wt(X, W)
            if (kind == "se") 
                mat$cov <- mat$cov/mat$n.obs
            if (missing(conf)) 
                t <- 1
            else t <- sqrt(qchisq(conf, 2))
            if (draw == "lines") 
                lines(ellipse(mat$cov, centre = mat$center, t = t), 
                      ...)
            else {
                xy <- ellipse(mat$cov, center = mat$center, t = t)
                polygon(xy[, 1] + mat$center[1], xy[, 2] + mat$center[2], 
                        ...)
            }
        }
    }
    invisible()
}
"ordigrid" <-
function (ord, levels, replicates, display = "sites", ...) 
{
    pts <- scores(ord, display = display, ...)
    npoints <- nrow(pts)
    gr <- gl(levels, replicates, npoints)
    ordisegments(pts, groups = gr, ...)
    gr <- gl(replicates, levels, npoints)
    ordisegments(pts, groups = gr, ...)
    invisible()
}
"ordihull" <-
function (ord, groups, display = "sites", draw=c("lines","polygon"), ...) 
{
    draw <- match.arg(draw)
    pts <- scores(ord, display = display, ...)
    out <- seq(along = groups)
    inds <- names(table(groups))
    for (is in inds) {
        gr <- out[groups == is]
        if (length(gr) > 1) {
            X <- pts[gr, ]
            hpts <- chull(X)
            hpts <- c(hpts, hpts[1])
            if (draw == "lines")
               lines(X[hpts, ], ...)
            else
               polygon(X[hpts, ], ...)
        }
    }
    invisible()
}
"ordiplot" <-
function (ord, choices = c(1, 2), type = "points", ...) 
{
    if (!is.null(attr(ord, "class")) && (class(ord) == "decorana" || 
        any(class(ord) == "cca"))) {
        out <- plot(ord, choices, type = type, ...)
    }
    else {
        type <- match.arg(type, c("points", "text", "none"))
        X <- scores(ord, choices = choices, display = "sites")
        options(show.error.messages = FALSE)
        Y <- try(scores(ord, choices = choices, display = "species"))
        options(show.error.messages = TRUE)
        if (inherits(Y, "try-error")) {
            warning("Species scores not available")
            Y <- NULL
        }
        else if (nrow(X) == nrow(Y) && all.equal.numeric(X, Y)) {
            Y <- NULL
            warning("Species scores not available")
        }
        xlim <- range(X[, 1], Y[, 1])
        ylim <- range(X[, 2], Y[, 2])
        plot(X, xlim = xlim, ylim = ylim, asp = 1, type = "n", 
            ...)
        if (type == "points") {
            points(X, pch = 1, col = 1, cex = 0.7, ...)
            if (!is.null(Y)) 
                points(Y, pch = "+", col = "red", cex = 0.7, 
                  ...)
        }
        if (type == "text") {
            text(X, labels = rownames(X), col = 1, cex = 0.7, ...)
            if (!is.null(Y))
                text(Y, labels = rownames(Y), col = "red", cex = 0.7, ...)
        }
        out <- list(sites = X, species = Y)
    }
    class(out) <- "ordiplot"
    invisible(out)
}
"ordisegments" <-
function (ord, groups, levels, replicates, display = "sites", 
    ...) 
{
    pts <- scores(ord, display = "sites", ...)
    npoints <- nrow(pts)
    if (missing(groups)) 
        groups <- gl(levels, replicates, npoints)
    out <- seq(along = groups)
    inds <- names(table(groups))
    for (is in inds) {
        gr <- out[groups == is]
        if (length(gr) > 1) {
            X <- pts[gr, , drop=FALSE ]
            X0 <- X[-nrow(X), , drop=FALSE]
            X1 <- X[-1, , drop=FALSE]
            segments(X0[, 1], X0[, 2], X1[, 1], X1[, 2], ...)
        }
    }
    invisible()
}
"ordispantree" <-
    function(ord, tree, display = "sites",  ...)
{
    ord <- scores(ord, display = display)
    if (is.list(tree) && !is.null(tree$kid))
        tree <- tree$kid
    segments(ord[-1,1], ord[-1,2], ord[tree, 1], ord[tree, 2], ...)
    invisible()
}
"ordispider" <-
    function (ord, groups, display = "sites", w = weights(ord, display), 
              ...) 
{
    if (inherits(ord, "cca") && missing(groups)) {
        lc <- scores(ord, display = "lc", ...)
        wa <- scores(ord, display = "wa", ...)
        segments(lc[, 1], lc[, 2], wa[, 1], wa[, 2], ...)
        return(invisible())
    }
    pts <- scores(ord, display = display, ...)
    w <- eval(w)
    if (length(w) == 1) w <- rep(1, nrow(pts))
    if (is.null(w)) 
        w <- rep(1, nrow(pts))
    out <- seq(along = groups)
    inds <- names(table(groups))
    for (is in inds) {
        gr <- out[groups == is]
        if (length(gr) > 1) {
            X <- pts[gr, ]
            W <- w[gr]
            ave <- apply(X, 2, weighted.mean, w = W)
            segments(ave[1], ave[2], X[, 1], X[, 2], ...)
        }
    }
    invisible()
}
"ordisurf" <-
function (x, y, choices = c(1, 2), knots = 10, family = "gaussian", 
    col = "red", thinplate = TRUE, add = FALSE, ...) 
{
    if(!require(mgcv))
      stop("Requires package `mgcv'")
    if (!require(akima))
      stop("Requires package `akima'")
    X <- scores(x, choices = choices, display = "sites")
    x1 <- X[, 1]
    x2 <- X[, 2]
    if (thinplate)
       mod <- gam(y ~ s(x1, x2, k = knots), family = family)
    else
       mod <- gam(y ~ s(x1, k=knots) + s(x2, k=knots), family = family)
    fit <- predict(mod, type = "response")
    if (!add) {
        plot(X, asp = 1, ...)
        mtext(deparse(substitute(y)))
    }
    contour(interp(x1, x2, fit, duplicate="mean"), col = col, add = TRUE)
    return(mod)
}
"permuted.index" <-
function (n, strata) 
{
   if (missing(strata))
       out <- sample(n,n)
   else {
       out <- 1:n
       inds <- names(table(strata))
       for (is in inds) {
          gr <- out[strata == is]
          if (length(gr) > 1) 
             out[gr] <- sample(gr, length(gr))
       }
   }
   out
}
"permutest.cca" <-
    function (x, permutations = 100, model = c("reduced", "full"), 
              strata) 
{
    model <- match.arg(model)
    Chi.z <- x$CCA$tot.chi
    Chi.xz <- x$CA$tot.chi
    q <- x$CCA$rank
    r <- x$CA$rank
    F.0 <- (Chi.z/q)/(Chi.xz/r)
    F.perm <- rep(0, permutations)
    if (!is.null(x$pCCA)) {
        Y.Z <- x$pCCA$Fit
        QZ <- x$pCCA$QR
    }
    if (model == "reduced") 
        E <- x$CCA$Xbar
    else E <- x$CA$Xbar
    N <- nrow(E)
    Q <- x$CCA$QR
    for (i in 1:permutations) {
        take <- permuted.index(N, strata)
        Y <- E[take, ]
        if (!is.null(x$pCCA)) {
            Y <- Y.Z + Y
            Y <- qr.resid(QZ, Y)
        }
        cca.ev <- sum(diag(crossprod(qr.fitted(Q, Y))))
        ca.ev <- sum(diag(crossprod(qr.resid(Q, Y))))
        F.perm[i] <- (cca.ev/q)/(ca.ev/r)
    }
    sol <- list(call = x$call, model = model, F.0 = F.0, F.perm = F.perm, 
                nperm = permutations, method = x$method)
    if (!missing(strata)) {
        sol$strata <- deparse(substitute(strata))
        sol$stratum.values <- strata
    }
    class(sol) <- "permutest.cca"
    sol
}
"plot.anosim" <-
function (x, title=NULL, ...) 
{
   boxplot(x$dis.rank ~ x$class.vec, notch=TRUE, varwidth=TRUE, 
           ...)
   title(title)
   if (x$permutations) {
     pval <- format.pval(x$signif, eps=1/x$permutations)
   } else {
     pval <- "not assessed"
   }
   mtext(paste("R = ", round(x$statistic, 3), ", ",
               "P = ", pval ), 3)
   invisible()
}
"plot.cca" <-
    function (x, choices = c(1, 2), display = c("sp", "wa", "cn"), 
              scaling = 2, type, ...) 
{
    TYPES <- c("text", "points", "none")
    g <- scores(x, choices, display, scaling)
    if (!is.list(g)) 
        g <- list(default = g)
    if (!is.null(g$centroids)) {
        if (is.null(g$biplot)) 
            g$biplot <- scores(x, choices, "bp", scaling)
        if (!is.na(g$centroids)[1]) {
            bipnam <- rownames(g$biplot)
            cntnam <- rownames(g$centroids)
            g$biplot <- g$biplot[!(bipnam %in% cntnam), , drop = FALSE]
            if (nrow(g$biplot) == 0) 
                g$biplot <- NULL
        }
    }
    if (missing(type)) {
        nitlimit <- 80
        nit <- max(nrow(g$spe), nrow(g$sit), nrow(g$con), nrow(g$def))
        if (nit > nitlimit) 
            type <- "points"
        else type <- "text"
    }
    else type <- match.arg(type, TYPES)
    xran <- range(g$spe[, 1], g$sit[, 1], g$con[, 1], g$default[, 
                                                                1])
    yran <- range(g$spe[, 2], g$sit[, 2], g$con[, 2], g$default[, 
                                                                2])
    plot(g[[1]], xlim = xran, ylim = yran, type = "n", asp = 1, 
         ...)
    abline(h = 0, lty = 3)
    abline(v = 0, lty = 3)
    if (!is.null(g$species)) {
        if (type == "text") 
            text(g$species, rownames(g$species), col = "red", 
                 cex = 0.7)
        else if (type == "points") 
            points(g$species, pch = "+", col = "red", cex = 0.7)
    }
    if (!is.null(g$sites)) {
        if (type == "text") 
            text(g$sites, rownames(g$sites), cex = 0.7)
        else if (type == "points") 
            points(g$sites, pch = 1, cex = 0.7)
    }
    if (!is.null(g$constraints)) {
        if (type == "text") 
            text(g$constraints, rownames(g$constraints), cex = 0.7, 
                 col = "darkgreen")
        else if (type == "points") 
            points(g$constraints, pch = 2, cex = 0.7, col = "darkgreen")
    }
    if (!is.null(g$biplot) && type != "none") {
        if (length(display) > 1) {
            mul <- par("usr")/c(range(g$biplot[, 1]), range(g$biplot[, 2]))
            mul <- mul[is.finite(mul) & mul>0]
            mul <- 0.75 * min(mul)
        }
        else mul <- 1
        arrows(0, 0, mul * g$biplot[, 1], mul * g$biplot[, 2], 
               len = 0.05, col = "blue")
        text(1.1 * mul * g$biplot, rownames(g$biplot), col = "blue")
        axis(3, at = c(-mul, 0, mul), labels = rep("", 3), col = "blue")
        axis(4, at = c(-mul, 0, mul), labels = c(-1, 0, 1), col = "blue")
    }
    if (!is.null(g$centroids) && !is.na(g$centroids) && type != 
        "none") {
        if (type == "text") 
            text(g$centroids, rownames(g$centroids), col = "blue")
        else if (type == "points") 
            points(g$centroids, pch = "x", col = "blue")
    }
    if (!is.null(g$default) && type != "none") {
        if (type == "text") 
            text(g$default, rownames(g$default), cex = 0.7)
        else if (type == "points") 
            points(g$default, pch = 1, cex = 0.7)
    }
    class(g) <- "ordiplot"
    invisible(g)
}
"plot.decorana" <-
    function (x, choices = c(1, 2), origin = TRUE, display = c("both", 
                                                   "sites", "species", "none"), cex = 0.8, cols = c(1, 2), type, 
              ...) 
{
    display <- match.arg(display)
    sites <- x$rproj
    specs <- x$cproj
    if (missing(type)) {
        nitlimit <- 120
        nit <- 0
        if (display == "sites" || display == "both") 
            nit <- nit + nrow(sites)
        if (display == "species" || display == "both") 
            nit <- nit + nrow(specs)
        if (nit > nitlimit) 
            type <- "points"
        else type <- "text"
    }
    else type <- match.arg(type, c("text", "points", "none"))
    if (origin) {
        sites <- sweep(x$rproj, 2, x$origin, "-")
        specs <- sweep(x$cproj, 2, x$origin, "-")
    }
    sitnam <- rownames(x$rproj)
    spenam <- rownames(x$cproj)
    sites <- sites[, choices]
    specs <- specs[, choices]
    sp.x <- range(specs[, 1])
    sp.y <- range(specs[, 2])
    st.x <- range(sites[, 1])
    st.y <- range(sites[, 2])
    switch(display, both = {
        xlim <- range(sp.x, st.x)
        ylim <- range(sp.y, st.y)
    }, sites = {
        xlim <- st.x
        ylim <- st.y
    }, species = {
        xlim <- sp.x
        ylim <- sp.y
    }, none = {
        xlim <- range(sp.x, st.x)
        ylim <- range(sp.y, st.y)
    })
    plot(sites, type = "n", xlim = xlim, ylim = ylim, asp = 1, 
         ...)
    if (origin) {
        abline(h = 0, lty = 3)
        abline(v = 0, lty = 3)
    }
    else {
        abline(h = x$origin[choices[2]], lty = 3)
        abline(v = x$origin[choices[1]], lty = 3)
    }
    if (type != "none" && (display == "both" || display == "sites")) {
        if (type == "text") 
            text(sites, sitnam, cex = cex, col = cols[1])
        else points(sites, cex = cex, col = cols[1])
    }
    if (type != "none" && (display == "both" || display == "species")) {
        if (type == "text") 
            text(specs, spenam, cex = cex, col = cols[2])
        else points(specs, pch = "+", cex = cex, col = cols[2])
    }
    out <- list(sites = sites, species = specs)
    class(out) <- "ordiplot"
    invisible(out)
}
"plot.envfit" <-
    function (x, choices = c(1, 2), arrow.mul = 1, p.max = NULL, col = "blue", 
              add = TRUE, ...) 
{
    formals(arrows) <- c(formals(arrows), alist(... = ))
    if (!is.null(p.max)) {
        if (!is.null(x$vectors)) {
            take <- x$vectors$pvals <= p.max
            x$vectors$arrows <- x$vectors$arrows[take, , drop=FALSE]
            x$vectors$r <- x$vectors$r[take]
            if (nrow(x$vectors$arrows) == 0)
                x$vectors <- NULL
        }
        if (!is.null(x$factors)) {
            tmp <- x$factors$pvals <= p.max
            nam <- names(tmp)[tmp]
            take <- x$factors$var.id %in% nam
            x$factors$centroids <- x$factors$centroids[take, , drop=FALSE]
            if (nrow(x$factors$centroids) == 0)
                x$factors <- NULL
        }
    }
    if (!is.null(x$vectors)) {
        vect <- arrow.mul * sqrt(x$vectors$r) * x$vectors$arrows[, 
                                                                 choices]
        if (!any(dim(vect))) 
            dim(vect) <- c(1, length(vect))
    }
    if (!add) {
        xlim <- range(x$vectors$arrows[, choices[2]], x$factors$centroids[, 
                                                                          choices[2]])
        ylim <- range(x$vectors$arrows[, choices[1]], x$factors$centroids[, 
                                                                          choices[1]])
        if (!is.null(x$vectors)) 
            plot(x$vectors$arrows[, choices], xlim = xlim, ylim = ylim, 
                 asp = 1, type = "n", ...)
        else if (!is.null(x$factors)) 
            plot(x$factors$centroids[, choices], asp = 1, xlim = xlim, 
                 ylim = ylim, type = "n", ...)
        else stop("Nothing to plot")
    }
    if (!is.null(x$vectors)) {
        arrows(0, 0, vect[, 1], vect[, 2], len = 0.05, col = col)
        text(1.1 * vect, rownames(x$vectors$arrows), col = col, 
             ...)
    }
    if (!is.null(x$factors)) {
        text(x$factors$centroids[, choices], rownames(x$factors$centroids), 
             col = col, ...)
    }
    invisible()
}
"plot.fisherfit" <-
    function(x, xlab = "Frequency", ylab = "Species", bar.col = "skyblue",
             line.col= "red", lwd=2, ...)
{
    freq <- as.numeric(names(x$fisher))
    plot(freq, x$fisher, ylab=ylab, xlab=xlab,
         ylim=c(0,max(x$fisher)),  xlim=c(0.5, max(freq)+0.5), type="n", ...)
    rect(freq-0.5,0,freq+0.5,x$fisher, col=bar.col, ...)
    alpha <- x$estimate
    k <- x$nuisance
    curve(alpha*k^x/x, 1, max(freq), col=line.col, lwd=lwd, add=TRUE, ...)
    invisible()
}
"plot.humpfit" <-
    function(x, xlab="Biomass", ylab="Species Richness", lwd=2, l.col="blue",
             p.col = 1, type="b", ...)
{
    plot(x$x, x$y, xlab = xlab, ylab = ylab, type="n", ...)
    if (type == "b" || type == "p")
        points(x, col = p.col, ...)
    if (type == "b" || type == "l")
        lines(x, lwd = lwd, col = l.col, ...)
    invisible()
}
"plot.prestonfit" <-
    function (x, xlab = "Frequency", ylab = "Species", bar.col = "skyblue", 
              line.col = "red", lwd = 2, ...) 
{
    freq <- x$freq
    oct <- as.numeric(names(freq))
    noct <- max(oct) + 1
    plot(oct, freq, type = "n", ylim = c(0, max(freq)), xlim = c(-1, 
                                                        max(oct)), ylab = ylab, xlab = xlab, axes = FALSE, ...)
    axis(2)
    axis(1, at = 0:noct, labels = 2^(0:noct))
    box()
    rect(oct - 1, 0, oct, freq, col = bar.col, ...)
    p <- x$coefficients
    curve(p[3] * exp(-(x - p[1])^2/2/p[2]^2), -1, max(oct), add = TRUE, 
          col = line.col, lwd = lwd, ...)
    segments(p["mode"], 0, p["mode"], p["S0"], col = line.col, ...)
    segments(p["mode"] - p["width"], p["S0"] * exp(-0.5), p["mode"] + 
             p["width"], p["S0"] * exp(-0.5), col = line.col, ...)
    invisible()
}
"plot.procrustes" <-
    function (x, kind = 1, choices = c(1, 2), xlab, ylab, main, ar.col = "blue", 
              len = 0.05, ...) 
{
    Yrot <- x$Yrot[, choices]
    X <- x$X[, choices]
    if (missing(main)) 
        main <- "Procrustes errors"
    if (kind <= 1) {
        formals(arrows) <- c(formals(arrows), alist(... = ))
        if (missing(xlab)) 
            xlab <- paste("Dimension", choices[1])
        if (missing(ylab)) 
            ylab <- paste("Dimension", choices[2])
        xrange <- range(Yrot[, 1], X[, 1])
        yrange <- range(Yrot[, 2], X[, 2])
        plot(xrange, yrange, xlab = xlab, ylab = ylab, main = main, 
             type = "n", asp = 1, ...)
        if (kind > 0) {
            points(Yrot, ...)
            ow <- options(warn = -1)
            arrows(Yrot[, 1], Yrot[, 2], X[, 1], X[, 2], col = ar.col, 
                   len = len, ...)
            options(ow)
        }
        out <- list(heads = X, points = Yrot)
        class(out) <- "ordiplot"
    }
    else if (kind == 2) {
        if (missing(xlab)) 
            xlab <- "Index"
        if (missing(ylab)) 
            ylab <- "Procrustes residual"
        res <- residuals(x)
        q <- quantile(res)
        plot(res, type = "h", xlab = xlab, ylab = ylab, main = main, 
             ...)
        abline(h = q[2:4], lty = c(2, 1, 2))
        out <- list(sites = cbind(seq(along = res), res))
        class(out) <- "ordiplot"
    }
    invisible(out)
}
"plot.rad" <-
    function(x, xlab="Rank", ylab="Abundance",  ...)
{
    rnk <- seq(along=x)
    plot(rnk, x, log="y", xlab=xlab, ylab=ylab, ...)
    out <- list(species = cbind(rnk, x))
    class(out) <- "ordiplot"
    invisible(out)
}
"plot.radfit" <-
    function (x, BIC = FALSE, legend = TRUE, ...) 
{
    out <- plot(x$y, ...)
    fv <- fitted(x)
    if (BIC)
        k = log(length(x$y))
    else
        k = 2
    emph <- which.min(sapply(x$models, AIC, k = k))
    lwd <- rep(1, ncol(fv))
    lwd[emph] <- 3
    matlines(fv, lty = 1, lwd = lwd, ...)
    if (legend) {
        usr <- par("usr")
        nm <- names(x$models)
        legend(usr[2] * 0.5, 10^usr[4] * 0.9, legend = nm, lty = 1, 
               lwd = lwd, col = 1:6)
    }
    invisible(out)
}
"plot.radfit.frame" <-
    function (x, order.by, BIC = FALSE, model, legend = TRUE, as.table = TRUE, 
              ...) 
{
    require(lattice)
    modnam <- names(x[[1]]$models)
    if (!missing(model)) 
        pick <- pmatch(model, modnam, nomatch = FALSE)
    else pick <- FALSE
    pickmod <- function(x, pick, BIC) {
        if (pick) return(pick)
        else {
            k <- if (BIC) log(length(x$y)) else 2
            which.min(AIC(x, k))
        }
    }
    Nhm <- length(x)
    Abundance <- unlist(lapply(x, function(x) x$y))
    Rank <- unlist(lapply(x, function(x) 1:length(x$y)))
    Site <- unlist(lapply(x, function(x) length(x$y)))
    N <- Site
    sitenames <- names(Site)
    Site <- rep(names(Site), Site)
    if (missing(order.by)) 
        order.by <- 1:Nhm
    else order.by <- order(order.by)
    Site <- factor(Site, levels = sitenames[order.by])
    fit <- unlist(lapply(x, function(x) fitted(x)[, pickmod(x, pick, BIC)]))
    take <- sapply(x, function(x) pickmod(x, pick, BIC))
    take <- rep(take, N)
    cols <- trellis.par.get("superpose.line")$col
    cols <- cols[2:length(cols)]
    if (legend) {
        mykey <- list(text = list(text = modnam), lines = list(lty = 1, 
                                                  col = cols[1:length(modnam)], lwd = 2), columns = 3)
    }
    else {
        mykey <- NULL
    }
    tics <- function(x = max(Abundance), z = min(Abundance)) {
        ii <- round(c(log10(z), log10(x)))
        x10 <- 10^(ii[1]:ii[2])
        if (length(x10) < 3) 
            x10 <- c(outer(c(1, 2, 5), x10))
        else if (length(x10) < 6) 
            x10 <- c(outer(c(1, 3), x10))
        x10[x10 <= x & x10 >= z]
    }
    out <- xyplot(Abundance ~ Rank | Site, subscripts = TRUE, 
                  as.table = as.table, key = mykey, scales = list(y = list(log = 10, 
                                                                  at = tics())), panel = function(x, y, subscripts) {
                                                                      panel.xyplot(x, y, ...)
                                                                      panel.xyplot(x, log10(fit[subscripts]), type = "l", 
                                                                                   col = cols[take[min(subscripts)]], lwd = 2, ...)
                                                                  }, ...)
    out
}
"plot.radline" <-
    function (x, xlab = "Rank", ylab = "Abundance", type = "b", ...) 
{
    rad <- x$y
    fit <- fitted(x)
    rnk <- seq(along = rad)
    plot(rnk, rad, log = "y", xlab = xlab, ylab = ylab, type = "n", 
         ...)
    out <- NULL
    if (type == "b" || type == "p") 
        out <- points(x, ...)
    if (type == "b" || type == "l") 
        lines(x, ...)
    invisible(out)
}
"plot.specaccum" <-
    function(x, add = FALSE, ci = 2, ci.type = c("bar","line","polygon"), 
             col = par("fg"), ci.col = col, ci.lty = 1, xlab = "Sites",
             ylab = x$method, ...)
{
    ci.type <- match.arg(ci.type)
    if (!add) {
        ymax <- max(x$richness, x$richness + ci*x$sd)
        plot(x$sites, x$richness, xlab=xlab, ylab=ylab, ylim=c(1,ymax),
             type="n", ...)
    }
    if (!is.null(x$sd) && ci)
        switch(ci.type,
               bar = segments(x$sites, x$richness - ci*x$sd, x$sites,
                  x$richness + ci*x$sd, col=ci.col, lty=ci.lty, ...),
               line = matlines(x$sites, x$richness + t(rbind(-ci,ci) %*% x$sd),
                 col=ci.col, lty=ci.lty, ...),
               polygon = polygon(c(x$sites, rev(x$sites)),
                 c(x$richness - ci*x$sd, rev(x$richness + ci*x$sd)), col=ci.col,
                 lty=ci.lty,  ...)
               )
    lines(x$sites, x$richness,col=col, ...)
    invisible()
}
"points.cca" <-
    function (x, display = "sites", choices = c(1, 2), scaling = 2, 
              mul.arrow = 1, head.arrow = 0.05, ...) 
{
    formals(arrows) <- c(formals(arrows), alist(... = ))
    if (length(display) > 1) 
        stop("Only one `display' item can be added in one command.")
    pts <- scores(x, choices = choices, display = display, scaling = scaling)
    if (display == "cn") {
        cnam <- rownames(pts)
        points(pts, ...)
        pts <- scores(x, choices = choices, display = "bp", scaling = scaling)
        bnam <- rownames(pts)
        pts <- pts[!(bnam %in% cnam), , drop = FALSE]
        if (nrow(pts) == 0) 
            return(invisible())
        else display <- "bp"
    }
    if (display == "bp") {
        pts <- pts * mul.arrow
        arrows(0, 0, pts[, 1], pts[, 2], length = head.arrow, 
               ...)
        pts <- pts * 1.1
        axis(3, at = c(-mul.arrow, 0, mul.arrow), labels = rep("", 3))
        axis(4, at = c(-mul.arrow, 0, mul.arrow), labels = c(-1, 0, 1))
        return(invisible())
    }
    points(pts, ...)
    invisible()
}
"points.humpfit" <-
    function(x, ...)
{
    points(x$x, x$y, ...)
    invisible()
}
"points.ordiplot" <-
function (x, what, ...) 
{
    x <- scores(x, what)
    points(x, ...)
    invisible()
}
"points.procrustes" <-
    function(x, display = c("target","rotated"), ...)
{
    display <- match.arg(display)
    x <- if (display == "target") x$X else x$Yrot
    points(x, ...)
    invisible()
}
"points.radline" <-
    function (x, ...) 
{
    poi <- x$y
    rnk <- seq(along = poi)
    points(rnk, poi, ...)
    out <- list(species = cbind(rnk, poi))
    class(out) <- "ordiplot"
    invisible(out)
}
"postMDS" <-
function (X, dist, pc = TRUE, center = TRUE, halfchange = TRUE, 
    threshold = 0.8, nthreshold = 10, plot = FALSE) 
{
    Size <- attributes(dist)$Size
    if (any(attributes(X)$names == "points")) 
        x <- X$points
    else x <- as.matrix(X)
    if (center) 
        x <- scale(x, scale = FALSE)
    if (pc) {
        if(!require(mva))
          stop("PCA rotation requires package `mva'")
        dn <- dimnames(x)
        x <- prcomp(x, center = center)$x
        dimnames(x) <- dn
    }
    if (halfchange) {
        dist <- as.vector(dist)
        ordi <- as.vector(vegdist(x, "euclidean"))
        take <- dist < threshold
        if (sum(take) < nthreshold) 
            stop("Too few data points for half-change scaling")
        k <- coef(lm(dist[take] ~ ordi[take]))
        names(k) <- NULL
        hc <- (1 - k[1])/2/k[2]
        x <- x/hc
    }
    if (plot && halfchange) {
        cross.lim <- 45
        if (Size > cross.lim) 
            pch <- "."
        else pch <- "+"
        orange <- range(c(ordi, 0, 1))
        drange <- range(c(dist, 0, 1))
        plot(orange, drange, type = "n", xlab = "Ordination distance", 
            ylab = "Community dissimilarity")
        points(ordi[take], dist[take], pch = pch, col = "blue")
        points(ordi[!take], dist[!take], pch = pch, col = "gray")
        abline(h = threshold)
        abline(h = k[1])
        hclevel <- (1 - k[1])/2 + k[1]
        segments(0, hclevel, hc, hclevel, col = "red", lwd = 2)
        arrows(hc, hclevel, hc, 0, col = "red", lwd = 2)
        arrows(0, k[1], 0, hclevel, col = "red", code = 3)
        arrows(0, hclevel, 0, 1, col = "red", code = 3)
        j <- 0.02
        text(0 + j, threshold + j, "Threshold", adj = c(0, 0))
        text(0 + j, k[1] + j, "Replicate dissimilarity", adj = c(0, 
            0))
        text(0 + j, hclevel + j, "Half-change", adj = c(0, 0))
        abline(k, col = "blue", lwd = 2)
    }
    if (any(attributes(X)$names == "points")) 
        X$points <- x
    else X <- x
    X
}
"predict.humpfit" <-
    function(object, newdata = NULL, ...)
{
    if (is.null(newdata))
        return(fitted(object))
    else {
        p <- coef(object)
        x <- unlist(newdata)
        x <- ifelse(x < p[1], x/p[1], p[1]*p[1]/x/x)
        fv <- p[3]*log(1 + p[2]*x/p[3])
    }
    fv
}
"prestondistr" <-
    function (x, truncate = -1,  ...) 
{
    fun <- function(par, x, truncate) {
        up <- dnorm(x, par[1], par[2], log = TRUE)
        dn <- pnorm(truncate, par[1], par[2], lower = FALSE)
        -sum(up - log(dn))
    }
    x <- x[x > 0]
    logx <- log2(x)
    p <- c(mean(logx), sd(logx))
    sol <- optim(p, fun, x = logx, truncate = truncate)
    p <- sol$par
    area <- pnorm(truncate, p[1], p[2], lower = FALSE)
    scale <- length(x)/sqrt(2 * pi)/p[2]/area
    p <- c(p, scale)
    oct <- as.preston(x)
    x <- as.numeric(names(oct))
    fit <- p[3] * exp(-(x - p[1])^2/2/p[2]^2) 
    names(p) <- c("mode", "width", "S0")
    out <- list(freq = oct, fitted = fit, coefficients = p)
    out$method <- "maximized likelihood to log2 abundances"
    class(out) <- "prestonfit"
    out
}
"prestonfit" <-
    function (x, ...) 
{
    x <- as.preston(x)
    oct <- as.numeric(names(x))
    fit <- glm(x ~ oct + I(oct^2), family = poisson)
    fv <- fitted(fit)
    p <- coef(fit)
    if (!is.na(p[3]) && p[3] < 0) {
        mu <- -p[2]/2/p[3]
        sd <- sqrt(-1/2/p[3])
        S0 <- exp(p[1] - p[2]^2/4/p[3])
        p <- c(mu, sd, S0)
    }
    else {
        p <- rep(NA, 3)
    }
    names(p) <- c("mode", "width", "S0")
    out <- list(freq = unclass(x), fitted = fv, coefficients = p)
    out$method = "Poisson fit to octaves"
    class(out) <- c("prestonfit")
    out
}
"print.anosim" <-
    function (x, digits = max(3, getOption("digits") - 3), ...) 
{
    cat("\nCall:\n")
    cat(deparse(x$call), "\n")
    cat("Dissimilarity:", x$dissimilarity,"\n\n")
    cat("ANOSIM statistic R: ")
    cat(formatC(x$statistic, digits = digits), "\n")
    nperm <- x$permutations
    if (nperm) {
        cat("      Significance:", format.pval(x$signif, eps = 1/nperm), 
            "\n\n")
        cat("Based on ", nperm, " permutations")
    }
    if (!is.null(x$strata)) 
        cat(", stratified within", x$strata)
    cat("\n\n")
    invisible(x)
}
"print.anova.cca" <-
function (x, ...) 
{
    eps <- 1/x$N.Perm[1]
    print.anova(x, eps.Pvalue = eps, ...)
    invisible(x)
}
"print.bioenv" <-
    function (x, ...) 
{
    cat("\nSubset of environmental variables with best correlation to community data.\n\n")
    cat("Community data:   ", x$comm, "\n")
    cat("Environment data: ", x$env, "\n")
    cat("Correlations:     ", x$method, "\n")
    cat("Dissimilarities:  ", x$index, "\n\n")
    i <- which.max(lapply(x$models, function(tmp) tmp$est))
    cat("Best model has", i, "parameters (max.", x$upto, "allowed):\n")
    cat(paste(x$names[x$models[[i]]$best], collapse = " "))
    cat("\nwith correlation ", x$models[[i]]$est, "\n\n")
    invisible(x)
}
"print.cca" <-
    function (x, digits = max(3, getOption("digits") - 3), ...) 
{
    cat("\nCall:\n")
    cat(deparse(x$call), "\n\n")
    chi <- rbind(x$tot.chi, x$pCCA$tot.chi, x$CCA$tot.chi, x$CA$tot.chi)
    rnk <- rbind(NA, x$pCCA$rank, x$CCA$rank, x$CA$rank)
    tbl <- cbind(chi, rnk)
    tbl <- cbind(chi, rnk)
    colnames(tbl) <- c("Inertia", "Rank")
    rn <- c("Total", "Conditional", "Constrained", "Unconstrained")
    rownames(tbl) <- rn[c(TRUE, !is.null(x$pCCA), !is.null(x$CCA), 
                          !is.null(x$CA))]

    printCoefmat(tbl, digits=digits, na.print="")
    cat("Inertia is", x$inertia, "\n")
    if (!is.null(x$CCA)) {
        cat("\nEigenvalues for constrained axes:\n")
        print(x$CCA$eig, digits = digits, ...)
    }
    if (!is.null(x$CA)) {
        ax.lim <- 8
        ax.trig <- 16
        cat("\nEigenvalues for unconstrained axes:\n")
        if (x$CA$rank > ax.trig) {
            print(x$CA$eig[1:ax.lim], digits = digits, ...)
            cat("(Showed only", ax.lim, "of all", x$CA$rank, 
                "unconstrained eigenvalues)\n")
        }
        else print(x$CA$eig, digits = digits, ...)
    }
    cat("\n")
    invisible(x)
}
"print.decorana" <-
function (x, digits = max(3, getOption("digits") - 3), ...) 
{
    cat("\nCall:\n")
    cat(deparse(x$call), "\n\n")
    cat(ifelse(x$ira, "Orthogonal", "Detrended"), "correspondence analysis")
    cat(ifelse(!x$ira, paste(" with ", x$mk, " segments.\n", 
        sep = ""), ".\n"))
    if (x$iresc) {
        cat("Rescaling of axes with", x$iresc, "iterations")
        if (x$short) 
            cat(", and shortest axis rescaled", x$short)
        cat(".\n")
    }
    if (!is.null(x$v)) 
        cat("Downweighting of rare species from fraction 1/", x$fraction, ".\n", sep="")
    if (!is.null(x$before)) {
        cat("Piecewise transformation of above-zero abundances:\n")
        print(rbind(before = x$before, after = x$after))
    }
    axlen <- NULL
    if (!x$ira && x$iresc) {
        axlen <- apply(x$rproj, 2, max)
    }
    cat("\n")
    print(rbind(Eigenvalues = x$evals, "Decorana values" = x$evals.decorana, 
        "Axis lengths" = axlen), digits = digits)
    cat("\n")
    invisible(x)
}
"print.envfit" <-
  function(x, ...)
{
  if (!is.null(x$vectors)) {
    cat("\n***VECTORS\n\n")
    print(x$vectors)
  }
  if (!is.null(x$factors)) {
    cat("\n***FACTORS:\n\n")
    print(x$factors)
  }
  invisible(x)
}

"print.factorfit" <-
    function (x, ...) 
{
    if (x$permutations) 
        eps <- 1/x$permutations
    else eps <- .Machine$double.eps
    cat("Centroids:\n")
    printCoefmat(x$centroids, tst.ind = 1:ncol(x$centroids), na.print = "", ...)
    cat("\nGoodness of fit:\n")
    out <- cbind(r2 = x$r, "Pr(>r)" = x$pvals)
    if (x$permutations) {
        printCoefmat(out, has.Pvalue = TRUE, eps.Pvalue = eps, ...)
        cat("P values based on", x$permutations, "permutations")
        if (!is.null(x$strata)) 
            cat(", stratified within", x$strata)
        cat(".\n")
    }
    else  printCoefmat(out, na.print = "", ...)
    invisible(x)
}
"print.fisherfit" <-
    function (x, ...) 
{
    cat("\nFisher log series model\n")
    cat("No. of species:", sum(x$fisher), "\n")
    cat("Fisher alpha:  ", x$estimate,"\n\n")
    invisible(x)
}
"print.humpfit" <-
    function(x, ...)
{
    cat("\nHump-backed Null model of richness vs. productivity\n\n")
    cat("Family:", family(x)$family,"\n")
    cat("Link function: Fisher diversity\n\n")
    cat("Coefficients:\n\n")
    print(coef(x))
    cat("\nDeviance", deviance(x), "with", df.residual(x))
    cat(" residual degrees of freedom\n")
    invisible(x)
}
"print.mantel" <-
function (x, digits = max(3, getOption("digits") - 3), ...) 
{
    cat("\nCall:\n")
    cat(deparse(x$call), "\n\n")
    cat("Mantel statistic based on", x$method, "\n\n")
    cat("Mantel statistic r: ")
    cat(formatC(x$statistic, digits = digits), "\n")
    nperm <- x$permutations
    if (nperm) {
        cat("      Significance:", format.pval(x$signif, eps = 1/nperm), "\n\n")
        out <- quantile(x$perm, c(0.9, 0.95, 0.975, 0.99))
        cat("Empirical upper confidence limits of r:\n")
        print(out, digits = 3)
        cat("\nBased on", nperm, "permutations")
        if (!is.null(x$strata))
           cat(", stratified within", x$strata)
    }
    cat("\n\n")
    invisible(x)
}
"print.permutest.cca" <-
    function (x, ...) 
{
    cat("\nPermutation test for", x$method, "\nCall:\n")
    cat(deparse(x$call), "\n\n")
    Pval <- sum(x$F.perm >= x$F.0)/x$nperm
    cat("Test for significance of all constrained eigenvalues\n")
    cat("Pseudo-F:\t", x$F.0, "\n")
    cat("Significance:\t", format.pval(Pval, eps = 1/x$nperm), 
        "\n")
    cat("Based on", x$nperm, "permutations under", x$model, "model")
    if (!is.null(x$strata)) 
        cat(",\nstratified within factor", x$strata)
    cat(".\n\n")
    invisible(x)
}
"print.prestonfit" <-
    function (x, ...) 
{
    cat("\nPreston lognormal model\n")
    cat("Method:", x$method,"\n")
    cat("No. of species:", sum(x$freq), "\n\n")
    print(x$coefficients, ...)
    cat("\nFrequencies by Octave\n")
    print(rbind(Observed = x$freq, Fitted = x$fitted), ...)
    cat("\n")
    invisible(x)
}
"print.procrustes" <-
  function (x, digits = max(3, getOption("digits") - 3), ...) 
{
  cat("\nCall:\n")
  cat(deparse(x$call), "\n\n")
  cat("Procrustes sum of squares:\n")
  cat(formatC(x$ss, digits = digits), "\n\n")
  invisible(x)
}
"print.protest" <-
  function(x, digits = max(3, getOption("digits") - 3), ...)
{
  cat("\nCall:\n")
  cat(deparse(x$call), "\n\n")
  cat("Correlation in a symmetric Procrustes rotation:  ")
  cat(formatC(x$t0, digits = digits), "\n")
  cat("Significance:  ")
  cat(format.pval(x$signif, eps = 1/x$permutations),"\n")
  cat("Based on", x$permutations, "permutations")
  if (!is.null(x$strata)) 
    cat(", stratified within", x$strata)
  cat(".\n\n")
  invisible(x)
}
"print.radfit" <-
    function (x, ...) 
{
    cat("\nRAD models, family", x$family$family, "\n")
    cat("No. of species ", length(x$y), ", total abundance ", 
        sum(x$y), "\n\n", sep = "")
    p <- coef(x)
    aic <- sapply(x$models, AIC)
    bic <- sapply(x$models, AIC, k = log(length(x$y)))
    dev <- sapply(x$models, deviance)
    out <- cbind(p, Deviance = dev, AIC = aic, BIC = bic)
    printCoefmat(out, zap.ind=1:3, tst.ind=4:6, na.print="",...)
    invisible(x)
}
"print.radfit.frame" <-
    function (x, ...) 
{
    cat("\nDeviance for RAD models:\n\n")
    out <- sapply(x, function(x) unlist(lapply(x$models, deviance)))
    printCoefmat(out, na.print = "", ...)
    invisible(x)
}
"print.radline" <-
    function (x, ...) 
{
    cat("\nRAD model:", x$model, "\n")
    cat("Family:", family(x)$family, "\n")
    cat("No. of species: ", length(x$y), "\nTotal abundance:", 
        sum(x$y), "\n\n")
    p <- coef(x)
    dev <- deviance(x)
    AIC <- AIC(x)
    BIC <- AIC(x, k = log(length(x$y)))
    tmp <- c(p, dev, AIC, BIC)
    names(tmp) <- c(names(p), "Deviance", "AIC", "BIC")
    print(tmp, ...)
    invisible(x)
}
"print.specaccum" <-
    function(x, ...)
{
    cat("Species Accumulation Curve\n")
    cat("Accumulation method:", x$method)
    if (x$method == "random") {
        cat(", with ", ncol(x$perm), " permutations", sep="")
    }
    cat("\n")
    cat("Call:", deparse(x$call), "\n\n")
    mat <- rbind(Sites = x$sites, Richness = x$richness, sd=x$sd)
    colnames(mat) <- rep("", ncol(mat))
    print(mat)
    invisible(x)
}
"print.summary.bioenv" <-
    function(x, ...)
{
    out <- data.frame(size = x$size, correlation = x$cor)
    rownames(out) <- x$var
    printCoefmat(out, ...)
    invisible(x)
}
"print.summary.cca" <-
    function (x, digits = x$digits, ...) 
{
    cat("\nCall:\n")
    statnam <- if (x$method == "rda") "sums" else "averages"
    cat("\nPartitioning of ", x$inertia, ":\n", sep = "")
    out <- rbind(Total = x$tot.chi, "Conditioned out" = x$partial.chi, 
                 Constrained = x$constr.chi, Unconstrained = x$unconst.chi)
    colnames(out) <- ""
    print(out, digits = digits, ...)
    cat("\nEigenvalues, and their contribution to the", x$inertia, 
        "\n")
    if (!is.null(x$partial.chi)) {
        cat("after removing the contribution of conditiniong variables\n")
    }
    cat("\n")
    out <- rbind(lambda = c(x$ev.con, x$ev.uncon), accounted = c(x$ev.con.account, 
                                                   x$ev.uncon.account))
    print(out, digits = digits, ...)
    cat("\nScaling", x$scaling, "for species and site scores\n")
    if (x$scaling == 2) {
        ev.ent <- "Species"
        other.ent <- "Sites"
    }
    else if (x$scaling == 1) {
        ev.ent <- "Sites"
        other.ent <- "Species"
    }
    else {
        ev.ent <- "Both sites and species"
        other.ent <- NULL
    }
    cat("--", ev.ent, "are scaled proportional to eigenvalues\n")
    if (!is.null(other.ent)) 
        cat("--", other.ent, "are unscaled: weighted dispersion equal")
    cat(" on all dimensions\n")
    cat("\n\nSpecies scores\n\n")
    print(x$species, digits = digits, ...)
    cat("\n\nSite scores (weighted", statnam, "of species scores)\n\n")
    print(x$sites, digits = digits, ...)
    if (!is.null(x$constraints)) {
        cat("\n\nSite constraints (linear combinations of constraining variables)\n\n")
        print(x$constraints, digits = digits, ...)
    }
    if (!is.null(x$biplot)) {
        cat("\n\nBiplot scores for constraining variables\n\n")
        print(x$biplot, digits = digits, ...)
    }
    if (!is.na(x$centroids)) {
        cat("\n\nCentroids for factor constraints\n\n")
        print(x$centroids, digits = digits, ...)
    }
    cat("\n")
    invisible(x)
}
"print.summary.decorana" <-
    function (x, ...) 
{
    digits <- x$digits
    if (!is.null(x$spec.scores)) {
        cat("Species scores:\n\n")
        TABLE <- cbind(x$spec.scores, Weights = x$spec.priorweights, 
                       Totals = x$spec.totals)
        printCoefmat(TABLE, digits = digits, na.print = "", ...)
        cat("\n")
    }
    if (!is.null(x$site.scores)) {
        cat("Site scores:\n\n")
        TABLE <- cbind(x$site.scores, Totals = x$site.totals)
        printCoefmat(TABLE, digits = digits, na.print = "", ...)
        cat("\n")
    }
    invisible(x)
}
"print.summary.humpfit" <-
    function(x, ...)
{
    cat("\nHump-backed Null model of richness vs. productivity\n\n")
    cat("Family:", x$family,"\n")
    cat("Link function: Fisher diversity\n\n")
    cat("Coefficients:\n\n")
    printCoefmat(x$est, ...)
    cat("\nDeviance", x$deviance, "with", x$df.residual)
    cat(" residual degrees of freedom\n")
    cat("AIC:", x$aic,"   BIC:", x$bic, "\n")
    cat("\nCorrelation of Coefficients:\n")
    correl <- format(round(x$correlation, 2), nsmall = 2)
    correl[!lower.tri(correl)] <- ""
    print(correl[-1, -3], quote=FALSE)
    cat("\nDiagnostics from nlm:\n")
    cat("Number of iterations: ", x$iter, ", code: ", x$code,"\n", sep="")
    invisible(x)
}
"print.summary.procrustes" <-
  function (x, digits = x$digits, ...) 
{
  cat("\nCall:\n")
  cat(deparse(x$call), "\n")
  cat("\nNumber of objects:", x$n, "   Number of dimensions:", 
      x$k, "\n")
  cat("\nProcrustes sum of squares:  ")
  cat("\n", formatC(x$ss, digits = digits), "\n")
  cat("Procrustes root mean squared error: ")
  cat("\n", formatC(x$rmse, digits = digits), "\n")
  cat("Quantiles of Procrustes errors:\n")
  nam <- c("Min", "1Q", "Median", "3Q", "Max")
  rq <- structure(quantile(x$resid), names = nam)
  print(rq, digits = digits, ...)
  cat("\n")
  invisible(x)
}
"print.vectorfit" <-
    function (x, ...) 
{
    if (x$permutations) 
        eps <- 1/x$permutations
    else eps <- .Machine$double.eps
    out <- cbind(x$arrows, r2 = x$r, "Pr(>r)" = x$pvals)
    printCoefmat(out, eps.Pvalue = eps, na.print = "", ...)
    if (x$permutations) {
        cat("P values based on", x$permutations, "permutations")
        if (!is.null(x$strata)) 
            cat(", stratified within", x$strata)
        cat(".\n")
    }
    invisible(x)
}
"procrustes" <-
function (X, Y, scale = TRUE, symmetric = FALSE) 
{
    if (is.list(X)) 
        X <- scores(X, display = "sites")
    if (is.list(Y)) 
        Y <- scores(Y, display = "sites")
    X <- as.matrix(X)
    Y <- as.matrix(Y)
    if (ncol(X) < ncol(Y)) {
        warning("X has fewer axes than Y: X adjusted to comform Y\n")
        addcols <- ncol(Y) - ncol(X)
        for (i in 1:addcols) X <- cbind(X, 0)
    }
    ctrace <- function(MAT) sum(diag(crossprod(MAT)))
    c <- 1
    if (symmetric) {
       X <- scale(X, scale=FALSE)
       Y <- scale(Y, scale=FALSE)
       X <- X/sqrt(ctrace(X))
       Y <- Y/sqrt(ctrace(Y))
    }
    xmean <- apply(X, 2, mean)
    ymean <- apply(Y, 2, mean)
    if (!symmetric) {
      X <- scale(X, scale = FALSE)
      Y <- scale(Y, scale = FALSE)
    }
    XY <- crossprod(X, Y)
    sol <- svd(XY)
    A <- sol$v %*% t(sol$u)
    if (scale) {
        c <- sum(sol$d)/ctrace(Y)
    }
    Yrot <- c * Y %*% A
    b <- xmean - t(A %*% ymean)
    R2 <- ctrace(X) + c * c * ctrace(Y) - 2 * c * sum(sol$d)
    reslt <- list(Yrot = Yrot, X = X, ss = R2, rotation = A, 
        translation = b, scale = c, symmetric = symmetric, 
        call = match.call())
    reslt$svd <- sol
    class(reslt) <- "procrustes"
    return(reslt)
}
"protest" <-
  function(X, Y, permutations=1000, strata)
{
  X <- scores(X, display="sites")
  Y <- scores(Y, display="sites")
  sol <- procrustes(X, Y, symmetric = TRUE)
  sol$t0 <- sqrt(1 - sol$ss)
  N <- nrow(X)
  perm <- rep(0, permutations)
  for (i in 1:permutations) {
    take <- permuted.index(N, strata)
    tmp <- procrustes(X, Y[take,], symmetric=TRUE)$ss
    perm[i] <- sqrt(1 - tmp)
  }
  Pval <- sum(perm >= sol$t0) / permutations
  if (!missing(strata)) {
    strata <- deparse(substitute(strata))
    s.val <- strata
  }
  else {
    strata <- NULL
    s.val <- NULL
  }
  sol$t <- perm
  sol$signif <- Pval
  sol$permutations <- permutations
  sol$strata <- strata
  sol$stratum.values <- s.val
  sol$call <- match.call()
  class(sol) <- c("protest", "procrustes")
  sol
}
"rad.lognormal" <-
    function (x, family = poisson, ...) 
{
    x <- as.rad(x)
    n <- length(x)
    rnk <- -qnorm(ppoints(n))
    fam <- family(link = "log")
    ln <- try(glm(x ~ rnk, family = fam))
    if (inherits(ln, "try-error")) {
        aic <- rdf <- ln <- nl <- dev <-  NA
        p <- rep(NA, 2)
        fit <- res <- wts <- rep(NA, length(x))
    }
    else {
        p <- coef(ln)
        fit <- fitted(ln)
        aic <- AIC(ln)
        rdf <- df.residual(ln)
        dev <- deviance(ln)
        res <- ln$residuals
        wts <- weights(ln)
    }
    names(p) <- c("log.mu", "log.sigma")
    out <- list(model = "Log-Normal", family = fam, y = x, 
                coefficients = p, fitted.values = fit, aic = aic, rank = 2, 
                df.residual = rdf, deviance = dev, residuals = res, 
                prior.weights = wts)
    class(out) <- c("radline", "glm")
    out
}
"rad.preempt" <-
    function (x, family = poisson, ...) 
{
    canfun <- function(p, x, ...) {
        p <- plogis(p)
        if (p == 1) 
            p <- 1 - .Machine$double.eps
        fv <- linkinv(logJ + log(p) + log(1 - p) * rnk)
        n <- rep(1, length(fv))
        dev <- sum(dev.resids(x, fv, wt))
        aicfun(x, n, fv, wt, dev)/2
    }
    fam <- family(link = "log")
    aicfun <- fam$aic
    linkinv <- fam$linkinv
    dev.resids <- fam$dev.resids
    x <- as.rad(x)
    rnk <- seq(along = x) - 1
    wt <- rep(1, length(x))
    logJ <- log(sum(x))
    p <- qlogis(0.1)
    canon <- try(nlm(canfun, p = p, x = x, rnk = rnk, logJ = logJ, wt = wt,
                     hessian = TRUE, ...))
    if (inherits(canon, "try-error")) {
        aic <- rdf <- devaince <- NA
        p <- rep(NA, 1)
        fit <- residuals <- prior.weights <- rep(NA, length(x))
    }
    else {
        p <- plogis(canon$estimate)
        fit <- exp(logJ + log(p) + log(1 - p) * rnk)
        res <- dev.resids(x, fit, wt)
        deviance <- sum(res)
        residuals <- x-fit
        aic <- aicfun(x, rep(1, length(x)), fit, wt, res) + 2
        rdf <- length(x) - 1
    }
    names(p) <- c("alpha")
    out <- list(model = "Preemption", family = fam, 
                y = x, coefficients = p, fitted.values = fit, aic = aic, rank = 1, 
                df.residual = rdf, deviance = deviance, residuals = residuals,
                prior.weights=wt)
    class(out) <- c("radline", "glm")
    out
}
"rad.veil" <-
    function (x, family = poisson, ...) 
{
    veilfun <- function(p, x) {
        p <- max(.Machine$double.eps, plogis(p))
        rnk <- -qnorm(p * ppoints(length(x)))
        sol <- glm(x ~ rnk, family = family(link = "log"))
        -logLik(sol)
    }
    x <- as.rad(x)
    p <- qlogis(0.8)
    fam <- family(link = "log")
    veil <- try(nlm(veilfun, p = p, x = x, hessian = TRUE, ...))
    if (inherits(veil, "try-error")) {
        aic <- rdf <- ln <- nl <- dev <- NA
        p <- rep(NA, 3)
        fit <- res <- wts <- rep(NA, length(x))
    }
    else {
        p <- max(.Machine$double.eps, plogis(veil$estimate))
        rnk <- -qnorm(p * ppoints(length(x)))
        ln <- glm(x ~ rnk, family = family(link = "log"))
        p <- c(coef(ln), p)
        fit <- fitted(ln)
        aic <- AIC(ln) + 2
        rdf <- df.residual(ln) - 1
        dev <- deviance(ln)
        res <- ln$residuals
        wts <- weights(ln)
    }
    names(p) <- c("log.mu", "log.sigma", "veil")
    out <- list(model = "Veil Log-Normal", family = fam, 
                y = x, coefficients = p, fitted.values = fit, aic = aic, 
                rank = 3, df.residual = rdf, deviance = dev, 
                residuals = res, prior.weights = wts)
    class(out) <- c("radline", "glm")
    out
}
"rad.zipf" <-
    function (x, family = poisson, ...) 
{
    x <- as.rad(x)
    rnk <- seq(along = x)
    off <- rep(log(sum(x)), length(x))
    fam <- family(link = "log")
    ln <- try(glm(x ~ log(rnk) + offset(off), family = fam))
    if (inherits(ln, "try-error")) {
        aic <- rdf <- ln <- nl <- dev <- NA
        p <- rep(NA, 2)
        fit <- res <- wts <- rep(NA, length(x))
    }
    else {
        fit <- fitted(ln)
        p <- coef(ln)
        p[1] <- exp(p[1])
        aic <- AIC(ln)
        rdf <- df.residual(ln)
        dev <- deviance(ln)
        res <- ln$residuals
        wts <- weights(ln)
    }
    names(p) <- c("p1", "gamma")
    out <- list(model = "Zipf", family = fam, y = x, coefficients = p, 
                fitted.values = fit, aic = aic, rank = 2, df.residual = rdf, 
                deviance = dev, residuals = res, prior.weights = wts)
    class(out) <- c("radline", "glm")
    out
}
"rad.zipfbrot" <-
    function (x, family = poisson, ...) 
{
    mandelfun <- function(p, x, ...) {
        brnk <- log(rnk + exp(p))
        sol <- glm(x ~ brnk + offset(off), family = family(link = "log"))
        -logLik(sol)
    }
    x <- as.rad(x)
    rnk <- seq(along = x)
    off <- rep(log(sum(x)), length(x))
    p <- 0
    fam <- family(link = "log")
    nl <- try(nlm(mandelfun, p = p, x = x, rnk = rnk, off = off, 
                  family = fam, hessian = TRUE, ...))
    if (inherits(nl, "try-error")) {
        aic <- rdf <- ln <- nl <- dev <-  NA
        p <- rep(NA, 3)
        fit <- res <- wts <- rep(NA, length(x))
    }
    else {
        ln <- glm(x ~ log(rnk + exp(nl$estimate)) + offset(off), 
                  family = family(link = "log"))
        fit <- fitted(ln)
        p <- c(coef(ln), exp(nl$estimate))
        p[1] <- exp(p[1])
        aic <- AIC(ln) + 2
        rdf <- df.residual(ln) - 1
        dev <- deviance(ln)
        res <- ln$residuals
        wts <- weights(ln)
    }
    names(p) <- c("c", "gamma", "beta")
    out <- list(model = "Zipf-Mandelbrot", family = fam, 
                y = x, coefficients = p, fitted.values = fit, aic = aic, 
                rank = 3, df.residual = rdf, deviance = dev, 
                residuals = res, prior.weights = wts)
    class(out) <- c("radline", "glm")
    out
}
"radfit" <-
    function (...)
{
    UseMethod("radfit")
}
"radfit.data.frame" <-
    function(df, ...)
{
    out <- apply(df, 1, radfit, ...)
    if (length(out) == 1)
        out <- out[[1]]
    else {
        Call <- match.call()
        class(out) <- "radfit.frame"
    }
    out
}
"radfit.default" <-
    function (x, ...) 
{
    x <- as.rad(x)
    PE <- rad.preempt(x, ...)
    LN <- rad.lognormal(x, ...)
    VL <- rad.veil(x, ...)
    ZP <- rad.zipf(x, ...)
    ZM <- rad.zipfbrot(x, ...)
    out <- list(y = x, family = PE$family)
    models <- list(Preemption = PE, Lognormal = LN, Veiled.LN = VL, 
                   Zipf = ZP, Mandelbrot = ZM)
    out$models <- models
    class(out) <- "radfit"
    out
}
"rankindex" <-
    function (grad, veg, indices = c("euc", "man", "gow", "bra", "kul"),
              stepacross = FALSE, method = "kendall", 
              ...) 
{
    grad <- as.matrix(grad)
    veg <- as.matrix(veg)
    span <- vegdist(grad, "eucl")
    res <- numeric(length(indices))
    names(res) <- indices
    for (i in indices) {
        y <- vegdist(veg, i)
        if (stepacross) {
            is.na(y) <- no.shared(veg)
            y <- stepacross(y, trace = FALSE, toolong=-1, ...)
        }
        res[i] <- cor.test(span, y, method = method)$estimate
    }
    res
}
"rarefy" <-
function (x, sample, se = FALSE, MARGIN = 1) 
{
    x <- as.matrix(x)
    if (missing(sample)) {
        sample <- min(apply(x, MARGIN, sum))
        info <- paste("The size of `sample' must be given --\nHint: Smallest site maximum",
                      sample)
        stop(info)
    }
    rarefun <- function(x, sample) {
        x <- x[x > 0]
        J <- sum(x)
        ldiv <- lchoose(J, sample)
        p1 <- ifelse(J-x < sample, 0, exp(lchoose(J - x, sample) - ldiv))
        out <- sum(1-p1)
        if(se) {
            V <- sum(p1*(1-p1))
            Jxx <- J - outer(x, x, "+")
            ind <- lower.tri(Jxx)
            Jxx <- Jxx[ind]
            V <- V + 2*sum(ifelse(Jxx < sample, 0, exp(lchoose(Jxx, sample) - ldiv))
            - outer(p1,p1)[ind])
            out <- cbind(out, sqrt(V))
        }
        out
    }
    S.rare <- apply(x, MARGIN, rarefun, sample = sample)
    if (se)
        rownames(S.rare) <- c("S","se")
    attr(S.rare, "Subsample") <- sample
    S.rare
}
"rda" <-
function (...) 
{
    UseMethod("rda")
}
"rda.default" <-
    function (X, Y, Z, scale = FALSE, ...) 
{
    CCA <- NULL
    pCCA <- NULL
    CA <- NULL
    X <- as.matrix(X)
    NR <- nrow(X) - 1
    Xbar <- scale(X, center = TRUE, scale = scale)
    tot.chi <- sum(svd(Xbar, nu = 0, nv = 0)$d^2)/NR
    if (!missing(Z) && !is.null(Z)) {
        Z <- as.matrix(Z)
        Z.r <- scale(Z, center = TRUE, scale = FALSE)
        Q <- qr(Z.r)
        Z <- qr.fitted(Q, Xbar)
        tmp <- sum(svd(Z, nu = 0, nv = 0)$d^2)/NR
        pCCA <- list(rank = Q$rank, tot.chi = tmp, QR = Q, Fit = Z)
        Xbar <- qr.resid(Q, Xbar)
    }
    else Z.r <- NULL
    if (!missing(Y) && !is.null(Y)) {
        Y <- as.matrix(Y)
        rawmat <- Y
        Y.r <- scale(Y, center = TRUE, scale = FALSE)
        Q <- qr(cbind(Y.r, Z.r))
        if (is.null(pCCA)) 
            rank <- Q$rank
        else rank <- Q$rank - pCCA$rank
        Y <- qr.fitted(Q, Xbar)
        sol <- svd(Y)
        rank <- min(rank, length(sol$d))
        sol$d <- sol$d/sqrt(NR)
        ax.names <- paste("RDA", 1:length(sol$d), sep = "")
        colnames(sol$u) <- ax.names
        colnames(sol$v) <- ax.names
        names(sol$d) <- ax.names
        rownames(sol$u) <- rownames(X)
        rownames(sol$v) <- colnames(X)
        CCA <- list(eig = sol$d[1:rank]^2)
        CCA$u <- as.matrix(sol$u)[, 1:rank, drop = FALSE]
        CCA$v <- as.matrix(sol$v)[, 1:rank, drop = FALSE]
        CCA$u.eig <- sweep(as.matrix(CCA$u), 2, sol$d[1:rank], 
                           "*")
        CCA$v.eig <- sweep(as.matrix(CCA$v), 2, sol$d[1:rank], 
                           "*")
        CCA$wa.eig <- Xbar %*% sol$v[, 1:rank, drop = FALSE]
        CCA$wa.eig <- CCA$wa.eig/sqrt(NR)
        CCA$wa <- sweep(CCA$wa.eig, 2, 1/sol$d[1:rank], "*")
        CCA$biplot <- cor(as.matrix(Y.r), sol$u[, 1:rank, drop = FALSE])
        CCA$rank <- rank
        CCA$tot.chi <- sum(CCA$eig)
        CCA$QR <- Q
        CCA$Xbar <- Xbar
        Xbar <- qr.resid(Q, Xbar)
    }
    Q <- qr(Xbar)
    if (Q$rank > 0) {
        sol <- svd(Xbar)
        sol$d <- sol$d/sqrt(NR)
        ax.names <- paste("PC", 1:length(sol$d), sep = "")
        colnames(sol$u) <- ax.names
        colnames(sol$v) <- ax.names
        names(sol$d) <- ax.names
        rownames(sol$u) <- rownames(X)
        rownames(sol$v) <- colnames(X)
        CA <- list(eig = (sol$d[1:Q$rank]^2))
        CA$u <- as.matrix(sol$u)[, 1:Q$rank, drop = FALSE]
        CA$v <- as.matrix(sol$v)[, 1:Q$rank, drop = FALSE]
        CA$u.eig <- sweep(as.matrix(CA$u), 2, sol$d[1:Q$rank], 
                          "*")
        CA$v.eig <- sweep(as.matrix(CA$v), 2, sol$d[1:Q$rank], 
                          "*")
        CA$rank <- Q$rank
        CA$tot.chi <- sum(CA$eig)
        CA$Xbar <- Xbar
    }
    call <- match.call()
    call[[1]] <- as.name("rda")
    sol <- list(call = call, grand.total = NA, rowsum = NA, colsum = NA, 
                tot.chi = tot.chi, pCCA = pCCA, CCA = CCA, CA = CA)
    sol$method <- "rda"
    sol$inertia <- if (scale) "correlations" else "variance"
    class(sol) <- c("rda", "cca")
    sol
}
"rda.formula" <-
    function (formula, data, scale = FALSE) 
{
    if (missing(data)) {
        data <- parent.frame()
    }
    d <- ordiParseFormula(formula, data)
    sol <- rda.default(d$X, d$Y, d$Z, scale)
    if (!is.null(sol$CCA))
        sol$CCA$centroids <- centroids.cca(sol$CCA$wa, d$modelframe)
    sol$terms <- d$terms
    sol$call <- match.call()
    sol$call[[1]] <- as.name("rda")
    sol$call$formula <- formula(d$terms, width.cutoff = 500)
    sol
}
"read.cep" <-
  function (file, maxdata = 10000, positive = TRUE, trace = FALSE,
            force = FALSE) 
{
  if (!force) {
    stop("R may crash: if you want to try, save your session and use `force=T'")
  }
  ftypes <- c("free", "open", "condensed")
  file <- path.expand(file)
  if (trace) 
    cat("File", file, "\n")
  if (file.access(file, 4) < 0) {
    stop("File does not exist or is not readable.")
  }
  on.exit(.Fortran("cepclose", PACKAGE = "vegan"))
  cep <- .Fortran("cephead", file = file, kind = integer(1), 
                  nitem = integer(1), nst = integer(1), fmt = character(1), 
                  PACKAGE = "vegan")
  if (cep$kind > 3) 
    stop("Unknown CEP file type")
  if (trace) {
    cat("looks like", ftypes[cep$kind], "CEP file,\n")
    cat("with", cep$nitem, "items per record")
    if (cep$kind == 1) 
      cat(" and", cep$nst, "records")
    cat(".\n")
  }
  switch(cep$kind,
         cd <- .Fortran("cepfree",
                        nitem = as.integer(cep$nitem), 
                        axdat = as.integer(maxdata),
                        nsp = integer(1),
                        nst = as.integer(cep$nst),
                        i = integer(maxdata),
                        j = integer(maxdata),
                        y = double(maxdata),
                        w = double(cep$nitem),
                        ier = integer(1),
                        PACKAGE = "vegan"), 
         cd <- .Fortran("cepopen",
                        fmt = as.character(cep$fmt), 
                        nitem = as.integer(cep$nitem),
                        maxdat = as.integer(maxdata), 
                        nsp = integer(1),
                        nst = integer(1),
                        i = integer(maxdata), 
                        j = integer(maxdata),
                        y = double(maxdata),
                        w = double(cep$nitem), 
                        ier = integer(1),
                        PACKAGE = "vegan"),
         cd <- .Fortran("cepcond",
                        fmt = as.character(cep$fmt),
                        nitem = as.integer(cep$nitem),
                        maxdat = as.integer(maxdata),
                        nsp = integer(1),
                        nst = integer(1),
                        i = integer(maxdata),
                        j = integer(maxdata),
                        y = double(maxdata),
                        w = double(cep$nitem),
                        iw = integer(cep$nitem),
                        ier = integer(1),
                        PACKAGE = "vegan"))
  if (cd$ier) {
    if (cd$ier == 1) 
      stop("Too many non-zero entries: increase maxdata.")
    else stop("Unknown and obscure error: don't know what to do.")
  }
  if (trace) 
    cat("Read", cd$nsp, "species, ", cd$nst, "sites.\n")
  d <- matrix(0, cd$nst, cd$nsp)
  for (i in 1:length(cd$i)) d[cd$i[i], cd$j[i]] <- cd$y[i]
  nlines <- ceiling(cd$nsp/10)
  names <- NULL
  for (i in 1:nlines) {
    tmpnames <- .Fortran("cepnames", character(1), PACKAGE = "vegan")
    tmpnames <- substring(as.character(tmpnames), 1, 80)
    tmpnames <- substring(tmpnames, seq(1, 80, by = 8), seq(8, 
                                                 80, by = 8))
    names <- c(names, tmpnames)
  }
  names <- gsub(" ", "", names)
  names <- make.names(names, unique = TRUE)
  colnames(d) <- names[1:ncol(d)]
  nlines <- ceiling(cd$nst/10)
  names <- NULL
  for (i in 1:nlines) {
    tmpnames <- .Fortran("cepnames", character(1), PACKAGE = "vegan")
    tmpnames <- substring(as.character(tmpnames), 1, 80)
    tmpnames <- substring(tmpnames, seq(1, 80, by = 8), seq(8, 
                                                 80, by = 8))
    names <- c(names, tmpnames)
  }
  names <- gsub(" ", "", names)
  names <- make.names(names, unique = TRUE)
  rownames(d) <- names[1:nrow(d)]
  if (positive) {
    rsum <- apply(d, 1, sum)
    csum <- apply(d, 2, sum)
    d <- d[rsum > 0, csum > 0]
  }
  as.data.frame(d)
}
"renyi" <-
function (x, scales = c(0, 0.25, 0.5, 1, 2, 4, 8, 16, 32, 64, 
    Inf), hill = FALSE) 
{
    x <- as.matrix(x)
    n <- nrow(x)
    p <- ncol(x)
    if (p == 1) {
        x <- t(x)
        n <- nrow(x)
        p <- ncol(x)
    }
    x <- decostand(x, "total", 1)
    m <- length(scales)
    result <- array(0, dim = c(n, m))
    dimnames(result) <- list(sites = rownames(x), scale = scales)
    for (a in 1:m) {
        if (scales[a] != 0 && scales[a] != 1 && scales[a] != 
            Inf) {
            for (i in 1:n) {
                result[i, a] <- log(apply(x[i, ]^scales[a], 
                  1, sum))/(1 - scales[a])
            }
        }
        else {
            if (scales[a] == 0) {
                result[, a] <- log(apply(x > 0, 1, sum))
            }
            else if (scales[a] == Inf) {
                result[, a] <- -log(apply(x, 1, max))
            }
            else {
                result[, a] <- diversity(x)
            }
        }
    }
    if (hill) 
        result <- exp(result)
    result <- as.data.frame(result)
    if (any(dim(result) == 1)) 
        result <- unlist(result, use.names = FALSE)
    result
}
"residuals.procrustes" <-
  function (object, ...) 
{
  distance <- object$X - object$Yrot
  resid <- apply(distance^2, 1, sum)
  resid <- sqrt(resid)
  resid
}
"ripley.subs" <-
    function(x, string)
{
    ripley.subsets(length(string), x, string)
}
"ripley.subsets" <-
    function(n, r, s = 1:n)
{
    if(mode(n) != "numeric" || length(n) != 1
       || n < 1 || (n %% 1) != 0) stop("bad value of n")
    if(mode(r) != "numeric" || length(r) != 1
       || r < 1 || (r %% 1) != 0) stop("bad value of r")
    if(!is.atomic(s) || length(s) < n)
        stop("s is either non-atomic or too short")
    fun <- function(n, r, s)
        if(r <= 0) vector(mode(s), 0) else if(r >= n) s[1:n] else
    rbind(cbind(s[1], Recall(n - 1, r - 1, s[-1])),
          Recall(n - 1, r, s[-1]))
    fun(n, r, s)
}
"scores" <-
function(x, ...) UseMethod("scores")
"scores.cca" <-
    function (x, choices = c(1, 2), display = c("sp", "wa", "cn"), 
              scaling = 2, ...) 
{
    tabula <- c("species", "sites", "constraints", "biplot", 
                "centroids")
    names(tabula) <- c("sp", "wa", "lc", "bp", "cn")
    if (is.null(x$CCA)) 
        tabula <- tabula[1:2]
    if (length(display) == 1) {
        display <- match.arg(display, c("sites", "species", "wa", 
                                        "lc", "bp", "cn"))
        if (display == "sites") 
            display <- "wa"
        else if (display == "species") 
            display <- "sp"
    }
    take <- tabula[display]
    max.ax <- max(choices)
    sol <- summary(x, max.ax, scaling = scaling)[take]
    if ("species" %in% take && any(choices != 1)) 
        sol$species <- sol$species[, choices]
    if ("sites" %in% take && any(choices != 1)) 
        sol$sites <- sol$sites[, choices]
    if ("constraints" %in% take && any(choices != 1)) {
        sol$constraints <- as.matrix(sol$constraints)
        nc <- ncol(sol$constraints)
        nr <- nrow(sol$constraints)
        if (nc < max.ax) {
            tmp <- matrix(0, nrow = nr, ncol = (max.ax - nc))
            sol$constraints <- cbind(sol$constraints, tmp)
        }
        sol$constraints <- sol$constraints[, choices]
    }
    if ("biplot" %in% take && any(choices != 1)) {
        sol$biplot <- as.matrix(sol$biplot)
        nc <- ncol(sol$biplot)
        nr <- nrow(sol$biplot)
        if (nc < max.ax) {
            tmp <- matrix(0, nrow = nr, ncol = (max.ax - nc))
            sol$biplot <- cbind(sol$biplot, tmp)
        }
        sol$biplot <- sol$biplot[, choices, drop = FALSE]
    }
    if ("centroids" %in% take && any(choices != 1) && !is.na(sol$centroids)) {
        sol$centroids <- as.matrix(sol$centroids)
        nc <- ncol(sol$centroids)
        nr <- nrow(sol$centroids)
        if (nc < max.ax) {
            tmp <- matrix(0, nrow = nr, ncol = (max.ax - nc))
            sol$centroids <- cbind(sol$centroids, tmp)
        }
        sol$centroids <- sol$centroids[, choices, drop = FALSE]
    }
    if (length(sol) == 1) 
        sol <- sol[[1]]
    return(sol)
}
"scores.decorana" <-
function (x, display=c("sites","species"), choices = 1:4, origin=TRUE, ...) 
{
   display <- match.arg(display)
   if(display == "sites")
      X <- x$rproj
   else if(display == "species")
      X <- x$cproj
   if (origin)
      X <- sweep(X, 2, x$origin, "-")
   X <- X[,choices]
   X 
}
"scores.default" <-
function (x, display = c("sites", "species"), choices, ...) 
{
    display <- match.arg(display)
    att <- attributes(x)$names
    if (is.list(x) && display == "sites") {
        if ("points" %in% att) 
            X <- x$points
        else if ("rproj" %in% att) 
            X <- x$rproj
        else if ("x" %in% att) 
            X <- x$x
        else if ("scores" %in% att) 
            X <- x$scores
        else stop("Can't find scores")
    }
    else if (is.list(x) && display == "species") {
        if ("cproj" %in% att) 
            X <- x$cproj
        else if ("rotation" %in% att) 
            X <- x$rotation
        else if ("loadings" %in% att) 
            X <- x$loadings
        else stop("Can't find scores")
    }
    else if(is.matrix(x))
        X <- x
    if (is.null(rownames(X))) {
       root <- substr(display, 1, 4)
       rownames(X) <- paste(root,1:nrow(X), sep="")
    }
    if (is.null(colnames(X)))
       colnames(X) <- paste("Dim",1:ncol(X), sep="")
    if (!missing(choices)) 
        X <- X[, choices]
    X <- as.matrix(X)
    X
}
"scores.ordiplot" <-
function (x, display = "sites", ...) 
{
    if (length(x) == 1)
        return(x[[1]])
    items <- names(x)
    items <- items[!is.na(items)]
    display <- match.arg(display, items)
    cmd <- paste("x", display, sep = "$")
    eval(parse(text = cmd))
}
"spantree" <-
    function (dis, toolong = 1) 
{
    dis <- as.dist(dis)
    n <- attr(dis, "Size")
    dis <- .C("primtree", dist = as.double(dis), toolong = as.double(toolong),
              n = as.integer(n), val = double(n+1), dad=integer(n+1),
              NAOK = TRUE, PACKAGE = "vegan")
    out <- list(kid = dis$dad[2:n] + 1, dist = dis$val[2:n])
    out
}
"specaccum" <-
    function(comm, method = "exact", permutations = 100, ...)
{
    x <- comm
    x <- as.matrix(x)
    n <- nrow(x)
    p <- ncol(x)
    if (p==1) {
        x <- t(x)
        n <- nrow(x)
        p <- ncol(x)        
    }
    #n2 <- n
    accumulator <- function (x, ind) {
        rowSums(apply(x[ind,],2,cumsum) > 0)
    }
    METHODS <- c("collector", "random", "exact", "rarefaction", "coleman")
    method <- match.arg(method, METHODS)
    specaccum <- sdaccum <- sites <- perm <- NULL
    if (n==1 & method!="rarefaction")
        stop(paste("only 1 site provided"))
    switch(method, collector = {
        sites <- 1:n
        specaccum <- accumulator(x,sites)
    }, random = {
        perm <- array(dim=c(n,permutations))
        for (i in 1:permutations) {
            perm[,i] <- accumulator(x,sample(n))
        }
        sites <- 1:n
        specaccum <- apply(perm, 1, mean)
        sdaccum <- apply(perm, 1, sd)
    }, exact = {
        freq <- colSums(x>0)
        freq <- freq[freq>0]
        f <- length(freq)
        ldiv <- lchoose(n, 1:n)
        result <- array(dim=c(n, f))
        for (i in 1:n) {
            result[i,] <- ifelse(n-freq < i, 0, exp(lchoose(n-freq, i) - ldiv[i]))
        }
        V <- result*(1-result)
        tmp1 <- cor(x>0)
        ind <- lower.tri(tmp1)
        tmp1 <- tmp1[ind]
        tmp1[is.na(tmp1)] <- 0
        cv <- numeric(n)
        for (i in 1:n) {
            tmp2 <- outer(sqrt(V[i,]), sqrt(V[i,]))[ind]
            cv[i] <- 2*sum(tmp1 * tmp2)  
        }
        V <- rowSums(V)
        sites <- 1:n
        specaccum <- rowSums(1-result)
        sdaccum <- sqrt(V+cv)
    }, rarefaction = {
        freq <- colSums(x)
        freq <- freq[freq>0]
        tot <- sum(freq)
        ind <- round(seq(tot/n, tot, length=n))
        result <- matrix(NA, nrow=2, ncol=n)
        for (i in 1:n) {
            result[,i] <- rarefy(t(freq), ind[i], se=TRUE)
        }
        specaccum <- result[1,]
        sdaccum <- result[2,]
        sites <- ind/tot*n
    }, coleman = {
        freq <- colSums(x>0)
        result <- array(dim=c(n,p))
        for (i in 1:n) {
            result[i,] <- (1-i/n)^freq
        }
        result <- 1-result
        sites <- 1:n
        specaccum <- apply(result,1,sum)
        sdaccum <- sqrt(apply(result*(1-result), 1, sum))
    })
    out <- list(call = match.call(), method = method, sites = sites,
                richness = specaccum, sd = sdaccum, perm = perm)
    class(out) <- "specaccum"
    out
}
"specnumber" <-
    function(x, MARGIN = 1)
{
    apply(x > 0, MARGIN, sum)
}
"specpool" <-
function(x, pool)
{
    x <- as.matrix(x)
    if (missing(pool))
        pool <- rep("All", nrow(x))
    out <- seq(1:nrow(x))
    groups <- table(pool)
    inds <- names(groups)
    S <- chao <- jack.1 <- jack.2 <- bootS <- rep(NA, length(inds))
    names(S) <- names(chao) <- names(jack.1) <- names(jack.2) <- names(bootS) <- inds
    for (is in inds) {
        a1 <- a2 <- NA
        gr <- out[pool == is]
        n <- length(gr)
        X <- x[gr, , drop=FALSE]
        freq <- colSums(X > 0)
        p <- freq[freq>0]/n
        S[is] <- sum(freq > 0)
        if (n > 1)
            a1 <- sum(freq == 1)
        if (n > 2)
            a2 <- sum(freq == 2)
        chao[is] <- S[is] + a1*a1/2/a2
        jack.1[is] <- S[is] + a1*(n-1)/n
        jack.2[is] <- S[is] + a1*(2*n-3)/n - a2*(n-2)^2/n/(n-1)
        bootS[is] <- S[is] + sum((1 - p)^n)
    }
    out <- list(Species = S, Chao = chao, Jack.1 = jack.1, Jack.2 = jack.2,
                Boot = bootS, n = as.vector(groups))
    out <- as.data.frame(out)
    attr(out, "pool") <- pool
    out
}
"specpool2vect" <-
function(X, index = c("Jack.1","Jack.2", "Chao", "Boot", "Species"))
{
    pool <- attr(X, "pool")
    index <- match.arg(index)
    sel <- paste("X", index, sep = "$")
    sel <- eval(parse(text=sel))
    sel[pool]
}
"spider.cca" <-
    function (x, ...) 
{
    stop("Function is deprecated: Use ordispider instead")
    invisible()
}
"stepacross" <-
    function (dis, path = "shortest", toolong = 1, trace = TRUE) 
{
    path <- match.arg(path, c("shortest", "extended"))
    if (!inherits(dis, "dist")) 
        dis <- as.dist(dis)
    oldatt <- attributes(dis)
    n <- attr(dis, "Size")
    if (path == "shortest") 
        dis <- .C("dykstrapath", dist = as.double(dis), n = as.integer(n), 
                  as.double(toolong), as.integer(trace), out = double(length(dis)), 
                  NAOK = TRUE, PACKAGE = "vegan")$out
    else dis <- .C("stepacross", dis = as.double(dis), as.integer(n), 
                   as.double(toolong), as.integer(trace),
                   NAOK = TRUE, PACKAGE = "vegan")$dis
    attributes(dis) <- oldatt
    attr(dis, "method") <- paste(attr(dis, "method"), path)
    dis
}
"summary.anosim" <-
function (object, ...) 
{
   print(object)
   if (object$permutations) {
     out <- quantile(object$perm, c(0.9, 0.95, 0.975, 0.99))
     cat("Empirical upper confidence limits of R:\n")
     print(out, digits=3)
   }
   cat("\n")
   tmp <- tapply(object$dis.rank, object$class.vec, quantile)
   out <- matrix(NA, length(tmp), 5)
   for (i in 1:length(tmp)) out[i,] <- tmp[[i]]
   rownames(out) <- names(tmp)
   colnames(out) <- names(tmp$Between)
   out <- cbind(out, N = table(object$class.vec))
   cat("Dissimilarity ranks between and within classes:\n")
   print(out)
   cat("\n") 
   invisible()
}
"summary.bioenv" <-
    function(object, ...)
{
    x <- object$models
    nam <- object$names
    size <- seq(1:length(x))
    cor <- unlist(lapply(x, function(tmp) tmp$est))
    pars <- unlist(lapply(x, function(tmp) paste(nam[tmp$best], collapse=" ")))
    out <- list(size = size, correlation = cor, variables = pars)
    class(out) <- "summary.bioenv"
    out
}
"summary.cca" <-
    function (object, scaling = 2, axes = 6, digits = max(3, getOption("digits") - 
                                             3), ...) 
{
    axes <- min(axes, sum(object$CCA$rank, object$CA$rank))
    summ <- object[c("call", "tot.chi")]
    summ$partial.chi <- object$pCCA$tot.chi
    summ$constr.chi <- object$CCA$tot.chi
    summ$unconst.chi <- object$CA$tot.chi
    summ$ev.con <- object$CCA$eig
    summ$ev.uncon <- object$CA$eig
    ev.account <- summ$tot.chi
    if (!is.null(object$pCCA)) 
        ev.account <- ev.account - summ$partial.chi
    summ$ev.con.account <- cumsum(summ$ev.con)/ev.account
    summ$ev.uncon.account <- cumsum(summ$ev.uncon)/ev.account
    summ$ev.head <- c(summ$ev.con, summ$ev.uncon)[1:axes]
    summ$scaling <- scaling
    cc.dim <- min(object$CCA$rank, axes)
    if (is.null(object$CCA)) 
        cc.dim <- 0
    biplot <- object$CCA$biplot[, 1:cc.dim, drop = FALSE]
    add.dim <- axes - cc.dim
    species <- object$CCA$v[, 1:cc.dim, drop = FALSE]
    sites <- object$CCA$wa.eig[, 1:cc.dim, drop = FALSE]
    site.constr <- object$CCA$u[, 1:cc.dim, drop = FALSE]
    centroids <- NA
    if (!is.null(object$CCA$centroids) && !is.na(object$CCA$centroids)[1]) 
        centroids <- object$CCA$centroids[, 1:cc.dim, drop = FALSE]
    evscale <- sqrt(summ$ev.con[1:cc.dim])
    if (abs(scaling) == 2) {
        if (cc.dim) {
            species <- sweep(species, 2, evscale, "*")
            sites <- sweep(sites, 2, evscale, "/")
            if (!is.na(centroids)[1]) 
                centroids <- sweep(centroids, 2, evscale, "/")
        }
        if (add.dim) {
            evscale0 <- sqrt(summ$ev.uncon[1:add.dim])
            tmp <- object$CA$v[, 1:add.dim, drop = FALSE]
            tmp <- sweep(tmp, 2, evscale0, "*")
            species <- cbind(species, tmp)
            sites <- cbind(sites, object$CA$u[, 1:add.dim, drop = FALSE])
        }
    }
    if (abs(scaling) == 1) {
        if (cc.dim) 
            site.constr <- sweep(site.constr, 2, evscale, "*")
        if (add.dim) {
            evscale0 <- sqrt(summ$ev.uncon[1:add.dim])
            species <- cbind(species, object$CA$v[, 1:add.dim, 
                                                  drop = FALSE])
            tmp <- object$CA$u[, 1:add.dim, drop = FALSE]
            tmp <- sweep(tmp, 2, evscale0, "*")
            sites <- cbind(sites, tmp)
        }
    }
    if (abs(scaling) == 3) {
        if (cc.dim) {
            species <- sweep(species, 2, sqrt(evscale), "*")
            sites <- sweep(sites, 2, sqrt(evscale), "/")
            if (!is.na(centroids)[1]) 
                centroids <- sweep(centroids, 2, sqrt(evscale), 
                                   "/")
            site.constr <- sweep(site.constr, 2, sqrt(evscale), 
                                     "*")
        }
        if (add.dim) {
            evscale0 <- sqrt(sqrt(summ$ev.uncon[1:add.dim]))
            tmp <- object$CA$u[, 1:add.dim, drop = FALSE]
            tmp <- sweep(tmp, 2, evscale0, "*")
            sites <- cbind(sites, tmp)
            tmp <- object$CA$v[, 1:add.dim, drop = FALSE]
            tmp <- sweep(tmp, 2, evscale0, "*")
            species <- cbind(species, tmp)
        }
    }
    if (scaling < 0) {
        evscale <- evscale0 <- NULL
        if(cc.dim)
            evscale <- summ$ev.con[1:cc.dim]
        if(add.dim)
            evscale0 <- summ$ev.uncon[1:add.dim]
        evscale <- c(evscale, evscale0)
        evscale <- sqrt(1/(1 - evscale))
        species <- sweep(species, 2, evscale, "*")
        sites <- sweep(sites, 2, evscale, "*")
        if (!is.na(centroids)[1]) 
            centroids <- sweep(centroids, 2, evscale[1:cc.dim], 
                               "*")
        if (!is.null(site.constr))
            site.constr <- sweep(site.constr, 2, evscale[1:cc.dim], 
                                 "*")
    }
    summ$species <- species
    summ$sites <- sites
    summ$constraints <- site.constr
    summ$biplot <- biplot
    summ$centroids <- centroids
    summ$digits <- digits
    summ$inertia <- object$inertia
    summ$method <- object$method
    class(summ) <- "summary.cca"
    summ
}
"summary.decorana" <-
    function (object, digits = 3, origin = TRUE, display = c("both", 
                                                 "species", "sites", "none"), ...) 
{
    display <- match.arg(display)
    print(object)
    if (origin) {
        object$cproj <- sweep(object$cproj, 2, object$origin, 
                              "-")
        object$rproj <- sweep(object$rproj, 2, object$origin, 
                              "-")
    }
    tmp <- list()
    if (display == "both" || display == "species") {
        tmp$spec.scores <- object$cproj
        tmp$spec.priorweights <- object$v
        tmp$spec.totals <- object$adotj
    }
    if (display == "both" || display == "sites") {
        tmp$site.scores <- object$rproj
        tmp$site.totals <- object$aidot
    }
    tmp$digits <- digits
    class(tmp) <- "summary.decorana"
    tmp
}
"summary.humpfit" <-
    function(object, ...)
{
    p <- coef(object)
    se <- sqrt(diag(solve(object$nlm$hessian)))
    est <- cbind(p, se)
    colnames(est) <- c("Estimate", "Std. Error")
    covmat <- solve(object$nlm$hessian)
    dg <- sqrt(diag(covmat))
    cormat <- covmat/outer(dg, dg)
    colnames(cormat) <- names(p)
    rownames(cormat) <- names(p)
    aic <- AIC(object)
    bic <- AIC(object, k = log(length(object$y)))
    out <- list(est = est, aic = aic, bic = bic, family = family(object)$family,
                deviance = deviance(object), df.residual = df.residual(object),
                correlation = cormat, iter = object$nlm$iterations,
                code = object$nlm$code)
    class(out) <- "summary.humpfit"
    out
}
"summary.procrustes" <-
  function (object, ...) 
{
  ans <- object[c("call", "ss")]
  n <- nrow(object$Yrot)
  k <- ncol(object$Yrot)
  ans$resid <- residuals(object)
  rmse <- sqrt(object$ss/n)
  ans$n <- n
  ans$k <- k
  ans$rmse <- rmse
  class(ans) <- "summary.procrustes"
  ans
}
"summary.rda" <-
    function (object, scaling = 2, axes = 6, digits = max(3, getOption("digits") - 
                                             3), ...) 
{
    axes <- min(axes, sum(object$CCA$rank, object$CA$rank))
    summ <- object[c("call", "tot.chi")]
    summ$partial.chi <- object$pCCA$tot.chi
    summ$constr.chi <- object$CCA$tot.chi
    summ$unconst.chi <- object$CA$tot.chi
    summ$ev.con <- object$CCA$eig
    summ$ev.uncon <- object$CA$eig
    ev.account <- summ$tot.chi
    if (!is.null(object$pCCA)) 
        ev.account <- ev.account - summ$partial.chi
    summ$ev.con.account <- cumsum(summ$ev.con)/ev.account
    summ$ev.uncon.account <- cumsum(summ$ev.uncon)/ev.account
    summ$ev.head <- c(summ$ev.con, summ$ev.uncon)[1:axes]
    summ$scaling <- scaling
    cc.dim <- min(object$CCA$rank, axes)
    if (is.null(object$CCA)) 
        cc.dim <- 0
    biplot <- object$CCA$biplot[, 1:cc.dim, drop = FALSE]
    add.dim <- axes - cc.dim
    species <- object$CCA$v[, 1:cc.dim, drop = FALSE]
    sites <- object$CCA$wa[, 1:cc.dim, drop = FALSE]
    centroids <- NA
    if (!is.null(object$CCA$centroids) && !is.na(object$CCA$centroids)[1]) 
        centroids <- object$CCA$centroids[, 1:cc.dim, drop = FALSE]
    site.constr <- object$CCA$u[, 1:cc.dim, drop = FALSE]
    sum.ev <- object$tot.chi
    if (is.null(object$CCA$u)) 
        nr <- nrow(object$CA$u)
    else nr <- nrow(object$CCA$u)
    const <- sqrt(sqrt((nr - 1) * sum.ev))
    evscale <- sqrt(summ$ev.con[1:cc.dim]/sum.ev)
    if (scaling == 2) {
        if (cc.dim) {
            species <- sweep(species, 2, evscale, "*")
        }
        if (add.dim) {
            evscale0 <- sqrt(summ$ev.uncon[1:add.dim]/sum.ev)
            tmp <- object$CA$v[, 1:add.dim, drop = FALSE]
            tmp <- sweep(tmp, 2, evscale0, "*")
            species <- cbind(species, tmp)
            sites <- cbind(sites, object$CA$u[, 1:add.dim, drop = FALSE])
        }
    }
    if (scaling == 1) {
        if (cc.dim) {
            site.constr <- sweep(site.constr, 2, evscale, "*")
            sites <- sweep(sites, 2, evscale, "*")
            if (!is.na(centroids)[1]) 
                centroids <- sweep(centroids, 2, evscale, "*")
        }
        if (add.dim) {
            evscale0 <- sqrt(summ$ev.uncon[1:add.dim]/sum.ev)
            species <- cbind(species, object$CA$v[, 1:add.dim, 
                                                  drop = FALSE])
            tmp <- object$CA$u[, 1:add.dim, drop = FALSE]
            tmp <- sweep(tmp, 2, evscale0, "*")
            sites <- cbind(sites, tmp)
        }
    }
    if (scaling == 3) {
        if (cc.dim) {
            species <- sweep(species, 2, sqrt(evscale), "*")
            sites <- sweep(sites, 2, sqrt(evscale), "/")
            if (!is.na(centroids)[1]) 
                centroids <- sweep(centroids, 2, sqrt(evscale), 
                                   "/")
            site.constr <- sweep(site.constr, 2, sqrt(evscale), 
                                 "/")
        }
        if (add.dim) {
            evscale0 <- sqrt(sqrt(summ$ev.uncon[1:add.dim]/sum.ev))
            tmp <- object$CA$u[, 1:add.dim, drop = FALSE]
            tmp <- sweep(tmp, 2, evscale0, "*")
            sites <- cbind(sites, tmp)
            tmp <- object$CA$v[, 1:add.dim, drop = FALSE]
            tmp <- sweep(tmp, 2, evscale0, "*")
            species <- cbind(species, tmp)
        }
    }
    summ$species <- const * species
    summ$sites <- const * sites
    summ$constraints <- const * site.constr
    summ$biplot <- biplot
    summ$centroids <- const * centroids
    summ$digits <- digits
    summ$inertia <- object$inertia
    summ$method <- object$method
    class(summ) <- "summary.cca"
    summ
}
"summary.specaccum" <-
    function(object, ...)
{
    if (is.null(object$perm))
        stop("Specific summary available only for method=\"random\"")
    else {
        tmp <- summary(t(object$perm), ...)
        colnames(tmp) <- paste(1:ncol(tmp), "sites")
        tmp
    }
}
"text.cca" <-
    function (x, display = "sites", choices = c(1, 2), scaling = 2, 
              mul.arrow = 1, head.arrow = 0.05, ...) 
{
    formals(arrows) <- c(formals(arrows), alist(... = ))
    if (length(display) > 1) 
        stop("Only one `display' item can be added in one command.")
    pts <- scores(x, choices = choices, display = display, scaling = scaling)
    if (display == "cn") {
        cnam <- rownames(pts)
        text(pts, labels = cnam, ...)
        pts <- scores(x, choices = choices, display = "bp", scaling = scaling)
        bnam <- rownames(pts)
        pts <- pts[!(bnam %in% cnam), , drop = FALSE]
        if (nrow(pts) == 0) 
            return(invisible())
        else display <- "bp"
    }
    if (display == "bp") {
        pts <- pts * mul.arrow
        arrows(0, 0, pts[, 1], pts[, 2], length = head.arrow, 
               ...)
        pts <- pts * 1.1
        axis(3, at = c(-mul.arrow, 0, mul.arrow), labels = rep("", 3))
        axis(4, at = c(-mul.arrow, 0, mul.arrow), labels = c(-1, 0, 1))
    }
    text(pts, labels = rownames(pts), ...)
    invisible()
}
"text.ordiplot" <-
function (x, what, ...) 
{
     x <- scores(x, what)
     text(x, labels = rownames(x), ...)
     invisible()
}
"vectorfit" <-
    function (X, P, permutations = 0, strata, choices=c(1,2)) 
{
    X <- scores(X, display = "sites", choices)
    X <- scale(X, scale = FALSE)
    P <- as.matrix(P)
    nc <- ncol(X)
    Q <- qr(X)
    H <- qr.fitted(Q, P)
    heads <- qr.coef(Q, P)
    r <- diag(cor(H, P)^2)
    heads <- decostand(heads, "norm", 2)
    heads <- t(heads)
    if (is.null(colnames(X))) 
        colnames(heads) <- paste("Dim", 1:nc, sep = "")
    else colnames(heads) <- colnames(X)
    if (permutations) {
        permstore <- matrix(nrow = permutations, ncol = ncol(P))
        for (i in 1:permutations) {
            indx <- permuted.index(nrow(P), strata)
            take <- P[indx, ,drop=FALSE]
            Hperm <- qr.fitted(Q, take)
            permstore[i, ] <- diag(cor(Hperm, take))^2
        }
        permstore <- sweep(permstore, 2, r, ">")
        pvals <- apply(permstore, 2, sum)/permutations
    }
    else pvals <- NULL
    sol <- list(arrows = heads, r = r, permutations = permutations, 
                pvals = pvals)
    if (!missing(strata)) {
        sol$strata <- deparse(substitute(strata))
        sol$stratum.values <- strata
    }
    class(sol) <- "vectorfit"
    sol
}
"vegdist" <-
    function (x, method = "bray", diag = FALSE, upper = FALSE) 
{
    if (!is.na(pmatch(method, "euclidian"))) 
        method <- "euclidean"
    METHODS <- c("manhattan", "euclidean", "canberra", "bray", "kulczynski",
                 "gower", "morisita", "horn", "mountford", "jaccard")
    method <- pmatch(method, METHODS)
    if (is.na(method)) 
        stop("invalid distance method")
    if (method == -1) 
        stop("ambiguous distance method")
    if (method == 6)
        x <- decostand(x, "range", 2)
    N <- nrow(x <- as.matrix(x))
    d <- .C("veg_distance", x = as.double(x), nr = N, nc = ncol(x), 
            d = double(N * (N - 1)/2), diag = as.integer(FALSE), 
            method = as.integer(method), PACKAGE="vegan")$d
    if (method == 10)
        d <- 2*d/(1+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)
}
"vegemite" <-
function (x, use, scale, sp.ind = NULL, site.ind = NULL, zero = ".") 
{
    if (!missing(use)) {
        if (!is.list(use) && is.vector(use)) {
            if (is.null(site.ind)) 
                site.ind <- order(use)
            if (is.null(sp.ind)) 
                sp.ind <- order(wascores(use, x))
        }
        else if (!is.null(attr(use, "class")) && class(use) == "hclust") {
            if (is.null(site.ind))  
                site.ind <- use$order
            if (is.null(sp.ind)) 
                sp.ind <- order(wascores(order(site.ind), x))
        }
        else if (is.list(use)) {
            tmp <- scores(use, choices=1, display="sites")
            if (is.null(site.ind)) 
                site.ind <- order(tmp)
            if (is.null(sp.ind))
                sp.ind <- try(order(scores(use, choices=1, display="species")))
            if (inherits(sp.ind, "try-error"))
                sp.ind <- order(wascores(tmp, x))
        }
        else if (is.matrix(use)) {
            tmp <- scores(use, choices=1, display="sites")
            if (is.null(site.ind)) 
                site.ind <- order(tmp)
            if (is.null(sp.ind))
                sp.ind <- order(wascores(tmp, x))
        }
    }
    if (is.null(sp.ind)) 
        sp.ind <- 1:ncol(x)
    if (is.null(site.ind)) 
        site.ind <- 1:nrow(x)
    if (!missing(scale)) 
        x <- coverscale(x, scale)
    if (any(apply(x, 1, nchar) > 1))
        stop("Cowardly refusing to use more than 1 char symbols:\nUse scale")
    x <- x[site.ind, sp.ind]
    x <- as.matrix(x)
    x <- t(x)
    sp.nam <- rownames(x)
    sp.len <- max(nchar(sp.nam))
    nst <- ncol(x)
    page.width <- getOption("width")
    per.page <- page.width - sp.len - 3
    istart <- seq(1, nst, by=per.page)
    iend <- pmin(istart+per.page-1, nst)
    for (st in 1:length(istart)) {
        tbl <- apply(x[,istart[st]:iend[st], drop=FALSE], 1, paste, sep = "", collapse = "")
        names(tbl) <- NULL
        tbl <- gsub("0", zero, tbl)
        tbl <- cbind(sp.nam, tbl)
        st.nam <- colnames(x)[istart[st]:iend[st]]
        nlen <- max(nchar(st.nam))
        mathead <- matrix(" ", nrow = length(st.nam), ncol = nlen)
        for (i in 1:length(st.nam)) {
            tmp <- unlist(strsplit(st.nam[i], NULL))
            start <- nlen - length(tmp) + 1
            mathead[i, start:nlen] <- tmp
        }
        head <- cbind(apply(mathead, 2, paste, sep = "", collapse = ""))
        tbl <- rbind(cbind(matrix(" ", nrow = nrow(head), 1), head), 
                     tbl)
        d <- list()
        l <- 0
        for (i in dim(tbl)) {
            d[[l <- l + 1]] <- rep("", i)
        }
        dimnames(tbl) <- d
        print(noquote(tbl))
    }
    out <- list(sites = site.ind, spec = sp.ind)
    invisible(out)
}
"veiledspec" <-
    function(x, ...)
{
    if (!inherits(x, "prestonfit"))
        x <- prestonfit(x)
    S.obs <- sum(x$freq)
    p <- x$coefficients
    S.tot <- p["S0"]*p["width"]*sqrt(2*pi)
    out <- c(S.tot, S.obs, S.tot - S.obs)
    names(out) <- c("Extrapolated","Observed","Veiled")
    out
}
"wascores" <-
function (x, w, expand = FALSE) 
{
    x <- as.matrix(x)
    w <- as.matrix(w)
    nc <- ncol(x)
    nr <- ncol(w)
    wa <- matrix(NA, nrow = nr, ncol = nc)
    colnames(wa) <- colnames(x)
    rownames(wa) <- colnames(w)
    for (i in 1:nr) {
        wa[i, ] <- apply(x, 2, weighted.mean, w = w[, i])
    }
    if (expand) {
        x.w <- rowSums(w)
        wa.w <- colSums(w)
        x.cov <- cov.wt(x, x.w)
        wa.cov <- cov.wt(wa, wa.w)
        x.cov$cov <- x.cov$cov * (1 - sum(x.cov$wt^2))
        wa.cov$cov <- wa.cov$cov * (1 - sum(wa.cov$wt^2))
        mul <- sqrt(diag(x.cov$cov)/diag(wa.cov$cov))
        wa <- sweep(wa, 2, wa.cov$center, "-")
        wa <- sweep(wa, 2, mul, "*")
        wa <- sweep(wa, 2, wa.cov$center, "+")
        attr(wa, "shrinkage") <- 1/mul^2
    }
    wa
}
"weights.cca" <-
    function(object, display="sites", ...)
{
    display <- match.arg(display, c("sites","species"))
    if (display == "sites") object$rowsum
    else object$colsum
}
"weights.decorana" <-
    function(object, display="sites", ...)
{
    display <- match.arg(display, c("sites","species"))
    if (display == "sites") object$aidot
    else object$adotj
}
"weights.rda" <-
    function(object, display="sites", ...)
{
    display <- match.arg(display, c("sites","species"))
    n <- ifelse(display == "sites",
                nrow(object$CA$Xbar), ncol(object$CA$Xbar))
    rep(1, n)
}
"wisconsin" <-
  function (x) 
{
  x <- decostand(x, "max", 2)
  x <- decostand(x, "tot", 1)
  x 
}
.First.lib <- function(lib, pkg)  {
    library.dynam("vegan", pkg, lib)
}
if (R.version$major == 1 && R.version$minor < 8)
    printCoefmat <- print.coefmat


