[Vegan-commits] r347 - in pkg: R inst man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun May 11 15:49:41 CEST 2008
Author: gsimpson
Date: 2008-05-11 15:49:40 +0200 (Sun, 11 May 2008)
New Revision: 347
Added:
pkg/R/ordiArgAbsorber.R
Modified:
pkg/R/lines.spantree.R
pkg/R/ordiarrows.R
pkg/R/ordicluster.R
pkg/R/ordiellipse.R
pkg/R/ordihull.R
pkg/R/ordisegments.R
pkg/R/ordispider.R
pkg/R/orditorp.R
pkg/R/points.decorana.R
pkg/inst/ChangeLog
pkg/man/ordihull.Rd
pkg/man/vegan-internal.Rd
Log:
now uses ordiArgAbsorber to manage handling of non-graphical arguments passed in '...'
Modified: pkg/R/lines.spantree.R
===================================================================
--- pkg/R/lines.spantree.R 2008-05-11 06:28:19 UTC (rev 346)
+++ pkg/R/lines.spantree.R 2008-05-11 13:49:40 UTC (rev 347)
@@ -1,13 +1,9 @@
"lines.spantree" <-
function (x, ord, display = "sites", ...)
{
- localSegments <- function(..., shrink, origin, scaling, triangular)
- segments(...)
ord <- scores(ord, display = display, ...)
tree <- x$kid
- #segments(ord[-1, 1], ord[-1, 2], ord[tree, 1], ord[tree,
- # 2], ...)
- localSegments(ord[-1, 1], ord[-1, 2], ord[tree, 1], ord[tree,
- 2], ...)
+ ordiArgAbsorber(ord[-1, 1], ord[-1, 2], ord[tree, 1], ord[tree, 2],
+ FUN = segments)
invisible()
}
Added: pkg/R/ordiArgAbsorber.R
===================================================================
--- pkg/R/ordiArgAbsorber.R (rev 0)
+++ pkg/R/ordiArgAbsorber.R 2008-05-11 13:49:40 UTC (rev 347)
@@ -0,0 +1,3 @@
+`ordiArgAbsorber` <- function(..., shrink, origin, scaling, triangular,
+ FUN)
+ match.fun(FUN)(...)
Modified: pkg/R/ordiarrows.R
===================================================================
--- pkg/R/ordiarrows.R 2008-05-11 06:28:19 UTC (rev 346)
+++ pkg/R/ordiarrows.R 2008-05-11 13:49:40 UTC (rev 347)
@@ -2,10 +2,6 @@
function (ord, groups, levels, replicates, display = "sites",
show.groups, startmark, ...)
{
- localArrows <- function(..., shrink, origin, scaling, triangular)
- arrows(...)
- localSegments <- function(..., shrink, origin, scaling, triangular)
- segments(...)
pts <- scores(ord, display = display, ...)
npoints <- nrow(pts)
if (missing(groups))
@@ -27,10 +23,10 @@
if (!missing(startmark))
points(X0[1,1], X0[1,2], pch=startmark, ...)
if (nseg > 1)
- localSegments(X0[-nseg,1], X0[-nseg,2], X1[-nseg,1],
- X1[-nseg,2], ...)
- localArrows(X0[nseg, 1], X0[nseg, 2], X1[nseg, 1], X1[nseg, 2],
- ...)
+ ordiArgAbsorber(X0[-nseg,1], X0[-nseg,2], X1[-nseg,1],
+ X1[-nseg,2], FUN = segments, ...)
+ ordiArgAbsorber(X0[nseg, 1], X0[nseg, 2], X1[nseg, 1], X1[nseg, 2],
+ FUN = arrows, ...)
}
}
invisible()
Modified: pkg/R/ordicluster.R
===================================================================
--- pkg/R/ordicluster.R 2008-05-11 06:28:19 UTC (rev 346)
+++ pkg/R/ordicluster.R 2008-05-11 13:49:40 UTC (rev 347)
@@ -2,8 +2,6 @@
function (ord, cluster, prune=0, display="sites", w = weights(ord, display),
...)
{
- localSegments <- function(..., shrink, origin, scaling, triangular)
- segments(...)
w <- eval(w)
mrg <- cluster$merge
ord <- scores(ord, display = display, ...)
@@ -19,7 +17,7 @@
two <- if (b < 0) ord[-b,] else go[b,]
n1 <- if (a < 0) n[-a] else n[a]
n2 <- if (b < 0) n[-b] else n[b]
- localSegments(one[1], one[2], two[1], two[2], ...)
+ ordiArgAbsorber(one[1], one[2], two[1], two[2], FUN = segments, ...)
xm <- weighted.mean(c(one[1],two[1]), w=c(n1,n2))
ym <- weighted.mean(c(one[2],two[2]), w=c(n1,n2))
go[i,] <- c(xm,ym)
Modified: pkg/R/ordiellipse.R
===================================================================
--- pkg/R/ordiellipse.R 2008-05-11 06:28:19 UTC (rev 346)
+++ pkg/R/ordiellipse.R 2008-05-11 13:49:40 UTC (rev 347)
@@ -3,9 +3,6 @@
conf, draw = c("lines", "polygon"), w = weights(ord, display),
show.groups, ...)
{
- localLines <- function(..., shrink, origin, scaling, triangular) lines(...)
- localPolygon <- function(..., shrink, origin, scaling, triangular)
- polygon(...)
if (!require(ellipse))
stop("Requires package `ellipse' (from CRAN)")
kind <- match.arg(kind)
@@ -36,12 +33,13 @@
t <- 1
else t <- sqrt(qchisq(conf, 2))
if (draw == "lines")
- localLines(ellipse(mat$cov, centre = mat$center, t = t),
- ...)
+ ordiArgAbsorber(ellipse(mat$cov, centre = mat$center, t = t),
+ FUN = lines, ...)
else {
xy <- ellipse(mat$cov, center = mat$center, t = t)
- localPolygon(xy[, 1] + mat$center[1], xy[, 2] + mat$center[2],
- ...)
+ ordiArgAbsorber(xy[, 1] + mat$center[1],
+ xy[, 2] + mat$center[2],
+ FUN = polygon, ...)
}
}
}
Modified: pkg/R/ordihull.R
===================================================================
--- pkg/R/ordihull.R 2008-05-11 06:28:19 UTC (rev 346)
+++ pkg/R/ordihull.R 2008-05-11 13:49:40 UTC (rev 347)
@@ -2,9 +2,6 @@
function (ord, groups, display = "sites", draw = c("lines", "polygon"),
show.groups, ...)
{
- localLines <- function(..., shrink, origin, scaling, triangular) lines(...)
- localPolygon <- function(..., shrink, origin, scaling, triangular)
- polygon(...)
draw <- match.arg(draw)
pts <- scores(ord, display = display, ...)
if (!missing(show.groups)) {
@@ -21,8 +18,8 @@
hpts <- chull(X)
hpts <- c(hpts, hpts[1])
if (draw == "lines")
- localLines(X[hpts, ], ...)
- else localPolygon(X[hpts,], ...)
+ ordiArgAbsorber(X[hpts, ], FUN = lines, ...)
+ else ordiArgAbsorber(X[hpts,], FUN = polygon, ...)
}
}
invisible()
Modified: pkg/R/ordisegments.R
===================================================================
--- pkg/R/ordisegments.R 2008-05-11 06:28:19 UTC (rev 346)
+++ pkg/R/ordisegments.R 2008-05-11 13:49:40 UTC (rev 347)
@@ -2,8 +2,6 @@
function (ord, groups, levels, replicates, display = "sites",
show.groups, ...)
{
- localSegments <- function(..., shrink, origin, scaling, triangular)
- segments(...)
pts <- scores(ord, display = display, ...)
npoints <- nrow(pts)
if (missing(groups))
@@ -21,7 +19,8 @@
X <- pts[gr, , drop = FALSE]
X0 <- X[-nrow(X), , drop = FALSE]
X1 <- X[-1, , drop = FALSE]
- localSegments(X0[, 1], X0[, 2], X1[, 1], X1[, 2], ...)
+ ordiArgAbsorber(X0[, 1], X0[, 2], X1[, 1], X1[, 2],
+ FUN = segments, ...)
}
}
invisible()
Modified: pkg/R/ordispider.R
===================================================================
--- pkg/R/ordispider.R 2008-05-11 06:28:19 UTC (rev 346)
+++ pkg/R/ordispider.R 2008-05-11 13:49:40 UTC (rev 347)
@@ -2,8 +2,6 @@
function (ord, groups, display = "sites", w = weights(ord, display),
show.groups, ...)
{
- localSegments <- function(..., shrink, origin, scaling, triangular)
- segments(...)
if (inherits(ord, "cca") && missing(groups)) {
lc <- scores(ord, display = "lc", ...)
wa <- scores(ord, display = "wa", ...)
@@ -30,7 +28,8 @@
X <- pts[gr, ]
W <- w[gr]
ave <- apply(X, 2, weighted.mean, w = W)
- localSegments(ave[1], ave[2], X[, 1], X[, 2], ...)
+ ordiArgAbsorber(ave[1], ave[2], X[, 1], X[, 2],
+ FUN = segments, ...)
}
}
invisible()
Modified: pkg/R/orditorp.R
===================================================================
--- pkg/R/orditorp.R 2008-05-11 06:28:19 UTC (rev 346)
+++ pkg/R/orditorp.R 2008-05-11 13:49:40 UTC (rev 347)
@@ -7,15 +7,6 @@
pcex <- cex
if (missing(pcol))
pcol <- col
- ## currently need to extract three arguments from '...'
- ## i) scaling, ii) origin, iii) shrink, iv) triangular
- ## define local functions as per plot.default
- ## arguments after '...' in local functions are dropped and not passed on
- ##
- ## For future, if new scores methods accept extra arguments, add their
- ## names to the local functions below.
- localPoints <- function(..., shrink, origin, scaling, triangular) points(...)
- localText <- function(..., shrink, origin, scaling, triangular) text(...)
x <- scores(x, display = display, choices = choices, ...)
if (missing(labels))
labels <- rownames(x)
@@ -45,15 +36,15 @@
pcex <- (pcex[ord])[!tt]
if (length(pcol) > 1)
pcol <- (pcol[ord])[!tt]
- localPoints(x[!tt, , drop = FALSE], pch = pch, cex = pcex,
- col = pcol, ...)
+ ordiArgAbsorber(x[!tt, , drop = FALSE], pch = pch, cex = pcex,
+ col = pcol, FUN = points, ...)
}
if (length(cex) > 1)
cex <- (cex[ord])[tt]
if (length(col) > 1)
col <- (col[ord])[tt]
- localText(x[tt, , drop = FALSE], labels[tt], cex = cex, col = col,
- ...)
+ ordiArgAbsorber(x[tt, , drop = FALSE], labels[tt], cex = cex, col = col,
+ FUN = text, ...)
names(tt) <- labels
tt <- tt[order(ord)]
invisible(tt)
Modified: pkg/R/points.decorana.R
===================================================================
--- pkg/R/points.decorana.R 2008-05-11 06:28:19 UTC (rev 346)
+++ pkg/R/points.decorana.R 2008-05-11 13:49:40 UTC (rev 347)
@@ -1,13 +1,12 @@
"points.decorana" <-
- function (x, display=c("sites", "species"), choices=1:2, origin = TRUE, select, ...)
+ function (x, display=c("sites", "species"), choices=1:2, origin = TRUE,
+ select, ...)
{
- localPoints <- function(..., shrink, origin, scaling, triangular)
- points(...)
display <- match.arg(display)
x <- scores(x, display = display, choices = choices, origin = origin, ...)
if (!missing(select))
x <- x[select,,drop=FALSE]
- localPoints(x, ...)
+ ordiArgAbsorber(x, FUN = points, ...)
invisible()
}
Modified: pkg/inst/ChangeLog
===================================================================
--- pkg/inst/ChangeLog 2008-05-11 06:28:19 UTC (rev 346)
+++ pkg/inst/ChangeLog 2008-05-11 13:49:40 UTC (rev 347)
@@ -8,14 +8,15 @@
uses metaMDSdist transformed data for getting species scores
(similarly as metaMDS recently does).
- * ordiTerminfo: does not give superfluos warnings if constrained
+ * ordiTerminfo: does not give superfluous warnings if constrained
ordination called without constraints and without data=, like
capscale(x ~ 1).
* graphical functions: Graphical functions that also pass '...' to
non-graphical functions (such as scores) now accept non-graphical
arguments without issuing an warning. These warnings were harmless
- but it is neater to stop them happening in the first place.
+ but it is neater to stop them happening in the first place. This
+ is facilitated by the new internal function ordiArgAbsorber().
* MOStest: added fieller.MOStest for approximate confidence
intervals of the location of the hump or pit. The method is based
Modified: pkg/man/ordihull.Rd
===================================================================
--- pkg/man/ordihull.Rd 2008-05-11 06:28:19 UTC (rev 346)
+++ pkg/man/ordihull.Rd 2008-05-11 13:49:40 UTC (rev 347)
@@ -140,9 +140,10 @@
data(dune.env)
mod <- cca(dune ~ Moisture, dune.env)
attach(dune.env)
-plot(mod, type="n")
-ordihull(mod, Moisture)
-ordispider(mod, col="red")
+## pass non-graphical arguments without warnings
+plot(mod, type="n", scaling = 3)
+ordihull(mod, Moisture, scaling = 3)
+ordispider(mod, col="red", scaling = 3)
plot(mod, type = "p", display="sites")
ordicluster(mod, hclust(vegdist(dune)), prune=3, col = "blue")
# The following is not executed automatically because it needs
Modified: pkg/man/vegan-internal.Rd
===================================================================
--- pkg/man/vegan-internal.Rd 2008-05-11 06:28:19 UTC (rev 346)
+++ pkg/man/vegan-internal.Rd 2008-05-11 13:49:40 UTC (rev 347)
@@ -6,6 +6,7 @@
\alias{ordiTerminfo}
\alias{pasteCall}
\alias{ordiArrowMul}
+\alias{ordiArgAbsorber}
\title{Internal vegan functions}
\description{
@@ -16,6 +17,7 @@
ordiParseFormula(formula, data, xlev = NULL)
ordiTerminfo(d, data)
ordiArrowMul(x, at = c(0,0), fill = 0.75)
+ordiArgAbsorber(..., shrink, origin, scaling, triangular, FUN)
centroids.cca(x, mf, wt)
permuted.index(n, strata)
pasteCall(call, prefix = "Call:")
More information about the Vegan-commits
mailing list