├── .github ├── .gitignore └── workflows │ ├── recheck.yml │ └── pkgdown.yaml ├── R ├── vegan-deprecated.R ├── scores.R ├── bstick.R ├── cca.R ├── estimateR.R ├── rda.R ├── bioenv.R ├── envfit.R ├── goodness.R ├── adipart.R ├── hiersimu.R ├── multipart.R ├── radfit.R ├── estimateR.matrix.R ├── str.nullmodel.R ├── estimateR.data.frame.R ├── calibrate.R ├── residuals.cca.R ├── eigengrad.R ├── deviance.cca.R ├── deviance.rda.R ├── initMDS.R ├── print.summary.taxondive.R ├── plot.varpart.R ├── confint.MOStest.R ├── print.nestedn0.R ├── print.poolaccum.R ├── scores.pcnm.R ├── pasteCall.R ├── boxplot.betadisper.R ├── lines.permat.R ├── residuals.procrustes.R ├── bstick.default.R ├── persp.tsallisaccum.R ├── specpool2vect.R ├── print.nestedtemp.R ├── print.summary.bioenv.R ├── weights.decorana.R ├── print.nestedchecker.R ├── identify.ordiplot.R ├── print.fisherfit.R ├── zzz.R ├── print.nesteddisc.R ├── print.radfit.frame.R ├── metaMDSredist.R ├── lines.radline.R ├── summary.radfit.frame.R ├── tolerance.R ├── extractAIC.cca.R ├── orditkplot.R ├── plot.rad.R ├── print.procrustes.R ├── ordiArgAbsorber.R ├── print.mantel.correlog.R ├── wisconsin.R ├── plot.metaMDS.R ├── labels.envfit.R ├── scores.ordihull.R ├── SSgitay.R ├── bstick.prcomp.R ├── print.vectorfit.R ├── bstick.princomp.R ├── nestedchecker.R ├── print.summary.isomap.R ├── summary.specaccum.R ├── plot.taxondive.R ├── summary.clamtest.R ├── summary.isomap.R ├── SSarrhenius.R ├── points.radline.R ├── print.mso.R ├── veiledspec.R ├── bstick.decorana.R ├── ca.R ├── envfit.formula.R ├── pco.R ├── print.nestednodf.R ├── scores.betadiver.R ├── TukeyHSD.betadisper.R ├── print.envfit.R ├── SSgleason.R ├── print.prestonfit.R ├── scores.ordiplot.R ├── pca.R ├── swan.R ├── print.taxondive.R ├── anova.betadisper.R ├── points.metaMDS.R ├── cophenetic.spantree.R ├── points.decorana.R ├── print.isomap.R ├── specnumber.R ├── summary.bioenv.R ├── plot.anosim.R ├── nestedn0.R ├── ordiTerminfo.R ├── print.commsim.R ├── print.MOStest.R ├── boxplot.specaccum.R ├── no.shared.R ├── plot.radline.R ├── print.factorfit.R ├── coef.radfit.R ├── weights.rda.R ├── veganCovEllipse.R ├── bioenv.formula.R ├── print.radline.R ├── simpson.unb.R ├── print.protest.R ├── spenvcor.R ├── fitted.radfit.R ├── text.metaMDS.R ├── scores.lda.R ├── radfit.default.R ├── print.anosim.R ├── weights.cca.R ├── as.ts.permat.R ├── fitted.cca.R ├── ordigrid.R ├── plot.fisherfit.R ├── summary.taxondive.R ├── vif.cca.R ├── lines.prestonfit.R ├── summary.procrustes.R ├── as.fisher.R ├── print.summary.prc.R ├── plot.varpart234.R ├── print.summary.clamtest.R ├── print.nullmodel.R ├── text.decorana.R ├── coef.rda.R ├── fisher.alpha.R ├── lines.procrustes.R ├── plot.renyiaccum.R ├── summary.ordiellipse.R ├── as.ts.oecosimu.R ├── lines.spantree.R ├── print.summary.meandist.R ├── scores.betadisper.R ├── print.bioenv.R ├── print.varpart.R ├── vegandocs.R ├── plot.ordipointlabel.R ├── radfit.data.frame.R ├── plot.poolaccum.R ├── summary.dispweight.R ├── persp.renyiaccum.R ├── plot.mantel.correlog.R ├── adipart.formula.R ├── distconnected.R ├── multipart.formula.R ├── points.cca.R ├── print.specaccum.R ├── calibrate.ordisurf.R ├── hiersimu.formula.R ├── print.radfit.R ├── eventstar.R ├── print.mantel.R ├── summary.anosim.R ├── coef.cca.R ├── fitted.rda.R ├── plot.betadiver.R ├── as.rad.R ├── bstick.cca.R ├── fitted.procrustes.R ├── spantree.R ├── plot.contribdiv.R ├── prestonfit.R ├── SSlomolino.R ├── summary.ordihull.R ├── points.ordiplot.R ├── plot.radfit.R ├── anova.prc.R ├── betadistances.R ├── summary.meandist.R ├── fieller.MOStest.R ├── intersetcor.R ├── stepacross.R ├── prestondistr.R ├── points.procrustes.R ├── plot.isomap.R ├── summary.poolaccum.R ├── indpower.R ├── summary.prc.R ├── hierParseFormula.R ├── print.simmat.R ├── print.summary.procrustes.R ├── ordilattice.getEnvfit.R ├── plot.prestonfit.R ├── veganMahatrans.R ├── drop1.cca.R ├── AIC.radfit.R ├── rad.null.R ├── print.permat.R ├── print.summary.cca.R ├── isomap.R ├── print.permutest.cca.R ├── treeheight.R ├── fitted.capscale.R ├── model.frame.cca.R ├── summary.cca.R ├── plot.renyi.R ├── print.CCorA.R ├── summary.decorana.R ├── nobs.R ├── cca.formula.R ├── fitted.dbrda.R ├── rda.formula.R ├── commsim.R ├── renyi.R ├── spandepth.R ├── print.betadisper.R ├── ordiArrowMul.R ├── radlattice.R ├── plot.permat.R ├── pcnm.R ├── raupcrick.R ├── text.ordiplot.R ├── alias.cca.R ├── print.mrpp.R ├── nestedbetasor.R ├── scores.envfit.R ├── print.decorana.R ├── rad.zipf.R ├── prc.R ├── update.nullmodel.R ├── print.varpart234.R ├── rad.lognormal.R ├── predict.fitspecaccum.R ├── model.matrix.cca.R ├── plot.ordisurf.R ├── as.preston.R ├── dispindmorisita.R ├── meandist.R ├── scalingUtils.R ├── biplot.rda.R ├── calibrate.cca.R ├── coverscale.R ├── ordixyplot.R ├── downweight.R ├── inertcomp.R ├── plot.spantree.R ├── plot.clamtest.R ├── anova.ccanull.R ├── scores.decorana.R ├── plot.meandist.R ├── MOStest.R ├── rda.default.R ├── diversity.R ├── toCoda.R ├── treedist.R ├── make.cepnames.R ├── ordimedian.R ├── procrustes.R ├── getPermuteMatrix.R ├── plot.nestedtemp.R └── tsallis.R ├── src ├── Makevars └── backtrack.h ├── inst └── ONEWS ├── data ├── BCI.rda ├── dune.rda ├── mite.rda ├── BCI.env.rda ├── mite.xy.rda ├── pyrifos.rda ├── sipoo.rda ├── dune.env.rda ├── mite.env.rda ├── mite.pcnm.rda ├── sipoo.map.rda ├── varechem.rda ├── varespec.rda ├── dune.taxon.rda └── dune.phylodis.rda ├── .gitattributes ├── vignettes ├── varpart23.pdf └── varpart4.pdf ├── .Rbuildignore ├── .gitignore ├── man ├── vegan-deprecated.Rd ├── varechem.Rd ├── sipoo.Rd └── nobs.cca.Rd ├── _pkgdown.yml └── tests └── oecosimu-tests.R /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /R/vegan-deprecated.R: -------------------------------------------------------------------------------- 1 | ## deprecated functions 2 | 3 | 4 | -------------------------------------------------------------------------------- /R/scores.R: -------------------------------------------------------------------------------- 1 | "scores" <- 2 | function(x, ...) UseMethod("scores") 3 | -------------------------------------------------------------------------------- /src/Makevars: -------------------------------------------------------------------------------- 1 | PKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) 2 | -------------------------------------------------------------------------------- /R/bstick.R: -------------------------------------------------------------------------------- 1 | `bstick` <- 2 | function(n, ...) UseMethod("bstick") 3 | 4 | -------------------------------------------------------------------------------- /inst/ONEWS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegandevs/vegan/HEAD/inst/ONEWS -------------------------------------------------------------------------------- /R/cca.R: -------------------------------------------------------------------------------- 1 | "cca" <- 2 | function (...) 3 | { 4 | UseMethod("cca") 5 | } 6 | -------------------------------------------------------------------------------- /R/estimateR.R: -------------------------------------------------------------------------------- 1 | "estimateR" <- 2 | function(x, ...) UseMethod("estimateR") 3 | -------------------------------------------------------------------------------- /R/rda.R: -------------------------------------------------------------------------------- 1 | "rda" <- 2 | function (...) 3 | { 4 | UseMethod("rda") 5 | } 6 | -------------------------------------------------------------------------------- /data/BCI.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegandevs/vegan/HEAD/data/BCI.rda -------------------------------------------------------------------------------- /data/dune.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegandevs/vegan/HEAD/data/dune.rda -------------------------------------------------------------------------------- /data/mite.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegandevs/vegan/HEAD/data/mite.rda -------------------------------------------------------------------------------- /data/BCI.env.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegandevs/vegan/HEAD/data/BCI.env.rda -------------------------------------------------------------------------------- /data/mite.xy.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegandevs/vegan/HEAD/data/mite.xy.rda -------------------------------------------------------------------------------- /data/pyrifos.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegandevs/vegan/HEAD/data/pyrifos.rda -------------------------------------------------------------------------------- /data/sipoo.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegandevs/vegan/HEAD/data/sipoo.rda -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | * text=auto 2 | data/* binary 3 | src/* text=lf 4 | R/* text=lf 5 | 6 | -------------------------------------------------------------------------------- /R/bioenv.R: -------------------------------------------------------------------------------- 1 | "bioenv" <- 2 | function(...) 3 | { 4 | UseMethod("bioenv") 5 | } 6 | -------------------------------------------------------------------------------- /R/envfit.R: -------------------------------------------------------------------------------- 1 | "envfit" <- 2 | function(...) 3 | { 4 | UseMethod("envfit") 5 | } 6 | -------------------------------------------------------------------------------- /R/goodness.R: -------------------------------------------------------------------------------- 1 | "goodness" <- 2 | function(object, ...) UseMethod("goodness") 3 | 4 | -------------------------------------------------------------------------------- /data/dune.env.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegandevs/vegan/HEAD/data/dune.env.rda -------------------------------------------------------------------------------- /data/mite.env.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegandevs/vegan/HEAD/data/mite.env.rda -------------------------------------------------------------------------------- /data/mite.pcnm.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegandevs/vegan/HEAD/data/mite.pcnm.rda -------------------------------------------------------------------------------- /data/sipoo.map.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegandevs/vegan/HEAD/data/sipoo.map.rda -------------------------------------------------------------------------------- /data/varechem.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegandevs/vegan/HEAD/data/varechem.rda -------------------------------------------------------------------------------- /data/varespec.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegandevs/vegan/HEAD/data/varespec.rda -------------------------------------------------------------------------------- /R/adipart.R: -------------------------------------------------------------------------------- 1 | adipart <- 2 | function (...) 3 | { 4 | UseMethod("adipart") 5 | } 6 | 7 | -------------------------------------------------------------------------------- /R/hiersimu.R: -------------------------------------------------------------------------------- 1 | hiersimu <- 2 | function (...) 3 | { 4 | UseMethod("hiersimu") 5 | } 6 | -------------------------------------------------------------------------------- /R/multipart.R: -------------------------------------------------------------------------------- 1 | multipart <- 2 | function (...) 3 | { 4 | UseMethod("multipart") 5 | } 6 | -------------------------------------------------------------------------------- /R/radfit.R: -------------------------------------------------------------------------------- 1 | `radfit` <- 2 | function (x, ...) 3 | { 4 | UseMethod("radfit") 5 | } 6 | -------------------------------------------------------------------------------- /data/dune.taxon.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegandevs/vegan/HEAD/data/dune.taxon.rda -------------------------------------------------------------------------------- /R/estimateR.matrix.R: -------------------------------------------------------------------------------- 1 | "estimateR.matrix" <- 2 | function(x, ...) apply(x, 1, estimateR, ...) 3 | -------------------------------------------------------------------------------- /R/str.nullmodel.R: -------------------------------------------------------------------------------- 1 | `str.nullmodel` <- 2 | function(object, ...) str(as.list(object), ...) 3 | -------------------------------------------------------------------------------- /data/dune.phylodis.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegandevs/vegan/HEAD/data/dune.phylodis.rda -------------------------------------------------------------------------------- /vignettes/varpart23.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegandevs/vegan/HEAD/vignettes/varpart23.pdf -------------------------------------------------------------------------------- /vignettes/varpart4.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegandevs/vegan/HEAD/vignettes/varpart4.pdf -------------------------------------------------------------------------------- /R/estimateR.data.frame.R: -------------------------------------------------------------------------------- 1 | "estimateR.data.frame" <- 2 | function(x, ...) apply(x, 1, estimateR, ...) 3 | -------------------------------------------------------------------------------- /R/calibrate.R: -------------------------------------------------------------------------------- 1 | `calibrate` <- 2 | function(object, ...) 3 | { 4 | UseMethod("calibrate") 5 | } 6 | -------------------------------------------------------------------------------- /R/residuals.cca.R: -------------------------------------------------------------------------------- 1 | "residuals.cca" <- 2 | function(object, ...) fitted(object, model = "CA", ...) 3 | 4 | -------------------------------------------------------------------------------- /R/eigengrad.R: -------------------------------------------------------------------------------- 1 | "eigengrad" <- 2 | function (x, w) 3 | { 4 | attr(wascores(x, w, expand=TRUE), "shrinkage") 5 | } 6 | -------------------------------------------------------------------------------- /R/deviance.cca.R: -------------------------------------------------------------------------------- 1 | `deviance.cca` <- 2 | function(object, ...) 3 | { 4 | object$CA$tot.chi * object$grand.tot 5 | } 6 | -------------------------------------------------------------------------------- /R/deviance.rda.R: -------------------------------------------------------------------------------- 1 | `deviance.rda` <- 2 | function(object, ...) 3 | { 4 | object$CA$tot.chi * (nobs(object) - 1) 5 | } 6 | -------------------------------------------------------------------------------- /R/initMDS.R: -------------------------------------------------------------------------------- 1 | "initMDS" <- 2 | function(x, k=2) 3 | { 4 | nr <- attr(x, "Size") 5 | res <- runif(nr*k) 6 | dim(res) <- c(nr,k) 7 | res 8 | } 9 | -------------------------------------------------------------------------------- /R/print.summary.taxondive.R: -------------------------------------------------------------------------------- 1 | `print.summary.taxondive` <- 2 | function (x, ...) 3 | { 4 | printCoefmat(x, na.print="", ...) 5 | invisible(x) 6 | } 7 | 8 | -------------------------------------------------------------------------------- /R/plot.varpart.R: -------------------------------------------------------------------------------- 1 | `plot.varpart` <- 2 | function(x, Xnames = x$tables, ...) 3 | { 4 | plot(x$part, Xnames = Xnames, ...) 5 | invisible() 6 | } 7 | 8 | -------------------------------------------------------------------------------- /R/confint.MOStest.R: -------------------------------------------------------------------------------- 1 | `confint.MOStest` <- 2 | function (object, parm = 1, level = 0.95, ...) 3 | { 4 | confint(profile(object), level = level, ...) 5 | } 6 | -------------------------------------------------------------------------------- /R/print.nestedn0.R: -------------------------------------------------------------------------------- 1 | "print.nestedn0" <- 2 | function(x, ...) 3 | { 4 | cat("Nestedness index N0:", format(x$statistic), "\n") 5 | invisible(x) 6 | } 7 | 8 | -------------------------------------------------------------------------------- /R/print.poolaccum.R: -------------------------------------------------------------------------------- 1 | `print.poolaccum` <- 2 | function(x, ...) 3 | { 4 | rownames(x$means) <- rep("", nrow(x$means)) 5 | print(x$means, ...) 6 | invisible(x) 7 | } 8 | -------------------------------------------------------------------------------- /R/scores.pcnm.R: -------------------------------------------------------------------------------- 1 | `scores.pcnm` <- 2 | function(x, choices, ...) 3 | { 4 | if (missing(choices)) 5 | x$vectors 6 | else 7 | x$vectors[, choices] 8 | } 9 | -------------------------------------------------------------------------------- /R/pasteCall.R: -------------------------------------------------------------------------------- 1 | `pasteCall` <- function (call, prefix = "Call:") 2 | { 3 | call.str <- paste(deparse(call), collapse = " ") 4 | paste(prefix, call.str, "\n", sep = " ") 5 | } 6 | -------------------------------------------------------------------------------- /R/boxplot.betadisper.R: -------------------------------------------------------------------------------- 1 | `boxplot.betadisper` <- function(x, ylab = "Distance to centroid", ...) { 2 | tmp <- boxplot(x$distances ~ x$group, ylab = ylab, ...) 3 | invisible(tmp) 4 | } 5 | -------------------------------------------------------------------------------- /R/lines.permat.R: -------------------------------------------------------------------------------- 1 | ## S3 lines method for permat 2 | `lines.permat` <- 3 | function(x, type = "bray", ...) 4 | { 5 | lines(summary(x)[[match.arg(type, c("bray", "chisq"))]], ...) 6 | } 7 | -------------------------------------------------------------------------------- /R/residuals.procrustes.R: -------------------------------------------------------------------------------- 1 | `residuals.procrustes` <- 2 | function (object, ...) 3 | { 4 | distance <- object$X - object$Yrot 5 | resid <- rowSums(distance^2) 6 | sqrt(resid) 7 | } 8 | -------------------------------------------------------------------------------- /R/bstick.default.R: -------------------------------------------------------------------------------- 1 | `bstick.default` <- 2 | function(n, tot.var = 1, ...) 3 | { 4 | res <- rev(cumsum(tot.var/n:1)/n) 5 | names(res) <- paste("Stick", seq(len=n), sep="") 6 | res 7 | } 8 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | LICENSE 2 | ^README\.md$ 3 | ^\.travis\.yml$ 4 | ^travis-tool\.sh 5 | ^appveyor\.yml$ 6 | ^Makefile$ 7 | ^\.github 8 | ^_pkgdown\.yml$ 9 | ^\.github$ 10 | ^.*\.Rproj$ 11 | ^\.Rproj\.user$ 12 | -------------------------------------------------------------------------------- /R/persp.tsallisaccum.R: -------------------------------------------------------------------------------- 1 | persp.tsallisaccum <- 2 | function(x, theta = 220, phi = 15, col = heat.colors(100), zlim, ...) 3 | { 4 | persp.renyiaccum(x, theta = theta, phi = phi, col = col, zlim = zlim, ...) 5 | } 6 | -------------------------------------------------------------------------------- /R/specpool2vect.R: -------------------------------------------------------------------------------- 1 | "specpool2vect" <- 2 | function(X, index = c("jack1","jack2", "chao", "boot", "Species")) 3 | { 4 | pool <- attr(X, "pool") 5 | index <- match.arg(index) 6 | X[[index]][pool] 7 | } 8 | -------------------------------------------------------------------------------- /R/print.nestedtemp.R: -------------------------------------------------------------------------------- 1 | "print.nestedtemp" <- 2 | function(x, ...) 3 | { 4 | cat("nestedness temperature:", format(x$statistic, ...), "\n") 5 | cat("with matrix fill", format(x$fill, ...), "\n") 6 | invisible(x) 7 | } 8 | 9 | -------------------------------------------------------------------------------- /R/print.summary.bioenv.R: -------------------------------------------------------------------------------- 1 | "print.summary.bioenv" <- 2 | function(x, ...) 3 | { 4 | out <- data.frame(size = x$size, correlation = x$cor) 5 | rownames(out) <- x$var 6 | printCoefmat(out, ...) 7 | invisible(x) 8 | } 9 | -------------------------------------------------------------------------------- /R/weights.decorana.R: -------------------------------------------------------------------------------- 1 | "weights.decorana" <- 2 | function(object, display="sites", ...) 3 | { 4 | display <- match.arg(display, c("sites","species")) 5 | if (display == "sites") object$aidot 6 | else object$adotj 7 | } 8 | -------------------------------------------------------------------------------- /R/print.nestedchecker.R: -------------------------------------------------------------------------------- 1 | "print.nestedchecker" <- 2 | function(x, ...) 3 | { 4 | cat("Checkerboard Units :", format(x$statistic), "\n") 5 | cat("C-score (species mean):", format(x$C.score), "\n") 6 | invisible(x) 7 | } 8 | 9 | -------------------------------------------------------------------------------- /R/identify.ordiplot.R: -------------------------------------------------------------------------------- 1 | `identify.ordiplot` <- 2 | function (x, what, labels, ...) 3 | { 4 | x <- scores(x, display = what) 5 | if (missing(labels)) 6 | labels <- rownames(x) 7 | identify(x, labels = labels, ...) 8 | } 9 | -------------------------------------------------------------------------------- /R/print.fisherfit.R: -------------------------------------------------------------------------------- 1 | `print.fisherfit` <- 2 | function (x, ...) 3 | { 4 | cat("\nFisher log series model\n") 5 | cat("No. of species:", sum(x$fisher), "\n") 6 | cat("Fisher alpha: ", x$estimate, "\n\n") 7 | invisible(x) 8 | } 9 | -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | .onAttach <- function(lib, pkg) { 2 | if(interactive()) 3 | packageStartupMessage( 4 | "This is vegan ", 5 | utils::packageDescription("vegan", fields="Version"), 6 | appendLF = TRUE) 7 | } 8 | -------------------------------------------------------------------------------- /R/print.nesteddisc.R: -------------------------------------------------------------------------------- 1 | "print.nesteddisc" <- 2 | function(x, ...) 3 | { 4 | cat("nestedness discrepancy:", x$statistic, "\n") 5 | if(x$ties) 6 | cat("There are tied column frequencies: result can depend on input order\n") 7 | invisible(x) 8 | } 9 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # History files 2 | .Rhistory 3 | 4 | # Example code in package build process 5 | *-Ex.R 6 | 7 | ## ignore backup files 8 | 9 | .Rproj.user 10 | 11 | # compiled source files 12 | src/*.o 13 | src/*.so 14 | 15 | # Apple stuff 16 | .DS_Store 17 | -------------------------------------------------------------------------------- /R/print.radfit.frame.R: -------------------------------------------------------------------------------- 1 | "print.radfit.frame" <- 2 | function (x, ...) 3 | { 4 | cat("\nDeviance for RAD models:\n\n") 5 | out <- sapply(x, function(x) unlist(lapply(x$models, deviance))) 6 | printCoefmat(out, na.print = "", ...) 7 | invisible(x) 8 | } 9 | -------------------------------------------------------------------------------- /src/backtrack.h: -------------------------------------------------------------------------------- 1 | /* definitions for backtrack in nestedness.c */ 2 | #ifndef BACKSTEP 3 | #define BACKSTEP (4) 4 | #endif /* BACKSTEP depth */ 5 | #ifndef RESET 6 | #define RESET 1 7 | #endif /* RESET */ 8 | #ifndef LOUD 9 | #define LOUD 0 10 | #endif /* LOUD */ 11 | -------------------------------------------------------------------------------- /R/metaMDSredist.R: -------------------------------------------------------------------------------- 1 | "metaMDSredist" <- 2 | function(object, ...) 3 | { 4 | if (!inherits(object, "metaMDS")) 5 | stop("Needs a metaMDS result object") 6 | call <- object$call 7 | call[[1]] <- as.name("metaMDSdist") 8 | eval(call, parent.frame()) 9 | } 10 | 11 | -------------------------------------------------------------------------------- /R/lines.radline.R: -------------------------------------------------------------------------------- 1 | `lines.radline` <- 2 | function (x, ...) 3 | { 4 | lin <- fitted(x) 5 | rnk <- seq(along = lin) 6 | lines(rnk, lin, ...) 7 | invisible() 8 | } 9 | 10 | `lines.radfit` <- 11 | function(x, ...) 12 | { 13 | matlines(fitted(x), ...) 14 | } 15 | -------------------------------------------------------------------------------- /R/summary.radfit.frame.R: -------------------------------------------------------------------------------- 1 | "summary.radfit.frame" <- 2 | function (object, ...) 3 | { 4 | labels <- names(object) 5 | for (i in seq_along(labels)) { 6 | cat("\n***", labels[i], "***\n") 7 | print(object[[i]], ...) 8 | } 9 | invisible(object) 10 | } 11 | 12 | -------------------------------------------------------------------------------- /R/tolerance.R: -------------------------------------------------------------------------------- 1 | ##' S3 generic for function to compute tolerances 2 | ##' 3 | ##' Brought this in here from analogue because of tolerance.cca 4 | ##' 5 | ##' @param x an R object 6 | ##' @param ... arguments passed to other methods 7 | `tolerance` <- function(x, ...) 8 | UseMethod("tolerance") 9 | -------------------------------------------------------------------------------- /R/extractAIC.cca.R: -------------------------------------------------------------------------------- 1 | `extractAIC.cca` <- 2 | function (fit, scale = 0, k = 2, ...) 3 | { 4 | n <- nobs(fit) 5 | edf <- n - df.residual(fit) 6 | RSS <- deviance(fit) 7 | dev <- if(scale > 0) 8 | RSS/scale - n 9 | else n * log(RSS/n) 10 | c(edf, dev + k*edf) 11 | } 12 | -------------------------------------------------------------------------------- /R/orditkplot.R: -------------------------------------------------------------------------------- 1 | ### 2 | ### Editable Tcl/Tk plot for ordination 3 | ### 4 | `orditkplot` <- 5 | function(...) 6 | { 7 | .Defunct(package = "vegan", 8 | msg = "orditkplot was moved to CRAN package vegan3d -- 9 | install vegan3d from CRAN and use vegan3d::orditkplot") 10 | } 11 | -------------------------------------------------------------------------------- /R/plot.rad.R: -------------------------------------------------------------------------------- 1 | "plot.rad" <- 2 | function(x, xlab="Rank", ylab="Abundance", log = "y", ...) 3 | { 4 | rnk <- seq(along=x) 5 | plot(rnk, x, log=log, xlab=xlab, ylab=ylab, ...) 6 | out <- list(species = cbind(rnk, x)) 7 | class(out) <- "ordiplot" 8 | invisible(out) 9 | } 10 | -------------------------------------------------------------------------------- /R/print.procrustes.R: -------------------------------------------------------------------------------- 1 | "print.procrustes" <- 2 | function (x, digits = max(3, getOption("digits") - 3), ...) 3 | { 4 | cat("\nCall:\n") 5 | cat(deparse(x$call), "\n\n") 6 | cat("Procrustes sum of squares:\n") 7 | cat(formatC(x$ss, digits = digits), "\n\n") 8 | invisible(x) 9 | } 10 | -------------------------------------------------------------------------------- /R/ordiArgAbsorber.R: -------------------------------------------------------------------------------- 1 | ### List non-graphical arguments used in vegan plot commands 2 | `ordiArgAbsorber` <- function(..., shrink, origin, scaling, triangular, 3 | display, choices, const, truemean, optimize, 4 | arrows, FUN) 5 | match.fun(FUN)(...) 6 | -------------------------------------------------------------------------------- /R/print.mantel.correlog.R: -------------------------------------------------------------------------------- 1 | 'print.mantel.correlog' <- function(x, ...) 2 | { 3 | cat('\nMantel Correlogram Analysis\n') 4 | cat('\nCall:\n','\n') 5 | cat(deparse(x$call),'\n') 6 | cat('\n') 7 | printCoefmat(x$mantel.res, P.values=TRUE, signif.stars=TRUE, Pvalues = TRUE) 8 | invisible(x) 9 | } 10 | -------------------------------------------------------------------------------- /R/wisconsin.R: -------------------------------------------------------------------------------- 1 | `wisconsin` <- 2 | function(x, na.rm = FALSE) 3 | { 4 | x <- decostand(x, "max", 2, na.rm = na.rm) 5 | mx <- attr(x, "parameters")$max 6 | x <- decostand(x, "total", 1, na.rm = na.rm) 7 | attr(x, "parameters")$max <- mx 8 | attr(x, "decostand") <- "wisconsin" 9 | x 10 | } 11 | -------------------------------------------------------------------------------- /R/plot.metaMDS.R: -------------------------------------------------------------------------------- 1 | `plot.metaMDS` <- 2 | function (x, display = c("sites","species"), choices = c(1, 2), type = "p", 3 | shrink = FALSE, cex = 0.7, ...) 4 | { 5 | x <- scores(x, display = display, choices = choices, shrink = shrink) 6 | ordiplot(x, display = display, type = type, cex = cex, ...) 7 | } 8 | -------------------------------------------------------------------------------- /R/labels.envfit.R: -------------------------------------------------------------------------------- 1 | `labels.envfit` <- 2 | function(object, ...) 3 | { 4 | out <- list("vectors" = rownames(object$vectors$arrows), 5 | "factors" = rownames(object$factors$centroids)) 6 | if (is.null(out$vectors) || is.null(out$factors)) 7 | out <- unlist(out, use.names = FALSE) 8 | out 9 | } 10 | -------------------------------------------------------------------------------- /R/scores.ordihull.R: -------------------------------------------------------------------------------- 1 | ## Extract the points in the hull as a one matrix 2 | `scores.ordihull` <- 3 | function(x, ...) 4 | { 5 | out <- NULL 6 | for(i in seq_along(x)) 7 | out <- rbind(out, x[[i]]) 8 | hulls <- rep(names(x), sapply(x, function(z) NROW(z))) 9 | attr(out, "hulls") <- hulls 10 | out 11 | } 12 | -------------------------------------------------------------------------------- /R/SSgitay.R: -------------------------------------------------------------------------------- 1 | SSgitay <- 2 | selfStart(~ (k + slope*log(area))^2, 3 | function(mCall, data, LHS, ...) 4 | { 5 | xy <- sortedXyData(mCall[["area"]], LHS, data) 6 | value <- as.vector(coef(lm(sqrt(xy[,"y"]) ~ log(xy[,"x"])))) 7 | names(value) <- mCall[c("k","slope")] 8 | value 9 | }, 10 | c("k","slope")) 11 | -------------------------------------------------------------------------------- /R/bstick.prcomp.R: -------------------------------------------------------------------------------- 1 | `bstick.prcomp` <- 2 | function(n, ...) 3 | { 4 | if(!inherits(n, "prcomp")) 5 | stop("'n' not of class \"prcomp\"") 6 | tot.chi <- sum(n$sdev^2) 7 | n.comp <- length(n$sdev) 8 | res <- bstick.default(n.comp, tot.chi, ...) 9 | names(res) <- dimnames(n$rotation)[[2]] 10 | res 11 | } 12 | -------------------------------------------------------------------------------- /R/print.vectorfit.R: -------------------------------------------------------------------------------- 1 | `print.vectorfit` <- 2 | function (x, ...) 3 | { 4 | out <- cbind(x$arrows, r2 = x$r, "Pr(>r)" = x$pvals) 5 | printCoefmat(out, na.print = "", 6 | zap.ind = seq_len(ncol(out)-2), ...) 7 | if (x$permutations) { 8 | cat(howHead(x$control)) 9 | } 10 | invisible(x) 11 | } 12 | -------------------------------------------------------------------------------- /R/bstick.princomp.R: -------------------------------------------------------------------------------- 1 | `bstick.princomp` <- 2 | function(n, ...) 3 | { 4 | if(!inherits(n, "princomp")) 5 | stop("'n' not of class \"princomp\"") 6 | tot.chi <- sum(n$sdev^2) 7 | n.comp <- length(n$sdev) 8 | res <- bstick.default(n.comp, tot.chi, ...) 9 | names(res) <- dimnames(n$loadings)[[2]] 10 | res 11 | } 12 | -------------------------------------------------------------------------------- /R/nestedchecker.R: -------------------------------------------------------------------------------- 1 | "nestedchecker" <- 2 | function(comm) 3 | { 4 | cb <- sum(designdist(comm, "(A-J)*(B-J)", "binary")) 5 | sppairs <- ncol(comm)*(ncol(comm)-1)/2 6 | out <- list("C.score" = cb/sppairs, statistic = cb) 7 | names(out$statistic) <- "checkerboards" 8 | class(out) <- "nestedchecker" 9 | out 10 | } 11 | 12 | -------------------------------------------------------------------------------- /R/print.summary.isomap.R: -------------------------------------------------------------------------------- 1 | `print.summary.isomap` <- 2 | function (x, ...) 3 | { 4 | cat("\nCall:\n") 5 | cat(deparse(x$call), "\n\n") 6 | cat("\nRetained dissimilarities between points:\n") 7 | prmatrix(t(x$net), collab = rep("", x$nnet) , ...) 8 | cat("\nRetained", x$nnet, "of", x$ndis, "dissimilarities\n") 9 | invisible(x) 10 | } 11 | 12 | -------------------------------------------------------------------------------- /R/summary.specaccum.R: -------------------------------------------------------------------------------- 1 | `summary.specaccum` <- 2 | function(object, ...) 3 | { 4 | if (is.null(object$perm)) 5 | stop("specific summary available only for method=\"random\"") 6 | else { 7 | tmp <- summary(t(object$perm), ...) 8 | colnames(tmp) <- paste(1:ncol(tmp), "sites") 9 | tmp 10 | } 11 | } 12 | -------------------------------------------------------------------------------- /R/plot.taxondive.R: -------------------------------------------------------------------------------- 1 | `plot.taxondive` <- 2 | function (x, ...) 3 | { 4 | plot(x$Species, x$Dplus, xlab="Number of Species", ylab=expression(Delta^"+"), ...) 5 | i <- order(x$Species) 6 | abline(h=x$EDplus, ...) 7 | lines(x$Species[i], x$EDplus - 2*x$sd.Dplus[i], ...) 8 | lines(x$Species[i], x$EDplus + 2*x$sd.Dplus[i], ...) 9 | } 10 | 11 | -------------------------------------------------------------------------------- /R/summary.clamtest.R: -------------------------------------------------------------------------------- 1 | summary.clamtest <- function(object, ...) { 2 | structure(c(attr(object, "settings"), 3 | list(summary=cbind(Species=table(object$Classes), 4 | Proportion=table(object$Classes)/nrow(object)), 5 | minv=attr(object, "minv"), 6 | coverage=attr(object, "coverage"))), class="summary.clamtest") 7 | } 8 | -------------------------------------------------------------------------------- /R/summary.isomap.R: -------------------------------------------------------------------------------- 1 | `summary.isomap` <- 2 | function (object, ...) 3 | { 4 | axes <- min(axes, ncol(object$points)) 5 | out <- list() 6 | out$call <- object$call 7 | out$net <- object$net 8 | n <- nrow(object$points) 9 | out$ndis <- n * (n-1) / 2 10 | out$nnet <- nrow(object$net) 11 | class(out) <- "summary.isomap" 12 | out 13 | } 14 | 15 | -------------------------------------------------------------------------------- /R/SSarrhenius.R: -------------------------------------------------------------------------------- 1 | SSarrhenius <- 2 | selfStart(~ k*area^z, 3 | function(mCall, data, LHS, ...) 4 | { 5 | xy <- sortedXyData(mCall[["area"]], LHS, data) 6 | value <- as.vector(coef(lm(log(pmax(xy[,"y"],1)) ~ log(xy[,"x"])))) 7 | value[1] <- exp(value[1]) 8 | names(value) <- mCall[c("k","z")] 9 | value 10 | }, 11 | c("k","z")) 12 | -------------------------------------------------------------------------------- /R/points.radline.R: -------------------------------------------------------------------------------- 1 | `points.radline` <- 2 | function (x, ...) 3 | { 4 | poi <- x$y 5 | rnk <- seq(along = poi) 6 | points(rnk, poi, ...) 7 | out <- list(species = cbind(rnk, poi)) 8 | class(out) <- "ordiplot" 9 | invisible(out) 10 | } 11 | 12 | `points.radfit` <- 13 | function(x, ...) 14 | { 15 | points.radline(x, ...) 16 | } 17 | -------------------------------------------------------------------------------- /R/print.mso.R: -------------------------------------------------------------------------------- 1 | `print.mso` <- 2 | function(x, digits = max(3, getOption("digits") - 3), ...) 3 | { 4 | NextMethod("print") 5 | cat("mso variogram:\n\n") 6 | print(x$vario, digits = digits, ...) 7 | if(!is.null(attr(x$vario, "control"))) 8 | cat("\n", howHead(attr(x$vario, "control")), "\n", sep="") 9 | invisible(x) 10 | } 11 | 12 | -------------------------------------------------------------------------------- /R/veiledspec.R: -------------------------------------------------------------------------------- 1 | "veiledspec" <- 2 | function(x, ...) 3 | { 4 | if (!inherits(x, "prestonfit")) 5 | x <- prestonfit(x) 6 | S.obs <- sum(x$freq) 7 | p <- x$coefficients 8 | S.tot <- p["S0"]*p["width"]*sqrt(2*pi) 9 | out <- c(S.tot, S.obs, S.tot - S.obs) 10 | names(out) <- c("Extrapolated","Observed","Veiled") 11 | out 12 | } 13 | -------------------------------------------------------------------------------- /R/bstick.decorana.R: -------------------------------------------------------------------------------- 1 | `bstick.decorana` <- 2 | function(n, ...) 3 | { 4 | tot.chi <- n$totchi 5 | ## assume full rank input 6 | n.comp <- min(nrow(n$rproj), nrow(n$cproj)) - 1 7 | res <- bstick.default(n.comp, tot.chi, ...) 8 | ## only four axes in decorana 9 | res <- res[1:4] 10 | names(res) <- names(n$evals) 11 | res 12 | } 13 | 14 | -------------------------------------------------------------------------------- /R/ca.R: -------------------------------------------------------------------------------- 1 | `ca` <- function(X, ...) { 2 | if (inherits(X, "formula")) { 3 | stop("Argument 'X' was supplied a formula, which is not supported by 'ca()'", 4 | call. = FALSE) 5 | } 6 | ord <- cca(X = X, ...) 7 | # change the call to be from ca() 8 | ord$call <- match.call() 9 | class(ord) <- append(class(ord), "vegan_ca", after = 0) 10 | ord 11 | } 12 | -------------------------------------------------------------------------------- /R/envfit.formula.R: -------------------------------------------------------------------------------- 1 | `envfit.formula` <- 2 | function(formula, data, ...) 3 | { 4 | if (missing(data)) 5 | data <- environment(formula) 6 | X <- formula[[2]] 7 | X <- eval(X, environment(formula), enclos = .GlobalEnv) 8 | formula[[2]] <- NULL 9 | P <- model.frame(formula, data, na.action = na.pass) 10 | envfit.default(X, P, ...) 11 | } 12 | -------------------------------------------------------------------------------- /R/pco.R: -------------------------------------------------------------------------------- 1 | `pco` <- function(X, ...) { 2 | if (inherits(X, "formula")) { 3 | stop("Argument 'X' was supplied a formula, which is not supported by 'pco()'", 4 | call. = FALSE) 5 | } 6 | ord <- dbrda(X ~ 1, ...) 7 | # change the call to be from pco() 8 | ord$call <- match.call() 9 | class(ord) <- append(class(ord), "vegan_pco", after = 0) 10 | ord 11 | } 12 | -------------------------------------------------------------------------------- /R/print.nestednodf.R: -------------------------------------------------------------------------------- 1 | `print.nestednodf` <- 2 | function(x, ...) 3 | { 4 | cat("N columns :", format(x$statistic["N.columns"], ...), "\n") 5 | cat("N rows :", format(x$statistic["N.rows"], ...), "\n") 6 | cat("NODF :", format(x$statistic["NODF"], ...), "\n") 7 | cat("Matrix fill:", format(x$fill, ...), "\n") 8 | invisible(x) 9 | } 10 | -------------------------------------------------------------------------------- /R/scores.betadiver.R: -------------------------------------------------------------------------------- 1 | `scores.betadiver` <- 2 | function(x, triangular = TRUE, ...) 3 | { 4 | if (triangular) { 5 | tot <- x$a + x$b + x$c 6 | a <- x$a/tot 7 | c <- x$c/tot 8 | y <- sqrt(0.75)*a 9 | x <- c + a/2 10 | out <- cbind(x, y) 11 | } else { 12 | out <- sapply(x, cbind) 13 | } 14 | out 15 | } 16 | -------------------------------------------------------------------------------- /R/TukeyHSD.betadisper.R: -------------------------------------------------------------------------------- 1 | `TukeyHSD.betadisper` <- function(x, which = "group", ordered = FALSE, 2 | conf.level = 0.95, ...) { 3 | df <- data.frame(distances = x$distances, group = x$group) 4 | mod.aov <- aov(distances ~ group, data = df) 5 | TukeyHSD(mod.aov, which = which, ordered = ordered, 6 | conf.level = conf.level, ...) 7 | } 8 | -------------------------------------------------------------------------------- /R/print.envfit.R: -------------------------------------------------------------------------------- 1 | "print.envfit" <- 2 | function(x, ...) 3 | { 4 | if (!is.null(x$vectors)) { 5 | cat("\n***VECTORS\n\n") 6 | print(x$vectors) 7 | } 8 | if (!is.null(x$factors)) { 9 | cat("\n***FACTORS:\n\n") 10 | print(x$factors) 11 | } 12 | if (!is.null(x$na.action)) 13 | cat("\n", naprint(x$na.action), "\n", sep="") 14 | invisible(x) 15 | } 16 | 17 | -------------------------------------------------------------------------------- /R/SSgleason.R: -------------------------------------------------------------------------------- 1 | SSgleason <- 2 | selfStart(~ k + slope*log(area), 3 | function(mCall, data, LHS, ...) 4 | { 5 | ## Gleason is a linear model: starting values are final ones 6 | xy <- sortedXyData(mCall[["area"]], LHS, data) 7 | value <- as.vector(coef(lm(xy[,"y"] ~ log(xy[,"x"])))) 8 | names(value) <- mCall[c("k","slope")] 9 | value 10 | }, 11 | c("k","slope")) 12 | -------------------------------------------------------------------------------- /R/print.prestonfit.R: -------------------------------------------------------------------------------- 1 | "print.prestonfit" <- 2 | function (x, ...) 3 | { 4 | cat("\nPreston lognormal model\n") 5 | cat("Method:", x$method,"\n") 6 | cat("No. of species:", sum(x$freq), "\n\n") 7 | print(x$coefficients, ...) 8 | cat("\nFrequencies by Octave\n") 9 | print(rbind(Observed = x$freq, Fitted = x$fitted), ...) 10 | cat("\n") 11 | invisible(x) 12 | } 13 | -------------------------------------------------------------------------------- /R/scores.ordiplot.R: -------------------------------------------------------------------------------- 1 | `scores.ordiplot` <- 2 | function (x, display = "sites", ...) 3 | { 4 | if (length(x) == 1) { 5 | attr(x[[1]], "score") <- names(x) 6 | return(x[[1]]) 7 | } 8 | items <- names(x) 9 | items <- items[!is.na(items)] 10 | display <- match.arg(display, items) 11 | x <- x[[display]] 12 | attr(x, "score") <- display 13 | x 14 | } 15 | -------------------------------------------------------------------------------- /R/pca.R: -------------------------------------------------------------------------------- 1 | `pca` <- function(X, scale = FALSE, ...) { 2 | if (inherits(X, "formula")) { 3 | stop("Argument 'X' was supplied a formula, which is not supported by 'pca()'", 4 | call. = FALSE) 5 | } 6 | ord <- rda(X = X, scale = scale, ...) 7 | # change the call to be from pca() 8 | ord$call <- match.call() 9 | class(ord) <- append(class(ord), "vegan_pca", after = 0) 10 | ord 11 | } 12 | -------------------------------------------------------------------------------- /R/swan.R: -------------------------------------------------------------------------------- 1 | swan <- 2 | function (x, maxit = Inf, type = 0) 3 | { 4 | zeros <- -Inf 5 | iter <- 0 6 | while(zeros != (zeros <- sum(x == 0)) && any(x == 0) && 7 | iter < maxit) { 8 | x[x > 0] <- x[x > 0] - min(x[x > 0]) + 1 9 | x[x == 0] <- beals(x, type = type)[x == 0] 10 | iter <- iter + 1 11 | } 12 | x 13 | } 14 | ### (Ecology 51, 89-102; 1970). 15 | -------------------------------------------------------------------------------- /R/print.taxondive.R: -------------------------------------------------------------------------------- 1 | `print.taxondive` <- 2 | function (x, ...) 3 | { 4 | out <- cbind(x$Species, x$D, x$Dstar, x$Lambda, x$Dplus, x$SDplus) 5 | out <- rbind(out, Expected = c(NA, x$ED, x$EDstar, NA, x$EDplus, NA)) 6 | colnames(out) <- c("Species", "Delta", "Delta*", "Lambda+", 7 | "Delta+", "S Delta+") 8 | printCoefmat(out, na.print = "") 9 | invisible(x) 10 | } 11 | -------------------------------------------------------------------------------- /R/anova.betadisper.R: -------------------------------------------------------------------------------- 1 | `anova.betadisper` <- function(object, ...) 2 | { 3 | model.dat <- with(object, data.frame(Distances = distances, 4 | Groups = group)) 5 | n.grps <- with(model.dat, length(unique(as.numeric(Groups)))) 6 | if(n.grps < 2) 7 | stop("anova() only applicable to two or more groups") 8 | anova(lm(Distances ~ Groups, data = model.dat)) 9 | } 10 | -------------------------------------------------------------------------------- /R/points.metaMDS.R: -------------------------------------------------------------------------------- 1 | `points.metaMDS` <- 2 | function (x, display = c("sites", "species"), 3 | choices = c(1, 2), shrink = FALSE, select, cex = 0.7, ...) 4 | { 5 | display <- match.arg(display) 6 | x <- scores(x, display = display, choices = choices, shrink = shrink) 7 | if (!missing(select)) 8 | x <- .checkSelect(select, x) 9 | points(x, cex = cex, ...) 10 | invisible() 11 | } 12 | -------------------------------------------------------------------------------- /R/cophenetic.spantree.R: -------------------------------------------------------------------------------- 1 | `cophenetic.spantree` <- 2 | function(x) 3 | { 4 | n <- x$n 5 | mat <- matrix(NA, nrow=n, ncol=n) 6 | if (n < 2) 7 | return(as.dist(mat)) 8 | ind <- apply(cbind(2:n, x$kid), 1, sort) 9 | ind <- t(ind[2:1,]) 10 | mat[ind] <- x$dist 11 | d <- as.dist(mat) 12 | attr(d, "Labels") <- x$labels 13 | stepacross(d, path = "extended", toolong=0, trace=FALSE) 14 | } 15 | -------------------------------------------------------------------------------- /R/points.decorana.R: -------------------------------------------------------------------------------- 1 | "points.decorana" <- 2 | function (x, display=c("sites", "species"), choices=1:2, origin = TRUE, 3 | select, ...) 4 | { 5 | display <- match.arg(display) 6 | x <- scores(x, display = display, choices = choices, origin = origin, ...) 7 | if (!missing(select)) 8 | x <- .checkSelect(select, x) 9 | ordiArgAbsorber(x, FUN = points, ...) 10 | invisible() 11 | } 12 | 13 | -------------------------------------------------------------------------------- /R/print.isomap.R: -------------------------------------------------------------------------------- 1 | `print.isomap` <- 2 | function (x, ...) 3 | { 4 | cat("\nIsometric Feature Mapping (isomap)\n\n") 5 | cat("Call:\n") 6 | cat(deparse(x$call), "\n\n") 7 | cat("Distance method:", x$method, "\n") 8 | cat("Criterion:", x$criterion, "=", x$critval, "\n") 9 | if(!is.null(x$take)) 10 | cat("Data were fragmented, analysed", sum(x$take), "of", length(x$take), "points\n") 11 | invisible(x) 12 | } 13 | 14 | -------------------------------------------------------------------------------- /R/specnumber.R: -------------------------------------------------------------------------------- 1 | `specnumber` <- 2 | function(x, groups, MARGIN = 1) 3 | { 4 | if (!missing(groups)) { 5 | if (length(groups) == 1) 6 | groups <- rep(groups, nrow(x)) 7 | x <- aggregate(x, list(groups), max) 8 | rownames(x) <- x[,1] 9 | x <- x[,-1] 10 | } 11 | if (length(dim(x)) > 1) 12 | apply(x > 0, MARGIN, sum) 13 | else 14 | sum(x > 0) 15 | } 16 | -------------------------------------------------------------------------------- /R/summary.bioenv.R: -------------------------------------------------------------------------------- 1 | "summary.bioenv" <- 2 | function(object, ...) 3 | { 4 | x <- object$models 5 | nam <- object$names 6 | size <- seq_along(x) 7 | cor <- unlist(lapply(x, function(tmp) tmp$est)) 8 | pars <- unlist(lapply(x, function(tmp) paste(nam[tmp$best], collapse=" "))) 9 | out <- list(size = size, correlation = cor, variables = pars) 10 | class(out) <- "summary.bioenv" 11 | out 12 | } 13 | -------------------------------------------------------------------------------- /R/plot.anosim.R: -------------------------------------------------------------------------------- 1 | "plot.anosim" <- 2 | function (x, title=NULL, ...) 3 | { 4 | boxplot(x$dis.rank ~ x$class.vec, notch=TRUE, varwidth=TRUE, 5 | ...) 6 | title(title) 7 | if (x$permutations) { 8 | pval <- format.pval(x$signif) 9 | } else { 10 | pval <- "not assessed" 11 | } 12 | mtext(paste("R = ", round(x$statistic, 3), ", ", 13 | "P = ", pval ), 3) 14 | invisible() 15 | } 16 | -------------------------------------------------------------------------------- /R/nestedn0.R: -------------------------------------------------------------------------------- 1 | "nestedn0" <- 2 | function(comm) 3 | { 4 | comm <- ifelse(comm > 0, 1, 0) 5 | R <- rowSums(comm) 6 | spmin <- apply(comm, 2, function(x) min((x*R)[x > 0])) 7 | n0 <- spmin 8 | for (i in 1:ncol(comm)) 9 | n0[i] <- sum(comm[,i] == 0 & R > spmin[i]) 10 | out <- list(spmin = spmin, n0 = n0, statistic = sum(n0)) 11 | names(out$statistic) <- "N0" 12 | class(out) <- "nestedn0" 13 | out 14 | } 15 | 16 | -------------------------------------------------------------------------------- /R/ordiTerminfo.R: -------------------------------------------------------------------------------- 1 | `ordiTerminfo` <- 2 | function(d, data) 3 | { 4 | Terms <- delete.response(d$terms.expand) 5 | if (length(attr(Terms, "term.labels")) == 0) 6 | mf <- data.frame(NULL) 7 | else 8 | mf <- d$modelframe 9 | xlev <- .getXlevels(Terms, mf) 10 | ordered <- sapply(mf, is.ordered) 11 | assign <- attr(d$Y, "assign") 12 | list(terms = Terms, assign = assign, xlev = xlev, ordered = ordered) 13 | } 14 | -------------------------------------------------------------------------------- /R/print.commsim.R: -------------------------------------------------------------------------------- 1 | print.commsim <- function(x, ...) { 2 | cat("An object of class", dQuote(class(x)[1L]), "\n") 3 | isSeq <- ifelse(x$isSeq, "sequential", "non-sequential") 4 | if(x$binary) 5 | kind <- "binary" 6 | else 7 | kind <- ifelse(x$mode == "integer", "count", "abundance") 8 | cat(sQuote(x$method), " method (", 9 | kind, ", ", isSeq, ", ", x$mode, " mode)\n\n", sep="") 10 | invisible(x) 11 | } 12 | -------------------------------------------------------------------------------- /R/print.MOStest.R: -------------------------------------------------------------------------------- 1 | `print.MOStest` <- 2 | function(x, ...) 3 | { 4 | cat("\nMitchell-Olds and Shaw test\n") 5 | cat("Null: hump of a quadratic linear predictor is at min or max\n") 6 | print(x$family) 7 | print(x$hump) 8 | if (!x$isBracketed) 9 | cat("***** Caution: hump/pit not bracketed by the data ******\n") 10 | cat("\n") 11 | printCoefmat(coef(x), has.Pvalue = TRUE, na.print = "") 12 | invisible(x) 13 | } 14 | -------------------------------------------------------------------------------- /R/boxplot.specaccum.R: -------------------------------------------------------------------------------- 1 | `boxplot.specaccum` <- 2 | function(x, add=FALSE, ...) 3 | { 4 | if (x$method != "random") 5 | stop("boxplot available only for method=\"random\"") 6 | if (!add) { 7 | plot(x$sites, x$richness, type="n", xlab="Sites", ylab="Species", 8 | ylim=c(1, max(x$richness, na.rm = TRUE)), ...) 9 | } 10 | tmp <- boxplot(data.frame(t(x$perm)), add=TRUE, at=x$sites, axes=FALSE, ...) 11 | invisible(tmp) 12 | } 13 | -------------------------------------------------------------------------------- /R/no.shared.R: -------------------------------------------------------------------------------- 1 | `no.shared` <- 2 | function(x) 3 | { 4 | x <- as.matrix(x, rownames.force = TRUE) 5 | d <- .Call(do_vegdist, x, as.integer(99), PACKAGE = "vegan") 6 | d <- as.logical(d) 7 | attr(d, "Size") <- NROW(x) 8 | attr(d, "Labels") <- dimnames(x)[[1]] 9 | attr(d, "Diag") <- FALSE 10 | attr(d, "Upper") <- FALSE 11 | attr(d, "method") <- "no.shared" 12 | attr(d, "call") <- match.call() 13 | class(d) <- "dist" 14 | d 15 | } 16 | -------------------------------------------------------------------------------- /R/plot.radline.R: -------------------------------------------------------------------------------- 1 | "plot.radline" <- 2 | function (x, xlab = "Rank", ylab = "Abundance", type = "b", ...) 3 | { 4 | rad <- x$y 5 | fit <- fitted(x) 6 | rnk <- seq(along = rad) 7 | plot(rnk, rad, log = "y", xlab = xlab, ylab = ylab, type = "n", 8 | ...) 9 | out <- NULL 10 | if (type == "b" || type == "p") 11 | out <- points(x, ...) 12 | if (type == "b" || type == "l") 13 | lines(x, ...) 14 | invisible(out) 15 | } 16 | -------------------------------------------------------------------------------- /R/print.factorfit.R: -------------------------------------------------------------------------------- 1 | `print.factorfit` <- 2 | function (x, ...) 3 | { 4 | cat("Centroids:\n") 5 | printCoefmat(x$centroids, tst.ind = 1:ncol(x$centroids), na.print = "", ...) 6 | cat("\nGoodness of fit:\n") 7 | out <- cbind(r2 = x$r, "Pr(>r)" = x$pvals) 8 | if (x$permutations) { 9 | printCoefmat(out, has.Pvalue = TRUE, ...) 10 | cat(howHead(x$control)) 11 | } 12 | else printCoefmat(out, na.print = "", ...) 13 | invisible(x) 14 | } 15 | -------------------------------------------------------------------------------- /.github/workflows/recheck.yml: -------------------------------------------------------------------------------- 1 | on: 2 | workflow_dispatch: 3 | inputs: 4 | which: 5 | type: choice 6 | description: Which dependents to check 7 | options: 8 | - strong 9 | - most 10 | 11 | name: Reverse dependency check 12 | 13 | jobs: 14 | revdep_check: 15 | name: Reverse check ${{ inputs.which }} dependents 16 | uses: r-devel/recheck/.github/workflows/recheck.yml@v1 17 | with: 18 | which: ${{ inputs.which }} 19 | 20 | -------------------------------------------------------------------------------- /R/coef.radfit.R: -------------------------------------------------------------------------------- 1 | `coef.radfit` <- 2 | function (object, ...) 3 | { 4 | out <- sapply(object$models, function(x) if (length(coef(x)) < 5 | 3) 6 | c(coef(x), rep(NA, 3 - length(coef(x)))) 7 | else coef(x)) 8 | out <- t(out) 9 | colnames(out) <- paste("par", 1:3, sep = "") 10 | out 11 | } 12 | 13 | `coef.radfit.frame` <- 14 | function(object, ...) 15 | { 16 | lapply(object, coef, ...) 17 | } 18 | -------------------------------------------------------------------------------- /R/weights.rda.R: -------------------------------------------------------------------------------- 1 | `weights.rda` <- 2 | function (object, display = "sites", ...) 3 | { 4 | display <- match.arg(display, c("sites", "species", "lc", 5 | "wa")) 6 | if (display %in% c("sites", "lc", "wa")) { 7 | n <- nobs(object) 8 | if (!is.null(object$na.action) && 9 | inherits(object$na.action, "exclude")) 10 | n <- n + length(object$na.action) 11 | } 12 | else n <- length(object$colsum) 13 | rep(1, n) 14 | } 15 | -------------------------------------------------------------------------------- /R/veganCovEllipse.R: -------------------------------------------------------------------------------- 1 | `veganCovEllipse` <- 2 | function(cov, center = c(0,0), scale = 1, npoints = 100) 3 | { 4 | ## Basically taken from the 'car' package: The Cirlce 5 | theta <- (0:npoints) * 2 * pi/npoints 6 | Circle <- cbind(cos(theta), sin(theta)) 7 | ## scale, center and cov must be calculated separately 8 | Q <- chol(cov, pivot = TRUE) 9 | ## pivot takes care of cases when points are on a line 10 | o <- attr(Q, "pivot") 11 | t(center + scale * t(Circle %*% Q[,o])) 12 | } 13 | -------------------------------------------------------------------------------- /R/bioenv.formula.R: -------------------------------------------------------------------------------- 1 | `bioenv.formula` <- 2 | function (formula, data, ...) 3 | { 4 | if (missing(data)) 5 | data <- environment(formula) 6 | fla <- formula 7 | comm <- formula[[2]] 8 | comm <- eval(comm, environment(formula), parent.frame()) 9 | formula[[2]] <- NULL 10 | env <- model.frame(formula, data, na.action = NULL) 11 | out <- bioenv(comm, env, ...) 12 | out$formula <- fla 13 | out$call <- match.call() 14 | out$call[[1]] <- as.name("bioenv") 15 | out 16 | } 17 | -------------------------------------------------------------------------------- /R/print.radline.R: -------------------------------------------------------------------------------- 1 | "print.radline" <- 2 | function (x, ...) 3 | { 4 | cat("\nRAD model:", x$model, "\n") 5 | cat("Family:", family(x)$family, "\n") 6 | cat("No. of species: ", length(x$y), "\nTotal abundance:", 7 | sum(x$y), "\n\n") 8 | p <- coef(x) 9 | dev <- deviance(x) 10 | AIC <- AIC(x) 11 | BIC <- AIC(x, k = log(length(x$y))) 12 | tmp <- c(p, dev, AIC, BIC) 13 | names(tmp) <- c(names(p), "Deviance", "AIC", "BIC") 14 | print(tmp, ...) 15 | invisible(x) 16 | } 17 | -------------------------------------------------------------------------------- /R/simpson.unb.R: -------------------------------------------------------------------------------- 1 | ### unbiased Simpson index, Hurlbert (1971) "nonconcept" paper, eq. 5, 2 | ### but implemented here with rarefy (because I'm lazy and just re-use 3 | ### work already done). 4 | 5 | `simpson.unb` <- 6 | function(x, inverse = FALSE) 7 | { 8 | d <- rarefy(x, 2) - 1 9 | ## alternatively use directly the Hurlbert equation 10 | ## n <- rowSums(x) 11 | ## d <- rowSums(x/n*(n-x)/(n-1)) 12 | if (inverse) 13 | d <- 1/(1-d) 14 | attr(d, "Subsample") <- NULL 15 | d 16 | } 17 | -------------------------------------------------------------------------------- /R/print.protest.R: -------------------------------------------------------------------------------- 1 | `print.protest` <- 2 | function(x, digits = max(3, getOption("digits") - 3), ...) 3 | { 4 | cat("\nCall:\n") 5 | cat(deparse(x$call), "\n\n") 6 | cat("Procrustes Sum of Squares (m12 squared): ") 7 | cat(formatC(x$ss, digits=digits), "\n") 8 | cat("Correlation in a symmetric Procrustes rotation: ") 9 | cat(formatC(x$t0, digits = digits), "\n") 10 | cat("Significance: ") 11 | cat(format.pval(x$signif),"\n\n") 12 | cat(howHead(x$control)) 13 | cat("\n") 14 | invisible(x) 15 | } 16 | -------------------------------------------------------------------------------- /R/spenvcor.R: -------------------------------------------------------------------------------- 1 | `spenvcor` <- 2 | function (object) 3 | { 4 | if (is.null(object$CCA)) 5 | stop("needs results from constrained ordination") 6 | u <- object$CCA$u 7 | wa <- object$CCA$wa 8 | if (!inherits(object, "rda")) { # is CCA 9 | r <- sqrt(object$rowsum) 10 | u <- r * u 11 | wa <- r * wa 12 | } 13 | ## because colSums(u*u) = 1, we can simplify diag(cor(u, wa)) -- 14 | ## and we must for weighted CA 15 | colSums(u * wa)/sqrt(colSums(wa^2)) 16 | } 17 | 18 | -------------------------------------------------------------------------------- /R/fitted.radfit.R: -------------------------------------------------------------------------------- 1 | `fitted.radfit` <- 2 | function(object, ...) 3 | { 4 | out <- sapply(object$models, fitted) 5 | if (!length(object$y)) 6 | out <- numeric(length(object$models)) 7 | if (length(object$y) <= 1) 8 | out <- structure(as.vector(out), dim = c(1, length(object$models)), 9 | dimnames = list(names(object$y), names(object$models))) 10 | out 11 | } 12 | 13 | `fitted.radfit.frame` <- 14 | function(object, ...) 15 | { 16 | lapply(object, fitted, ...) 17 | } 18 | -------------------------------------------------------------------------------- /R/text.metaMDS.R: -------------------------------------------------------------------------------- 1 | `text.metaMDS` <- 2 | function (x, display = c("sites", "species"), labels, 3 | choices = c(1, 2), shrink = FALSE, select, cex = 0.7, ...) 4 | { 5 | display <- match.arg(display) 6 | x <- scores(x, display = display, choices = choices, shrink = shrink) 7 | if (!missing(select)) 8 | x <- .checkSelect(select, x) 9 | if (!missing(labels)) 10 | rownames(x) <- labels 11 | text.ordiplot(x, what = display, labels = rownames(x), cex = cex, ...) 12 | invisible() 13 | } 14 | -------------------------------------------------------------------------------- /R/scores.lda.R: -------------------------------------------------------------------------------- 1 | `scores.lda` <- 2 | function(x, display, ...) 3 | { 4 | display <- match.arg(display, 5 | c("sites", "species", "scores", "predictors", "x", "coef"), 6 | several.ok = TRUE) 7 | out <- NULL 8 | if (display %in% c("sites", "scores", "x")) 9 | out[["scores"]] <- predict(x)$x 10 | if (display %in% c("species", "predictors", "coef")) 11 | out[["coefficients"]] <- coef(x) 12 | if (length(out) == 1) 13 | out <- out[[1]] 14 | out 15 | } 16 | -------------------------------------------------------------------------------- /R/radfit.default.R: -------------------------------------------------------------------------------- 1 | "radfit.default" <- 2 | function (x, ...) 3 | { 4 | x <- as.rad(x) 5 | NU <- rad.null(x, ...) 6 | PE <- rad.preempt(x, ...) 7 | ##BS <- rad.brokenstick(x, ...) 8 | LN <- rad.lognormal(x, ...) 9 | ZP <- rad.zipf(x, ...) 10 | ZM <- rad.zipfbrot(x, ...) 11 | out <- list(y = x, family = PE$family) 12 | models <- list(Null = NU, Preemption = PE, Lognormal = LN, 13 | Zipf = ZP, Mandelbrot = ZM) 14 | out$models <- models 15 | class(out) <- "radfit" 16 | out 17 | } 18 | -------------------------------------------------------------------------------- /R/print.anosim.R: -------------------------------------------------------------------------------- 1 | `print.anosim` <- 2 | function (x, digits = max(3, getOption("digits") - 3), ...) 3 | { 4 | cat("\nCall:\n") 5 | cat(deparse(x$call), "\n") 6 | cat("Dissimilarity:", x$dissimilarity,"\n\n") 7 | cat("ANOSIM statistic R: ") 8 | cat(formatC(x$statistic, digits = digits), "\n") 9 | nperm <- x$permutations 10 | if (nperm) { 11 | cat(" Significance:", format.pval(x$signif), 12 | "\n\n") 13 | cat(howHead(x$control)) 14 | } 15 | cat("\n") 16 | invisible(x) 17 | } 18 | -------------------------------------------------------------------------------- /R/weights.cca.R: -------------------------------------------------------------------------------- 1 | "weights.cca" <- 2 | function (object, display = "sites", ...) 3 | { 4 | display <- match.arg(display, c("sites", "species", "lc", "wa")) 5 | if (display %in% c("sites", "lc", "wa")) { 6 | if (!is.null(object$na.action) && 7 | inherits(object$na.action, "exclude")) { 8 | object$rowsum <- napredict(object$na.action, object$rowsum) 9 | object$rowsum[object$na.action] <- object$rowsum.excluded 10 | } 11 | object$rowsum 12 | } 13 | else object$colsum 14 | } 15 | -------------------------------------------------------------------------------- /R/as.ts.permat.R: -------------------------------------------------------------------------------- 1 | `as.ts.permat` <- 2 | function(x, type = "bray", ...) 3 | { 4 | type <- match.arg(type, c("bray", "chisq")) 5 | out <- summary(x)[[type]] 6 | if (!is.ts(out)) { 7 | seqmethods <- sapply(make.commsim(), function(z) make.commsim(z)$isSeq) 8 | seqmethods <- names(seqmethods)[seqmethods] 9 | ## seqmethods <- c("swap", "tswap", "abuswap") 10 | stop(gettextf("as.ts available only for sequential methods %s", 11 | paste(seqmethods, collapse=", "))) 12 | } 13 | out 14 | } 15 | -------------------------------------------------------------------------------- /R/fitted.cca.R: -------------------------------------------------------------------------------- 1 | `fitted.cca` <- 2 | function (object, model = c("CCA","CA","pCCA"), 3 | type = c("response", "working"), ...) 4 | { 5 | type <- match.arg(type) 6 | model <- match.arg(model) 7 | if (is.null(object[[model]])) 8 | stop(gettextf("component '%s' does not exist", model)) 9 | Xbar <- ordiYbar(object, model) 10 | if (type == "response") { 11 | gtot <- object$grand.total 12 | rc <- object$rowsum %o% object$colsum 13 | Xbar <- (Xbar * sqrt(rc) + rc) * gtot 14 | } 15 | Xbar 16 | } 17 | -------------------------------------------------------------------------------- /R/ordigrid.R: -------------------------------------------------------------------------------- 1 | "ordigrid" <- 2 | function (ord, levels, replicates, display = "sites", lty=c(1,1), col=c(1,1), 3 | lwd = c(1,1), ...) 4 | { 5 | pts <- scores(ord, display = display, ...) 6 | npoints <- nrow(pts) 7 | gr <- gl(levels, replicates, npoints) 8 | ordisegments(pts, groups = gr, lty = lty[1], col = col[1], 9 | lwd = lwd[1], ...) 10 | gr <- gl(replicates, 1, npoints) 11 | ordisegments(pts, groups = gr, lty = lty[2], col = col[2], 12 | lwd = lwd[2], ...) 13 | invisible() 14 | } 15 | -------------------------------------------------------------------------------- /R/plot.fisherfit.R: -------------------------------------------------------------------------------- 1 | "plot.fisherfit" <- 2 | function(x, xlab = "Frequency", ylab = "Species", bar.col = "skyblue", 3 | line.col= "red", lwd=2, ...) 4 | { 5 | freq <- as.numeric(names(x$fisher)) 6 | plot(freq, x$fisher, ylab=ylab, xlab=xlab, 7 | ylim=c(0,max(x$fisher)), xlim=c(0.5, max(freq)+0.5), type="n", ...) 8 | rect(freq-0.5,0,freq+0.5,x$fisher, col=bar.col, ...) 9 | alpha <- x$estimate 10 | k <- x$nuisance 11 | curve(alpha*k^x/x, 1, max(freq), col=line.col, lwd=lwd, add=TRUE, ...) 12 | invisible() 13 | } 14 | -------------------------------------------------------------------------------- /R/summary.taxondive.R: -------------------------------------------------------------------------------- 1 | `summary.taxondive` <- 2 | function (object, ...) 3 | { 4 | z <- (object$Dplus - object$EDplus)/object$sd.Dplus 5 | pval <- 2*pnorm(-abs(z)) 6 | out <- cbind(object$D, object$Dstar, object$Dplus, object$sd.Dplus, 7 | z, pval) 8 | out <- rbind(out, "Expected"=c(object$ED, object$EDstar, object$EDplus, NA, NA, NA)) 9 | colnames(out) <- c("Delta", "Delta*", "Delta+", "sd(Delta+)", 10 | "z(Delta+)", "Pr(>|z|)") 11 | class(out) <- "summary.taxondive" 12 | out 13 | } 14 | 15 | -------------------------------------------------------------------------------- /R/vif.cca.R: -------------------------------------------------------------------------------- 1 | `vif.cca` <- 2 | function(object) 3 | { 4 | if (is.null(object$CCA) || object$CCA$rank == 0) 5 | stop("can be used only with constrained ordination") 6 | Q <- object$CCA$QR 7 | out <- rep(NA, NCOL(Q$qr)) 8 | names(out)[Q$pivot] <- colnames(Q$qr) 9 | rank <- Q$rank 10 | V <- chol2inv(Q$qr, size = rank) 11 | X <- qr.X(Q, ncol = length(Q$pivot))[, Q$pivot[1:rank], drop=FALSE] 12 | Vi <- crossprod(X) 13 | v1 <- diag(V) 14 | v2 <- diag(Vi) 15 | out[Q$pivot[1:rank]] <- v1 * v2 16 | out 17 | } 18 | 19 | -------------------------------------------------------------------------------- /R/lines.prestonfit.R: -------------------------------------------------------------------------------- 1 | "lines.prestonfit" <- 2 | function(x, line.col = "red", lwd = 2, ...) 3 | { 4 | p <- x$coefficients 5 | freq <- x$freq 6 | oct <- as.numeric(names(freq)) 7 | curve(p[3] * exp(-(x-p[1])^2/2/p[2]^2), -1, max(oct), add = TRUE, 8 | col = line.col, lwd = lwd, ...) 9 | segments(p["mode"], 0, p["mode"], p["S0"], col = line.col, 10 | ...) 11 | segments(p["mode"] - p["width"], p["S0"] * exp(-0.5), p["mode"] + 12 | p["width"], p["S0"] * exp(-0.5), col = line.col, ...) 13 | invisible() 14 | } 15 | -------------------------------------------------------------------------------- /R/summary.procrustes.R: -------------------------------------------------------------------------------- 1 | "summary.procrustes" <- 2 | function (object, digits = getOption("digits"), ...) 3 | { 4 | ans <- object[c("call", "ss")] 5 | n <- nrow(object$Yrot) 6 | k <- ncol(object$Yrot) 7 | ans$resid <- residuals(object) 8 | rmse <- sqrt(object$ss/n) 9 | ans$n <- n 10 | ans$k <- k 11 | ans$rmse <- rmse 12 | ans$rotation <- object$rotation 13 | ans$translation <- object$translation 14 | ans$scale <- object$scale 15 | ans$digits <- digits 16 | class(ans) <- "summary.procrustes" 17 | ans 18 | } 19 | 20 | -------------------------------------------------------------------------------- /R/as.fisher.R: -------------------------------------------------------------------------------- 1 | `as.fisher` <- 2 | function (x, ...) 3 | { 4 | if (inherits(x, "fisher")) 5 | return(x) 6 | ## is not fisher but a 1 x n data.frame or matrix: matrix is faster 7 | x <- as.matrix(x) 8 | if (!isTRUE(all.equal(x, round(x)))) 9 | stop("function accepts only integers (counts)") 10 | x <- round(x) # sqrt(2)^2 != 2 11 | freq <- x[x > 0] 12 | freq <- table(freq, deparse.level = 0) 13 | nm <- names(freq) 14 | freq <- as.vector(freq) 15 | names(freq) <- nm 16 | class(freq) <- "fisher" 17 | freq 18 | } 19 | -------------------------------------------------------------------------------- /R/print.summary.prc.R: -------------------------------------------------------------------------------- 1 | "print.summary.prc" <- 2 | function(x, ...) 3 | { 4 | cat("\nCall:\n") 5 | cat(deparse(x$call), "\n") 6 | cat("Species scores:\n") 7 | print(x$sp, digits=x$digits, ...) 8 | cat("\nCoefficients for", 9 | paste(x$names[2], "+", paste(x$names, collapse=":")), 10 | "interaction\n") 11 | cat(paste("which are contrasts to", x$names[2], x$corner, "\n")) 12 | cat(paste(c("rows are",", columns are"), x$names[2:1], collapse="")) 13 | cat("\n") 14 | print(coef(x), digits = x$digits, ...) 15 | invisible(x) 16 | } 17 | 18 | -------------------------------------------------------------------------------- /R/plot.varpart234.R: -------------------------------------------------------------------------------- 1 | `plot.varpart234` <- 2 | function(x, cutoff = 0, digits = 1, ...) 3 | { 4 | vals <- x$indfract[, 3] 5 | is.na(vals) <- vals < cutoff 6 | if (cutoff >= 0) 7 | vals <- round(vals, digits+1) 8 | labs <- format(vals, digits=digits, nsmall=digits+1) 9 | labs <- gsub("NA", "", labs) 10 | showvarparts(x$nsets, labs, ...) 11 | if (any(is.na(vals))) { 12 | localMtext <- function(..., Xnames, cutoff) mtext(...) 13 | localMtext(paste("Values <", cutoff," not shown", sep=""), side=1, ...) 14 | } 15 | invisible() 16 | } 17 | 18 | -------------------------------------------------------------------------------- /R/print.summary.clamtest.R: -------------------------------------------------------------------------------- 1 | print.summary.clamtest <- function(x, digits=max(3, getOption("digits") - 3), ...) { 2 | cat("Two Groups Species Classification Method (CLAM)\n\n") 3 | cat("Specialization threshold =", x$specialization) 4 | cat("\nAlpha level =", x$alpha) 5 | cat("\n\nEstimated sample coverage:\n") 6 | print(x$coverage, digits=digits) 7 | cat("\nMinimum abundance for classification:\n") 8 | print(structure(c(x$minv[[1]][1,2], x$minv[[2]][1,1]), 9 | .Names=x$labels)) 10 | cat("\n") 11 | printCoefmat(x$summary, digits=digits, ...) 12 | } 13 | 14 | -------------------------------------------------------------------------------- /R/print.nullmodel.R: -------------------------------------------------------------------------------- 1 | print.nullmodel <- function(x, ...) { 2 | isSeq <- ifelse(x$commsim$isSeq, "sequential", "non-sequential") 3 | if (x$commsim$binary) 4 | kind <- "binary" 5 | else 6 | kind <- ifelse(x$commsim$mode == "integer", "count", "abundance") 7 | cat("An object of class", dQuote(class(x)[1L]), "\n") 8 | cat(sQuote(x$commsim$method), " method (", 9 | kind, ", ", isSeq, ")\n", sep="") 10 | cat(x$nrow, "x", x$ncol, "matrix\n") 11 | if (x$commsim$isSeq) 12 | cat("Iterations =", x$iter, "\n\n") else cat("\n") 13 | invisible(x) 14 | } 15 | -------------------------------------------------------------------------------- /R/text.decorana.R: -------------------------------------------------------------------------------- 1 | `text.decorana` <- 2 | function (x, display = c("sites", "species"), labels, choices = 1:2, 3 | origin = TRUE, select, ...) 4 | { 5 | localText <- function(..., shrink, origin, scaling, triangular) 6 | text(...) 7 | display <- match.arg(display) 8 | x <- scores(x, display = display, choices = choices, origin = origin, 9 | ...) 10 | if (!missing(select)) 11 | x <- .checkSelect(select, x) 12 | if (!missing(labels)) 13 | rownames(x) <- labels 14 | localText(x, rownames(x), ...) 15 | invisible() 16 | } 17 | -------------------------------------------------------------------------------- /R/coef.rda.R: -------------------------------------------------------------------------------- 1 | `coef.rda` <- 2 | function (object, norm = FALSE, ...) 3 | { 4 | if(is.null(object$CCA) || object$CCA$rank == 0) 5 | stop("unconstrained or empty models do not have coefficients") 6 | Q <- object$CCA$QR 7 | u <- object$CCA$u 8 | ## scores.cca uses na.predict and may add missing NA rows to u, 9 | ## but Q has no missing cases 10 | if (nrow(Q$qr) < nrow(u) && inherits(object$na.action, "exclude")) 11 | u <- u[-object$na.action,, drop=FALSE] 12 | b <- qr.coef(Q, u) 13 | if (norm) 14 | b <- sqrt(colSums(qr.X(Q)^2)) * b 15 | b 16 | } 17 | 18 | -------------------------------------------------------------------------------- /R/fisher.alpha.R: -------------------------------------------------------------------------------- 1 | `fisher.alpha` <- 2 | function (x, MARGIN = 1, ...) 3 | { 4 | x <- as.matrix(x, rownames.force = TRUE) 5 | if(ncol(x) == 1) 6 | x <- t(x) 7 | sol <- apply(x, MARGIN, fisherfit) 8 | out <- unlist(lapply(sol, function(x) x$estimate)) 9 | if (FALSE) { 10 | out <- list(alpha = out) 11 | out$se <- unlist(lapply(sol, function(x) sqrt(diag(solve(x$hessian)))[1])) 12 | out$df.residual <- unlist(lapply(sol, df.residual)) 13 | out$code <- unlist(lapply(sol, function(x) x$code)) 14 | out <- as.data.frame(out) 15 | } 16 | out 17 | } 18 | -------------------------------------------------------------------------------- /R/lines.procrustes.R: -------------------------------------------------------------------------------- 1 | `lines.procrustes` <- 2 | function(x, type=c("segments", "arrows"), choices=c(1,2), 3 | truemean = FALSE, ...) 4 | { 5 | type <- match.arg(type) 6 | X <- x$X[,choices, drop=FALSE] 7 | Y <- x$Yrot[, choices, drop=FALSE] 8 | if (truemean) { 9 | X <- sweep(X, 2, x$xmean[choices], "+") 10 | Y <- sweep(Y, 2, x$xmean[choices], "+") 11 | } 12 | if (type == "segments") 13 | ordiArgAbsorber(X[,1], X[,2], Y[,1], Y[,2], FUN = segments, ...) 14 | else 15 | ordiArgAbsorber(X[,1], X[,2], Y[,1], Y[,2], FUN = arrows, ...) 16 | invisible() 17 | } 18 | -------------------------------------------------------------------------------- /R/plot.renyiaccum.R: -------------------------------------------------------------------------------- 1 | `plot.renyiaccum` <- 2 | function (x, what=c("Collector", "mean", "Qnt 0.025", "Qnt 0.975"), 3 | type = "l", ...) 4 | { 5 | what <- what[what %in% dimnames(x)[[3]]] 6 | if (any(what %in% dimnames(x)[[3]])) 7 | x <- x[,,what, drop = FALSE] 8 | dm <- dim(x) 9 | dnam <- dimnames(x) 10 | lin <- rep(dnam[[3]], each=dm[1]*dm[2]) 11 | Sites <- rep(1:dm[1], len=prod(dm)) 12 | alp <- factor(dnam[[2]], levels=dnam[[2]]) 13 | alpha <- rep(rep(alp, each=dm[1]), len=prod(dm)) 14 | Diversity <- as.vector(x) 15 | xyplot(Diversity ~ Sites | alpha, groups=lin, type=type, ...) 16 | } 17 | 18 | -------------------------------------------------------------------------------- /R/summary.ordiellipse.R: -------------------------------------------------------------------------------- 1 | ### Centres and areas of plotted ellipses. The principal axes of the 2 | ### conic (oblique ellipse) are found from the eigenvalues of the 3 | ### covariance matrix. 4 | `summary.ordiellipse` <- 5 | function(object, ...) 6 | { 7 | cnts <- sapply(object, function(x) x$center) 8 | ## 2nd eigenvalue should be zero if points are on line (like two 9 | ## points), but sometimes it comes out negative, and area is NaN 10 | areas <- sapply(object, 11 | function(x) 12 | sqrt(pmax.int(0, det(x$cov))) * pi * x$scale^2) 13 | rbind(cnts, `Area` = areas) 14 | } 15 | -------------------------------------------------------------------------------- /R/as.ts.oecosimu.R: -------------------------------------------------------------------------------- 1 | `as.ts.oecosimu` <- 2 | function(x, ...) 3 | { 4 | if (!x$oecosimu$isSeq) 5 | stop("as.ts available only for sequential methods") 6 | chains <- attr(x$oecosimu$simulated, "chains") 7 | if (!is.null(chains) && chains > 1) 8 | stop("as.ts available only for single chain") 9 | thin <- attr(x$oecosimu$simulated, "thin") 10 | startval <- attr(x$oecosimu$simulated, "burnin") + thin 11 | out <- ts(t(x$oecosimu$simulated), start = startval, deltat=thin, 12 | names = names(x$oecosimu$z)) 13 | attr(out, "burnin") <- NULL 14 | attr(out, "thin") <- NULL 15 | out 16 | } 17 | -------------------------------------------------------------------------------- /R/lines.spantree.R: -------------------------------------------------------------------------------- 1 | `lines.spantree` <- 2 | function (x, ord, display = "sites", col = 1, ...) 3 | { 4 | ord <- scores(ord, display = display, ...) 5 | tree <- x$kid 6 | ## recycle colours and use a mixture of joined points for line segments 7 | col <- rep(col, length = nrow(ord)) 8 | col <- col2rgb(col)/255 9 | ## average colour for pairs of points 10 | col <- rgb(t(col[,-1] + col[,tree])/2) 11 | if (x$n > 1) 12 | ordiArgAbsorber(ord[-1, 1], ord[-1, 2], ord[tree, 1], ord[tree, 2], 13 | col = col, 14 | FUN = segments, ...) 15 | invisible() 16 | } 17 | -------------------------------------------------------------------------------- /R/print.summary.meandist.R: -------------------------------------------------------------------------------- 1 | `print.summary.meandist` <- 2 | function(x, ...) 3 | { 4 | cat("\nMean distances:\n") 5 | tab <- rbind("within groups" = x$W, 6 | "between groups" = x$B, 7 | "overall" = x$D) 8 | colnames(tab) <- "Average" 9 | print(tab, ...) 10 | cat("\nSummary statistics:\n") 11 | tab <- rbind("MRPP A weights n" = x$A1, 12 | "MRPP A weights n-1" = x$A2, 13 | "MRPP A weights n(n-1)"= x$A3, 14 | "Classification strength"=x$CS) 15 | colnames(tab) <- "Statistic" 16 | print(tab, ...) 17 | invisible(x) 18 | } 19 | 20 | -------------------------------------------------------------------------------- /R/scores.betadisper.R: -------------------------------------------------------------------------------- 1 | `scores.betadisper` <- 2 | function(x, display = c("sites", "centroids"), 3 | choices = c(1,2), ...) 4 | { 5 | display <- match.arg(display, several.ok = TRUE) 6 | sol <- list() 7 | if("sites" %in% display) 8 | sol$sites <- x$vectors[, choices] 9 | if("centroids" %in% display) { 10 | if(is.matrix(x$centroids)) 11 | sol$centroids <- x$centroids[, choices, drop = FALSE] 12 | else 13 | sol$centroids <- matrix(x$centroids[choices], ncol = length(choices), byrow = TRUE) 14 | } 15 | if (length(sol) == 1) 16 | sol <- sol[[1]] 17 | sol 18 | } 19 | -------------------------------------------------------------------------------- /R/print.bioenv.R: -------------------------------------------------------------------------------- 1 | `print.bioenv` <- 2 | function (x, ...) 3 | { 4 | cat("\nCall:\n") 5 | cat(deparse(x$call), "\n") 6 | cat("\nSubset of environmental variables with best correlation to community data.\n\n") 7 | cat("Correlations: ", x$method, "\n") 8 | cat("Dissimilarities:", x$index, "\n") 9 | cat("Metric: ", x$metric, "\n\n") 10 | i <- which.max(lapply(x$models, function(tmp) tmp$est)) 11 | cat("Best model has", i, "parameters (max.", x$upto, "allowed):\n") 12 | cat(paste(x$names[x$models[[i]]$best], collapse = " ")) 13 | cat("\nwith correlation ", x$models[[i]]$est, "\n\n") 14 | invisible(x) 15 | } 16 | -------------------------------------------------------------------------------- /R/print.varpart.R: -------------------------------------------------------------------------------- 1 | `print.varpart` <- 2 | function (x, ...) 3 | { 4 | cat("\nPartition of", x$inert, "in", x$RDA, "\n\n") 5 | writeLines(strwrap(pasteCall(x$call))) 6 | if (x$RDA == "RDA") { 7 | if (x$scale) 8 | cat("Columns of Y were scaled to unit variance\n") 9 | if (!is.null(x$transfo)) 10 | cat("Species transformation: ", x$transfo) 11 | } 12 | cat("\n") 13 | cat("Explanatory tables:\n") 14 | cat(paste(paste(paste("X", seq_along(x$tables), sep=""),": ", 15 | x$tables, sep=""), collapse="\n"), "\n\n") 16 | print(x$part, ...) 17 | invisible(x) 18 | } 19 | 20 | -------------------------------------------------------------------------------- /R/vegandocs.R: -------------------------------------------------------------------------------- 1 | `vegandocs` <- 2 | function (doc = c("NEWS", "ONEWS", "FAQ-vegan", 3 | "intro-vegan", "diversity-vegan", 4 | "decision-vegan", "partitioning", "permutations")) 5 | { 6 | doc <- match.arg(doc) 7 | if (doc == "NEWS") { 8 | .Defunct('news(package="vegan")') 9 | } else if (doc %in% vignette(package="vegan")$results[, "Item"]) { 10 | .Defunct('browseVignettes("vegan")') 11 | } else if (doc == "permutations") { 12 | .Defunct('browseVignettes("permute")') 13 | } else { # last resort 14 | .Defunct(gettextf('file.show(system.file(package="vegan", "%s"))', doc)) 15 | } 16 | } 17 | -------------------------------------------------------------------------------- /R/plot.ordipointlabel.R: -------------------------------------------------------------------------------- 1 | plot.ordipointlabel <- function (x, ...) 2 | { 3 | plot(x$points, pch = x$args$pch, cex = x$args$pcex, col = x$args$pcol, 4 | bg = x$args$pbg, asp = 1, ...) 5 | font <- attr(x$labels, "font") 6 | if (is.null(font)) 7 | font <- par("font") 8 | text(x$labels, rownames(x$labels), cex = x$args$tcex, col = x$args$tcol, 9 | font = font, ...) 10 | psize <- par("din") 11 | if(any(abs(psize - x$dim)/x$dim > 0.1)) 12 | message(gettextf( 13 | "original plot size was %.1f x %.1f, current is %.1f x %.1f", 14 | x$dim[1], x$dim[2], psize[1], psize[2])) 15 | invisible(x) 16 | } 17 | -------------------------------------------------------------------------------- /R/radfit.data.frame.R: -------------------------------------------------------------------------------- 1 | `radfit.data.frame` <- 2 | function(x, ...) 3 | { 4 | ## x *must* have rownames 5 | rownames(x) <- rownames(x, do.NULL = TRUE) 6 | ## remove empty rows with no species 7 | nspec <- specnumber(x) 8 | if (any(nspec == 0)) { 9 | warning("removed empty rows with no species") 10 | x <- x[nspec>0,, drop=FALSE] 11 | } 12 | out <- apply(x, 1, radfit, ...) 13 | if (length(out) == 1) 14 | out <- out[[1]] 15 | else { 16 | class(out) <- "radfit.frame" 17 | } 18 | out 19 | } 20 | 21 | `radfit.matrix` <- 22 | function(x, ...) 23 | { 24 | radfit(as.data.frame(x), ...) 25 | } 26 | -------------------------------------------------------------------------------- /R/plot.poolaccum.R: -------------------------------------------------------------------------------- 1 | `plot.poolaccum` <- 2 | function(x, alpha = 0.05, type = c("l","g"), ...) 3 | { 4 | m <- summary(x, alpha = alpha, ...) 5 | n <- nrow(m[[1]]) 6 | Size <- as.vector(sapply(m, function(x) c(x[,1], x[,1], rev(x[,1])))) 7 | Richness <- as.vector(sapply(m, function(x) c(x[,2], x[,3], rev(x[,4]))) ) 8 | indnames <- as.character(sapply(m, function(x) colnames(x[,2, drop=FALSE]))) 9 | Index <- factor(rep(indnames, each = 3 * n), levels = indnames) 10 | lintype <- rep(c(rep("aver", n), rep("envel", 2*n)), length=length(Size)) 11 | xyplot(Richness ~ Size | Index, as.table = TRUE, groups = lintype, 12 | type = type, ...) 13 | } 14 | -------------------------------------------------------------------------------- /R/summary.dispweight.R: -------------------------------------------------------------------------------- 1 | ### summary methods extracts dispweight attributes, and prints a table 2 | ### of dispersion statistics 3 | 4 | `summary.dispweight` <- 5 | function(object, ...) 6 | { 7 | x <- attributes(object) 8 | class(x) <- "summary.dispweight" 9 | x 10 | } 11 | 12 | `print.summary.dispweight` <- 13 | function(x, ...) 14 | { 15 | tab <- with(x, cbind(D, weights, df, p)) 16 | colnames(tab) <- c("Dispersion", "Weight", "Df", "Pr(Disp.)") 17 | printCoefmat(tab, cs.ind = NA, ...) 18 | if (!is.na(x$nsimul)) 19 | cat(sprintf("Based on %d simulations on '%s' nullmodel\n", 20 | x$nsimul, x$nullmodel)) 21 | invisible(x) 22 | } 23 | -------------------------------------------------------------------------------- /R/persp.renyiaccum.R: -------------------------------------------------------------------------------- 1 | `persp.renyiaccum` <- 2 | function(x, theta = 220, col = heat.colors(100), zlim, ...) 3 | { 4 | dn <- dimnames(x) 5 | Sites <- seq(along=dn[[1]]) 6 | Scale <- seq(along=dn[[2]]) 7 | Diversity <- x[,,"mean"] 8 | if (missing(zlim)) 9 | zlim <- range(Diversity, 0) 10 | if (length(col) > 1) { 11 | ind <- Diversity 12 | ind <- (ind[-1,-1] + ind[-1,-ncol(ind)] + ind[-nrow(ind),-1] + 13 | ind[-nrow(ind),-ncol(ind)])/4 14 | ind <- round((length(col) - 1) * (ind - min(ind))/diff(range(ind)) + 1) 15 | col <- col[ind] 16 | } 17 | persp(Sites, Scale, Diversity, theta = theta, zlim = zlim, col = col, ...) 18 | } 19 | -------------------------------------------------------------------------------- /R/plot.mantel.correlog.R: -------------------------------------------------------------------------------- 1 | `plot.mantel.correlog` <- 2 | function(x, alpha=0.05, ...) 3 | { 4 | lim <- max(x$n.tests) 5 | plot(x$mantel.res[1:lim,1],x$mantel.res[1:lim,3], 6 | xlab="Distance class index", ylab="Mantel correlation", pch=22) 7 | if(x$mult == "none") { 8 | signif <- which((x$mantel.res[1:lim,4] <= alpha)) 9 | } else { 10 | signif <- which((x$mantel.res[1:lim,5] <= alpha)) 11 | } 12 | lines(x$mantel.res[1:lim,1], x$mantel.res[1:lim,3]) 13 | points(x$mantel.res[1:lim,1], x$mantel.res[1:lim,3], pch=22, bg="white") 14 | points(x$mantel.res[signif,1], x$mantel.res[signif,3], pch=22, bg="black") 15 | abline(a=0, b=0, col="red") 16 | invisible() 17 | } 18 | -------------------------------------------------------------------------------- /R/adipart.formula.R: -------------------------------------------------------------------------------- 1 | `adipart.formula` <- 2 | function(formula, data, index=c("richness", "shannon", "simpson"), 3 | weights=c("unif", "prop"), relative = FALSE, nsimul=99, 4 | method = "r2dtable", ...) 5 | { 6 | ## evaluate formula 7 | if (missing(data)) 8 | data <- parent.frame() 9 | tmp <- hierParseFormula(formula, data) 10 | ## run simulations 11 | sim <- adipart.default(tmp$lhs, tmp$rhs, index = index, weights = weights, 12 | relative = relative, nsimul = nsimul, 13 | method = method, ...) 14 | call <- match.call() 15 | call[[1]] <- as.name("adipart") 16 | attr(sim, "call") <- call 17 | sim 18 | } 19 | -------------------------------------------------------------------------------- /R/distconnected.R: -------------------------------------------------------------------------------- 1 | `distconnected` <- 2 | function(dis, toolong = 1, trace = TRUE) 3 | { 4 | n <- attr(dis, "Size") 5 | out <- .C(stepabyss, dis = as.double(dis), n = as.integer(n), 6 | toolong = as.double(toolong), val = integer(n), 7 | NAOK = TRUE, PACKAGE = "vegan")$val 8 | if (trace) { 9 | cat("Connectivity of distance matrix with threshold dissimilarity", 10 | toolong,"\n") 11 | n <- length(unique(out)) 12 | if (n == 1) 13 | cat("Data are connected\n") 14 | else { 15 | cat("Data are disconnected:", n, "groups\n") 16 | print(table(out, dnn="Groups sizes")) 17 | } 18 | } 19 | out 20 | } 21 | -------------------------------------------------------------------------------- /R/multipart.formula.R: -------------------------------------------------------------------------------- 1 | `multipart.formula` <- 2 | function(formula, data, index=c("renyi", "tsallis"), scales = 1, 3 | global = FALSE, relative = FALSE, nsimul=99, 4 | method = "r2dtable", ...) 5 | { 6 | ## evaluate formula 7 | if (missing(data)) 8 | data <- parent.frame() 9 | tmp <- hierParseFormula(formula, data) 10 | ## run simulations 11 | sim <- multipart.default(tmp$lhs, tmp$rhs, index = index, scales = scales, 12 | global = global, relative = relative, 13 | nsimul = nsimul, method = method, ...) 14 | call <- match.call() 15 | call[[1]] <- as.name("multipart") 16 | attr(sim, "call") <- call 17 | sim 18 | } 19 | -------------------------------------------------------------------------------- /R/points.cca.R: -------------------------------------------------------------------------------- 1 | `points.cca` <- 2 | function (x, display = "sites", choices = c(1, 2), scaling = "species", 3 | arrow.mul, head.arrow = 0.05, select, const, 4 | correlation = FALSE, hill = FALSE, ...) 5 | { 6 | if (length(display) > 1) 7 | stop("only one 'display' item can be added in one command") 8 | pts <- scores(x, choices = choices, display = display, scaling = scaling, 9 | const, correlation = correlation, hill = hill, tidy=FALSE, 10 | droplist = FALSE) 11 | class(pts) <- "ordiplot" 12 | if (!missing(select)) 13 | pts[[1]] <- .checkSelect(select, pts[[1]]) 14 | points.ordiplot(pts, what = names(pts), ...) 15 | invisible() 16 | } 17 | 18 | -------------------------------------------------------------------------------- /R/print.specaccum.R: -------------------------------------------------------------------------------- 1 | `print.specaccum` <- 2 | function(x, ...) 3 | { 4 | cat("Species Accumulation Curve\n") 5 | if (inherits(x, "fitspecaccum")) 6 | cat("Non-linear regression model:", x$SSmodel, "\n") 7 | cat("Accumulation method:", x$method) 8 | if (x$method == "random") { 9 | cat(", with ", ncol(x$perm), " permutations", sep="") 10 | } 11 | if (!is.null(x$weights)) 12 | cat(", weighted") 13 | cat("\n") 14 | cat("Call:", deparse(x$call), "\n\n") 15 | mat <- rbind(Sites = x$sites, Individuals = x$individuals, Effort = x$effort, 16 | Richness = x$richness, sd=x$sd) 17 | colnames(mat) <- rep("", ncol(mat)) 18 | print(zapsmall(mat)) 19 | invisible(x) 20 | } 21 | -------------------------------------------------------------------------------- /R/calibrate.ordisurf.R: -------------------------------------------------------------------------------- 1 | `calibrate.ordisurf` <- 2 | function(object, newdata, ...) 3 | { 4 | if (missing(newdata)) 5 | fit <- predict(object, type = "response", ...) 6 | else { 7 | ## Got only a vector of two coordinates 8 | if (is.vector(newdata) && length(newdata) == 2) 9 | newdata = data.frame(x1 = newdata[1], x2 = newdata[2]) 10 | ## Got a matrix or a data frme 11 | else{ 12 | if (NCOL(newdata) < 2) 13 | stop("needs a matrix or a data frame with two columns") 14 | newdata <- data.frame(x1 = newdata[,1], x2 = newdata[,2]) 15 | } 16 | fit <- predict(object, newdata = newdata, type = "response", ...) 17 | } 18 | fit 19 | } 20 | -------------------------------------------------------------------------------- /R/hiersimu.formula.R: -------------------------------------------------------------------------------- 1 | `hiersimu.formula` <- 2 | function(formula, data, FUN, location = c("mean", "median"), 3 | relative = FALSE, drop.highest = FALSE, nsimul=99, 4 | method = "r2dtable", ...) 5 | { 6 | ## evaluate formula 7 | if (missing(data)) 8 | data <- parent.frame() 9 | tmp <- hierParseFormula(formula, data) 10 | ## run simulations 11 | sim <- hiersimu.default(tmp$lhs, tmp$rhs, FUN = FUN, location = location, 12 | relative = relative, drop.highest = drop.highest, 13 | nsimul = nsimul, method = method, ...) 14 | call <- match.call() 15 | call[[1]] <- as.name("hiersimu") 16 | attr(sim, "call") <- call 17 | sim 18 | } 19 | 20 | -------------------------------------------------------------------------------- /R/print.radfit.R: -------------------------------------------------------------------------------- 1 | "print.radfit" <- 2 | function(x, digits = max(3, getOption("digits") - 2), ...) 3 | { 4 | cat("\nRAD models, family", x$family$family, "\n") 5 | cat("No. of species ", length(x$y), ", total abundance ", 6 | sum(x$y), "\n\n", sep = "") 7 | p <- coef(x) 8 | if (any(!is.na(p))) 9 | p <- formatC(p, format="g", flag = " ", digits = digits) 10 | p <- apply(p, 2, function(x) gsub("NA", " ", x)) 11 | aic <- sapply(x$models, AIC) 12 | bic <- sapply(x$models, AIC, k = log(length(x$y))) 13 | dev <- sapply(x$models, deviance) 14 | stats <- format(cbind(Deviance = dev, AIC = aic, BIC = bic), digits = digits, ...) 15 | out <- cbind(p, stats) 16 | print(out, quote=FALSE) 17 | invisible(x) 18 | } 19 | -------------------------------------------------------------------------------- /R/eventstar.R: -------------------------------------------------------------------------------- 1 | `eventstar` <- 2 | function(x, qmax=5) 3 | { 4 | if (is.null(dim(x))) 5 | x <- matrix(x, 1, length(x)) 6 | else 7 | x <- as.matrix(x) # faster than data.frame 8 | lossfun <- function(q, x) 9 | tsallis(x, scales=q, norm=TRUE) 10 | qstarfun <- function(x) { 11 | optimize(lossfun, interval=c(0, qmax), x=x)$minimum 12 | } 13 | qs <- apply(x, 1, qstarfun) 14 | Hs <- sapply(1:nrow(x), function(i) tsallis(x[i,], 15 | scales=qs[i], hill=FALSE)) 16 | S <- rowSums(x) 17 | Es <- ifelse(qs==1, log(S), Hs/((S^(1-qs)-1)/(1-qs))) 18 | Ds <- (1-(qs-1)*Hs)^(1/(1-qs)) 19 | out <- data.frame(qstar=qs, Estar=Es, Hstar=Hs, Dstar=Ds) 20 | rownames(out) <- rownames(x) 21 | out 22 | } 23 | -------------------------------------------------------------------------------- /R/print.mantel.R: -------------------------------------------------------------------------------- 1 | `print.mantel` <- 2 | function (x, digits = max(3, getOption("digits") - 3), ...) 3 | { 4 | cat("\n") 5 | if (inherits(x, "mantel.partial")) 6 | cat("Partial ") 7 | cat("Mantel statistic based on", x$method, "\n") 8 | cat("\nCall:\n") 9 | cat(deparse(x$call), "\n\n") 10 | cat("Mantel statistic r: ") 11 | cat(formatC(x$statistic, digits = digits), "\n") 12 | nperm <- x$permutations 13 | if (nperm) { 14 | cat(" Significance:", format.pval(x$signif), 15 | "\n\n") 16 | out <- quantile(x$perm, c(0.9, 0.95, 0.975, 0.99), na.rm = TRUE) 17 | cat("Upper quantiles of permutations (null model):\n") 18 | print(out, digits = 3) 19 | cat(howHead(x$control)) 20 | } 21 | cat("\n") 22 | invisible(x) 23 | } 24 | 25 | -------------------------------------------------------------------------------- /R/summary.anosim.R: -------------------------------------------------------------------------------- 1 | `summary.anosim` <- 2 | function (object, ...) 3 | { 4 | print(object) 5 | if (object$permutations) { 6 | out <- quantile(object$perm, c(0.9, 0.95, 0.975, 0.99)) 7 | cat("Upper quantiles of permutations (null model):\n") 8 | print(out, digits=3) 9 | } 10 | cat("\n") 11 | tmp <- tapply(object$dis.rank, object$class.vec, quantile) 12 | out <- matrix(NA, length(tmp), 5) 13 | for (i in seq_along(tmp)) { 14 | if (!is.null(tmp[[i]])) out[i,] <- tmp[[i]] 15 | } 16 | rownames(out) <- names(tmp) 17 | colnames(out) <- names(tmp$Between) 18 | out <- cbind(out, N = table(object$class.vec)) 19 | cat("Dissimilarity ranks between and within classes:\n") 20 | print(out) 21 | cat("\n") 22 | invisible() 23 | } 24 | -------------------------------------------------------------------------------- /R/coef.cca.R: -------------------------------------------------------------------------------- 1 | `coef.cca` <- 2 | function (object, norm = FALSE, ...) 3 | { 4 | if(is.null(object$CCA) || object$CCA$rank == 0) 5 | stop("unconstrained or empty models do not have coefficients") 6 | Q <- object$CCA$QR 7 | u <- object$CCA$u 8 | ## if rank==0, the next would fail, but this kluge gives 9 | ## consistent results with coef.rda and vegan 2.4 10 | if (ncol(u)) 11 | u <- sqrt(object$rowsum) * u 12 | ## scores.cca uses na.predict and may add missing NA rows to u, 13 | ## but Q has no missing cases 14 | if (nrow(Q$qr) < nrow(u) && inherits(object$na.action, "exclude")) 15 | u <- u[-object$na.action,, drop=FALSE] 16 | b <- qr.coef(Q, u) 17 | if (norm) 18 | b <- sqrt(colSums(qr.X(Q)^2)) * b 19 | b 20 | } 21 | 22 | -------------------------------------------------------------------------------- /R/fitted.rda.R: -------------------------------------------------------------------------------- 1 | `fitted.rda` <- 2 | function (object, model = c("CCA", "CA", "pCCA"), 3 | type = c("response", "working"), ...) 4 | { 5 | type <- match.arg(type) 6 | model <- match.arg(model) 7 | if (is.null(object[[model]])) 8 | stop(gettextf("component '%s' does not exist", model)) 9 | Xbar <- ordiYbar(object, model) 10 | if (type == "response") { 11 | cent <- attr(Xbar, "scaled:center") 12 | scal <- attr(Xbar, "scaled:scale") 13 | if (!is.null(scal)) { 14 | Xbar <- sweep(Xbar, 2, scal, "*") 15 | attr(Xbar, "scaled:scale") <- NULL 16 | } 17 | Xbar <- Xbar * sqrt(nrow(Xbar) - 1) 18 | Xbar <- sweep(Xbar, 2, cent, "+") 19 | attr(Xbar, "scaled:center") <- NULL 20 | } 21 | Xbar 22 | } 23 | -------------------------------------------------------------------------------- /R/plot.betadiver.R: -------------------------------------------------------------------------------- 1 | `plot.betadiver` <- 2 | function (x, ...) 3 | { 4 | xy <- scores(x, ...) 5 | plot(c(0, 1), c(0, sqrt(0.75)), type = "n", axes = FALSE, 6 | xlab = "", ylab = "", asp = 1) 7 | for (tic in seq(0.2, 0.8, by = 0.2)) { 8 | segments(tic, 0, tic/2, sqrt(0.75) * tic, lty = 3) 9 | segments(tic/2, sqrt(0.75) * tic, 1 - tic/2, sqrt(0.75) * 10 | tic, lty = 3) 11 | segments(tic, 0, tic/2 + 0.5, sqrt(0.75) * (1 - tic), 12 | lty = 3) 13 | } 14 | text(c(0, 1, 0.5), c(0, 0, sqrt(0.75)), c("b'", "c'", "a'"), 15 | pos = c(2, 4, 3), cex = par("cex.axis"), xpd=TRUE) 16 | lines(c(0, 1, 0.5, 0), c(0, 0, sqrt(0.75), 0), xpd = TRUE) 17 | points(xy, ...) 18 | class(xy) <- "ordiplot" 19 | invisible(xy) 20 | } 21 | -------------------------------------------------------------------------------- /R/as.rad.R: -------------------------------------------------------------------------------- 1 | `as.rad` <- 2 | function(x) 3 | { 4 | if (inherits(x, "rad")) 5 | return(x) 6 | ## recursive call for several observations 7 | if (isTRUE(nrow(x) > 1)) { 8 | comm <- apply(x, 1, as.rad) 9 | class(comm) <- "rad.frame" 10 | return(comm) 11 | } 12 | take <- x > 0 13 | nm <- names(x) 14 | comm <- x[take] 15 | names(comm) <- nm[take] 16 | comm <- sort(comm, decreasing = TRUE, index.return = TRUE) 17 | ## ordered index of included taxa 18 | index <- which(take)[comm$ix] 19 | comm <- comm$x 20 | attr(comm, "index") <- index 21 | class(comm) <- "rad" 22 | comm 23 | } 24 | 25 | ## do not print 'index' attribute 26 | 27 | `print.rad` <- 28 | function(x, ...) 29 | { 30 | print(as.table(x), ...) 31 | invisible(x) 32 | } 33 | -------------------------------------------------------------------------------- /R/bstick.cca.R: -------------------------------------------------------------------------------- 1 | `bstick.cca` <- 2 | function(n, ...) 3 | { 4 | if(!inherits(n, c("rda", "cca"))) 5 | stop("'n' not of class \"cca\" or \"rda\"") 6 | if(!is.null(n$CCA) && n$CCA$rank > 0) 7 | stop("'bstick' only for unconstrained models") 8 | ## No idea how to define bstick for dbrda or capscale with 9 | ## negative eigenvalues 10 | if (inherits(n, c("dbrda", "capscale")) && 11 | (!is.null(n$CA$imaginary.u) || !is.null(n$CA$imaginary.u.eig))) 12 | stop(gettextf("'bstick' cannot be used for '%s' with negative eigenvalues", 13 | class(n)[1])) 14 | ## need to select appropriate total inertia 15 | tot.chi <- n$CA$tot.chi 16 | n.comp <- n$CA$rank 17 | res <- bstick.default(n.comp, tot.chi, ...) 18 | names(res) <- names(n$CA$eig) 19 | res 20 | } 21 | -------------------------------------------------------------------------------- /R/fitted.procrustes.R: -------------------------------------------------------------------------------- 1 | `fitted.procrustes` <- 2 | function(object, truemean = TRUE, ...) 3 | { 4 | fit <- object$Yrot 5 | if (truemean) 6 | fit <- sweep(fit, 2, object$xmean, "+") 7 | fit 8 | } 9 | 10 | ## Like above, except when takes 'newata' 11 | 12 | `predict.procrustes` <- 13 | function(object, newdata, truemean = TRUE, ...) 14 | { 15 | if (missing(newdata)) 16 | return(fitted(object, truemean = truemean)) 17 | if (object$symmetric) 18 | stop(gettextf("'predict' not available for symmetric procrustes analysis with 'newdata'")) 19 | Y <- as.matrix(newdata) 20 | ## scaling and rotation 21 | Y <- object$scale * Y %*% object$rotation 22 | ## translation: always 23 | Y <- sweep(Y, 2, object$translation, "+") 24 | if (!truemean) 25 | Y <- sweep(Y, 2, object$xmean, "-") 26 | Y 27 | } 28 | -------------------------------------------------------------------------------- /R/spantree.R: -------------------------------------------------------------------------------- 1 | `spantree` <- 2 | function (d, toolong = 0) 3 | { 4 | if (!inherits(d, "dist")) { 5 | if ((is.matrix(d) || is.data.frame(d)) && 6 | isSymmetric(unname(as.matrix(d)))) { 7 | d <- as.dist(d) 8 | } else { 9 | stop("input must be dissimilarities") 10 | } 11 | } 12 | if (!is.numeric(d)) 13 | stop("input data must be numeric") 14 | n <- attr(d, "Size") 15 | labels <- labels(d) 16 | dis <- .C(primtree, dist = as.double(d), toolong = as.double(toolong), 17 | n = as.integer(n), val = double(n + 1), 18 | dad = integer(n + 1), NAOK = TRUE, PACKAGE = "vegan") 19 | out <- list(kid = dis$dad[2:n] + 1, dist = dis$val[2:n], 20 | labels = labels, n = n, call = match.call()) 21 | class(out) <- "spantree" 22 | out 23 | } 24 | -------------------------------------------------------------------------------- /R/plot.contribdiv.R: -------------------------------------------------------------------------------- 1 | plot.contribdiv <- 2 | function(x, sub, xlab, ylab, ylim, col, ...) { 3 | y <- x[,c(1,3)] 4 | if (missing(ylab)) 5 | ylab <- paste("Diversity components (", attr(x, "index"), ")", sep = "") 6 | if (missing(xlab)) 7 | xlab <- "Sites" 8 | if (missing(sub)) 9 | sub <- paste("Differentiation coefficient = ", round(attr(x, "diff.coef"),3), sep = "") 10 | if (missing(ylim)) 11 | ylim <- c(0, max(y)) 12 | if (missing(col)) 13 | col <- c("lightgrey", "darkgrey") 14 | matplot(y, type = "n", sub=sub, xlab=xlab, ylab=ylab, axes = FALSE, 15 | bty = "n", ...) 16 | polygon(c(1,1:nrow(y),nrow(y)), c(0,y$gamma,0), col=col[1]) 17 | polygon(c(1,1:nrow(y),nrow(y)), c(0,y$alpha,0), col=col[2]) 18 | axis(side = 1) 19 | axis(side = 2) 20 | box() 21 | invisible(x) 22 | } 23 | -------------------------------------------------------------------------------- /R/prestonfit.R: -------------------------------------------------------------------------------- 1 | `prestonfit` <- 2 | function (x, tiesplit = TRUE, ...) 3 | { 4 | x <- as.preston(x, tiesplit = tiesplit) 5 | oct <- as.numeric(names(x)) 6 | fit <- glm(x ~ oct + I(oct^2), 7 | family = if (tiesplit) quasipoisson else poisson) 8 | fv <- fitted(fit) 9 | p <- coef(fit) 10 | if (!is.na(p[3]) && p[3] < 0) { 11 | mu <- -p[2]/2/p[3] 12 | sd <- sqrt(-1/2/p[3]) 13 | S0 <- exp(p[1] - p[2]^2/4/p[3]) 14 | p <- c(mu, sd, S0) 15 | } 16 | else { 17 | p <- rep(NA, 3) 18 | } 19 | names(p) <- c("mode", "width", "S0") 20 | out <- list(freq = unclass(x), fitted = fv, coefficients = p) 21 | out$method = "Poisson fit to octaves" 22 | if(tiesplit) 23 | out$method <- paste("Quasi-", out$method, sep="") 24 | class(out) <- c("prestonfit") 25 | out 26 | } 27 | -------------------------------------------------------------------------------- /R/SSlomolino.R: -------------------------------------------------------------------------------- 1 | SSlomolino <- 2 | selfStart(~ Asym/(1 + slope^log(xmid/area)), 3 | function(mCall, data, LHS, ...) 4 | { 5 | xy <- sortedXyData(mCall[["area"]], LHS, data) 6 | ## approximate with Arrhenius model on log-log 7 | .p <- coef(lm(log(xy[["y"]]) ~ log(xy[["x"]]))) 8 | ## Asym is value at max(x) but > max(y) and xmid is x which gives 9 | ## Asym/2 10 | .Smax <- max(xy[["y"]])*1.1 11 | .S <- exp(.p[1] + log(max(xy[["x"]])) * (.p[2])) 12 | .S <- max(.S, .Smax) 13 | .xmid <- exp((log(.S/2) - .p[1])/.p[2]) 14 | ## approximate slope for log(Asym/y - 1) ~ log(xmid/x) + 0 15 | .y <- log(.S/xy[["y"]] - 1) 16 | .z <- log(.xmid/xy[["x"]]) 17 | .b <- coef(lm(.y ~ .z - 1)) 18 | value <- c(.S, .xmid, exp(.b)) 19 | names(value) <- mCall[c("Asym","xmid", "slope")] 20 | value 21 | }, 22 | c("Asym","xmid","slope")) 23 | -------------------------------------------------------------------------------- /R/summary.ordihull.R: -------------------------------------------------------------------------------- 1 | ### Centres and areas of convex hulls (simple polygons). 2 | `summary.ordihull` <- 3 | function(object, ...) 4 | { 5 | polyarea <- function(x) { 6 | n <- nrow(x) 7 | if (n < 4) 8 | return(0) 9 | else 10 | abs(sum(x[-n,1]*x[-1,2] - x[-1,1]*x[-n,2]))/2 11 | } 12 | polycentre <- function(x) { 13 | n <- nrow(x) 14 | if (n < 4) 15 | return(colMeans(x[-n,, drop = FALSE])) 16 | xy <- x[-n,1]*x[-1,2] - x[-1,1]*x[-n,2] 17 | A <- sum(xy)/2 18 | xc <- sum((x[-n,1] + x[-1,1]) * xy)/A/6 19 | yc <- sum((x[-n,2] + x[-1,2]) * xy)/A/6 20 | structure(c(xc, yc), names = colnames(x)) 21 | } 22 | areas <- sapply(object, function(x) polyarea(x)) 23 | cnts <- sapply(object, function(x) polycentre(x)) 24 | rbind(cnts, `Area` = areas) 25 | } 26 | -------------------------------------------------------------------------------- /R/points.ordiplot.R: -------------------------------------------------------------------------------- 1 | `points.ordiplot` <- 2 | function (x, what, select, arrows = FALSE, length = 0.05, 3 | arr.mul, ...) 4 | { 5 | sco <- scores(x, display = what) 6 | if (!missing(select)) 7 | sco <- .checkSelect(select, sco) 8 | if (!missing(arr.mul)) { 9 | arrows <- TRUE 10 | sco <- sco * arr.mul 11 | } else { 12 | ## draw adjusted arrows automatically for biplot scores 13 | scoatt <- attr(sco, "score") 14 | if (!is.null(scoatt) && scoatt %in% c("biplot", "regression")) { 15 | arrows = TRUE 16 | sco <- sco * ordiArrowMul(sco) 17 | } 18 | } 19 | ## draw arrows when requested, also for "species" etc 20 | if (arrows) { 21 | arrows(0, 0, sco[,1], sco[,2], length = length, ...) 22 | } else { 23 | points(sco, ...) 24 | } 25 | invisible(x) 26 | } 27 | -------------------------------------------------------------------------------- /R/plot.radfit.R: -------------------------------------------------------------------------------- 1 | `plot.radfit` <- 2 | function (x, BIC = FALSE, legend = TRUE, ...) 3 | { 4 | if (length(x$y) == 0) 5 | stop("no species, nothing to plot") 6 | ## if 'type = "n"', do not add legend (other types are not 7 | ## supported) 8 | type <- match.call(expand.dots = FALSE)$...$type 9 | if (is.null(type)) 10 | type <- "" 11 | out <- plot(x$y, ...) 12 | if (length(x$y) == 1) 13 | return(invisible(out)) 14 | fv <- fitted(x) 15 | if (BIC) 16 | k = log(length(x$y)) 17 | else k = 2 18 | emph <- which.min(sapply(x$models, AIC, k = k)) 19 | lwd <- rep(1, ncol(fv)) 20 | lwd[emph] <- 3 21 | matlines(fv, lty = 1, lwd = lwd, ...) 22 | if (legend && type != "n") { 23 | nm <- names(x$models) 24 | legend("topright", legend = nm, lty = 1, lwd = lwd, col = 1:6) 25 | } 26 | invisible(out) 27 | } 28 | -------------------------------------------------------------------------------- /man/vegan-deprecated.Rd: -------------------------------------------------------------------------------- 1 | \name{vegan-deprecated} 2 | 3 | \alias{as.mcmc.oecosimu} 4 | \alias{as.mcmc.permat} 5 | \alias{vegan-deprecated} 6 | 7 | %------ NOTE: ../R/vegan-deprecated.R must be synchronized with this! 8 | \title{Deprecated Functions in vegan package} 9 | %------ PLEASE: one \alias{.} for EACH ! (+ one \usage{} & \arguments{} for all) 10 | 11 | \description{ 12 | These functions are provided for compatibility with older versions of 13 | \pkg{vegan} only, and may be defunct as soon as the next release. 14 | } 15 | 16 | \usage{ 17 | 18 | ## use toCoda instead 19 | as.mcmc.oecosimu(x) 20 | as.mcmc.permat(x) 21 | } 22 | 23 | \arguments{ 24 | 25 | \item{x}{object to be transformed.} 26 | 27 | } 28 | 29 | \details{ 30 | 31 | \code{as.mcmc} functions were replaced with \code{\link{toCoda}}. 32 | } 33 | 34 | \seealso{ 35 | \code{\link{Deprecated}} 36 | } 37 | \keyword{misc} 38 | -------------------------------------------------------------------------------- /R/anova.prc.R: -------------------------------------------------------------------------------- 1 | `anova.prc` <- 2 | function(object, ...) 3 | { 4 | ## if user specified 'by', cast prc() to an rda() and call anova 5 | ## on its result 6 | extras <- match.call(expand.dots = FALSE) 7 | if ("by" %in% names(extras$...)) { 8 | Y <- as.character(object$call$response) 9 | X <- as.character(object$call$treatment) 10 | Z <- as.character(object$call$time) 11 | fla <- paste(Y, "~", X, "*", Z, "+ Condition(", Z, ")") 12 | fla <- as.formula(fla) 13 | ## get extras 14 | m <- match(c("data", "scale", "subset", "na.action"), 15 | names(object$call), 0) 16 | call <- object$call[c(1,m)] 17 | call$formula <- fla 18 | call[[1]] <- as.name("rda") 19 | object <- eval(call, parent.frame()) 20 | anova(object, ...) 21 | } else { 22 | NextMethod("anova") 23 | } 24 | } 25 | -------------------------------------------------------------------------------- /R/betadistances.R: -------------------------------------------------------------------------------- 1 | ### Function to find distances from each sampling unit to each centroid 2 | ### for vegan::betadisper result. 3 | ### x (input): result object from vegan::betadisper 4 | ### 5 | ### Originally published in 6 | ### https://stackoverflow.com/questions/77391007/ and in github issue 7 | ### #606 8 | 9 | `betadistances` <- 10 | function(x, ...) 11 | { 12 | cnt <- x$centroids 13 | coord <- x$vectors 14 | pos <- which(x$eig >= 0) 15 | neg <- which(x$eig < 0) 16 | d <- apply(cnt[,pos], 1, 17 | function(z) rowSums(sweep(coord[,pos], 2, z)^2)) 18 | if (length(neg)) 19 | d <- d - apply(cnt[, neg], 1, 20 | function(z) rowSums(sweep(coord[,neg], 2, z)^2)) 21 | d <- as.data.frame(sqrt(d)) 22 | nearest <- levels(x$group)[apply(d, 1, which.min)] 23 | out <- data.frame("group" = x$group, "nearest" = nearest, d) 24 | out 25 | } 26 | -------------------------------------------------------------------------------- /R/summary.meandist.R: -------------------------------------------------------------------------------- 1 | `summary.meandist` <- 2 | function(object, ...) 3 | { 4 | n <- attr(object, "n") 5 | wmat <- n %o% n 6 | diag(wmat) <- diag(wmat) - n 7 | ## mean distances within, between groups and in total 8 | W <- weighted.mean(diag(object), w = diag(wmat), na.rm = TRUE) 9 | B <- weighted.mean(object[lower.tri(object)], 10 | w = wmat[lower.tri(wmat)], na.rm = TRUE) 11 | D <- weighted.mean(object, w = wmat, na.rm = TRUE) 12 | ## Variants of MRPP statistics 13 | A1 <- weighted.mean(diag(object), w = n, na.rm = TRUE) 14 | A2 <- weighted.mean(diag(object), w = n - 1, na.rm = TRUE) 15 | A3 <- weighted.mean(diag(object), w = n * (n - 1), na.rm = TRUE) 16 | ## 17 | out <- list(W = W, B = B, D = D, CS = B-A1, 18 | A1 = 1 - A1/D, A2 = 1 - A2/D, A3 = 1 - A3/D) 19 | class(out) <- "summary.meandist" 20 | out 21 | } 22 | 23 | -------------------------------------------------------------------------------- /R/fieller.MOStest.R: -------------------------------------------------------------------------------- 1 | `fieller.MOStest` <- 2 | function (object, level = 0.95) 3 | { 4 | smodel <- summary(object$mod) 5 | ## overdispersion included in cov.scaled 6 | var <- smodel$cov.scaled 7 | k <- coef(object$mod) 8 | b2 <- -2 * k[3] 9 | u <- -k[2]/2/k[3] 10 | alpha <- (1-level)/2 11 | limits <- numeric(2) 12 | names(limits) <- paste(round(100*(c(alpha, 1-alpha)), 1), "%") 13 | wvar <- var[2,2] 14 | uvar <- 4 * var[3,3] 15 | vvar <- -2 * var[2,3] 16 | z <- qnorm(1 - alpha) 17 | g <- z^2 * uvar/b2^2 18 | if (g >= 1) { 19 | limits <- c(NA, NA) 20 | } 21 | else { 22 | x <- u - g * vvar/uvar 23 | f <- z/b2 24 | s <- sqrt(wvar - 2 * u * vvar + u^2 * uvar - 25 | g * (wvar - vvar^2/uvar)) 26 | limits[1] <- (x - f * s)/(1 - g) 27 | limits[2] <- (x + f * s)/(1 - g) 28 | } 29 | limits 30 | } 31 | -------------------------------------------------------------------------------- /R/intersetcor.R: -------------------------------------------------------------------------------- 1 | `intersetcor` <- 2 | function(object) 3 | { 4 | if (!inherits(object, "cca")) 5 | stop("can be used only with objects inheriting from 'cca'") 6 | if (is.null(object$CCA) || !object$CCA$rank) 7 | stop("no constrained ordination or rank of constraints is zero") 8 | wa <- object$CCA$wa 9 | X <- qr.X(object$CCA$QR, ncol = length(object$CCA$QR$pivot)) 10 | ## remove conditions (partial terms) 11 | if (!is.null(object$pCCA)) { 12 | X <- X[, -seq_along(object$pCCA$envcentre), drop = FALSE] 13 | X <- qr.resid(object$pCCA$QR, X) 14 | } 15 | if (inherits(object, "rda")) 16 | cor(X, wa) 17 | else { # cca: weighted analysis, terms already weighted-centred 18 | wa <- sqrt(object$rowsum) * wa 19 | cov <- crossprod(X, wa) 20 | isd <- outer(1/sqrt(colSums(X^2)), 1/sqrt(colSums(wa^2))) 21 | cov * isd 22 | } 23 | } 24 | -------------------------------------------------------------------------------- /R/stepacross.R: -------------------------------------------------------------------------------- 1 | `stepacross` <- 2 | function (dis, path = "shortest", toolong = 1, trace = TRUE, ...) 3 | { 4 | path <- match.arg(path, c("shortest", "extended")) 5 | if (!inherits(dis, "dist")) 6 | dis <- as.dist(dis) 7 | oldatt <- attributes(dis) 8 | n <- attr(dis, "Size") 9 | if (path == "shortest") 10 | dis <- .C(dykstrapath, dist = as.double(dis), n = as.integer(n), 11 | as.double(toolong), as.integer(trace), 12 | out = double(length(dis)), NAOK = TRUE, PACKAGE = "vegan")$out 13 | else dis <- .C(C_stepacross, dis = as.double(dis), as.integer(n), 14 | as.double(toolong), as.integer(trace), NAOK = TRUE, 15 | PACKAGE = "vegan")$dis 16 | if("maxdist" %in% oldatt) 17 | oldatt$maxdist <- NA 18 | attributes(dis) <- oldatt 19 | attr(dis, "method") <- paste(attr(dis, "method"), path) 20 | dis 21 | } 22 | -------------------------------------------------------------------------------- /R/prestondistr.R: -------------------------------------------------------------------------------- 1 | `prestondistr` <- 2 | function (x, truncate = -1, ...) 3 | { 4 | fun <- function(par, x, truncate) { 5 | up <- dnorm(x, par[1], par[2], log = TRUE) 6 | dn <- pnorm(truncate, par[1], par[2], lower.tail = FALSE) 7 | -sum(up - log(dn)) 8 | } 9 | x <- x[x > 0] 10 | logx <- log2(x) 11 | p <- c(mean(logx), sd(logx)) 12 | sol <- optim(p, fun, x = logx, truncate = truncate) 13 | p <- sol$par 14 | area <- pnorm(truncate, p[1], p[2], lower.tail = FALSE) 15 | scale <- length(x)/sqrt(2 * pi)/p[2]/area 16 | p <- c(p, scale) 17 | oct <- as.preston(x, ...) 18 | x <- as.numeric(names(oct)) 19 | fit <- p[3] * exp(-(x - p[1])^2/2/p[2]^2) 20 | names(p) <- c("mode", "width", "S0") 21 | out <- list(freq = oct, fitted = fit, coefficients = p) 22 | out$method <- "maximized likelihood to log2 abundances" 23 | class(out) <- "prestonfit" 24 | out 25 | } 26 | -------------------------------------------------------------------------------- /_pkgdown.yml: -------------------------------------------------------------------------------- 1 | home: 2 | title: "vegan: an R package for community ecologists" 3 | description: "Ordination methods, diversity analysis and other functions for community and vegetation ecologists." 4 | links: 5 | - text: R-universe 6 | href: https://vegandevs.r-universe.dev/vegan 7 | 8 | url: https://vegandevs.github.io/vegan/ 9 | 10 | deploy: 11 | install_metadata: true 12 | 13 | development: 14 | mode: auto 15 | 16 | template: 17 | bootstrap: 5 18 | bootswatch: flatly 19 | 20 | navbar: 21 | structure: 22 | left: [intro, reference, vignettes, news] 23 | right: [search, github] 24 | components: 25 | vignettes: 26 | text: Vignettes 27 | menu: 28 | - text: Vegan FAQ 29 | href: articles/FAQ-vegan.html 30 | 31 | figures: 32 | dev: ragg::agg_png 33 | dpi: 96 34 | dev.args: [] 35 | fig.ext: png 36 | fig.width: 7.2916667 37 | fig.height: ~ 38 | fig.retina: 2 39 | fig.asp: 1.618 40 | -------------------------------------------------------------------------------- /R/points.procrustes.R: -------------------------------------------------------------------------------- 1 | `points.procrustes` <- 2 | function(x, display = c("target","rotated"), choices = c(1,2), 3 | truemean = FALSE, ...) 4 | { 5 | display <- match.arg(display) 6 | X <- if (display == "target") x$X else x$Yrot 7 | X <- X[, choices, drop = FALSE] 8 | if (truemean) 9 | X <- sweep(X, 2, x$xmean[choices], "+") 10 | ordiArgAbsorber(X, FUN = points, ...) 11 | invisible() 12 | } 13 | 14 | `text.procrustes` <- 15 | function(x, display = c("target","rotated"), choices = c(1,2), 16 | labels, truemean = FALSE, ...) 17 | { 18 | display <- match.arg(display) 19 | X <- if (display == "target") x$X else x$Yrot 20 | X <- X[, choices, drop = FALSE] 21 | if (truemean) 22 | X <- sweep(X, 2, x$xmean[choices], "+") 23 | if (missing(labels)) 24 | labels <- rownames(X) 25 | ordiArgAbsorber(X, labels = labels, FUN = text, ...) 26 | invisible() 27 | } 28 | -------------------------------------------------------------------------------- /R/plot.isomap.R: -------------------------------------------------------------------------------- 1 | `plot.isomap` <- 2 | function (x, net = TRUE, n.col = "gray", type = "points", ...) 3 | { 4 | type <- match.arg(type, c("points", "text", "none")) 5 | if (!net) { 6 | pl <- ordiplot(x, display="sites", type = type, ...) 7 | } else { 8 | pl <- ordiplot(x, display = "sites", type = "none", ...) 9 | z <- scores(pl, display = "sites") 10 | k <- x$net 11 | ## recycle colour for points 12 | n.col <- rep(n.col, length = nrow(z)) 13 | n.col <- col2rgb(n.col)/255 14 | ## get average of colours of connected points 15 | n.col <- (n.col[,k[,1]] + n.col[,k[,2]])/2 16 | n.col <- rgb(t(n.col)) 17 | segments(z[k[,1],1], z[k[,1],2], z[k[,2],1], z[k[,2],2], col=n.col) 18 | if (type == "points") 19 | points(pl, "sites", ...) 20 | else if (type == "text") 21 | ordilabel(pl, ...) 22 | } 23 | invisible(pl) 24 | } 25 | 26 | -------------------------------------------------------------------------------- /R/summary.poolaccum.R: -------------------------------------------------------------------------------- 1 | `summary.poolaccum` <- 2 | function(object, display, alpha = 0.05, ...) 3 | { 4 | probs <- c(alpha/2, 1-alpha/2) 5 | if (inherits(object, "estaccumR")) 6 | dislabels <- c("S", "chao", "ace") 7 | else 8 | dislabels <- c("S", "chao", "jack1", "jack2", "boot") 9 | disnames <- colnames(object$means[,-1]) 10 | names(disnames) <- dislabels 11 | if (missing(display)) 12 | display <- dislabels 13 | else 14 | display <- match.arg(display, dislabels, several.ok = TRUE) 15 | out <- list() 16 | for (item in display) { 17 | out[[item]] <- cbind(`N` = object$N, 18 | `Mean` = object$means[,disnames[item], drop=FALSE], 19 | t(apply(object[[item]], 1, quantile, probs=probs)), 20 | `Std.Dev` = apply(object[[item]], 1, sd)) 21 | } 22 | class(out) <- "summary.poolaccum" 23 | out 24 | } 25 | -------------------------------------------------------------------------------- /R/indpower.R: -------------------------------------------------------------------------------- 1 | `indpower` <- 2 | function(x, type=0) 3 | { 4 | x <- as.matrix(x) 5 | if (!(is.numeric(x) || is.logical(x))) 6 | stop("input data must be numeric") 7 | x <- ifelse(x > 0, 1, 0) 8 | if (NCOL(x) < 2) 9 | stop("provide at least two columns for 'x'") 10 | if (!(type %in% 0:2)) 11 | stop("'type' must be 0, 1 or 2") 12 | n <- nrow(x) 13 | j <- crossprod(x) ## faster t(x) %*% x 14 | ip1 <- sweep(j, 1, diag(j), "/") 15 | ip2 <- 1 - sweep(-sweep(j, 2, diag(j), "-"), 1, n - diag(j), "/") 16 | out <- switch(as.character(type), 17 | "0" = sqrt(ip1 * ip2), 18 | "1" = ip1, 19 | "2" = ip2) 20 | cn <- if (is.null(colnames(out))) 21 | 1:ncol(out) else colnames(out) 22 | rn <- if (is.null(rownames(out))) 23 | 1:ncol(out) else rownames(out) 24 | colnames(out) <- paste("t", cn, sep=".") 25 | rownames(out) <- paste("i", rn, sep=".") 26 | out 27 | } 28 | -------------------------------------------------------------------------------- /R/summary.prc.R: -------------------------------------------------------------------------------- 1 | `summary.prc` <- function (object, axis = 1, scaling = "sites", const, 2 | digits = 4, correlation = FALSE, ...) { 3 | sc = scores(object, scaling = scaling, display = c("sp", "lc"), 4 | choices = axis, correlation = correlation, const = const,...) 5 | ## coef for scaled sites (coef(object) gives for orthonormal) 6 | b <- qr.coef(object$CCA$QR, sc$constraints) 7 | prnk <- object$pCCA$rank 8 | lentreat <- length(object$terminfo$xlev[[2]]) 9 | b = matrix(b[-(1:prnk)], nrow = lentreat-1, byrow = TRUE) 10 | rownames(b) <- (object$terminfo$xlev[[2]])[-1] 11 | colnames(b) <- object$terminfo$xlev[[1]] 12 | out <- list(sp = drop(sc$species), coefficients = b, 13 | names = names(object$terminfo$xlev), 14 | corner = (object$terminfo$xlev[[2]])[1], 15 | call = object$call, digits = digits) 16 | class(out) <- "summary.prc" 17 | out 18 | } 19 | -------------------------------------------------------------------------------- /R/hierParseFormula.R: -------------------------------------------------------------------------------- 1 | `hierParseFormula` <- 2 | function (formula, data) 3 | { 4 | lhs <- formula[[2]] 5 | if (any(attr(terms(formula, data = data), "order") > 1)) 6 | stop("interactions are not allowed") 7 | lhs <- as.matrix(eval(lhs, environment(formula), parent.frame())) 8 | formula[[2]] <- NULL 9 | rhs <- model.frame(formula, data, drop.unused.levels = TRUE) 10 | rhs[] <- lapply(rhs, function(u) { 11 | if (!is.factor(u)) 12 | u <- factor(u) 13 | u 14 | }) 15 | ## take care that the first column is a unique identifier for rows 16 | ## and the last column is constant for pooling all rows together 17 | if (length(unique(rhs[,1])) < nrow(rhs)) 18 | rhs <- cbind("unit" = factor(seq_len(nrow(rhs))), rhs) 19 | if (length(unique(rhs[, ncol(rhs)])) > 1) 20 | rhs <- cbind(rhs, "all" = factor(rep(1, nrow(rhs)))) 21 | attr(rhs, "terms") <- NULL 22 | list(lhs=lhs, rhs=rhs) 23 | } 24 | 25 | -------------------------------------------------------------------------------- /R/print.simmat.R: -------------------------------------------------------------------------------- 1 | print.simmat <- function(x, ...) { 2 | isSeq <- ifelse(attr(x, "isSeq"), "sequential", "non-sequential") 3 | if (attr(x, "binary")) { 4 | kind <- "binary" 5 | } else { 6 | kind <- ifelse(attr(x, "mode") == "integer", "count", "abundance") 7 | } 8 | d <- dim(x) 9 | cat("An object of class", dQuote(class(x)[1L]), "\n") 10 | cat(sQuote(attr(x, "method")), " method (", 11 | kind, ", ", isSeq, ")\n", sep="") 12 | cat(d[1L], "x", d[2L], "matrix\n") 13 | cat("Number of permuted matrices =", d[3L], "\n") 14 | if (attr(x, "isSeq")) { 15 | chainInfo <- "" 16 | if (!is.null(attr(x, "chains")) && attr(x, "chains") > 1L) 17 | chainInfo <- paste0(" (", attr(x, "chains"), " chains)") 18 | cat("Start = ", attr(x, "start"), ", End = ", attr(x, "end"), 19 | ", Thin = ", attr(x, "thin"), chainInfo, "\n\n", sep="") 20 | } else cat("\n") 21 | invisible(x) 22 | } 23 | -------------------------------------------------------------------------------- /R/print.summary.procrustes.R: -------------------------------------------------------------------------------- 1 | "print.summary.procrustes" <- 2 | function (x, digits = x$digits, ...) 3 | { 4 | cat("\nCall:\n") 5 | cat(deparse(x$call), "\n") 6 | cat("\nNumber of objects:", x$n, " Number of dimensions:", 7 | x$k, "\n") 8 | cat("\nProcrustes sum of squares: ") 9 | cat("\n", formatC(x$ss, digits = digits), "\n") 10 | cat("Procrustes root mean squared error: ") 11 | cat("\n", formatC(x$rmse, digits = digits), "\n") 12 | cat("Quantiles of Procrustes errors:\n") 13 | nam <- c("Min", "1Q", "Median", "3Q", "Max") 14 | rq <- structure(quantile(x$resid), names = nam) 15 | print(rq, digits = digits, ...) 16 | cat("\nRotation matrix:\n") 17 | print(x$rotation, digits = digits, ...) 18 | cat("\nTranslation of averages:\n") 19 | print(x$translation, digits = digits, ...) 20 | cat("\nScaling of target:\n") 21 | print(x$scale, digits = digits, ...) 22 | cat("\n") 23 | invisible(x) 24 | } 25 | 26 | -------------------------------------------------------------------------------- /R/ordilattice.getEnvfit.R: -------------------------------------------------------------------------------- 1 | `ordilattice.getEnvfit` <- 2 | function(formula, object, envfit, choices = 1:3, ...) 3 | { 4 | if (!missing(envfit) && !is.null(envfit)) 5 | object <- envfit 6 | bp <- scores(object, display = "bp", choices = choices, ...) 7 | cn <- scores(object, display = "cn", choices = choices, ...) 8 | bp <- bp[!(rownames(bp) %in% rownames(cn)),, drop=FALSE] 9 | left <- as.character(formula[[2]]) 10 | right <- formula[[3]] 11 | if (length(right) == 3) 12 | right <- right[[2]] 13 | right <- as.character(right) 14 | if (all(c(left,right) %in% colnames(bp))) 15 | bp <- bp[, c(left,right), drop=FALSE] 16 | else 17 | bp <- NULL 18 | if (!is.null(bp) && nrow(bp) == 0) 19 | bp <- NULL 20 | if (!is.null(ncol(cn)) && all(c(left,right) %in% colnames(cn))) 21 | cn <- cn[, c(left,right), drop=FALSE] 22 | else 23 | cn <- NULL 24 | list(arrows = bp, centres = cn) 25 | } 26 | -------------------------------------------------------------------------------- /R/plot.prestonfit.R: -------------------------------------------------------------------------------- 1 | "plot.prestonfit" <- 2 | function (x, xlab = "Frequency", ylab = "Species", bar.col = "skyblue", 3 | line.col = "red", lwd = 2, ...) 4 | { 5 | freq <- x$freq 6 | oct <- as.numeric(names(freq)) 7 | noct <- max(oct) + 1 8 | plot(oct, freq, type = "n", ylim = c(0, max(freq)), xlim = c(-1, 9 | max(oct)), ylab = ylab, xlab = xlab, axes = FALSE, ...) 10 | axis(2) 11 | axis(1, at = 0:noct, labels = 2^(0:noct)) 12 | box() 13 | rect(oct - 1, 0, oct, freq, col = bar.col, ...) 14 | p <- x$coefficients 15 | curve(p[3] * exp(-(x - p[1])^2/2/p[2]^2), -1, max(oct), add = TRUE, 16 | col = line.col, lwd = lwd, ...) 17 | segments(p["mode"], 0, p["mode"], p["S0"], col = line.col, ...) 18 | segments(p["mode"] - p["width"], p["S0"] * exp(-0.5), p["mode"] + 19 | p["width"], p["S0"] * exp(-0.5), col = line.col, ...) 20 | invisible() 21 | } 22 | -------------------------------------------------------------------------------- /R/veganMahatrans.R: -------------------------------------------------------------------------------- 1 | ### Internal function for Mahalanobis transformation of the matrix. 2 | ### Mahalanobis transformation of matrix X is M = X S^(-1/2) where S 3 | ### is the covariance matrix. The inverse square root of S is found 4 | ### via eigen decomposition S = G L G^T, where G is the matrix of 5 | ### eigenvectors, and L is the diagonal matrix of eigenvalues. Thus 6 | ### S^(-1/2) = G L^(-1/2) G^T. This is an internal function so that 7 | ### input must be correct: 'x' must be a centred matrix (not a 8 | ### data.frame, not raw data). 9 | `veganMahatrans` <- 10 | function (x, s2, tol = sqrt(.Machine$double.eps), na.rm = FALSE) 11 | { 12 | if (missing(s2)) 13 | s2 <- cov(x, use = if(na.rm) "pairwise.complete.obs" else "all.obs") 14 | e <- eigen(s2, symmetric = TRUE) 15 | k <- e$values > max(tol, tol * e$values[1L]) 16 | sisqr <- e$vectors[,k, drop=FALSE] %*% 17 | (sqrt(1/e$values[k]) * t(e$vectors[,k, drop = FALSE])) 18 | x %*% sisqr 19 | } 20 | -------------------------------------------------------------------------------- /R/drop1.cca.R: -------------------------------------------------------------------------------- 1 | `drop1.cca` <- 2 | function(object, scope, test = c("none", "permutation"), 3 | permutations = how(nperm = 199), ...) 4 | { 5 | if (inherits(object, "prc")) 6 | stop("'step'/'drop1' cannot be used for 'prc' objects") 7 | if (is.null(object$terms)) 8 | stop("ordination model must be fitted using formula") 9 | test <- match.arg(test) 10 | # don't show messages about aliased terms 11 | out <- suppressMessages(NextMethod("drop1", object, test = "none")) 12 | cl <- class(out) 13 | if (test == "permutation") { 14 | rn <- rownames(out)[-1] 15 | if (missing(scope)) 16 | scope <- rn 17 | else if (!is.character(scope)) 18 | scope <- drop.scope(scope) 19 | adds <- anova(object, by = "margin", scope = scope, 20 | permutations = permutations, ...) 21 | out <- cbind(out, rbind(NA, adds[rn,3:4])) 22 | class(out) <- cl 23 | } 24 | out 25 | } 26 | -------------------------------------------------------------------------------- /R/AIC.radfit.R: -------------------------------------------------------------------------------- 1 | ### these functions are defined _ex machina_ for radline objects which 2 | ### inherit from glm. Here we define them for radfit objects where 3 | ### object$models is a list of radline objects 4 | 5 | `AIC.radfit` <- 6 | function (object, k = 2, ...) 7 | { 8 | sapply(object$models, AIC, k = k, ...) 9 | } 10 | 11 | `deviance.radfit` <- 12 | function(object, ...) 13 | { 14 | sapply(object$models, deviance, ...) 15 | } 16 | 17 | `logLik.radfit` <- 18 | function(object, ...) 19 | { 20 | sapply(object$models, logLik, ...) 21 | } 22 | 23 | ### Define also for radfit.frames which are lists of radfit objects 24 | 25 | `AIC.radfit.frame` <- 26 | function(object, k = 2, ...) 27 | { 28 | sapply(object, AIC, k = k, ...) 29 | } 30 | 31 | `deviance.radfit.frame` <- 32 | function(object, ...) 33 | { 34 | sapply(object, deviance, ...) 35 | } 36 | 37 | `logLik.radfit.frame` <- 38 | function(object, ...) 39 | { 40 | sapply(object, logLik, ...) 41 | } 42 | -------------------------------------------------------------------------------- /R/rad.null.R: -------------------------------------------------------------------------------- 1 | "rad.null" <- 2 | function(x, family=poisson, ...) 3 | { 4 | fam <- family(link="log") 5 | aicfun <- fam$aic 6 | dev.resids <- fam$dev.resids 7 | x <- as.rad(x) 8 | nsp <- length(x) 9 | wt <- rep(1, nsp) 10 | if (nsp > 0) { 11 | fit <- rev(cumsum(1/nsp:1)/nsp) * sum(x) 12 | res <- dev.resids(x, fit, wt) 13 | deviance <- sum(res) 14 | aic <- aicfun(x, nsp, fit, wt, deviance) 15 | } 16 | else { 17 | fit <- NA 18 | aic <- NA 19 | res <- NA 20 | deviance <- NA 21 | } 22 | residuals <- x - fit 23 | rdf <- nsp 24 | names(fit) <- names(x) 25 | p <- NA 26 | names(p) <- "S" 27 | out <- list(model = "Brokenstick", family=fam, y = x, coefficients = p, 28 | fitted.values = fit, aic = aic, rank = 0, df.residual = rdf, 29 | deviance = deviance, residuals = residuals, prior.weights=wt) 30 | class(out) <- c("radline", "glm") 31 | out 32 | } 33 | -------------------------------------------------------------------------------- /R/print.permat.R: -------------------------------------------------------------------------------- 1 | ## S3 print method for permat 2 | `print.permat` <- 3 | function(x, digits=3, ...) 4 | { 5 | cat("Object of class 'permat' with ", attr(x, "times"), " simulations\n", sep="") 6 | cat("\nMatrix type:", attr(x, "mtype"), "\nPermutation type:", attr(x, "ptype")) 7 | cat("\nMethod: ", attr(x, "method"), sep = "") 8 | if (attr(x, "ptype") == "swap") { 9 | if (!is.na(attr(x, "burnin"))) 10 | cat(", burnin: ", attr(x, "burnin"), sep = "") 11 | if (!is.na(attr(x, "thin"))) 12 | cat(", thin: ", attr(x, "thin"), sep = "") 13 | } 14 | cat("\nRestricted:", attr(x, "is.strat"), "\nFixed margins:", attr(x, "fixedmar")) 15 | if (!is.na(attr(x, "shuffle"))) { 16 | if (attr(x, "shuffle")=="ind") cat("\nIndividuals") 17 | if (attr(x, "shuffle")=="samp") cat("\nSamples") 18 | if (attr(x, "shuffle")=="both") cat("\nIndividuals and samples") 19 | cat(" are shuffled") 20 | } 21 | cat("\n") 22 | invisible(x) 23 | } 24 | -------------------------------------------------------------------------------- /R/print.summary.cca.R: -------------------------------------------------------------------------------- 1 | `print.summary.cca` <- 2 | function (x, digits = x$digits, ...) 3 | { 4 | cat("\nCall:\n") 5 | cat(deparse(x$call), "\n") 6 | statnam <- if (x$method == "cca") 7 | "averages" 8 | else "sums" 9 | cat("\nPartitioning of ", x$inertia, ":\n", sep = "") 10 | out <- c(Total = x$tot.chi, Conditioned = x$partial.chi, 11 | Constrained = x$constr.chi, Unconstrained = x$unconst.chi) 12 | out <- cbind(Inertia = out, Proportion = out/out[1]) 13 | print(out, digits = digits, ...) 14 | cat("\nEigenvalues, and their contribution to the", x$inertia, 15 | "\n") 16 | if (!is.null(x$partial.chi)) { 17 | cat("after removing the contribution of conditiniong variables\n") 18 | } 19 | cat("\n") 20 | print(x$cont$importance, ...) 21 | if (!is.null(x$concont)) { 22 | cat("\nAccumulated constrained eigenvalues\n") 23 | print(x$concont$importance, ...) 24 | } 25 | cat("\n") 26 | invisible(x) 27 | } 28 | -------------------------------------------------------------------------------- /R/isomap.R: -------------------------------------------------------------------------------- 1 | `isomap` <- 2 | function(dist, ndim=10, ...) 3 | { 4 | dist <- isomapdist(dist, ...) 5 | out <- wcmdscale(dist, k=ndim, eig=TRUE) 6 | ## some versions of cmdscale may return NaN points corresponding 7 | ## to negative eigenvalues. 8 | if ((naxes <- sum(out$eig > 0)) < ndim && naxes) { 9 | out$points <- out$points[, seq(naxes), drop = FALSE] 10 | message(gettextf("isomap returns only %d axes with positive eigenvalues", 11 | naxes)) 12 | } 13 | npoints <- nrow(out$points) 14 | net <- matrix(FALSE, nrow=npoints, ncol=npoints) 15 | net[lower.tri(net)][attr(dist, "net")] <- TRUE 16 | net <- which(net, arr.ind=TRUE) 17 | out$method <- attr(dist, "method") 18 | out$criterion <- attr(dist, "criterion") 19 | out$critval <- attr(dist, "critval") 20 | out$take <- attr(dist, "take") 21 | out$net <- net 22 | out$npoints <- npoints 23 | out$call <- match.call() 24 | class(out) <- "isomap" 25 | out 26 | } 27 | 28 | -------------------------------------------------------------------------------- /R/print.permutest.cca.R: -------------------------------------------------------------------------------- 1 | `print.permutest.cca` <- 2 | function (x, ...) 3 | { 4 | EPS <- sqrt(.Machine$double.eps) 5 | cat("\nPermutation test for", x$method, "under", x$model, "model", "\n\n") 6 | if (x$nperm > 0) 7 | cat(howHead(x$control), "\n") 8 | writeLines(strwrap(pasteCall(x$testcall, prefix = "Model:"))) 9 | if (x$nperm > 0) 10 | Pval <- (colSums(sweep(x$F.perm, 2, x$F.0 - EPS, ">=")) + 1)/(x$nperm + 1) 11 | else 12 | Pval <- NA 13 | cat("Permutation test for ") 14 | if (x$first) 15 | cat("first constrained eigenvalue\n") 16 | else if (length(x$df) <= 2) 17 | cat("all constrained eigenvalues\n") 18 | else 19 | cat("sequential contrasts\n") 20 | anotab <- data.frame(x$df, x$chi, c(x$F.0, NA), c(Pval, NA)) 21 | colnames(anotab) <- c("Df", "Inertia", "F", "Pr(>F)") 22 | rownames(anotab) <- c(x$termlabels, "Residual") 23 | class(anotab) <- c("anova", "data.frame") 24 | print(anotab) 25 | invisible(x) 26 | } 27 | -------------------------------------------------------------------------------- /R/treeheight.R: -------------------------------------------------------------------------------- 1 | `treeheight` <- 2 | function(tree) 3 | { 4 | if (inherits(tree, "spantree")) 5 | return(sum(tree$dist)) 6 | tree <- as.hclust(tree) 7 | ## nodes should start from 0 -- if there are negative heights, 8 | ## tree is too pathological to be measured. 9 | if (any(tree$height < 0)) 10 | stop("negative heights: tree cannot be measured") 11 | ## can be done really fast if there are no reversals, but we need 12 | ## to traverse the tree with reversals 13 | if (is.unsorted(tree$height)) { # slow 14 | h <- tree$height 15 | m <- tree$merge 16 | height <- 0 17 | for (i in 1:nrow(m)) { 18 | for (j in 1:2) { 19 | if (m[i,j] < 0) 20 | height <- height + h[i] 21 | else 22 | height <- height + abs(h[i] - h[m[i,j]]) 23 | } 24 | } 25 | height 26 | } 27 | else # fast 28 | sum(tree$height) + max(tree$height) 29 | } 30 | 31 | -------------------------------------------------------------------------------- /R/fitted.capscale.R: -------------------------------------------------------------------------------- 1 | `fitted.capscale` <- 2 | function(object, model = c("CCA", "CA", "pCCA", "Imaginary"), 3 | type = c("response", "working"), ...) 4 | { 5 | model <- match.arg(model) 6 | if (is.null(object[[model]]) && model != "Imaginary") 7 | stop(gettextf("component '%s' does not exist", model)) 8 | type <- match.arg(type) 9 | ## Return scaled eigenvalues 10 | U <- switch(model, 11 | CCA = ordiYbar(object, "CCA"), 12 | CA = ordiYbar(object, "CA"), 13 | Imaginary = object$CA$imaginary.u.eig, 14 | pCCA = ordiYbar(object, "pCCA")) 15 | if (is.null(U)) 16 | stop(gettextf("component '%s' does not exist", model)) 17 | ## Distances or working scores U 18 | if (type == "response") { 19 | U <- dist(U) 20 | ## undo sqrt.dist -- sqrt.dist was applied first in capscale, 21 | ## so it must be last here 22 | if (object$sqrt.dist) 23 | U <- U^2 24 | } 25 | U 26 | } 27 | -------------------------------------------------------------------------------- /R/model.frame.cca.R: -------------------------------------------------------------------------------- 1 | `model.frame.cca` <- 2 | function (formula, ...) 3 | { 4 | call <- formula$call 5 | m <- match(c("formula", "data", "na.action", "subset"), names(call), 6 | 0) 7 | call <- call[c(1, m)] 8 | ## did we succeed? Fails if we have no formula, in prc and if 9 | ## there was no data= argument 10 | if (is.null(call$data)) 11 | stop("no sufficient information to reconstruct model frame") 12 | ## subset must be evaluated before ordiParseFormula 13 | if (!is.null(call$subset)) 14 | call$subset <- formula$subset 15 | if (is.null(call$na.action)) 16 | call$na.action <- na.pass 17 | data <- eval(call$data, environment(call$formula), .GlobalEnv) 18 | out <- ordiParseFormula(call$formula, data, na.action = call$na.action, 19 | subset = call$subset) 20 | mf <- out$modelframe 21 | attr(mf, "terms") <- out$terms.expand 22 | if (!is.null(out$na.action)) 23 | attr(mf, "na.action") <- out$na.action 24 | mf 25 | } 26 | -------------------------------------------------------------------------------- /R/summary.cca.R: -------------------------------------------------------------------------------- 1 | `summary.cca` <- function (object, 2 | digits = max(3, getOption("digits") - 3), 3 | ...) 4 | { 5 | summ <- list() 6 | summ$call <- object$call 7 | summ$tot.chi <- object$tot.chi 8 | ## only the Real component for capscale() with negative eigenvalues 9 | if (!is.null(object$CA$imaginary.chi)) 10 | summ$tot.chi <- summ$tot.chi - object$CA$imaginary.chi 11 | summ$partial.chi <- object$pCCA$tot.chi 12 | summ$constr.chi <- object$CCA$tot.chi 13 | summ$unconst.chi <- object$CA$tot.chi 14 | ## nested list cont$importance needed to keep vegan pre-2.5-0 compatibility 15 | summ$cont$importance <- summary(eigenvals(object)) 16 | if (!is.null(object$CCA) && object$CCA$rank > 0) 17 | summ$concont$importance <- summary(eigenvals(object, model = "constrained")) 18 | summ$digits <- digits 19 | summ$inertia <- object$inertia 20 | summ$method <- object$method 21 | class(summ) <- "summary.cca" 22 | summ 23 | } 24 | -------------------------------------------------------------------------------- /R/plot.renyi.R: -------------------------------------------------------------------------------- 1 | `plot.renyi` <- 2 | function(x, ...) 3 | { 4 | if (inherits(x, "data.frame")) { 5 | plt <- factor(rep(rownames(x), ncol(x)), levels=rownames(x)) 6 | alp <- factor(rep(colnames(x), each=nrow(x)), levels=colnames(x)) 7 | div <- as.vector(as.matrix(x)) 8 | df <- data.frame(diversity=div, plot=plt, alpha=alp) 9 | lo <- tapply(div, alp, min) 10 | hi <- tapply(div, alp, max) 11 | med <- tapply(div, alp, median) 12 | } else { 13 | df <- data.frame(diversity = x, alpha = factor(names(x), levels=names(x)), plot = "plot") 14 | lo <- hi <- med <- NA 15 | } 16 | cl <- trellis.par.get("superpose.line")$col 17 | bwplot(diversity ~ alpha | plot, data=df, 18 | panel = function(x, y, ...) { 19 | panel.lines(x, lo, lty=2, col=cl[3]) 20 | panel.lines(x, med, lty=2, col=cl[2]) 21 | panel.lines(x, hi, lty=2, col=cl[3]) 22 | panel.xyplot(x, y, ...) 23 | }, 24 | ...) 25 | } 26 | 27 | -------------------------------------------------------------------------------- /R/print.CCorA.R: -------------------------------------------------------------------------------- 1 | `print.CCorA` <- 2 | function(x, ...) 3 | { 4 | cat("\nCanonical Correlation Analysis\n") 5 | cat("\nCall:\n") 6 | cat(deparse(x$call), "\n\n") 7 | out <- structure(rbind(x$Mat.ranks), dimnames = list("Matrix Ranks", c("Y", "X"))) 8 | print(out, ...) 9 | cat("\n") 10 | cat("Pillai's trace: ", format(x$Pillai, ...), "\n") 11 | cat("\n") 12 | cat("Significance of Pillai's trace:\n") 13 | 14 | cat("from F-distribution: ", format.pval(x$p.Pillai), "\n") 15 | if (x$nperm > 0) { 16 | cat("based on permutations: ") 17 | cat(x$p.perm,"\n") 18 | cat(howHead(x$control), "\n") 19 | } 20 | out <- rbind("Eigenvalues" = x$EigenValues, "Canonical Correlations" = x$CanCorr) 21 | colnames(out) <- colnames(x$Cy) 22 | printCoefmat(out, ...) 23 | cat("\n") 24 | out <- rbind("RDA R squares" = x$RDA.Rsquares, "adj. RDA R squares" = x$RDA.adj.Rsq) 25 | colnames(out) <- c("Y | X", "X | Y") 26 | printCoefmat(out, ...) 27 | cat("\n") 28 | invisible(x) 29 | } 30 | -------------------------------------------------------------------------------- /R/summary.decorana.R: -------------------------------------------------------------------------------- 1 | "summary.decorana" <- 2 | function (object, digits = 3, origin = TRUE, display = c("both", 3 | "species", "sites", "none"), ...) 4 | { 5 | stop("'summary' is defunct: use 'scores' for scores, 'weights' for weights") 6 | display <- match.arg(display) 7 | print(object) 8 | if (origin) { 9 | object$cproj <- sweep(object$cproj, 2, object$origin, 10 | "-") 11 | object$rproj <- sweep(object$rproj, 2, object$origin, 12 | "-") 13 | } 14 | tmp <- list() 15 | if (display == "both" || display == "species") { 16 | tmp$spec.scores <- object$cproj 17 | tmp$spec.priorweights <- object$v 18 | tmp$spec.totals <- object$adotj 19 | } 20 | if (display == "both" || display == "sites") { 21 | tmp$site.scores <- object$rproj 22 | tmp$site.totals <- object$aidot 23 | } 24 | tmp$digits <- digits 25 | class(tmp) <- "summary.decorana" 26 | tmp 27 | } 28 | -------------------------------------------------------------------------------- /R/nobs.R: -------------------------------------------------------------------------------- 1 | ### R 2.13.0 introduces nobs() method to get the number of 2 | ### observations. This file provides methods for vegan classes. 3 | 4 | `nobs.anova.cca` <- function(object, ...) NA 5 | 6 | `nobs.betadisper` <- function(object, ...) length(object$distances) 7 | 8 | `nobs.cca` <- function(object, ...) max(NROW(object$pCCA$u), 9 | NROW(object$CCA$u), 10 | NROW(object$CA$u)) 11 | 12 | `nobs.CCorA` <- function(object, ...) NROW(object$Cy) 13 | 14 | `nobs.decorana` <- function(object, ...) NROW(object$rproj) 15 | 16 | `nobs.isomap` <- function(object, ...) NROW(object$points) 17 | 18 | `nobs.metaMDS` <- function(object, ...) NROW(object$points) 19 | 20 | `nobs.pcnm` <- function(object, ...) NROW(object$vectors) 21 | 22 | `nobs.procrustes` <- function(object, ...) NROW(object$X) 23 | 24 | `nobs.rad` <- function(object, ...) length(object$y) 25 | 26 | `nobs.varpart` <- function(object, ...) object$part$n 27 | 28 | `nobs.wcmdscale` <- function(object, ...) NROW(object$points) 29 | -------------------------------------------------------------------------------- /R/cca.formula.R: -------------------------------------------------------------------------------- 1 | `cca.formula` <- 2 | function (formula, data, na.action = na.fail, subset = NULL, ...) 3 | { 4 | if (missing(data)) { 5 | data <- parent.frame() 6 | } else { 7 | data <- eval(match.call()$data, parent.frame(), environment(formula)) 8 | } 9 | d <- ordiParseFormula(formula, data = data, na.action = na.action, 10 | subset = substitute(subset)) 11 | sol <- cca.default(d$X, d$Y, d$Z) 12 | sol$CCA$centroids <- getCentroids(sol, d$modelframe) 13 | ## replace cca.default call 14 | call <- match.call() 15 | call[[1]] <- as.name("cca") 16 | call$formula <- formula(d$terms) 17 | sol$call <- call 18 | if (!is.null(d$na.action)) { 19 | sol$na.action <- d$na.action 20 | sol <- ordiNAexclude(sol, d$excluded) 21 | } 22 | if (!is.null(d$subset)) 23 | sol$subset <- d$subset 24 | ## drops class in c() 25 | sol <- c(sol, 26 | list(terms = d$terms, 27 | terminfo = ordiTerminfo(d, d$modelframe))) 28 | class(sol) <- "cca" 29 | sol 30 | } 31 | -------------------------------------------------------------------------------- /R/fitted.dbrda.R: -------------------------------------------------------------------------------- 1 | ### 'working' will be Gower's G = -GowerDblcen(dis^2)/2 2 | `fitted.dbrda` <- 3 | function (object, model = c("CCA", "CA", "pCCA"), 4 | type = c("response", "working"), ...) 5 | { 6 | ZAP <- sqrt(.Machine$double.eps) 7 | type <- match.arg(type) 8 | model <- match.arg(model) 9 | if (is.null(object[[model]])) 10 | stop(gettextf("component '%s' does not exist", model)) 11 | D <- ordiYbar(object, model) 12 | if (type == "response") { 13 | ## revert Gower double centring 14 | de <- diag(D) 15 | D <- -2 * D + outer(de, de, "+") 16 | ## we may have tiny negative zeros: zero them, but let large 17 | ## negative values be and give NaN in sqrt (with a warning) 18 | D[abs(D) < ZAP] <- 0 19 | if (!object$sqrt.dist) 20 | D <- sqrt(D) 21 | D <- D * object$adjust 22 | D <- as.dist(D) 23 | ## we do not remove Lingoes or Cailliez adjustment: this 24 | ## typically gives too many negative distances as unadjusted D 25 | ## often has zero-values 26 | } 27 | D 28 | } 29 | -------------------------------------------------------------------------------- /R/rda.formula.R: -------------------------------------------------------------------------------- 1 | `rda.formula` <- 2 | function (formula, data, scale = FALSE, na.action = na.fail, 3 | subset = NULL, ...) 4 | { 5 | if (missing(data)) { 6 | data <- parent.frame() 7 | } else { 8 | data <- eval(match.call()$data, parent.frame(), environment(formula)) 9 | } 10 | d <- ordiParseFormula(formula, data = data, na.action = na.action, 11 | subset = substitute(subset)) 12 | sol <- rda.default(d$X, d$Y, d$Z, scale) 13 | sol$CCA$centroids <- getCentroids(sol, d$modelframe) 14 | ## replace rda.default call 15 | call <- match.call() 16 | call[[1]] <- as.name("rda") 17 | call$formula <- formula(d$terms) 18 | sol$call <- call 19 | if (!is.null(d$na.action)) { 20 | sol$na.action <- d$na.action 21 | sol <- ordiNAexclude(sol, d$excluded) 22 | } 23 | if (!is.null(d$subset)) 24 | sol$subset <- d$subset 25 | ## drops class in c() 26 | sol <- c(sol, 27 | list(terms = d$terms, 28 | terminfo = ordiTerminfo(d, d$modelframe))) 29 | class(sol) <- c("rda", "cca") 30 | sol 31 | } 32 | -------------------------------------------------------------------------------- /R/commsim.R: -------------------------------------------------------------------------------- 1 | ## this is function to create a commsim object, does some checks 2 | ## there is a finite number of useful arguments here 3 | ## but I added ... to allow for unforeseen algorithms, 4 | ## or being able to reference to external objects 5 | commsim <- 6 | function(method, fun, binary, isSeq, mode) 7 | { 8 | fun <- if (!missing(fun)) 9 | match.fun(fun) else stop("'fun' missing") 10 | if (any(!(names(formals(fun)) %in% 11 | c("x", "n", "nr", "nc", "rs", "cs", "rf", "cf", "s", "fill", "thin", "...")))) 12 | stop("unexpected arguments in 'fun'") 13 | out <- structure(list(method = if (!missing(method)) 14 | as.character(method)[1L] else stop("'method' missing"), 15 | binary = if (!missing(binary)) 16 | as.logical(binary)[1L] else stop("'binary' missing"), 17 | isSeq = if (!missing(isSeq)) 18 | as.logical(isSeq)[1L] else stop("'isSeq' missing"), 19 | mode = if (!missing(mode)) 20 | match.arg(as.character(mode)[1L], 21 | c("integer", "double")) else stop("'mode' missing"), 22 | fun = fun), class = "commsim") 23 | out 24 | } 25 | -------------------------------------------------------------------------------- /man/varechem.Rd: -------------------------------------------------------------------------------- 1 | \encoding{UTF-8} 2 | \name{varespec} 3 | \alias{varechem} 4 | \alias{varespec} 5 | \docType{data} 6 | \title{Vegetation and environment in lichen pastures} 7 | \usage{ 8 | data(varechem) 9 | data(varespec) 10 | } 11 | \description{ 12 | The \code{varespec} data frame has 24 rows and 44 columns. Columns 13 | are estimated cover values of 44 species. The variable names are 14 | formed from the scientific names, and are self explanatory for anybody 15 | familiar with the vegetation type. 16 | The \code{varechem} data frame has 24 rows and 14 columns, giving the 17 | soil characteristics of the very same sites as in the \code{varespec} 18 | data frame. The chemical measurements have obvious names. 19 | \code{Baresoil} gives the estimated cover of bare soil, \code{Humdepth} 20 | the thickness of the humus layer. 21 | } 22 | \references{ 23 | \enc{Väre}{Vare}, H., Ohtonen, R. and Oksanen, J. (1995) Effects of reindeer 24 | grazing on understorey vegetation in dry Pinus sylvestris 25 | forests. \emph{Journal of Vegetation Science} 6, 523--530. 26 | } 27 | \examples{ 28 | data(varespec) 29 | data(varechem) 30 | } 31 | \keyword{datasets} 32 | -------------------------------------------------------------------------------- /R/renyi.R: -------------------------------------------------------------------------------- 1 | `renyi` <- 2 | function (x, scales = c(0, 0.25, 0.5, 1, 2, 4, 8, 16, 32, 64, 3 | Inf), hill = FALSE) 4 | { 5 | x <- as.matrix(x) 6 | n <- nrow(x) 7 | p <- ncol(x) 8 | if (p == 1) { 9 | x <- t(x) 10 | n <- nrow(x) 11 | p <- ncol(x) 12 | } 13 | ## scale rows to unit total 14 | x <- sweep(x, 1, rowSums(x), "/") 15 | m <- length(scales) 16 | result <- array(0, dim = c(n, m)) 17 | dimnames(result) <- list(sites = rownames(x), scale = scales) 18 | for (a in 1:m) { 19 | result[,a] <- 20 | switch(as.character(scales[a]), 21 | "0" = log(rowSums(x > 0)), 22 | "1" = -rowSums(x * log(x), na.rm = TRUE), 23 | "2" = -log(rowSums(x^2)), 24 | "Inf" = -log(apply(x, 1, max)), 25 | log(rowSums(x^scales[a]))/(1 - scales[a])) 26 | } 27 | if (hill) 28 | result <- exp(result) 29 | if (any(dim(result) == 1)) 30 | result <- drop(result) 31 | else 32 | result <- as.data.frame(result) 33 | class(result) <- c("renyi", class(result)) 34 | result 35 | } 36 | -------------------------------------------------------------------------------- /R/spandepth.R: -------------------------------------------------------------------------------- 1 | ### The depths of nodes in a 'spantree' object: The nodes are either 2 | ### leaves with one link, or internal nodes with >1 links. The leaves 3 | ### are removed recursively from the tree and at each step the depth 4 | ### is increased with one. 5 | `spandepth` <- 6 | function (x) 7 | { 8 | if (!inherits(x, "spantree")) 9 | stop("'x' must be 'spantree' result") 10 | kid <- c(NA, x$kid) 11 | par <- p <- seq_along(kid) 12 | par[1] <- NA 13 | ## Isolated nodes in disconnected tree have depth 0, other nodes 14 | ## start from depth 1 15 | intree <- p %in% kid | !is.na(kid) 16 | depth <- numeric(length(par)) 17 | depth[intree] <- 1 18 | if (!is.null(x$labels)) 19 | names(depth) <- x$labels 20 | while(any(intree)) { 21 | ## Node is internal (intree) if it is both a parent and a kid 22 | ## and kid is in the tree or it is kid to two or more parents 23 | intree <- (p %in% intersect(kid[intree], par[intree]) & 24 | p %in% p[intree][kid[intree] %in% p[intree]] | 25 | p %in% kid[intree][duplicated(kid[intree])]) 26 | depth[intree] <- depth[intree] + 1 27 | } 28 | depth 29 | } 30 | 31 | -------------------------------------------------------------------------------- /R/print.betadisper.R: -------------------------------------------------------------------------------- 1 | `print.betadisper` <- function(x, digits = max(3, getOption("digits") - 3), 2 | neigen = 8, ...) 3 | { 4 | ## limit number of eignvals to neigen 5 | eig <- eigenvals(x) 6 | nev <- length(eig) 7 | ax.lim <- min(nev, neigen) 8 | ## 9 | cat("\n") 10 | writeLines(strwrap("Homogeneity of multivariate dispersions\n", 11 | prefix = "\t")) 12 | cat("\n") 13 | writeLines(strwrap(pasteCall(x$call))) 14 | cat(paste("\nNo. of Positive Eigenvalues:", sum(eig > 0))) 15 | cat(paste("\nNo. of Negative Eigenvalues:", sum(eig < 0))) 16 | cat("\n\n") 17 | type <- ifelse(attr(x, "type") == "median", "median", "centroid") 18 | writeLines(strwrap(paste0("Average distance to ", type, ":\n"))) 19 | print.default(format(x$group.distances, digits = digits), quote = FALSE) 20 | cat("\n") 21 | writeLines(strwrap("Eigenvalues for PCoA axes:")) 22 | if (nev > neigen) { 23 | writeLines(strwrap(paste0("(Showing ", neigen, " of ", nev, 24 | " eigenvalues)"))) 25 | } 26 | print.default(format(eig[seq_len(ax.lim)], digits = digits), quote = FALSE) 27 | invisible(x) 28 | } 29 | -------------------------------------------------------------------------------- /R/ordiArrowMul.R: -------------------------------------------------------------------------------- 1 | ### Scaling of arrows to 'fill' a plot with vectors centred at 'at'. 2 | ### Plot dims from 'par("usr")' and arrow heads are in 'x'. 3 | `ordiArrowMul` <- function (x, at = c(0,0), fill = 0.75, 4 | display, choices = c(1,2), ...) { 5 | ## handle x, which we try with scores, but also retain past usage of 6 | ## a two column matrix 7 | X <- if (is.matrix(x)) { 8 | nc <- NCOL(x) 9 | if (nc != 2L) { 10 | stop("a two-column matrix of coordinates is required") 11 | } 12 | x 13 | } else { 14 | if (inherits(x, "envfit")) { 15 | scores(x, display = "vectors", ...)[, 1:2, drop = FALSE] 16 | } else { 17 | scores(x, display = display, choices = choices, ...) 18 | } 19 | } 20 | 21 | u <- par("usr") 22 | u <- u - rep(at, each = 2) 23 | r <- c(range(X[,1], na.rm = TRUE), range(X[,2], na.rm = TRUE)) 24 | ## 'rev' takes care of reversed axes like xlim(1,-1) 25 | rev <- sign(diff(u))[-2] 26 | if (rev[1] < 0) 27 | u[1:2] <- u[2:1] 28 | if (rev[2] < 0) 29 | u[3:4] <- u[4:3] 30 | u <- u/r 31 | u <- u[is.finite(u) & u > 0] 32 | fill * min(u) 33 | } 34 | -------------------------------------------------------------------------------- /R/radlattice.R: -------------------------------------------------------------------------------- 1 | `radlattice` <- 2 | function(x, BIC = FALSE, ...) 3 | { 4 | if (!inherits(x, "radfit")) 5 | stop("function only works with 'radfit' results for single site") 6 | y <- x$y 7 | fv <- unlist(fitted(x)) 8 | mods <- names(x$models) 9 | p <- length(mods) 10 | n <- length(y) 11 | Abundance <- rep(y, p) 12 | Rank <- rep(1:n, p) 13 | Model <- factor(rep(mods, each=n), levels = mods) 14 | if (BIC) 15 | k <- log(length(y)) 16 | else 17 | k <- 2 18 | aic <- AIC(x, k = k) 19 | col <- trellis.par.get("superpose.line")$col 20 | if (length(col) > 1) 21 | col <- col[2] 22 | xyplot(Abundance ~ Rank | Model, subscripts = TRUE, 23 | scales = list(y = list(log = 2)), as.table = TRUE, 24 | panel = function(x, y, subscripts) { 25 | panel.xyplot(x, y, ...) 26 | panel.xyplot(x, log2(fv[subscripts]), type="l", lwd=3, 27 | col = col, ...) 28 | panel.text(max(x), max(y), paste(if (BIC) "BIC" else "AIC", "=", 29 | formatC(aic[panel.number()], digits=2, format="f")), 30 | pos=2) 31 | } 32 | ) 33 | } 34 | 35 | -------------------------------------------------------------------------------- /man/sipoo.Rd: -------------------------------------------------------------------------------- 1 | \encoding{UTF-8} 2 | \name{sipoo} 3 | \alias{sipoo} 4 | \alias{sipoo.map} 5 | \docType{data} 6 | \title{ Birds in the Archipelago of Sipoo (Sibbo and Borgå)} 7 | \description{ 8 | Land birds on islands covered by 9 | coniferous forest in the Sipoo Archipelago, southern Finland. 10 | } 11 | \usage{ 12 | data(sipoo) 13 | data(sipoo.map) 14 | } 15 | 16 | \format{ 17 | The \code{sipoo} data frame contains data of occurrences of 50 land 18 | bird species on 18 islands in the Sipoo Archipelago (Simberloff & 19 | Martin, 1991, Appendix 3). The species are referred by 4+4 letter 20 | abbreviation of their Latin names (but using five letters in two 21 | species names to make these unique). 22 | 23 | The \code{sipoo.map} data contains the geographic coordinates of the 24 | islands in the ETRS89-TM35FIN coordinate system (EPSG:3067) and the 25 | areas of islands in hectares. 26 | } 27 | 28 | \source{ 29 | Simberloff, D. & Martin, J.-L. (1991). Nestedness of insular 30 | avifaunas: simple summary statistics masking complex species patterns. 31 | \emph{Ornis Fennica} 68:178--192. 32 | } 33 | 34 | \examples{ 35 | data(sipoo) 36 | data(sipoo.map) 37 | plot(N ~ E, data=sipoo.map, asp = 1) 38 | } 39 | 40 | \keyword{datasets} 41 | -------------------------------------------------------------------------------- /R/plot.permat.R: -------------------------------------------------------------------------------- 1 | ## S3 plot method for permat 2 | `plot.permat` <- 3 | function(x, type = "bray", ylab, xlab, col, lty, lowess=TRUE, plot=TRUE, text=TRUE, ...) 4 | { 5 | type <- match.arg(type, c("bray", "chisq")) 6 | if (missing(xlab)) 7 | xlab <- "Runs" 8 | if (missing(col)) 9 | col <- c(2,4) 10 | if (missing(lty)) 11 | lty <- c(1,2) 12 | n <- attr(x, "times") 13 | toplot <- numeric(n) 14 | if (type == "bray") { 15 | toplot <- summary(x)$bray 16 | if (missing(ylab)) 17 | ylab <- "Bray-Curtis dissimilarity" 18 | } 19 | if (type == "chisq") { 20 | toplot <- summary(x)$chisq 21 | if (missing(ylab)) 22 | ylab <- "Chi-squared" 23 | } 24 | if (plot) { 25 | plot(toplot,type="n",ylab=ylab,xlab=xlab, ...) 26 | lines(toplot,col=col[1], lty=lty[1]) 27 | if (lowess) 28 | lines(lowess(toplot),col=col[2], lty=lty[2]) 29 | if (text) title(sub=paste("(mean = ", substitute(z, list(z=round(mean(toplot),3))), 30 | ", min = ", substitute(z, list(z=round(min(toplot),3))), 31 | ", max = ", substitute(z, list(z=round(max(toplot),3))), ")", sep="")) 32 | } 33 | invisible(toplot) 34 | } 35 | -------------------------------------------------------------------------------- /R/pcnm.R: -------------------------------------------------------------------------------- 1 | `pcnm` <- function(dis, threshold, w, dist.ret = FALSE) { 2 | ## square matrix to dist 3 | if ((is.matrix(dis) || is.data.frame(dis)) && 4 | isSymmetric(unname(as.matrix(dis)))) 5 | dis <- as.dist(dis) 6 | if (!inherits(dis, "dist")) 7 | stop("'dis' does not appear to be distances") 8 | if (missing(threshold)) { 9 | threshold <- max(spantree(dis)$dist) 10 | } 11 | dis[dis > threshold] <- 4*threshold 12 | ## vegan:::wcmdscale is able to use weights which also means that 13 | ## 'k' need not be given, but all vecctors with >0 eigenvalues 14 | ## will be found 15 | mypcnm <- wcmdscale(dis, eig = TRUE, w=w) 16 | res <- list(vectors = mypcnm$points, values = mypcnm$eig, 17 | weights = mypcnm$weig) 18 | k <- ncol(mypcnm$points) 19 | res$vectors <- sweep(res$vectors, 2, sqrt(res$values[seq_len(k)]), "/") 20 | if (NCOL(res$vectors)) 21 | colnames(res$vectors) <- paste("PCNM", 1:k, sep="") 22 | res$threshold <- threshold 23 | if (dist.ret) { 24 | attr(dis, "method") <- paste(attr(dis, "method"), "pcnm") 25 | attr(dis, "threshold") <- threshold 26 | res$dist <- dis 27 | } 28 | class(res) <- "pcnm" 29 | res 30 | } 31 | -------------------------------------------------------------------------------- /R/raupcrick.R: -------------------------------------------------------------------------------- 1 | `raupcrick` <- 2 | function(comm, null = "r1", nsimul = 999, chase = FALSE, ...) 3 | { 4 | comm <- as.matrix(comm, rownames.force = TRUE) 5 | comm <- ifelse(comm > 0, 1, 0) 6 | ## 'tri' is a faster alternative to as.dist(): it takes the lower 7 | ## diagonal, but does not set attributes of a "dist" object 8 | N <- nrow(comm) 9 | tri <- matrix(FALSE, N, N) 10 | tri <- row(tri) > col(tri) 11 | ## function(x) designdist(x, "J", terms="binary") does the same, 12 | ## but is much slower 13 | sol <- oecosimu(comm, function(x) tcrossprod(x)[tri], method = null, 14 | nsimul = nsimul, 15 | alternative = if (chase) "less" else "greater", 16 | ...) 17 | ## Chase et al. way, or the standard way 18 | if (chase) 19 | out <- 1 - sol$oecosimu$pval 20 | else 21 | out <- sol$oecosimu$pval 22 | ## set attributes of a "dist" object 23 | attributes(out) <- list("class"=c("raupcrick", "dist"), "Size"=N, 24 | "Labels" = rownames(comm), "maxdist" = 1, 25 | "call" = match.call(), "Diag" = FALSE, 26 | "Upper" = FALSE, "method" = "raupcrick") 27 | out 28 | } 29 | -------------------------------------------------------------------------------- /R/text.ordiplot.R: -------------------------------------------------------------------------------- 1 | `text.ordiplot` <- 2 | function (x, what, labels, select, optimize = FALSE, arrows = FALSE, 3 | length = 0.05, arr.mul, bg, ...) 4 | { 5 | sco <- scores(x, display = what) 6 | if (!missing(select)) 7 | sco <- .checkSelect(select, sco) 8 | if (!missing(labels)) 9 | rownames(sco) <- labels 10 | if (!missing(arr.mul)) { 11 | arrows <- TRUE 12 | sco <- sco * arr.mul 13 | } else { 14 | scoatt <- attr(sco, "score") 15 | if (!is.null(scoatt) && scoatt %in% c("biplot", "regression")) { 16 | arrows <- TRUE 17 | sco <- sco * ordiArrowMul(sco) 18 | } 19 | } 20 | if (arrows) { 21 | arrows(0, 0, sco[,1], sco[,2], length = length, ...) 22 | sco <- ordiArrowTextXY(sco, rownames(sco), rescale = FALSE, ...) 23 | } 24 | if (optimize) { 25 | if (missing(bg)) 26 | ordipointlabel(sco, display = what, add = TRUE, ...) 27 | else 28 | ordipointlabel(sco, display = what, bg = bg, add = TRUE, ...) 29 | } else if (missing(bg)) 30 | text(sco, labels = rownames(sco), ...) 31 | else 32 | ordilabel(sco, labels = rownames(sco), fill = bg, ...) 33 | invisible(x) 34 | } 35 | -------------------------------------------------------------------------------- /R/alias.cca.R: -------------------------------------------------------------------------------- 1 | `alias.cca` <- 2 | function (object, names.only = FALSE, ...) 3 | { 4 | if (is.null(object$CCA)) 5 | stop("no constrained component, 'alias' cannot be applied") 6 | if (is.null(object$CCA$alias)) 7 | stop("no aliased terms") 8 | ## if we do not return CCA$QR from zero-rank components, we cannot 9 | ## have aliasing equation and have to return only names 10 | if (names.only || is.null(object$CCA$QR)) 11 | return(object$CCA$alias) 12 | CompPatt <- function(x, ...) { 13 | x[abs(x) < 1e-06] <- 0 14 | class(x) <- "mtable" 15 | x[abs(x) < 1e-06] <- NA 16 | x 17 | } 18 | Model <- object$terms 19 | attributes(Model) <- NULL 20 | value <- list(Model = Model) 21 | R <- object$CCA$QR$qr 22 | R <- R[1:min(dim(R)), , drop = FALSE] 23 | R[lower.tri(R)] <- 0 24 | d <- dim(R) 25 | rank <- object$CCA$QR$rank 26 | p <- d[2] 27 | value$Complete <- if (is.null(p) || rank == p) 28 | NULL 29 | else { 30 | p1 <- 1:rank 31 | X <- R[p1, p1] 32 | Y <- R[p1, -p1, drop = FALSE] 33 | beta12 <- as.matrix(qr.coef(qr(X), Y)) 34 | CompPatt(t(beta12)) 35 | } 36 | class(value) <- "listof" 37 | value 38 | } 39 | 40 | -------------------------------------------------------------------------------- /R/print.mrpp.R: -------------------------------------------------------------------------------- 1 | "print.mrpp" <- 2 | function (x, digits = max(3, getOption("digits") - 3), ...) 3 | { 4 | ### A print function for mrpp objects 5 | ### x -- An object of class "mrpp." 6 | #### cat = print 7 | cat("\nCall:\n") 8 | cat(deparse(x$call), "\n\n") 9 | cat("Dissimilarity index:", x$distance, "\n") 10 | cat("Weights for groups: ", switch(x$weight.type, "n", "n-1", "n(n-1)", "n(n-1)/2"), "\n\n") 11 | cat("Class means and counts:\n\n") 12 | print(noquote(rbind("delta" = formatC(x$classdelta, digits = digits), 13 | "n" = formatC(x$n, digits=0)))) 14 | cat("\n") 15 | if (!is.na(x$CS)) { 16 | cat("Classification strength: ") 17 | cat(formatC(x$CS, digits = digits), "\n") 18 | } 19 | cat("Chance corrected within-group agreement A: ") 20 | if (!is.na(x$A)) 21 | cat(formatC(x$A, digits = digits), "\n") 22 | else 23 | cat("NA\n") 24 | cat("Based on observed delta", formatC(x$delta), "and expected delta", 25 | formatC(x$E.delta),"\n\n") 26 | nperm <- x$permutations 27 | if (nperm) { 28 | cat("Significance of delta:", format.pval(x$Pvalue), 29 | "\n") 30 | } 31 | cat(howHead(x$control)) 32 | cat("\n") 33 | invisible(x) 34 | } 35 | -------------------------------------------------------------------------------- /R/nestedbetasor.R: -------------------------------------------------------------------------------- 1 | ### Multiple-site dissimilarity indices (Sorensen & Jaccard) and their 2 | ### decomposition into "turnover" and "nestedness" following Baselga 3 | ### (Global Ecology & Biogeography 19, 134-143; 2010). Implemented as 4 | ### nestedness functions and directly usable in oecosimu(). 5 | 6 | `nestedbetasor` <- 7 | function(comm) 8 | { 9 | beta <- betadiver(comm, method = NA) 10 | b <- beta$b 11 | c <- beta$c 12 | diffbc <- sum(abs(b-c)) 13 | sumbc <- sum(b+c) 14 | bmin <- sum(pmin.int(b, c)) 15 | a <- sum(comm > 0) - sum(colSums(comm) > 0) 16 | simpson <- bmin/(bmin + a) 17 | nest <- a/(bmin + a) * diffbc/(2*a + sumbc) 18 | sorensen <- sumbc/(2*a + sumbc) 19 | c(turnover = simpson, nestedness = nest, sorensen = sorensen) 20 | } 21 | 22 | `nestedbetajac` <- 23 | function(comm) 24 | { 25 | beta <- betadiver(comm, method = NA) 26 | b <- beta$b 27 | c <- beta$c 28 | diffbc <- sum(abs(b-c)) 29 | sumbc <- sum(b+c) 30 | bmin <- sum(pmin.int(b, c)) 31 | a <- sum(comm > 0) - sum(colSums(comm) > 0) 32 | simpson <- 2*bmin/(2*bmin + a) 33 | nest <- a/(2*bmin + a) * diffbc/(a + sumbc) 34 | jaccard <- sumbc/(a + sumbc) 35 | c(turnover = simpson, nestedness = nest, jaccard = jaccard) 36 | } 37 | -------------------------------------------------------------------------------- /man/nobs.cca.Rd: -------------------------------------------------------------------------------- 1 | \name{nobs.cca} 2 | \alias{nobs.betadisper} 3 | \alias{nobs.cca} 4 | \alias{nobs.CCorA} 5 | \alias{nobs.decorana} 6 | \alias{nobs.isomap} 7 | \alias{nobs.metaMDS} 8 | \alias{nobs.pcnm} 9 | \alias{nobs.procrustes} 10 | \alias{nobs.rad} 11 | \alias{nobs.varpart} 12 | \alias{nobs.wcmdscale} 13 | 14 | \title{ 15 | Extract the Number of Observations from a vegan Fit. 16 | } 17 | \description{ 18 | Extract the number of \sQuote{observations} from a \pkg{vegan} model fit. 19 | } 20 | \usage{ 21 | \method{nobs}{cca}(object, ...) 22 | } 23 | 24 | \arguments{ 25 | \item{object}{ 26 | A fitted model object. 27 | } 28 | \item{\dots}{ 29 | Further arguments to be passed to methods. 30 | } 31 | } 32 | 33 | \details{ Function \code{nobs} is generic in \R, and 34 | \pkg{vegan} provides methods for objects from 35 | \code{\link{betadisper}}, \code{\link{cca}} and other related 36 | methods, \code{\link{CCorA}}, \code{\link{decorana}}, 37 | \code{\link{isomap}}, \code{\link{metaMDS}}, \code{\link{pcnm}}, 38 | \code{\link{procrustes}}, \code{\link{radfit}}, 39 | \code{\link{varpart}} and \code{\link{wcmdscale}}. } 40 | 41 | \value{ A single number, normally an integer, giving the number of 42 | observations. } 43 | 44 | \author{ 45 | Jari Oksanen 46 | } 47 | 48 | \keyword{models} 49 | 50 | -------------------------------------------------------------------------------- /R/scores.envfit.R: -------------------------------------------------------------------------------- 1 | `scores.envfit` <- 2 | function (x, display, choices, arrow.mul = 1, tidy = FALSE, ...) 3 | { 4 | display <- match.arg(display, 5 | c("vectors", "bp", "factors", "cn"), 6 | several.ok = TRUE) 7 | out <- list() 8 | if (any(display %in% c("vectors", "bp"))) { 9 | vects <- x$vectors$arrows[, , drop = FALSE] 10 | if (!missing(choices)) 11 | vects <- vects[, choices, drop=FALSE] 12 | if (!is.null(vects)) 13 | out$vectors <- arrow.mul * sqrt(x$vectors$r) * vects 14 | } 15 | if (any(display %in% c("factors", "cn"))) { 16 | facts <- x$factors$centroids[, , drop = FALSE] 17 | if (!missing(choices)) 18 | facts <- facts[, choices, drop=FALSE] 19 | out$factors <- facts 20 | } 21 | if (tidy) { 22 | if (length(out) == 0) # no scores 23 | return(NULL) 24 | group <- sapply(out, nrow) 25 | group <- rep(names(group), group) 26 | out <- do.call(rbind, out) 27 | label <- rownames(out) 28 | out <- as.data.frame(out) 29 | out$score <- group 30 | out$label <- label 31 | } 32 | ## only two kind of scores: return NULL, matrix or a list 33 | switch(length(out), out[[1]], out) 34 | } 35 | 36 | -------------------------------------------------------------------------------- /R/print.decorana.R: -------------------------------------------------------------------------------- 1 | `print.decorana` <- 2 | function (x, digits = max(3, getOption("digits") - 3), ...) 3 | { 4 | cat("\nCall:\n") 5 | cat(deparse(x$call), "\n\n") 6 | cat(ifelse(x$ira, "Orthogonal", "Detrended"), "correspondence analysis") 7 | cat(ifelse(!x$ira, paste(" with ", x$mk, " segments.\n", 8 | sep = ""), ".\n")) 9 | if (x$iresc) { 10 | cat("Rescaling of axes with", x$iresc, "iterations") 11 | if (x$short) 12 | cat(", and shortest axis rescaled", x$short) 13 | cat(".\n") 14 | } 15 | if (!is.null(x$v)) 16 | cat("Downweighting of rare species from fraction 1/", x$fraction, ".\n", sep="") 17 | if (!is.null(x$before)) { 18 | cat("Piecewise transformation of above-zero abundances:") 19 | print(as.data.frame(rbind(before = x$before, after = x$after), 20 | optional=TRUE)) 21 | } 22 | cat("Total inertia (scaled Chi-square):", round(x$totchi, digits), "\n") 23 | axlen <- apply(x$rproj, 2, function(z) diff(range(z))) 24 | cat("\n") 25 | print(rbind("Eigenvalues" = x$evals, 26 | "Additive Eigenvalues" = x$evals.ortho, 27 | "Decorana values" = x$evals.decorana, 28 | "Axis lengths" = axlen), digits = digits) 29 | cat("\n") 30 | invisible(x) 31 | } 32 | -------------------------------------------------------------------------------- /R/rad.zipf.R: -------------------------------------------------------------------------------- 1 | "rad.zipf" <- 2 | function (x, family = poisson, ...) 3 | { 4 | x <- as.rad(x) 5 | rnk <- seq(along = x) 6 | off <- rep(log(sum(x)), length(x)) 7 | fam <- family(link = "log") 8 | if (length(x) > 1) 9 | ln <- try(glm(x ~ log(rnk) + offset(off), family = fam)) 10 | if (length(x) < 2) { 11 | aic <- NA 12 | dev <- rdf <- 0 13 | ln <- nl <- NA 14 | p <- rep(NA, 2) 15 | fit <- x 16 | res <- rep(0, length(x)) 17 | wts <- rep(1, length(x)) 18 | } 19 | else if (inherits(ln, "try-error")) { 20 | aic <- rdf <- ln <- nl <- dev <- NA 21 | p <- rep(NA, 2) 22 | fit <- res <- wts <- rep(NA, length(x)) 23 | } 24 | else { 25 | fit <- fitted(ln) 26 | p <- coef(ln) 27 | p[1] <- exp(p[1]) 28 | aic <- AIC(ln) 29 | rdf <- df.residual(ln) 30 | dev <- deviance(ln) 31 | res <- ln$residuals 32 | wts <- weights(ln) 33 | } 34 | names(p) <- c("p1", "gamma") 35 | out <- list(model = "Zipf", family = fam, y = x, coefficients = p, 36 | fitted.values = fit, aic = aic, rank = 2, df.residual = rdf, 37 | deviance = dev, residuals = res, prior.weights = wts) 38 | class(out) <- c("radline", "glm") 39 | out 40 | } 41 | -------------------------------------------------------------------------------- /R/prc.R: -------------------------------------------------------------------------------- 1 | `prc` <- 2 | function (response, treatment, time, ...) 3 | { 4 | extras <- match.call(expand.dots = FALSE)$... 5 | if (is.null(extras$data)) 6 | data <- parent.frame() 7 | else 8 | data <- eval(extras$data) 9 | y <- deparse(substitute(response)) 10 | x <- deparse(substitute(treatment)) 11 | z <- deparse(substitute(time)) 12 | oldcon <- options(contrasts = c("contr.treatment", "contr.poly")) 13 | on.exit(options(oldcon)) 14 | fla <- as.formula(paste("~", x, "+", z)) 15 | mf <- model.frame(fla, data, na.action = na.pass) 16 | if (!all(sapply(mf, is.factor))) 17 | stop(gettextf("%s and %s must be factors", x, z)) 18 | if (any(sapply(mf, is.ordered))) 19 | stop(gettextf("%s or %s cannot be ordered factors", x, z)) 20 | fla.zx <- as.formula(paste("~", z, ":", x)) 21 | fla.z <- as.formula(paste("~", z)) 22 | # delete first (control) level from the design matrix 23 | X = model.matrix(fla.zx, mf)[,-c(seq_len(nlevels(time)+1))] 24 | Z = model.matrix(fla.z, mf)[,-1] 25 | mod <- rda(response ~ X + Condition(Z), ...) 26 | mod$terminfo$xlev = list(levels(time), levels(treatment)) 27 | names(mod$terminfo$xlev) = c(paste(z), paste(x)) 28 | mod$call <- match.call() 29 | class(mod) <- c("prc", class(mod)) 30 | mod 31 | } 32 | -------------------------------------------------------------------------------- /R/update.nullmodel.R: -------------------------------------------------------------------------------- 1 | update.nullmodel <- 2 | function(object, nsim=1, seed = NULL, ...) 3 | { 4 | if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) 5 | runif(1) 6 | if (!is.null(seed)) { 7 | R.seed <- get(".Random.seed", envir = .GlobalEnv) 8 | set.seed(seed) 9 | on.exit(assign(".Random.seed", R.seed, envir = .GlobalEnv)) 10 | } 11 | if (object$commsim$isSeq) { 12 | perm <- object$commsim$fun(x=object$state, 13 | n=1L, 14 | nr=object$nrow, 15 | nc=object$ncol, 16 | rs=object$rowSums, 17 | cs=object$colSums, 18 | rf=object$rowFreq, 19 | cf=object$colFreq, 20 | s=object$totalSum, 21 | fill=object$fill, 22 | thin=as.integer(nsim), ...) 23 | state <- perm[,,1L] 24 | storage.mode(state) <- object$commsim$mode 25 | iter <- as.integer(object$iter + nsim) 26 | # assign("state", state, envir=object) 27 | # assign("iter", iter, envir=object) 28 | # attr(state, "iter") <- iter 29 | out <- nullmodel(state, object$commsim) 30 | out$iter <- iter 31 | out$data <- object$data 32 | } else { 33 | # state <- NULL 34 | out <- object 35 | } 36 | # invisible(state) 37 | out 38 | } 39 | -------------------------------------------------------------------------------- /R/print.varpart234.R: -------------------------------------------------------------------------------- 1 | `print.varpart234` <- 2 | function(x, digits = 5, ...) 3 | { 4 | cat("No. of explanatory tables:", x$nsets, "\n") 5 | cat("Total variation (SS):", format(x$SS.Y, digits=digits), "\n") 6 | if (x$ordination == "rda") 7 | cat(" Variance:", format(x$SS.Y/(x$n-1), digits=digits), "\n") 8 | cat("No. of observations:", x$n, "\n") 9 | cat("\nPartition table:\n") 10 | out <- rbind(x$fract, "Individual fractions" = NA, x$indfract) 11 | if (x$nsets > 3) 12 | out <- rbind(out, "Controlling 2 tables X" = NA, x$contr2) 13 | if (x$nsets > 2) 14 | out <- rbind(out, "Controlling 1 table X" = NA, x$contr1) 15 | out[,2:3] <- round(out[,2:3], digits=digits) 16 | out[,1:4] <- sapply(out[,1:4], function(x) gsub("NA", " ", format(x, digits=digits))) 17 | print(out) 18 | cat("---\nUse function", sQuote(x$ordination), 19 | "to test significance of fractions of interest\n") 20 | if (!is.null(x$bigwarning)) 21 | for (i in seq_along(x$bigwarning)) 22 | warning("collinearity detected: redundant variable(s) between tables ", 23 | x$bigwarning[i], 24 | "\nresults are probably incorrect: remove redundant variable(s) and repeat the analysis", 25 | call. = FALSE) 26 | invisible(x) 27 | } 28 | 29 | -------------------------------------------------------------------------------- /R/rad.lognormal.R: -------------------------------------------------------------------------------- 1 | "rad.lognormal" <- 2 | function (x, family = poisson, ...) 3 | { 4 | x <- as.rad(x) 5 | n <- length(x) 6 | rnk <- -qnorm(ppoints(n)) 7 | fam <- family(link = "log") 8 | ## Must be > 2 species to fit a model 9 | if (length(x) > 1) 10 | ln <- try(glm(x ~ rnk, family = fam)) 11 | if (length(x) < 2) { 12 | aic <- NA 13 | dev <- rdf <- 0 14 | ln <- nl <- NA 15 | p <- rep(NA, 2) 16 | fit <- x 17 | res <- rep(0, length(x)) 18 | wts <- rep(1, length(x)) 19 | } 20 | else if (inherits(ln, "try-error")) { 21 | aic <- rdf <- ln <- nl <- dev <- NA 22 | p <- rep(NA, 2) 23 | fit <- res <- wts <- rep(NA, length(x)) 24 | } 25 | else { 26 | p <- coef(ln) 27 | fit <- fitted(ln) 28 | aic <- AIC(ln) 29 | rdf <- df.residual(ln) 30 | dev <- deviance(ln) 31 | res <- ln$residuals 32 | wts <- weights(ln) 33 | } 34 | names(p) <- c("log.mu", "log.sigma") 35 | out <- list(model = "Log-Normal", family = fam, y = x, 36 | coefficients = p, fitted.values = fit, aic = aic, rank = 2, 37 | df.residual = rdf, deviance = dev, residuals = res, 38 | prior.weights = wts) 39 | class(out) <- c("radline", "glm") 40 | out 41 | } 42 | -------------------------------------------------------------------------------- /R/predict.fitspecaccum.R: -------------------------------------------------------------------------------- 1 | ### fitspecaccum returns fitted nls() models in item models. Here we 2 | ### provide interfaces for some "nls" class support functions, and 3 | ### others can be used in the similar way. 4 | 5 | `predict.fitspecaccum` <- 6 | function(object, newdata, ...) 7 | { 8 | mods <- object$models 9 | if (!missing(newdata)) { 10 | newdata <- drop(as.matrix(newdata)) 11 | if (length(dim(newdata)) > 1) 12 | stop("function accepts only one variable as 'newdata'") 13 | drop(sapply(mods, predict, newdata = data.frame(x = newdata), ...)) 14 | } else { 15 | drop(sapply(mods, predict, ...)) 16 | } 17 | } 18 | 19 | `AIC.fitspecaccum` <- 20 | function(object, ..., k = 2) 21 | { 22 | sapply(object$models, AIC, k = k, ...) 23 | } 24 | 25 | `deviance.fitspecaccum` <- 26 | function(object, ...) 27 | { 28 | sapply(object$models, deviance, ...) 29 | } 30 | 31 | `logLik.fitspecaccum` <- 32 | function(object, ...) 33 | { 34 | out <- sapply(object$models, logLik, ...) 35 | ## sapply() strips attributes: get'em back 36 | attr(out, "df") <- 1L + length(coef(object$models[[1L]])) 37 | attr(out, "nobs") <- nobs(object$models[[1L]]) 38 | class(out) <- "logLik" 39 | out 40 | } 41 | 42 | `nobs.fitspecaccum` <- 43 | function(object, ...) 44 | { 45 | sapply(object$models, nobs, ...) 46 | } 47 | -------------------------------------------------------------------------------- /R/model.matrix.cca.R: -------------------------------------------------------------------------------- 1 | `model.matrix.cca` <- 2 | function(object, ...) 3 | { 4 | X <- Z <- NULL 5 | w <- 1/sqrt(object$rowsum) 6 | if (!is.null(object$pCCA) && object$pCCA$rank > 0) 7 | Z <- w * qr.X(object$pCCA$QR, ncol = length(object$pCCA$QR$pivot)) 8 | if (!is.null(object$CCA) && object$CCA$rank > 0) { 9 | X <- qr.X(object$CCA$QR, ncol = length(object$CCA$QR$pivot)) 10 | ## First columns come from Z 11 | if (!is.null(Z)) 12 | X <- X[, -seq_len(ncol(Z)), drop = FALSE] 13 | X <- w * X 14 | } 15 | m <- list() 16 | if (!is.null(Z)) 17 | m$Conditions <- Z 18 | if (!is.null(X)) 19 | m$Constraints <- X 20 | if (length(m) == 1) 21 | m <- m[[1]] 22 | m 23 | } 24 | 25 | `model.matrix.rda` <- 26 | function(object, ...) 27 | { 28 | X <- Z <- NULL 29 | if (!is.null(object$pCCA) && object$pCCA$rank > 0) 30 | Z <- qr.X(object$pCCA$QR, ncol = length(object$pCCA$QR$pivot)) 31 | if (!is.null(object$CCA) && object$CCA$rank > 0) { 32 | X <- qr.X(object$CCA$QR, ncol = length(object$CCA$QR$pivot)) 33 | if (!is.null(Z)) 34 | X <- X[, -seq_len(ncol(Z)), drop=FALSE] 35 | } 36 | m <- list() 37 | if (!is.null(Z)) 38 | m$Conditions <- Z 39 | if (!is.null(X)) 40 | m$Constraints <- X 41 | if (length(m) == 1) 42 | m <- m[[1]] 43 | m 44 | } 45 | -------------------------------------------------------------------------------- /R/plot.ordisurf.R: -------------------------------------------------------------------------------- 1 | `plot.ordisurf` <- function(x, what = c("contour","persp","gam"), 2 | add = FALSE, bubble = FALSE, col = "red", cex = 1, 3 | nlevels = 10, levels, labcex = 0.6, 4 | lwd.cl = par("lwd"), ...) { 5 | what <- match.arg(what) 6 | y <- x$model$y 7 | x1 <- x$model$x1 8 | x2 <- x$model$x2 9 | X <- x$grid$x 10 | Y <- x$grid$y 11 | Z <- x$grid$z 12 | force(col) 13 | force(cex) 14 | if(what == "contour") { 15 | if(!add) { 16 | if(bubble) { 17 | if (is.numeric(bubble)) 18 | cex <- bubble 19 | cex <- (y - min(y))/diff(range(y)) * (cex-0.4) + 0.4 20 | } 21 | plot(x1, x2, asp = 1, cex = cex, ...) 22 | } 23 | if (missing(levels)) 24 | levels <- pretty(range(x$grid$z, finite = TRUE), nlevels) 25 | contour(X, Y, Z, col = col, add = TRUE, 26 | levels = levels, labcex = labcex, 27 | drawlabels = !is.null(labcex) && labcex > 0, 28 | lwd = lwd.cl) 29 | } else if(what == "persp") { 30 | persp(X, Y, Z, col = col, cex = cex, ...) 31 | } else { 32 | class(x) <- class(x)[-1] 33 | plot(x, ...) ##col = col, cex = cex, ...) 34 | class(x) <- c("ordisurf", class(x)) 35 | } 36 | invisible(x) 37 | } 38 | -------------------------------------------------------------------------------- /R/as.preston.R: -------------------------------------------------------------------------------- 1 | `as.preston` <- 2 | function (x, tiesplit = TRUE, ...) 3 | { 4 | if (inherits(x, "preston")) 5 | return(x) 6 | ## practically integer 7 | if (!isTRUE(all.equal(x, round(x)))) 8 | stop("function accepts only integers (counts)") 9 | ## need exact integers, since, e.g., sqrt(2)^2 - 2 = 4.4e-16 and 10 | ## tie breaks fail 11 | if (!is.integer(x)) 12 | x <- round(x) 13 | x <- x[x > 0] 14 | if (tiesplit) { 15 | ## Assume log2(2^k) == k *exactly* for integer k 16 | xlog2 <- log2(x) 17 | ties <- xlog2 == ceiling(xlog2) 18 | tiefreq <- table(xlog2[ties]) 19 | notiefreq <- table(ceiling(xlog2[!ties])) 20 | itie <- as.numeric(names(tiefreq)) + 1 21 | nitie <- as.numeric(names(notiefreq)) + 1 22 | freq <- numeric(max(itie+1, nitie)) 23 | ## split tied values between two adjacent octaves 24 | freq[itie] <- tiefreq/2 25 | freq[itie+1] <- freq[itie+1] + tiefreq/2 26 | freq[nitie] <- freq[nitie] + notiefreq 27 | } else { 28 | xlog2 <- ceiling(log2(x)) 29 | tmp <- table(xlog2) 30 | indx <- as.numeric(names(tmp)) + 1 31 | freq <- numeric(max(indx)) 32 | freq[indx] <- tmp 33 | } 34 | names(freq) <- seq_along(freq) - 1 35 | ## remove empty octaves 36 | freq <- freq[freq>0] 37 | class(freq) <- "preston" 38 | freq 39 | } 40 | -------------------------------------------------------------------------------- /R/dispindmorisita.R: -------------------------------------------------------------------------------- 1 | `dispindmorisita` <- 2 | function(x, unique.rm=FALSE, crit=0.05, na.rm=FALSE) 3 | { 4 | x <- as.matrix(x) 5 | n <- nrow(x) 6 | p <- ncol(x) 7 | Imor <- apply(x, 2, function(y) n * ((sum(y^2) - sum(y)) / (sum(y)^2 - sum(y)))) 8 | Smor <- Imor 9 | chicr <- qchisq(c(0+crit/2, 1-crit/2), n-1, lower.tail=FALSE) 10 | Muni <- apply(x, 2, function(y) (chicr[2] - n + sum(y)) / (sum(y) - 1)) 11 | Mclu <- apply(x, 2, function(y) (chicr[1] - n + sum(y)) / (sum(y) - 1)) 12 | rs <- colSums(x, na.rm=na.rm) 13 | pchi <- pchisq(Imor * (rs - 1) + n - rs, n-1, lower.tail=FALSE) 14 | for (i in 1:p) { 15 | if (rs[i] > 1) { 16 | if (Imor[i] >= Mclu[i] && Mclu[i] > 1) 17 | Smor[i] <- 0.5 + 0.5 * ((Imor[i] - Mclu[i]) / (n - Mclu[i])) 18 | if (Mclu[i] > Imor[i] && Imor[i] >=1) 19 | Smor[i] <- 0.5 * ((Imor[i] - 1) / (Mclu[i] - 1)) 20 | if (1 > Imor[i] && Imor[i] > Muni[i]) 21 | Smor[i] <- -0.5 * ((Imor[i] - 1) / (Muni[i] - 1)) 22 | if (1 > Muni[i] && Muni[i] > Imor[i]) 23 | Smor[i] <- -0.5 + 0.5 * ((Imor[i] - Muni[i]) / Muni[i]) 24 | } 25 | } 26 | out <- data.frame(imor = Imor, mclu = Mclu, muni = Muni, 27 | imst = Smor, pchisq = pchi) 28 | usp <- which(colSums(x > 0) == 1) 29 | if (unique.rm && length(usp) != 0) 30 | out <- out[-usp,] 31 | out 32 | } 33 | 34 | -------------------------------------------------------------------------------- /R/meandist.R: -------------------------------------------------------------------------------- 1 | `meandist` <- 2 | function(dist, grouping, ...) 3 | { 4 | if (!inherits(dist, "dist")) 5 | stop("'dist' must be dissimilarity object inheriting from", dQuote(dist)) 6 | ## check that 'dist' are dissimilarities (non-negative) 7 | if (any(dist < -sqrt(.Machine$double.eps))) 8 | warning("some dissimilarities are negative: is this intentional?") 9 | grouping <- factor(grouping, exclude = NULL) 10 | ## grouping for rows and columns 11 | grow <- grouping[as.dist(row(as.matrix(dist)))] 12 | gcol <- grouping[as.dist(col(as.matrix(dist)))] 13 | ## The row index must be "smaller" of the factor levels so that 14 | ## all means are in the lower triangle, and upper is NA 15 | first <- as.numeric(grow) >= as.numeric(gcol) 16 | cl1 <- ifelse(first, grow, gcol) 17 | cl2 <- ifelse(!first, grow, gcol) 18 | ## Cannot have within-group dissimilarity for group size 1 19 | n <- table(grouping) 20 | take <- matrix(TRUE, nlevels(grouping), nlevels(grouping)) 21 | diag(take) <- n > 1 22 | take[upper.tri(take)] <- FALSE 23 | out <- matrix(NA, nlevels(grouping), nlevels(grouping)) 24 | ## Get output matrix 25 | tmp <- tapply(dist, list(cl1, cl2), mean) 26 | out[take] <- tmp[!is.na(tmp)] 27 | out[upper.tri(out)] <- t(out)[upper.tri(out)] 28 | rownames(out) <- colnames(out) <- levels(grouping) 29 | class(out) <- c("meandist", "matrix") 30 | attr(out, "n") <- table(grouping) 31 | out 32 | } 33 | 34 | -------------------------------------------------------------------------------- /R/scalingUtils.R: -------------------------------------------------------------------------------- 1 | ##' @title Utility for handling user friendly scaling --- None exported 2 | ##' 3 | ##' @description Convert user-friendly descriptions of scalings to numeric codes used by \code{scores} to date. 4 | ##' 5 | ##' @param scaling character or numeric; which type of scaling is required? Numeric values are returned unaltered 6 | ##' @param correlation logical; should correlation-like scores be returned? 7 | ##' @param hill logical; should Hill's scaling scores be returned? 8 | `scalingType` <- function(scaling = c("none", "sites", "species", "symmetric"), 9 | correlation = FALSE, hill = FALSE) { 10 | ## Only process scaling further if it is character 11 | if (is.numeric(scaling)) { 12 | return(scaling) # numeric; return early 13 | } else if (is.character(scaling)) { 14 | ## non-numeric scaling: change to correct numeric code 15 | scaling <- match.arg(scaling) # match user choice 16 | ## Keep `tab` as this is the order of numeric codes 17 | ## Allows potential to change the default ordering of formal argument 'scaling' 18 | tab <- c("none", "sites", "species", "symmetric") 19 | scaling <- match(scaling, tab) - 1 # -1 as none == scaling 0 20 | if (correlation || hill) { 21 | scaling <- -scaling 22 | } 23 | } else { 24 | stop("'scaling' is not 'numeric' nor 'character'.") 25 | } 26 | scaling # return 27 | } 28 | -------------------------------------------------------------------------------- /R/biplot.rda.R: -------------------------------------------------------------------------------- 1 | ## biplot.rda 2 | ## 3 | ## draws pca biplots with species as arrows 4 | ## 5 | 6 | `biplot.cca` <- 7 | function(x, ...) 8 | { 9 | if (!inherits(x, "rda")) 10 | stop("biplot can be used only with linear ordination (e.g., PCA)") 11 | else 12 | NextMethod("biplot") 13 | } 14 | 15 | `biplot.rda` <- function(x, choices = c(1, 2), scaling = "species", 16 | display = c("sites", "species"), 17 | type, xlim, ylim, col = c(1,2), const, 18 | correlation = FALSE, ...) { 19 | if(!inherits(x, "rda")) 20 | stop("'biplot.rda' is only for objects of class 'rda'") 21 | if(!is.null(x$CCA)) 22 | stop("'biplot.rda' not suitable for models with constraints") 23 | TYPES <- c("text", "points", "none") 24 | display <- match.arg(display, several.ok = TRUE) 25 | if (length(col) == 1) 26 | col <- c(col,col) 27 | spe.par <- list(col = col[2], arrows = TRUE) 28 | sit.par <- list(col = col[1]) 29 | if (!missing(type)) { 30 | type <- match.arg(type, TYPES, several.ok = TRUE) 31 | if(length(type) < 2) 32 | type <- rep(type, 2) 33 | spe.par <- modifyList(spe.par, list(type = type[1])) 34 | sit.par <- modifyList(sit.par, list(type = type[2])) 35 | } 36 | plot(x, choices = choices, scaling = scaling, display = display, 37 | xlim = xlim, ylim = ylim, const = const, correlation = correlation, 38 | spe.par = spe.par, sit.par = sit.par, ...) 39 | } 40 | -------------------------------------------------------------------------------- /R/calibrate.cca.R: -------------------------------------------------------------------------------- 1 | `calibrate.cca` <- 2 | function(object, newdata, rank = "full", ...) 3 | { 4 | ## inversion solve(b) requires a square matrix, and we should 5 | ## append imaginary dims to get those in dbrda with negative 6 | ## constrained eigenvalues. Work is need to to verify this can be 7 | ## done, and therefore we just disable calibrate with negative 8 | ## eigenvalues in constraints. 9 | if (inherits(object, "dbrda") && object$CCA$poseig < object$CCA$qrank) 10 | stop("cannot be used with 'dbrda' with imaginary constrained dimensions") 11 | if (!is.null(object$pCCA)) 12 | stop("does not work with conditioned (partial) models") 13 | if (is.null(object$CCA) || object$CCA$rank == 0) 14 | stop("needs constrained model") 15 | if (object$CCA$rank < object$CCA$qrank) 16 | stop("rank of constraints is higher than rank of dependent data") 17 | if (rank != "full") 18 | rank <- min(rank, object$CCA$rank) 19 | else 20 | rank <- object$CCA$rank 21 | if (missing(newdata)) 22 | wa <- object$CCA$wa 23 | else 24 | wa <- predict(object, type="wa", newdata=newdata) 25 | qrank <- object$CCA$qrank 26 | b <- (coef(object))[object$CCA$QR$pivot[1:qrank], , drop=FALSE] 27 | b <- solve(b) 28 | pred <- wa[ , 1:rank, drop=FALSE] %*% b[1:rank, , drop =FALSE] 29 | envcen <- object$CCA$envcentre[object$CCA$QR$pivot] 30 | envcen <- envcen[1:object$CCA$qrank] 31 | sweep(pred, 2, envcen, "+") 32 | } 33 | 34 | -------------------------------------------------------------------------------- /R/coverscale.R: -------------------------------------------------------------------------------- 1 | `coverscale` <- 2 | function (x, scale = c("Braun.Blanquet", "Domin", "Hult", "Hill", 3 | "fix", "log"), maxabund, character = TRUE) 4 | { 5 | scale <- match.arg(scale) 6 | sol <- as.data.frame(x) 7 | x <- as.matrix(x) 8 | switch(scale, Braun.Blanquet = { 9 | codes <- c("r", "+", as.character(1:5)) 10 | lims <- c(0, 0.1, 1, 5, 25, 50, 75, 100) 11 | }, Domin = { 12 | codes <- c("+", as.character(1:9), "X") 13 | lims <- c(0, 0.01, 0.1, 1, 5, 10, 25, 33, 50, 75, 90, 14 | 100) 15 | }, Hult = { 16 | codes <- as.character(1:5) 17 | lims <- c(0, 100/2^(4:1), 100) 18 | }, Hill = { 19 | codes <- as.character(1:5) 20 | lims <- c(0, 2, 5, 10, 20, Inf) 21 | }, fix = { 22 | codes <- c("+", as.character(1:9), "X") 23 | lims <- c(0:10, 11 - 10 * .Machine$double.eps) 24 | }, log = { 25 | codes <- c("+", as.character(1:9)) 26 | if (missing(maxabund)) 27 | maxabund <- max(x) 28 | lims <- c(0, maxabund/2^(9:1), maxabund) 29 | }) 30 | for (i in 1:nrow(x)) { 31 | if (!character) 32 | codes <- FALSE 33 | tmp <- x[i, ] > 0 34 | sol[i, tmp] <- cut(x[i, tmp], breaks = lims, labels = codes, 35 | right = FALSE, include.lowest = TRUE) 36 | } 37 | attr(sol, "scale") <- 38 | if (scale == "log") paste("log, with maxabund", maxabund) else scale 39 | sol 40 | } 41 | 42 | -------------------------------------------------------------------------------- /tests/oecosimu-tests.R: -------------------------------------------------------------------------------- 1 | ### oecosimu-tests: unit tests for vegan functions 2 | 3 | ### This file contains basic unit tests for simulating null 4 | ### models. Currently we just test the marginal properties of null 5 | ### models using example(commsim). 6 | 7 | ### We had more extensive tests that also displayed heads of simulated 8 | ### matrices (not only the marginal sums), but these were unstable 9 | ### when R was compiled as ./configure --disable-long-double because 10 | ### some tests used R functions stats::rmultinom() which used long 11 | ### doubles and gave different results when long double was not 12 | ### available. 13 | 14 | ### We also had specific permatfull/permatswap tests, but these only 15 | ### tested the simple cases and were nothing but an alternative 16 | ### interface to commsim nullmodels tested here. 17 | 18 | ### <-- oecosimu/permat specifics --> 19 | 20 | ###<--- BEGIN TESTS ---> 21 | suppressPackageStartupMessages(require(vegan)) 22 | set.seed(4711) 23 | example(commsim) 24 | 25 | ### clean 26 | rm(list = ls()) 27 | 28 | ## end permatfull/swap 29 | 30 | ## The following vegan functions depend on *oecosimu*: adipart 31 | ## hiersimu multipart raupcrick. The following functions directly 32 | ## depend on *commsimulator*: permatfull1 permatswap1. All these have 33 | ## derived and/or method functions. These should not be broken. 34 | 35 | ## Do not break raupcrick: 36 | set.seed(4711) 37 | data(sipoo) 38 | as.numeric(raupcrick(sipoo, nsimul = 99)) 39 | rm(list = ls()) 40 | ## end raupcrick 41 | -------------------------------------------------------------------------------- /R/ordixyplot.R: -------------------------------------------------------------------------------- 1 | `ordixyplot` <- 2 | function(x, data = NULL, formula, display = "sites", choices=1:3, 3 | panel = "panel.ordi", aspect = "iso", envfit, 4 | type = c("p", "biplot"), ...) 5 | { 6 | localXyplot <- function(..., shrink, origin, scaling) xyplot(...) 7 | p <- as.data.frame(scores(x, display = display, choices = choices, ...)) 8 | if (!is.null(data)) 9 | p <- cbind(p, data) 10 | if (missing(formula)) { 11 | v <- colnames(p) 12 | formula <- as.formula(paste(v[2], "~", v[1])) 13 | } 14 | if ("biplot" %in% type && ((!is.null(x$CCA) && x$CCA$rank > 0) || 15 | !missing(envfit))) { 16 | if (missing(envfit)) 17 | envfit <- NULL 18 | env <- ordilattice.getEnvfit(formula, x, envfit, choices, ...) 19 | if (!is.null(env$arrows)) { 20 | mul <- apply(p[,colnames(env$arrows)], 2, range)/apply(env$arrows, 2, range) 21 | mul <- min(mul[is.finite(mul) & mul > 0]) 22 | env$arrows <- mul * env$arrows 23 | } 24 | } else { 25 | env <- NULL 26 | } 27 | ## plot polygon for all data plus superpose polygons for each panel 28 | if ("polygon" %in% type) { 29 | pol <- p[, all.vars(formula)[2:1]] 30 | pol <- pol[chull(pol),] 31 | } else { 32 | pol <- NULL 33 | } 34 | localXyplot(formula, data = p, panel = panel, aspect = aspect, 35 | biplot = env, polygon = pol, type = type, ...) 36 | } 37 | -------------------------------------------------------------------------------- /R/downweight.R: -------------------------------------------------------------------------------- 1 | ### Support functions for decorana 2 | 3 | ## Hill's downweighting 4 | 5 | ## An exported function that can be called outside decorana 6 | 7 | `downweight` <- 8 | function (veg, fraction = 5) 9 | { 10 | Const1 <- 1e-10 11 | if (fraction < 1) 12 | fraction <- 1/fraction 13 | veg <- as.matrix(veg, rownames.force = TRUE) 14 | yeig1 <- colSums(veg) 15 | y2 <- colSums(veg^2) + Const1 16 | y2 <- yeig1^2/y2 17 | amax <- max(y2)/fraction 18 | v <- rep(1, ncol(veg)) 19 | downers <- y2 < amax 20 | v[downers] <- (y2/amax)[downers] 21 | veg <- sweep(veg, 2, v, "*") 22 | attr(veg, "v") <- v 23 | attr(veg, "fraction") <- fraction 24 | veg 25 | } 26 | 27 | ## Hill's piecewise tranformation. Values of before are replaced with 28 | ## values of after, and intermediary values with linear interpolation. 29 | 30 | ## Not exported: if you think you need something like this, find a 31 | ## better tool in R. 32 | 33 | `beforeafter` <- 34 | function(x, before, after) 35 | { 36 | if (is.null(before) || is.null(after)) 37 | stop("both 'before' and 'after' must be given", call. = FALSE) 38 | if (is.unsorted(before)) 39 | stop("'before' must be sorted", call. = FALSE) 40 | if (length(before) != length(after)) 41 | stop("'before' and 'after' must have same lengths", call. = FALSE) 42 | for(i in seq_len(nrow(x))) { 43 | k <- x[i,] > 0 44 | x[i, k] <- approx(before, after, x[i, k], rule = 2)$y 45 | } 46 | x 47 | } 48 | -------------------------------------------------------------------------------- /R/inertcomp.R: -------------------------------------------------------------------------------- 1 | `inertcomp` <- 2 | function (object, display = c("species", "sites"), 3 | unity = FALSE, proportional = FALSE) 4 | { 5 | display <- match.arg(display) 6 | ## unity and proportional are conflicting arguments 7 | if (unity && proportional) 8 | stop("arguments 'unity' and 'proportional' cannot be both TRUE") 9 | if (!inherits(object, "cca")) 10 | stop("can be used only with objects inheriting from 'cca'") 11 | if (inherits(object, c("capscale", "dbrda")) && display == "species") 12 | stop(gettextf("cannot analyse species with '%s'", object$method)) 13 | if (inherits(object, "dbrda")) { 14 | display <- "dbrda" 15 | } 16 | ## function to get the eigenvalues 17 | getComps <- function(x, display) { 18 | if(!is.null(x)) 19 | switch(display, 20 | "species" = colSums(x^2), 21 | "sites" = rowSums(x^2), 22 | "dbrda" = diag(x) 23 | ) 24 | } 25 | pCCA <- ordiYbar(object, "pCCA") 26 | CCA <- ordiYbar(object, "CCA") 27 | CA <- ordiYbar(object, "CA") 28 | tot <- ordiYbar(object, "initial") 29 | out <- cbind("pCCA" = getComps(pCCA, display), 30 | "CCA" = getComps(CCA, display), 31 | "CA" = getComps(CA, display)) 32 | if (unity) ## each column sums to 1 33 | out <- sweep(out, 2, colSums(out), "/") 34 | if (proportional) 35 | out <- sweep(out, 1, rowSums(out), "/") 36 | out 37 | } 38 | -------------------------------------------------------------------------------- /R/plot.spantree.R: -------------------------------------------------------------------------------- 1 | `plot.spantree` <- 2 | function (x, ord, cex = 0.7, type = "p", labels, dlim, FUN = sammon, 3 | ...) 4 | { 5 | FUNname <- deparse(substitute(FUN)) 6 | FUN <- match.fun(FUN) 7 | n <- x$n 8 | if (missing(ord)) { 9 | d <- cophenetic(x) 10 | if (any(d<=0)) 11 | d[d<=0] <- min(d>0)/10 12 | if (!missing(dlim)) 13 | d[d > dlim ] <- dlim 14 | if (n > 2) { 15 | ## sammon needs extra care, for other cases we just try FUN(d) 16 | if (FUNname == "sammon") { 17 | y <- cmdscale(d) 18 | dup <- duplicated(y) 19 | if (any(dup)) 20 | y[dup, ] <- y[dup,] + runif(2*sum(dup), -0.01, 0.01) 21 | ord <- FUN(d, y = y) 22 | } else 23 | ord <- FUN(d) 24 | } else 25 | ord <- cbind(seq_len(n), rep(0,n)) 26 | } 27 | ord <- scores(ord, display = "sites", ...) 28 | ordiArgAbsorber(ord, asp = 1, type = "n", FUN = "plot", ...) 29 | lines(x, ord, ...) 30 | if (type == "p" || type == "b") 31 | ordiArgAbsorber(ord, cex = cex, FUN = "points", ...) 32 | else if (type == "t") { 33 | if (missing(labels)) 34 | labels <- x$labels 35 | x <- scores(ord, display = "sites", ...) 36 | ordiArgAbsorber(x, labels = labels, cex = cex, FUN = "ordilabel", ...) 37 | } 38 | ord <- list(sites = ord) 39 | class(ord) <- "ordiplot" 40 | invisible(ord) 41 | } 42 | -------------------------------------------------------------------------------- /R/plot.clamtest.R: -------------------------------------------------------------------------------- 1 | plot.clamtest <- function(x, xlab, ylab, main, 2 | pch=21:24, col.points=1:4, col.lines=2:4, lty=1:3, 3 | position="bottomright", ...) { 4 | summ <- summary(x) 5 | glabel <- summ$labels 6 | if (missing(main)) 7 | main <- "Species Classification" 8 | if (missing(xlab)) 9 | xlab <- paste(glabel[2], "(abundance + 1)") 10 | if (missing(ylab)) 11 | ylab <- paste(glabel[1], "(abundance + 1)") 12 | Y <- x[,2] 13 | X <- x[,3] 14 | minval <- summ$minv 15 | ## plot the dots 16 | rr <- range(X+1,Y+1) 17 | plot(X+1, Y+1, log = "xy", xaxt = "n", yaxt = "n", 18 | col=col.points[as.integer(x$Classes)], 19 | pch=pch[as.integer(x$Classes)], 20 | xlab=xlab, ylab=ylab, main=main, 21 | xlim=rr, ylim=rr, ...) 22 | axis(1, c(1,10,100,1000,10000)) 23 | axis(2, c(1,10,100,1000,10000)) 24 | ## too rare threshold 25 | Ymin <- minval[[1]][1,2] 26 | Xmin <- minval[[2]][1,1] 27 | lines(rep(Xmin, 2)+1, c(0, 1)+1, col=col.lines[1], lty=lty[1]) 28 | lines(c(0, 1)+1, rep(Ymin, 2)+1, col=col.lines[1], lty=lty[1]) 29 | tmp <- approx(c(Xmin, 1), c(1, Ymin)) 30 | lines(tmp$x+1, tmp$y+1, col=col.lines[1], lty=lty[1]) 31 | ## Y vs. gen threshold 32 | lines(minval[[1]]+1, col=col.lines[2], lty=lty[2]) 33 | ## X vs. gen threshold 34 | lines(minval[[2]]+1, col=col.lines[3], lty=lty[3]) 35 | if (!is.null(position)) 36 | legend(position, col=col.points, pch=pch, 37 | legend=rownames(summ$summary)) 38 | invisible(x) 39 | } 40 | -------------------------------------------------------------------------------- /.github/workflows/pkgdown.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | release: 9 | types: [published] 10 | workflow_dispatch: 11 | 12 | name: pkgdown 13 | 14 | permissions: read-all 15 | 16 | jobs: 17 | pkgdown: 18 | runs-on: ubuntu-latest 19 | # Only restrict concurrency for non-PR jobs 20 | concurrency: 21 | group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} 22 | env: 23 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 24 | permissions: 25 | contents: write 26 | steps: 27 | - uses: actions/checkout@v4 28 | 29 | - uses: r-lib/actions/setup-pandoc@v2 30 | 31 | - uses: r-lib/actions/setup-r@v2 32 | with: 33 | use-public-rspm: true 34 | 35 | - uses: r-lib/actions/setup-r-dependencies@v2 36 | with: 37 | extra-packages: any::pkgdown, local::. 38 | needs: website 39 | 40 | - name: Build site 41 | run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE) 42 | shell: Rscript {0} 43 | 44 | - name: Deploy to GitHub pages 🚀 45 | if: github.event_name != 'pull_request' 46 | uses: JamesIves/github-pages-deploy-action@v4.5.0 47 | with: 48 | clean: false 49 | branch: gh-pages 50 | folder: docs 51 | target-folder: docs 52 | -------------------------------------------------------------------------------- /R/anova.ccanull.R: -------------------------------------------------------------------------------- 1 | ### anova.cca cannot be performed if residuals or constraints are 2 | ### NULL, and this function handles these cases (but it doesn't test 3 | ### that these are the cases). 4 | `anovaCCAnull` <- 5 | function(object, ...) 6 | { 7 | table <- matrix(0, nrow = 2, ncol = 4) 8 | if (object$CA$rank == 0) { 9 | table[1,] <- c(object$CCA$qrank, object$CCA$tot.chi, NA, NA) 10 | table[2,] <- c(0,0,NA,NA) 11 | } 12 | else { 13 | table[1,] <- c(0,0,0,NA) 14 | table[2,] <- c(nrow(object$CA$u) - 1, object$CA$tot.chi, NA, NA) 15 | } 16 | rownames(table) <- c("Model", "Residual") 17 | if (inherits(object, c("capscale", "dbrda")) && object$adjust == 1) 18 | varname <- "SumOfSqs" 19 | else if (inherits(object, "rda")) 20 | varname <- "Variance" 21 | else 22 | varname <- "ChiSquare" 23 | colnames(table) <- c("Df", varname, "F", "Pr(>F)") 24 | table <- as.data.frame(table) 25 | if (object$CA$rank == 0) 26 | head <- "No residual component\n" 27 | else if (is.null(object$CCA) || object$CCA$rank == 0) 28 | head <- "No constrained component\n" 29 | else 30 | head <- c("!!!!! ERROR !!!!!\n") 31 | head <- c(head, paste("Model:", c(object$call))) 32 | if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) 33 | seed <- get(".Random.seed", envir = .GlobalEnv, inherits = FALSE) 34 | else 35 | seed <- NULL 36 | structure(table, heading = head, Random.seed = seed, 37 | class = c("anova.cca", "anova", "data.frame")) 38 | } 39 | -------------------------------------------------------------------------------- /R/scores.decorana.R: -------------------------------------------------------------------------------- 1 | `scores.decorana` <- 2 | function (x, display="sites", choices = 1:4, origin=TRUE, 3 | tidy = FALSE, ...) 4 | { 5 | display <- match.arg(display, c("sites", "species", "both"), several.ok = TRUE) 6 | ## return "both" in tidy scores 7 | if(tidy) 8 | display <- "both" 9 | out <- list() 10 | if(any(c("sites", "both") %in% display)) { 11 | sites <- x$rproj 12 | if (origin) 13 | sites <- sweep(sites, 2, x$origin, "-") 14 | out$sites <- sites[, choices, drop=FALSE] 15 | } 16 | if(any(c("species", "both") %in% display)) { 17 | species <- x$cproj 18 | if (origin) 19 | species <- sweep(species, 2, x$origin, "-") 20 | out$species <- species[, choices] 21 | } 22 | if (tidy) { 23 | if (length(out) == 0) # no scores (never TRUE?) 24 | return(NULL) 25 | group <- sapply(out, nrow) 26 | group <- rep(names(group), group) 27 | out <- do.call(rbind, out) 28 | label <- rownames(out) 29 | out <- as.data.frame(out) 30 | out$score <- group 31 | out$label <- label 32 | wts <- rep(NA, nrow(out)) 33 | if (any(take <- group == "sites")) 34 | wts[take] <- weights(x, display="sites") 35 | if (any(take <- group == "species")) 36 | wts[take] <- weights(x, display="species") 37 | out$weight <- wts 38 | } 39 | ## two kind of scores: return NULL, matrix or a list 40 | if (length(out) == 1) 41 | out[[1]] 42 | else 43 | out 44 | } 45 | -------------------------------------------------------------------------------- /R/plot.meandist.R: -------------------------------------------------------------------------------- 1 | `plot.meandist` <- 2 | function(x, kind = c("dendrogram", "histogram"), cluster = "average", ylim, 3 | axes = TRUE, ...) 4 | { 5 | kind <- match.arg(kind) 6 | n <- attr(x, "n") 7 | if (kind == "dendrogram") { 8 | cl <- hclust(as.dist(x), method = cluster, members = n) 9 | cl <- as.dendrogram(cl, hang = 0) 10 | w <- diag(x)[labels(cl)] 11 | tr <- unlist(dendrapply(cl, function(n) attr(n, "height"))) 12 | root <- attr(cl, "height") 13 | if (missing(ylim)) 14 | ylim <- range(c(w, tr, root), na.rm = TRUE) 15 | plot(cl, ylim = ylim, leaflab = "none", axes = axes, ...) 16 | seqw <- seq_along(w) 17 | for (i in seqw) { 18 | segments(i, tr[i], i, w[i]) 19 | } 20 | pos <- ifelse(w < tr, 1, 3) 21 | pos[is.na(pos)] <- 1 22 | w[is.na(w)] <- tr[is.na(w)] 23 | text(seqw, w, labels = labels(cl), pos = pos, srt = 0, xpd = TRUE, ...) 24 | } else { 25 | w <- diag(x) 26 | seqw <- seq_along(w) 27 | tr <- rep(summary(x)$B, length(w)) 28 | if (missing(ylim)) 29 | ylim <- range(c(w, tr), na.rm = TRUE) 30 | plot(seqw, tr, ylim = ylim, axes = FALSE, xlab = "", ylab = "", 31 | type = "l", ...) 32 | if (axes) 33 | axis(2, ...) 34 | for (i in seqw) segments(i, tr, i, w[i]) 35 | pos <- ifelse(w < tr, 1, 3) 36 | pos[is.na(pos)] <- 1 37 | text(seqw, w, labels = names(n), pos = pos, srt = 0, 38 | xpd = TRUE, ...) 39 | } 40 | } 41 | 42 | -------------------------------------------------------------------------------- /R/MOStest.R: -------------------------------------------------------------------------------- 1 | `MOStest` <- 2 | function(x, y, interval, ...) 3 | { 4 | if (!missing(interval)) 5 | interval <- sort(interval) 6 | x <- eval(x) 7 | m0 <- glm(y ~ x + I(x^2), ...) 8 | k <- coef(m0) 9 | isHump <- unname(k[3] < 0) 10 | hn <- if(isHump) "hump" else "pit" 11 | hump <- unname(-k[2]/2/k[3]) 12 | if (missing(interval)) 13 | p1 <- min(x) 14 | else 15 | p1 <- interval[1] 16 | if (missing(interval)) 17 | p2 <- max(x) 18 | else 19 | p2 <- interval[2] 20 | test <- if (m0$family$family %in% c("binomial", "poisson")) "Chisq" else "F" 21 | tmp <- glm(y ~ I(x^2 - 2*x*p1), ...) 22 | ## Chisq test has one column less than F test: extract statistic 23 | ## and its P value 24 | statmin <- anova(tmp, m0, test = test)[2, (5:6) - (test == "Chisq")] 25 | tmp <- glm(y ~ I(x^2 - 2*x*p2), ...) 26 | statmax <- anova(tmp, m0, test = test)[2, (5:6) - (test == "Chisq")] 27 | comb <- 1 - (1-statmin[2])*(1-statmax[2]) 28 | comb <- unlist(comb) 29 | stats <- rbind(statmin, statmax) 30 | rownames(stats) <- paste(hn, c("at min", "at max")) 31 | stats <- cbind("min/max" = c(p1,p2), stats) 32 | stats <- rbind(stats, "Combined" = c(NA, NA, comb)) 33 | vec <- c(p1, p2, hump) 34 | names(vec) <- c("min", "max", hn) 35 | vec <- sort(vec) 36 | isBracketed <- names(vec)[2] == hn 37 | out <- list(isHump = isHump, isBracketed = isBracketed, 38 | hump = vec, family = family(m0), coefficients = stats, 39 | mod = m0) 40 | class(out) <- "MOStest" 41 | out 42 | } 43 | -------------------------------------------------------------------------------- /R/rda.default.R: -------------------------------------------------------------------------------- 1 | `rda.default` <- 2 | function (X, Y = NULL, Z = NULL, scale = FALSE, ...) 3 | { 4 | ## Protect against grave misuse: some people have used 5 | ## dissimilarities instead of data 6 | if (inherits(X, "dist") || NCOL(X) == NROW(X) && 7 | isTRUE(all.equal(X, t(X)))) 8 | stop("function cannot be used with (dis)similarities") 9 | X <- as.matrix(X, rownames.force = TRUE) 10 | if (!is.null(Y)) { 11 | if (is.data.frame(Y) || is.factor(Y)) { # save Y for centroids 12 | mframe <- as.data.frame(Y) # can be a single factor 13 | Y <- model.matrix(~ ., as.data.frame(Y))[,-1,drop=FALSE] 14 | } 15 | Y <- as.matrix(Y) 16 | } 17 | if (!is.null(Z)) { 18 | if (is.data.frame(Z) || is.factor(Z)) 19 | Z <- model.matrix(~ ., as.data.frame(Z))[,-1,drop=FALSE] 20 | Z <- as.matrix(Z) 21 | } 22 | 23 | sol <- ordConstrained(X, Y, Z, arg = scale, method = "rda") 24 | ## mframe exists only if function was called rda(X, mframe) 25 | if (exists("mframe")) 26 | sol$CCA$centroids <- getCentroids(sol, mframe) 27 | 28 | call <- match.call() 29 | call[[1]] <- as.name("rda") 30 | sol$call <- call 31 | inertia <- if (scale) "correlations" else "variance" 32 | sol <- c(sol, 33 | list("inertia" = inertia)) 34 | ## package klaR also has rda(): add a warning text that will be 35 | ## printed if vegan::rda object is displayed with klaR:::print.rda 36 | sol$regularization <- "this is a vegan::rda result object" 37 | class(sol) <- c("rda", "cca") 38 | sol 39 | } 40 | -------------------------------------------------------------------------------- /R/diversity.R: -------------------------------------------------------------------------------- 1 | `diversity` <- 2 | function (x, index = "shannon", groups, equalize.groups = FALSE, 3 | MARGIN = 1, base = exp(1)) 4 | { 5 | x <- drop(as.matrix(x, rownames.force = TRUE)) 6 | if (!is.numeric(x)) 7 | stop("input data must be numeric") 8 | if (any(x < 0, na.rm = TRUE)) 9 | stop("input data must be non-negative") 10 | ## sum communities for groups 11 | if (!missing(groups)) { 12 | if (MARGIN == 2) 13 | x <- t(x) 14 | if (length(groups) == 1) # total for all SU 15 | groups <- rep(groups, NROW(x)) 16 | if (equalize.groups) 17 | x <- decostand(x, "total") 18 | x <- aggregate(x, list(groups), sum) # pool SUs by groups 19 | rownames(x) <- x[,1] 20 | x <- x[,-1, drop=FALSE] 21 | if (MARGIN == 2) 22 | x <- t(x) 23 | } 24 | INDICES <- c("shannon", "simpson", "invsimpson") 25 | index <- match.arg(index, INDICES) 26 | if (length(dim(x)) > 1) { 27 | total <- apply(x, MARGIN, sum) 28 | x <- sweep(x, MARGIN, total, "/") 29 | } else { 30 | x <- x/(total <- sum(x)) 31 | } 32 | if (index == "shannon") 33 | x <- -x * log(x, base) 34 | else 35 | x <- x*x 36 | if (length(dim(x)) > 1) 37 | H <- apply(x, MARGIN, sum, na.rm = TRUE) 38 | else 39 | H <- sum(x, na.rm = TRUE) 40 | if (index == "simpson") 41 | H <- 1 - H 42 | else if (index == "invsimpson") 43 | H <- 1/H 44 | ## check NA in data 45 | if (any(NAS <- is.na(total))) 46 | H[NAS] <- NA 47 | H 48 | } 49 | -------------------------------------------------------------------------------- /R/toCoda.R: -------------------------------------------------------------------------------- 1 | `toCoda` <- 2 | function(x) UseMethod("toCoda") 3 | 4 | `toCoda.oecosimu` <- 5 | function(x) 6 | { 7 | ## mcmc only for sequential methods 8 | if (!x$oecosimu$isSeq) 9 | stop("'toCoda' is only available for sequential null models") 10 | ## named variables 11 | rownames(x$oecosimu$simulated) <- names(x$oecosimu$z) 12 | chains <- attr(x$oecosimu$simulated, "chains") 13 | ## chains: will make each chain as an mcmc object and combine 14 | ## these to an mcmc.list 15 | if (!is.null(chains) && chains > 1) { 16 | x <- x$oecosimu$simulated 17 | nsim <- dim(x)[2] 18 | niter <- nsim / chains 19 | ## iterate over chains 20 | x <- lapply(1:chains, function(i) { 21 | z <- x[, ((i-1) * niter + 1):(i * niter), drop = FALSE] 22 | attr(z, "mcpar") <- 23 | c(attr(x, "burnin") + attr(x, "thin"), 24 | attr(x, "burnin") + attr(x, "thin") * niter, 25 | attr(x, "thin")) 26 | attr(z, "class") <- c("mcmc", class(z)) 27 | t(z) 28 | }) 29 | ## combine list of mcmc objects to a coda mcmc.list 30 | #x <- as.mcmc.list(x) 31 | class(x) <- "mcmc.list" 32 | } else { # one chain: make to a single mcmc object 33 | x <- as.ts(x) 34 | mcpar <- attr(x, "tsp") 35 | mcpar[3] <- round(1/mcpar[3]) 36 | attr(x, "mcpar") <- mcpar 37 | class(x) <- c("mcmc", class(x)) 38 | } 39 | x 40 | } 41 | 42 | `toCoda.permat` <- toCoda.oecosimu 43 | -------------------------------------------------------------------------------- /R/treedist.R: -------------------------------------------------------------------------------- 1 | `treedist` <- 2 | function(x, tree, relative = TRUE, match.force = TRUE, ...) 3 | { 4 | ## we cannot reconstruct tree with reversals from cophenetic 5 | tree <- as.hclust(tree) 6 | if (any(diff(tree$height) < -sqrt(.Machine$double.eps))) 7 | stop("tree with reversals cannot be handled") 8 | x <- as.matrix(x, rownames.force = TRUE) 9 | n <- nrow(x) 10 | ABJ <- matrix(0, n , n) 11 | dmat <- as.matrix(cophenetic(tree)) 12 | ## match names 13 | if (ncol(x) != ncol(dmat) || match.force) { 14 | if(!match.force) 15 | warning("dimensions do not match between 'x' and 'tree': matching by names") 16 | nm <- colnames(x) 17 | dmat <- dmat[nm, nm] 18 | } 19 | for(j in 1:n) { 20 | for (k in j:n) { 21 | jk <- x[j,] > 0 | x[k,] > 0 22 | if (sum(jk) > 1) 23 | ABJ[k, j] <- treeheight(update(tree, d = as.dist(dmat[jk, jk]))) 24 | } 25 | } 26 | A <- diag(ABJ) 27 | AB <- as.dist(outer(A, A, "+")) 28 | ABJ <- as.dist(ABJ) 29 | out <- (2 * ABJ - AB) 30 | if (relative) 31 | out <- out/ABJ 32 | out[ABJ==0] <- 0 33 | attr(out, "method") <- if (relative) "treedist" else "raw treeedist" 34 | attr(out, "call") <- match.call() 35 | attr(out, "Labels") <- row.names(x) 36 | ## if (relative) theoretical maximum is 2, but that is only 37 | ## achieved when two zero-height trees (only one species) are 38 | ## combined into above zero-height tree (two species), and 39 | ## therefore we set here NA (but this can be reconsidered). 40 | attr(out, "maxdist") <- NA 41 | out 42 | } 43 | -------------------------------------------------------------------------------- /R/make.cepnames.R: -------------------------------------------------------------------------------- 1 | `make.cepnames` <- 2 | function (names, minlengths = c(4,4), seconditem = FALSE, 3 | uniqgenera = FALSE, named = FALSE, method) 4 | { 5 | if (named) 6 | orignames <- names 7 | ## do not split by hyphens, but collapse hyphened names 8 | names <- gsub("-", "", names) 9 | ## make valid names 10 | names <- make.names(names, unique = FALSE, allow_ = FALSE) 11 | ## remove trailing and duplicated dots 12 | names <- gsub("\\.[\\.]+", ".", names) 13 | names <- gsub("\\.$", "", names) 14 | ## split by dots and get genus and epithet 15 | names <- strsplit(names, ".", fixed = TRUE) 16 | gen <- sapply(names, function(x) x[1]) 17 | epi <- sapply(names, 18 | function(x) {if (seconditem) x[2] 19 | else if (length(x) > 1) x[length(x)] else ""}) 20 | ## strict=TRUE always takes given minlength even if these are duplicates 21 | glen <- minlengths[1] 22 | nmlen <- sum(minlengths) 23 | if (missing(method)) 24 | method <- "left.kept" 25 | gen <- ifelse(epi != "", 26 | abbreviate(abbreviate(gen, glen, use.classes = FALSE, 27 | strict = !uniqgenera), 28 | glen, use.classes = TRUE, method = method), 29 | gen) 30 | names <- abbreviate(paste0(gen, epi), nmlen, use.classes = FALSE) 31 | ## try to remove wovels if names > nmlen 32 | names <- abbreviate(names, nmlen, use.classes = TRUE, method = method, 33 | named = FALSE) 34 | if (named) 35 | names(names) <- orignames 36 | names 37 | } 38 | -------------------------------------------------------------------------------- /R/ordimedian.R: -------------------------------------------------------------------------------- 1 | ## Ordimedian finds the spatial medians for groups. Spatial medians 2 | ## are L1 norms or statistics that minimize sum of distances of points 3 | ## from the statistic and 1d they are the medians. The current 4 | ## algorithm minimizes the L1 norm with optim and is pretty 5 | ## inefficient. Package ICSNP has a better algorithm (and we may steal 6 | ## it from them later). 7 | `ordimedian` <- 8 | function(ord, groups, display = "sites", label = FALSE, ...) 9 | { 10 | ## Sum of distances from the statistic 11 | medfun <- 12 | function(x, ord) sum(sqrt(rowSums(sweep(ord, 2, x)^2)), 13 | na.rm = TRUE) 14 | ## derivative of medfun (if NULL, optim will use numerical 15 | ## differentiation) 16 | dmedfun <- function(x, ord) { 17 | up <- -sweep(ord, 2, x) 18 | dn <- sqrt(rowSums(sweep(ord, 2, x)^2)) 19 | colSums(sweep(up, 1, dn, "/")) 20 | } 21 | #dmedfun <- NULL 22 | pts <- scores(ord, display = display, ...) 23 | inds <- names(table(groups)) 24 | medians <- matrix(NA, nrow = length(inds), ncol = ncol(pts)) 25 | rownames(medians) <- inds 26 | colnames(medians) <- colnames(pts) 27 | for (i in inds) { 28 | X <- pts[groups == i, , drop = FALSE] 29 | if (NROW(X) > 0) 30 | medians[i, ] <- optim(apply(X, 2, median, na.rm = TRUE), 31 | fn = medfun, gr = dmedfun, 32 | ord = X, method = "BFGS")$par 33 | if(label) 34 | ordiArgAbsorber(medians[i,1], medians[i,2], label = i, 35 | FUN = text, ...) 36 | } 37 | invisible(medians) 38 | } 39 | -------------------------------------------------------------------------------- /R/procrustes.R: -------------------------------------------------------------------------------- 1 | `procrustes` <- 2 | function (X, Y, scale = TRUE, symmetric = FALSE, scores = "sites", ...) 3 | { 4 | X <- scores(X, display = scores, ...) 5 | Y <- scores(Y, display = scores, ...) 6 | if (nrow(X) != nrow(Y)) 7 | stop(gettextf("matrices have different number of rows: %d and %d", 8 | nrow(X), nrow(Y))) 9 | if (ncol(X) < ncol(Y)) { 10 | warning("X has fewer axes than Y: X adjusted to comform Y\n") 11 | addcols <- ncol(Y) - ncol(X) 12 | for (i in 1:addcols) X <- cbind(X, 0) 13 | } 14 | ctrace <- function(MAT) sum(MAT^2) 15 | c <- 1 16 | if (symmetric) { 17 | X <- scale(X, scale = FALSE) 18 | Y <- scale(Y, scale = FALSE) 19 | X <- X/sqrt(ctrace(X)) 20 | Y <- Y/sqrt(ctrace(Y)) 21 | } 22 | xmean <- apply(X, 2, mean) 23 | ymean <- apply(Y, 2, mean) 24 | if (!symmetric) { 25 | X <- scale(X, scale = FALSE) 26 | Y <- scale(Y, scale = FALSE) 27 | } 28 | XY <- crossprod(X, Y) 29 | sol <- svd(XY) 30 | A <- sol$v %*% t(sol$u) 31 | if (scale) { 32 | c <- sum(sol$d)/ctrace(Y) 33 | } 34 | Yrot <- c * Y %*% A 35 | ## Translation (b) needs scale (c) although Mardia et al. do not 36 | ## have this. Reported by Christian Dudel. 37 | b <- xmean - c * ymean %*% A 38 | R2 <- ctrace(X) + c * c * ctrace(Y) - 2 * c * sum(sol$d) 39 | reslt <- list(Yrot = Yrot, X = X, ss = R2, rotation = A, 40 | translation = b, scale = c, xmean = xmean, 41 | symmetric = symmetric, call = match.call()) 42 | reslt$svd <- sol 43 | class(reslt) <- "procrustes" 44 | reslt 45 | } 46 | -------------------------------------------------------------------------------- /R/getPermuteMatrix.R: -------------------------------------------------------------------------------- 1 | ### Interface to the permute package 2 | 3 | ### input can be (1) a single number giving the number of 4 | ### permutations, (2) a how() structure for control parameter in 5 | ### permute::shuffleSet, or (3) a permutation matrix which is returned 6 | ### as is. In addition, there can be a 'strata' argument which will 7 | ### modify case (1). The number of shuffled items must be given in 'N'. 8 | 9 | `getPermuteMatrix` <- 10 | function(perm, N, strata = NULL) 11 | { 12 | ## 'perm' is either a single number, a how() structure or a 13 | ## permutation matrix 14 | if (length(perm) == 1) { 15 | perm <- how(nperm = perm) 16 | } 17 | ## apply 'strata', but only if possible: ignore silently other cases 18 | if (!missing(strata) && !is.null(strata)) { 19 | if (inherits(perm, "how") && is.null(getBlocks(perm))) 20 | setBlocks(perm) <- strata 21 | } 22 | ## now 'perm' is either a how() or a matrix 23 | if (inherits(perm, "how")) 24 | perm <- shuffleSet(N, control = perm) 25 | else { # matrix: check that it *strictly* integer 26 | if(!is.integer(perm) && !all(perm == round(perm))) 27 | stop("permutation matrix must be strictly integers: use round()") 28 | } 29 | ## now 'perm' is a matrix (or always was). If it is a plain 30 | ## matrix, set minimal attributes for printing. This is a dirty 31 | ## kluge: should be handled more cleanly. 32 | if (is.null(attr(perm, "control"))) 33 | attr(perm, "control") <- 34 | structure(list(within=list(type="supplied matrix"), 35 | nperm = nrow(perm)), class = "how") 36 | perm 37 | } 38 | -------------------------------------------------------------------------------- /R/plot.nestedtemp.R: -------------------------------------------------------------------------------- 1 | ### plot() methods for those nested* functions that return sufficient 2 | ### data to draw a plot. We display a plot using image() with coloured 3 | ### rectangles for occurrences or colours dependent on the 4 | ### contribution to the nestedness when appropriate. 5 | 6 | `plot.nestedtemp` <- 7 | function (x, kind = c("temperature", "incidence"), 8 | col = rev(heat.colors(100)), names = FALSE, 9 | ...) 10 | { 11 | kind <- match.arg(kind) 12 | if (kind == "temperature") 13 | z <- x$u 14 | else z <- x$comm 15 | z <- t(z[nrow(z):1, ]) 16 | image(z, axes = FALSE, col = col, ...) 17 | box() 18 | lines(x$smooth$x, 1 - x$smooth$y) 19 | if (length(names) == 1) 20 | names <- rep(names, 2) 21 | if (names[1]) { 22 | axis(2, at = seq(1, 0, len = nrow(x$u)), labels = rownames(x$u), 23 | las = 2, ...) 24 | } 25 | if (names[2]) { 26 | axis(3, at = seq(0, 1, len = ncol(x$u)), labels = colnames(x$u), 27 | las = 2, ...) 28 | } 29 | } 30 | 31 | `plot.nestednodf` <- 32 | function(x, col = "red", names = FALSE, ...) 33 | { 34 | z <- x$comm 35 | z <- t(z[nrow(z):1,]) 36 | if (length(col) == 1) 37 | col <- c(NA, col) 38 | image(z, axes = FALSE, col = col, ...) 39 | box() 40 | if (length(names) == 1) 41 | names <- rep(names, 2) 42 | if (names[1]) { 43 | axis(2, at = seq(1, 0, len = ncol(z)), labels = rev(colnames(z)), 44 | las = 2, ...) 45 | } 46 | if (names[2]) { 47 | axis(3, at = seq(0, 1, len = nrow(z)), labels = rownames(z), 48 | las = 2, ...) 49 | } 50 | } 51 | -------------------------------------------------------------------------------- /R/tsallis.R: -------------------------------------------------------------------------------- 1 | `tsallis` <- 2 | function (x, scales = seq(0, 2, 0.2), norm=FALSE, hill=FALSE) 3 | { 4 | if (norm && hill) 5 | stop("'norm = TRUE' and 'hill = TRUE' should not be used at the same time") 6 | x <- as.matrix(x) 7 | if (!is.numeric(x)) 8 | stop("input data must be numeric") 9 | n <- nrow(x) 10 | p <- ncol(x) 11 | if (p == 1) { 12 | x <- t(x) 13 | n <- nrow(x) 14 | p <- ncol(x) 15 | } 16 | x <- decostand(x, "total", 1) 17 | m <- length(scales) 18 | result <- array(0, dim = c(n, m)) 19 | dimnames(result) <- list(sites = rownames(x), scale = scales) 20 | for (a in 1:m) { 21 | if (scales[a] != 1 && scales[a] != 0) { 22 | result[, a] <- (1-(rowSums(x^scales[a])))/(scales[a] - 1) 23 | } 24 | else { 25 | if (scales[a] == 1) result[, a] <- diversity(x, "shannon") 26 | if (scales[a] == 0) result[, a] <- rowSums(x > 0) - 1 27 | } 28 | if (norm) { 29 | ST <- rowSums(x > 0) 30 | if (scales[a] == 1) result[, a] <- result[, a] / log(ST) 31 | else result[, a] <- result[, a] / ((ST^(1-scales[a]) - 1) / (1 - scales[a])) 32 | } 33 | if (hill) { 34 | result[, a] <- if (scales[a] == 1) { 35 | exp(result[, a]) 36 | } else { 37 | (1 - (scales[a] - 1) * result[, a])^(1/(1-scales[a])) 38 | } 39 | } 40 | } 41 | result <- as.data.frame(result) 42 | if (any(dim(result) == 1)) 43 | result <- unlist(result, use.names = TRUE) 44 | class(result) <- c("tsallis", "renyi", class(result)) 45 | result 46 | } 47 | --------------------------------------------------------------------------------