[Vegan-commits] r1110 - in branches/1.17: R inst
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Jan 8 17:44:52 CET 2010
Author: psolymos
Date: 2010-01-08 17:44:52 +0100 (Fri, 08 Jan 2010)
New Revision: 1110
Removed:
branches/1.17/R/multipart.R
branches/1.17/R/print.multipart.R
Modified:
branches/1.17/inst/ChangeLog
branches/1.17/inst/NEWS
Log:
multipart removed
Deleted: branches/1.17/R/multipart.R
===================================================================
--- branches/1.17/R/multipart.R 2010-01-08 13:59:41 UTC (rev 1109)
+++ branches/1.17/R/multipart.R 2010-01-08 16:44:52 UTC (rev 1110)
@@ -1,139 +0,0 @@
-multipart <-
-function(formula, data, index=c("renyi", "tsallis"), scales = 1,
- global = FALSE, relative = FALSE, nsimul=99, ...)
-{
- if (length(scales) > 1)
- stop("length of 'scales' must be 1")
- ## evaluate formula
- lhs <- formula[[2]]
- if (missing(data))
- data <- parent.frame()
- lhs <- as.matrix(eval(lhs, data))
- formula[[2]] <- NULL
- rhs <- model.frame(formula, data, drop.unused.levels = TRUE)
- tlab <- attr(attr(rhs, "terms"), "term.labels")
- nlevs <- length(tlab)
- if (nlevs < 2)
- stop("provide at least two level hierarchy")
- if (any(rowSums(lhs) == 0))
- stop("data matrix contains empty rows")
- if (any(lhs < 0))
- stop("data matrix contains negative entries")
-
- ## part check proper design of the model frame
- noint <- attr(attr(attr(rhs, "terms"), "factors"), "dimnames")[[1]]
- int <- attr(attr(attr(rhs, "terms"), "factors"), "dimnames")[[2]]
- if (!identical(noint, int))
- stop("interactions are not allowed in formula")
- if (!all(attr(attr(rhs, "terms"), "dataClasses") == "factor"))
- stop("all right hand side variables in formula must be factors")
- l1 <- sapply(rhs, function(z) length(unique(z)))
- if (!any(sapply(2:nlevs, function(z) l1[z] <= l1[z-1])))
- stop("number of levels are inapropriate, check sequence")
- rval <- list()
- rval[[1]] <- as.factor(rhs[,nlevs])
- rval[[1]] <- rval[[1]][drop = TRUE]
- nCol <- nlevs - 1
- for (i in 2:nlevs) {
- rval[[i]] <- interaction(rhs[,nCol], rval[[(i-1)]], drop=TRUE)
- nCol <- nCol - 1
- }
- rval <- as.data.frame(rval[rev(1:length(rval))])
- l2 <- sapply(rval, function(z) length(unique(z)))
- if (any(l1 != l2))
- warning("levels are not perfectly nested")
-
- ## aggregate response matrix
- fullgamma <-if (nlevels(rhs[,nlevs]) == 1)
- TRUE else FALSE
-# if (!fullgamma && !global)
-# warning("gamma diversity value might be meaningless")
- ftmp <- vector("list", nlevs)
- for (i in 1:nlevs) {
- ftmp[[i]] <- as.formula(paste("~", tlab[i], "- 1"))
- }
-
- ## is there a method/burnin/thin in ... ?
- method <- if (is.null(list(...)$method))
- "r2dtable" else list(...)$method
- burnin <- if (is.null(list(...)$burnin))
- 0 else list(...)$burnin
- thin <- if (is.null(list(...)$thin))
- 1 else list(...)$thin
-
- ## evaluate other arguments
- index <- match.arg(index)
- divfun <- switch(index,
- "renyi" = function(x) renyi(x, scales=scales, hill = TRUE),
- "tsallis" = function(x) tsallis(x, scales=scales, hill = TRUE))
-
- ## cluster membership determination
- nrhs <- rhs
- nrhs <- sapply(nrhs, as.numeric)
- idcl <- function(i) {
- h <- nrhs[,i]
- l <- nrhs[,(i-1)]
- sapply(unique(l), function(i) h[l==i][1])
- }
- id <- lapply(2:nlevs, idcl)
-
- ## this is the function passed to oecosimu
- if (global) {
- wdivfun <- function(x) {
- if (fullgamma) {
- tmp <- lapply(1:(nlevs-1), function(i) t(model.matrix(ftmp[[i]], rhs)) %*% x)
- tmp[[nlevs]] <- matrix(colSums(lhs), nrow = 1, ncol = ncol(lhs))
- } else {
- tmp <- lapply(1:nlevs, function(i) t(model.matrix(ftmp[[i]], rhs)) %*% x)
- }
- raw <- sapply(1:nlevs, function(i) divfun(tmp[[i]]))
- a <- sapply(raw, mean)
- G <- a[nlevs]
- b <- sapply(1:(nlevs-1), function(i) G / a[i])
- if (relative)
- b <- b / sapply(raw[1:(nlevs-1)], length)
- c(a, b)
- }
- } else {
- wdivfun <- function(x) {
- if (fullgamma) {
- tmp <- lapply(1:(nlevs-1), function(i) t(model.matrix(ftmp[[i]], rhs)) %*% x)
- tmp[[nlevs]] <- matrix(colSums(lhs), nrow = 1, ncol = ncol(lhs))
- } else {
- tmp <- lapply(1:nlevs, function(i) t(model.matrix(ftmp[[i]], rhs)) %*% x)
- }
- a <- sapply(1:nlevs, function(i) divfun(tmp[[i]]))
- am <- lapply(1:(nlevs-1), function(i) {
- sapply(1:length(unique(id[[i]])), function(ii) {
- mean(a[[i]][id[[i]]==ii])
- })
- })
- b <- lapply(1:(nlevs-1), function(i) a[[(i+1)]] / am[[i]])
- bmax <- lapply(id, function(i) table(i))
- if (relative)
- b <- lapply(1:(nlevs-1), function(i) b[[i]] / bmax[[i]])
- c(sapply(a, mean), sapply(b, mean))
- }
- }
- if (nsimul > 0) {
- sim <- oecosimu(lhs, wdivfun, method = method, nsimul=nsimul,
- burnin=burnin, thin=thin)
- } else {
- sim <- wdivfun(lhs)
- tmp <- rep(NA, length(sim))
- sim <- list(statistic = sim,
- oecosimu = list(z = tmp, pval = tmp, method = NA, statistic = sim))
- }
- nam <- c(paste("alpha", 1:(nlevs-1), sep="."), "gamma",
- paste("beta", 1:(nlevs-1), sep="."))
- names(sim$statistic) <- attr(sim$oecosimu$statistic, "names") <- nam
- attr(sim, "call") <- match.call()
- attr(sim, "index") <- index
- attr(sim, "scales") <- scales
- attr(sim, "global") <- TRUE
- attr(sim, "n.levels") <- nlevs
- attr(sim, "terms") <- tlab
- attr(sim, "model") <- rhs
- class(sim) <- c("multipart", "list")
- sim
-}
Deleted: branches/1.17/R/print.multipart.R
===================================================================
--- branches/1.17/R/print.multipart.R 2010-01-08 13:59:41 UTC (rev 1109)
+++ branches/1.17/R/print.multipart.R 2010-01-08 16:44:52 UTC (rev 1110)
@@ -1,27 +0,0 @@
-print.multipart <-
-function(x, ...)
-{
- n <- if (is.null(x$oecosimu$simulated))
- 0 else ncol(x$oecosimu$simulated)
- cat("multipart with", n, "simulations\n")
- att <- attributes(x)
- att$names <- att$call <- att$class <- att$n.levels <- att$terms <- att$model <- NULL
- cat("with", paste(names(att), att, collapse=", "))
- cat("\n\n")
- cl <- class(x)
- if (length(cl) > 1 && cl[2] != "list") {
- NextMethod("print", x)
- cat("\n")
- }
- if (!is.null(x$oecosimu$simulated)) {
- tmp <- x$oecosimu$simulated
- } else {
- tmp <- data.matrix(x$oecosimu$statistic)
- }
- qu <- apply(tmp, 1, quantile, probs=c(0.025, 0.5, 0.975))
- m <- cbind("statistic" = x$oecosimu$statistic,
- "z" = x$oecosimu$z, t(qu),
- "Pr(sim.)"=x$oecosimu$pval)
- printCoefmat(m, ...)
- invisible(x)
-}
Modified: branches/1.17/inst/ChangeLog
===================================================================
--- branches/1.17/inst/ChangeLog 2010-01-08 13:59:41 UTC (rev 1109)
+++ branches/1.17/inst/ChangeLog 2010-01-08 16:44:52 UTC (rev 1110)
@@ -12,6 +12,8 @@
* removed MOStest.
+ * removed multipart.
+
VEGAN DEVEL VERSIONS at http://r-forge.r-project.org/
Version 1.16-34 (closed January 2, 2010) -- (codename: Lucia)
Modified: branches/1.17/inst/NEWS
===================================================================
--- branches/1.17/inst/NEWS 2010-01-08 13:59:41 UTC (rev 1109)
+++ branches/1.17/inst/NEWS 2010-01-08 16:44:52 UTC (rev 1110)
@@ -7,12 +7,12 @@
- Guillaume Blanchet joined the vegan team.
- - New functions to partition data-set diversity (gamma) into
+ - New function to partition data-set diversity (gamma) into
within-plot (alpha) and between-plot (beta) diversity
- components. Function multipart performs multiplicative
- partitioning (gamma = alpha*beta), and function adipart additive
+ components. Function adipart performs additive
partitioning (gamma = alpha + beta). Function hiersimu performs
- hierarchical null model testing for adipart.
+ hierarchical null model testing similar to adipart but by using
+ custom function to calculate statistics for levels of a hierarchy.
- Subsets and missing value handling added to constrained
ordination methods cca(), rda() and capscale(). The missing
More information about the Vegan-commits
mailing list