From noreply at r-forge.r-project.org Mon Aug 18 16:19:53 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 18 Aug 2014 16:19:53 +0200 (CEST) Subject: [Vegan-commits] r2874 - in pkg/vegan: R inst Message-ID: <20140818141953.9C248186941@r-forge.r-project.org> Author: gsimpson Date: 2014-08-18 16:19:53 +0200 (Mon, 18 Aug 2014) New Revision: 2874 Modified: pkg/vegan/R/simper.R pkg/vegan/inst/ChangeLog Log: make simper work with single-member groups; make some of the loop counters robust Modified: pkg/vegan/R/simper.R =================================================================== --- pkg/vegan/R/simper.R 2014-06-06 13:00:16 UTC (rev 2873) +++ pkg/vegan/R/simper.R 2014-08-18 14:19:53 UTC (rev 2874) @@ -6,12 +6,14 @@ warning("you have empty rows: results may be meaningless") pfun <- function(x, comm, comp, i, contrp) { groupp <- group[perm[x,]] - ga <- comm[groupp == comp[i, 1], ] - gb <- comm[groupp == comp[i, 2], ] - for(j in 1:n.b) { - for(k in 1:n.a) { - mdp <- abs(ga[k, ] - gb[j, ]) - mep <- ga[k, ] + gb[j, ] + ga <- comm[groupp == comp[i, 1], , drop = FALSE] + gb <- comm[groupp == comp[i, 2], , drop = FALSE] + n.a <- nrow(ga) + n.b <- nrow(gb) + for(j in seq_len(n.b)) { + for(k in seq_len(n.a)) { + mdp <- abs(ga[k, , drop = FALSE] - gb[j, , drop = FALSE]) + mep <- ga[k, , drop = FALSE] + gb[j, , drop = FALSE] contrp[(j-1)*n.a+k, ] <- mdp / sum(mep) } } @@ -46,16 +48,16 @@ if (isParal && !isMulticore && !hasClus) { parallel <- makeCluster(parallel) } - for (i in 1:nrow(comp)) { - group.a <- comm[group == comp[i, 1], ] - group.b <- comm[group == comp[i, 2], ] + for (i in seq_len(nrow(comp))) { + group.a <- comm[group == comp[i, 1], , drop = FALSE] + group.b <- comm[group == comp[i, 2], , drop = FALSE] n.a <- nrow(group.a) n.b <- nrow(group.b) contr <- matrix(ncol = P, nrow = n.a * n.b) - for (j in 1:n.b) { - for (k in 1:n.a) { - md <- abs(group.a[k, ] - group.b[j, ]) - me <- group.a[k, ] + group.b[j, ] + for (j in seq_len(n.b)) { + for (k in seq_len(n.a)) { + md <- abs(group.a[k, , drop = FALSE] - group.b[j, , drop = FALSE]) + me <- group.a[k, , drop = FALSE] + group.b[j, , drop = FALSE] contr[(j-1)*n.a+k, ] <- md / sum(me) } } @@ -69,11 +71,11 @@ if (isParal) { if (isMulticore){ - perm.contr <- mclapply(1:nperm, function(d) + perm.contr <- mclapply(seq_len(nperm), function(d) pfun(d, comm, comp, i, contrp), mc.cores = parallel) perm.contr <- do.call(cbind, perm.contr) } else { - perm.contr <- parSapply(parallel, 1:nperm, function(d) + perm.contr <- parSapply(parallel, seq_len(npmer), function(d) pfun(d, comm, comp, i, contrp)) } } else { Modified: pkg/vegan/inst/ChangeLog =================================================================== --- pkg/vegan/inst/ChangeLog 2014-06-06 13:00:16 UTC (rev 2873) +++ pkg/vegan/inst/ChangeLog 2014-08-18 14:19:53 UTC (rev 2874) @@ -128,6 +128,9 @@ specified through formal arguments `col` and `lty`. Incidental wish of http://stackoverflow.com/q/22714775/429846. + * simper: now doesn't fail with obscure error when groups have a + single member. + Version 2.1-40 (closed December 12, 2013) * anova.cca: Function is now based on the new code, but the old is From noreply at r-forge.r-project.org Tue Aug 19 05:11:48 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 19 Aug 2014 05:11:48 +0200 (CEST) Subject: [Vegan-commits] r2875 - pkg/vegan/R Message-ID: <20140819031148.D6927183FEF@r-forge.r-project.org> Author: gsimpson Date: 2014-08-19 05:11:48 +0200 (Tue, 19 Aug 2014) New Revision: 2875 Modified: pkg/vegan/R/simper.R Log: fix a typo in part of the fix to r2874 Modified: pkg/vegan/R/simper.R =================================================================== --- pkg/vegan/R/simper.R 2014-08-18 14:19:53 UTC (rev 2874) +++ pkg/vegan/R/simper.R 2014-08-19 03:11:48 UTC (rev 2875) @@ -75,7 +75,7 @@ pfun(d, comm, comp, i, contrp), mc.cores = parallel) perm.contr <- do.call(cbind, perm.contr) } else { - perm.contr <- parSapply(parallel, seq_len(npmer), function(d) + perm.contr <- parSapply(parallel, seq_len(nperm), function(d) pfun(d, comm, comp, i, contrp)) } } else { From noreply at r-forge.r-project.org Mon Aug 25 12:34:01 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 25 Aug 2014 12:34:01 +0200 (CEST) Subject: [Vegan-commits] r2876 - pkg/vegan/R Message-ID: <20140825103401.8A6F51872D5@r-forge.r-project.org> Author: jarioksa Date: 2014-08-25 12:34:01 +0200 (Mon, 25 Aug 2014) New Revision: 2876 Modified: pkg/vegan/R/nestednodf.R Log: Merge pull request #23 from mattbarbour34/master changed >= to > in N.paired.rows and cols calc. Modified: pkg/vegan/R/nestednodf.R =================================================================== --- pkg/vegan/R/nestednodf.R 2014-08-19 03:11:48 UTC (rev 2875) +++ pkg/vegan/R/nestednodf.R 2014-08-25 10:34:01 UTC (rev 2876) @@ -35,7 +35,7 @@ if (weighted) { second <- comm[j, ] N.paired.rows[counter] <- - sum(first - second >= 0 & second > 0)/sum(second > 0) + sum(first - second > 0 & second > 0)/sum(second > 0) } else { N.paired.rows[counter] <- @@ -53,7 +53,7 @@ if (weighted) { second <- comm[, j] N.paired.cols[counter] <- - sum(first - second >= 0 & second > 0)/sum(second > 0) + sum(first - second > 0 & second > 0)/sum(second > 0) } else { N.paired.cols[counter] <- From noreply at r-forge.r-project.org Thu Aug 28 10:50:50 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 28 Aug 2014 10:50:50 +0200 (CEST) Subject: [Vegan-commits] r2877 - in pkg/vegan: R man Message-ID: <20140828085050.645F9183AE7@r-forge.r-project.org> Author: jarioksa Date: 2014-08-28 10:50:50 +0200 (Thu, 28 Aug 2014) New Revision: 2877 Modified: pkg/vegan/R/betadisper.R pkg/vegan/R/biplot.CCorA.R pkg/vegan/R/bstick.cca.R pkg/vegan/R/decorana.R pkg/vegan/R/ordipointlabel.R pkg/vegan/R/ordispider.R pkg/vegan/R/ordisurf.R pkg/vegan/R/points.cca.R pkg/vegan/R/read.cep.R pkg/vegan/R/scores.default.R pkg/vegan/R/text.cca.R pkg/vegan/R/tolerance.cca.R pkg/vegan/man/dune.taxon.Rd Log: Merge branch 'master' into r-forge-svn-local Modified: pkg/vegan/R/betadisper.R =================================================================== --- pkg/vegan/R/betadisper.R 2014-08-25 10:34:01 UTC (rev 2876) +++ pkg/vegan/R/betadisper.R 2014-08-28 08:50:50 UTC (rev 2877) @@ -68,7 +68,7 @@ n <- n - sum(gr.na) ## update labels labs <- labs[!gr.na] - warning("Missing observations due to 'group' removed.") + warning("missing observations due to 'group' removed") } ## remove NA's in d if(any(x.na <- apply(x, 1, function(x) any(is.na(x))))) { @@ -78,7 +78,7 @@ n <- n - sum(x.na) ## update labels labs <- labs[!x.na] - warning("Missing observations due to 'd' removed.") + warning("missing observations due to 'd' removed") } x <- x + t(x) x <- dblcen(x) Modified: pkg/vegan/R/biplot.CCorA.R =================================================================== --- pkg/vegan/R/biplot.CCorA.R 2014-08-25 10:34:01 UTC (rev 2876) +++ pkg/vegan/R/biplot.CCorA.R 2014-08-28 08:50:50 UTC (rev 2877) @@ -22,11 +22,11 @@ epsilon <- sqrt(.Machine$double.eps) if(length(which(x$Eigenvalues > epsilon)) == 1) - stop("Plot of axes (", paste(plot.axes, collapse=","), - ") not drawn because the solution has a single dimension.") + stop("plot of axes (", paste(plot.axes, collapse=","), + ") not drawn because the solution has a single dimension") if(max(plot.axes) > length(which(x$Eigenvalues > epsilon))) - stop("Plot of axes (", paste(plot.axes, collapse=","), - ") not drawn because the solution has fewer dimensions.") + stop("plot of axes (", paste(plot.axes, collapse=","), + ") not drawn because the solution has fewer dimensions") if (missing(xlabs)) xlabs <- rownames(x$Cy) Modified: pkg/vegan/R/bstick.cca.R =================================================================== --- pkg/vegan/R/bstick.cca.R 2014-08-25 10:34:01 UTC (rev 2876) +++ pkg/vegan/R/bstick.cca.R 2014-08-28 08:50:50 UTC (rev 2877) @@ -4,7 +4,7 @@ if(!inherits(n, c("rda", "cca"))) stop("'n' not of class \"cca\" or \"rda\"") if(!is.null(n$CCA) && n$CCA$rank > 0) - stop("'bstick' only for unconstrained models.") + stop("'bstick' only for unconstrained models") ## No idea how to define bstick for capscale with negative ## eigenvalues if (inherits(n, "capscale") && !is.null(n$CA$imaginary.rank)) Modified: pkg/vegan/R/decorana.R =================================================================== --- pkg/vegan/R/decorana.R 2014-08-25 10:34:01 UTC (rev 2876) +++ pkg/vegan/R/decorana.R 2014-08-28 08:50:50 UTC (rev 2877) @@ -8,11 +8,11 @@ ZEROEIG <- 1e-7 # consider as zero eigenvalue veg <- as.matrix(veg) if (any(rowSums(veg) <= 0)) - stop("All row sums must be >0 in the community matrix: remove empty sites.") + stop("all row sums must be >0 in the community matrix: remove empty sites") if (any(veg < 0)) stop("'decorana' cannot handle negative data entries") if (any(colSums(veg) <= 0)) - warning("Some species were removed because they were missing in the data.") + warning("some species were removed because they were missing in the data") nr <- nrow(veg) nc <- ncol(veg) mk <- mk + 4 Modified: pkg/vegan/R/ordipointlabel.R =================================================================== --- pkg/vegan/R/ordipointlabel.R 2014-08-25 10:34:01 UTC (rev 2876) +++ pkg/vegan/R/ordipointlabel.R 2014-08-28 08:50:50 UTC (rev 2877) @@ -15,7 +15,7 @@ if(isTRUE(all.equal(length(display), 1L))) { xy[[1]] <- .checkSelect(select, xy[[1]]) } else { - warning("'select' does not apply when plotting more than one set of scores.\n'select' was ignored.") + warning("'select' does not apply when plotting more than one set of scores--\n'select' was ignored") } } if (length(display) > 1) { Modified: pkg/vegan/R/ordispider.R =================================================================== --- pkg/vegan/R/ordispider.R 2014-08-25 10:34:01 UTC (rev 2876) +++ pkg/vegan/R/ordispider.R 2014-08-28 08:50:50 UTC (rev 2877) @@ -42,16 +42,19 @@ kk <- complete.cases(pts) for (is in inds) { gr <- out[groups == is & kk] - if (length(gr) > 1) { - X <- pts[gr, ] + if (length(gr)) { + X <- pts[gr, , drop = FALSE] W <- w[gr] - ave <- switch(spiders, - "centroid" = apply(X, 2, weighted.mean, w = W), - "median" = ordimedian(X, rep(1, nrow(X))) - ) + if (length(gr) > 1) { + ave <- switch(spiders, + "centroid" = apply(X, 2, weighted.mean, w = W), + "median" = ordimedian(X, rep(1, nrow(X)))) + ordiArgAbsorber(ave[1], ave[2], X[, 1], X[, 2], + FUN = segments, ...) + } else { + ave <- X + } spids[,gr] <- ave - ordiArgAbsorber(ave[1], ave[2], X[, 1], X[, 2], - FUN = segments, ...) if (label) { cntrs <- rbind(cntrs, ave) names <- c(names, is) Modified: pkg/vegan/R/ordisurf.R =================================================================== --- pkg/vegan/R/ordisurf.R 2014-08-25 10:34:01 UTC (rev 2876) +++ pkg/vegan/R/ordisurf.R 2014-08-28 08:50:50 UTC (rev 2877) @@ -25,7 +25,7 @@ { weights.default <- function(object, ...) NULL if(!missing(thinplate)) { - warning("Use of 'thinplate' is deprecated and will soon be removed;\nuse 'isotropic' instead.") + warning("use of 'thinplate' is deprecated and will soon be removed;\nuse 'isotropic' instead") isotropic <- thinplate } ## GRID no user-definable - why 31? @@ -48,9 +48,9 @@ x2 <- X[, 2] ## handle fx - allow vector of length up to two if(!(missfx <- missing(fx)) && missing(knots)) - warning("Requested fixed d.f. splines but without specifying 'knots'.\nSwitching to 'fx = FALSE'.") + warning("requested fixed d.f. splines but without specifying 'knots':\nswitching to 'fx = FALSE'") if (length(fx) > 2L) - warning("Length of 'fx' supplied exceeds '2'. Using the first two.") + warning("length of 'fx' supplied exceeds '2': using the first two") ## expand fx robustly, no matter what length supplied fx <- rep(fx, length.out = 2) ## can't have `fx = TRUE` and `select = TRUE` @@ -59,17 +59,17 @@ warning("'fx = TRUE' requested; using 'select = FALSE'") select <- FALSE } else if(!miss.select && isTRUE(select)){ - stop("Fixed d.f. splines ('fx = TRUE') incompatible with 'select = TRUE'") + stop("fixed d.f. splines ('fx = TRUE') incompatible with 'select = TRUE'") } } ## handle knots - allow vector of length up to two if (length(knots) > 2L) - warning("Length of 'knots' supplied exceeds '2'. Using the first two.") + warning("length of 'knots' supplied exceeds '2': using the first two") ## expand knots robustly, no matter what length supplied knots <- rep(knots, length.out = 2) ## handle the bs - we only allow some of the possible options if (length(bs) > 2L) - warning("Number of basis types supplied exceeds '2'. Only using the first two.") + warning("number of basis types supplied exceeds '2': only using the first two") bs <- rep(bs, length.out = 2) ## check allowed types BS <- c("tp","ts","cr","cs","ds","ps","ad") @@ -83,7 +83,7 @@ } ## can't use "cr", "cs", "ps" in 2-d smoother with s() if(isTRUE(isotropic) && any(bs %in% c("cr", "cs", "ps"))) { - stop("Bases \"cr\", \"cs\", and \"ps\" not allowed in isotropic smooths.") + stop("bases \"cr\", \"cs\", and \"ps\" not allowed in isotropic smooths") } ## Build formula if (knots[1] <= 0) { Modified: pkg/vegan/R/points.cca.R =================================================================== --- pkg/vegan/R/points.cca.R 2014-08-25 10:34:01 UTC (rev 2876) +++ pkg/vegan/R/points.cca.R 2014-08-28 08:50:50 UTC (rev 2877) @@ -4,7 +4,7 @@ { formals(arrows) <- c(formals(arrows), alist(... = )) if (length(display) > 1) - stop("Only one 'display' item can be added in one command.") + stop("only one 'display' item can be added in one command") pts <- scores(x, choices = choices, display = display, scaling = scaling, const) if (!missing(select)) Modified: pkg/vegan/R/read.cep.R =================================================================== --- pkg/vegan/R/read.cep.R 2014-08-25 10:34:01 UTC (rev 2876) +++ pkg/vegan/R/read.cep.R 2014-08-28 08:50:50 UTC (rev 2877) @@ -12,7 +12,7 @@ if (trace) cat("File", file, "\n") if (file.access(file, 4) < 0) { - stop("File does not exist or is not readable.") + stop("file does not exist or is not readable") } on.exit(.Fortran("cepclose", PACKAGE = "vegan")) cep <- .Fortran("cephead", file = file, kind = integer(1), @@ -66,8 +66,8 @@ PACKAGE = "vegan")) if (cd$ier) { if (cd$ier == 1) - stop("Too many non-zero entries: increase maxdata.") - else stop("Unknown and obscure error: don't know what to do.") + stop("too many non-zero entries: increase maxdata") + else stop("unknown and obscure error: I do not know what to do") } if (trace) cat("Read", cd$nsp, "species, ", cd$nst, "sites.\n") Modified: pkg/vegan/R/scores.default.R =================================================================== --- pkg/vegan/R/scores.default.R 2014-08-25 10:34:01 UTC (rev 2876) +++ pkg/vegan/R/scores.default.R 2014-08-28 08:50:50 UTC (rev 2877) @@ -39,11 +39,21 @@ } else if (is.numeric(x)) { X <- as.matrix(x) - ## as.matrix() changes 1-row scores into 1-col matrix: this is + ## as.matrix() changes a score vector to 1-col matrix: this is ## a hack which may fail sometimes (but probably less often ## than without this hack): - if (ncol(X) == 1 && nrow(X) == length(choices)) - X <- t(X) + + ## Removed this hack after an issue raised by + ## vanderleidebastiani in github. He was worried for getting + ## an error when 'choices' were not given with genuinely 1-dim + ## (1-col) results. At a second look, it seems that this hack + ## will fail both with missing 'choices', and also often with + ## 'choices' given because 'choices' are only applied later, + ## so that nrow(X) > length(choices). Only vectors (dim arg + ## missing) should fail here. Let's see... + + ##if (ncol(X) == 1 && nrow(X) == length(choices)) + ## X <- t(X) } if (is.null(rownames(X))) { root <- substr(display, 1, 4) Modified: pkg/vegan/R/text.cca.R =================================================================== --- pkg/vegan/R/text.cca.R 2014-08-25 10:34:01 UTC (rev 2876) +++ pkg/vegan/R/text.cca.R 2014-08-28 08:50:50 UTC (rev 2877) @@ -4,7 +4,7 @@ { formals(arrows) <- c(formals(arrows), alist(... = )) if (length(display) > 1) - stop("Only one 'display' item can be added in one command.") + stop("only one 'display' item can be added in one command") pts <- scores(x, choices = choices, display = display, scaling = scaling, const) if (!missing(labels)) Modified: pkg/vegan/R/tolerance.cca.R =================================================================== --- pkg/vegan/R/tolerance.cca.R 2014-08-25 10:34:01 UTC (rev 2876) +++ pkg/vegan/R/tolerance.cca.R 2014-08-28 08:50:50 UTC (rev 2877) @@ -27,7 +27,7 @@ which = c("species","sites"), scaling = 2, useN2 = FALSE, ...) { if(inherits(x, "rda")) - stop("Tolerances only available for unimodal ordinations.") + stop("tolerances only available for unimodal ordinations") if(missing(which)) which <- "species" ## reconstruct species/response matrix Y - up to machine precision! Modified: pkg/vegan/man/dune.taxon.Rd =================================================================== --- pkg/vegan/man/dune.taxon.Rd 2014-08-25 10:34:01 UTC (rev 2876) +++ pkg/vegan/man/dune.taxon.Rd 2014-08-28 08:50:50 UTC (rev 2877) @@ -23,7 +23,7 @@ \details{ The classification of vascular plants is based on APG (2009), and - that of mosses from Hill et al. (2006). + that of mosses on Hill et al. (2006). } \references{ APG [Angiosperm Phylogeny Group] (2009) An update of the Angiosperm