[Vegan-commits] r344 - pkg/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri May 9 20:16:47 CEST 2008
Author: gsimpson
Date: 2008-05-09 20:16:47 +0200 (Fri, 09 May 2008)
New Revision: 344
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/R/text.decorana.R
Log:
plotting functions that also pass ... to non-graphical functions now handle none graphical arguments much better
Modified: pkg/R/lines.spantree.R
===================================================================
--- pkg/R/lines.spantree.R 2008-05-09 13:16:59 UTC (rev 343)
+++ pkg/R/lines.spantree.R 2008-05-09 18:16:47 UTC (rev 344)
@@ -1,9 +1,13 @@
"lines.spantree" <-
- function (x, ord, display = "sites", ...)
+ 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], ...)
+ #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], ...)
invisible()
}
Modified: pkg/R/ordiarrows.R
===================================================================
--- pkg/R/ordiarrows.R 2008-05-09 13:16:59 UTC (rev 343)
+++ pkg/R/ordiarrows.R 2008-05-09 18:16:47 UTC (rev 344)
@@ -1,10 +1,14 @@
"ordiarrows" <-
- function (ord, groups, levels, replicates, display = "sites",
- show.groups, startmark, ...)
+ 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))
+ if (missing(groups))
groups <- gl(levels, replicates, npoints)
if (!missing(show.groups)) {
take <- groups %in% show.groups
@@ -22,9 +26,11 @@
nseg <- nrow(X0)
if (!missing(startmark))
points(X0[1,1], X0[1,2], pch=startmark, ...)
- if (nseg > 1)
- segments(X0[-nseg,1], X0[-nseg,2], X1[-nseg,1], X1[-nseg,2], ...)
- arrows(X0[nseg, 1], X0[nseg, 2], X1[nseg, 1], X1[nseg, 2], ...)
+ 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],
+ ...)
}
}
invisible()
Modified: pkg/R/ordicluster.R
===================================================================
--- pkg/R/ordicluster.R 2008-05-09 13:16:59 UTC (rev 343)
+++ pkg/R/ordicluster.R 2008-05-09 18:16:47 UTC (rev 344)
@@ -1,6 +1,9 @@
"ordicluster" <-
- function (ord, cluster, prune=0, display="sites", w = weights(ord, display), ...)
+ 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, ...)
@@ -16,7 +19,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]
- segments(one[1], one[2], two[1], two[2], ...)
+ localSegments(one[1], one[2], two[1], two[2], ...)
xm <- weighted.mean(c(one[1],two[1]), w=c(n1,n2))
ym <- weighted.mean(c(one[2],two[2]), w=c(n1,n2))
go[i,] <- c(xm,ym)
Modified: pkg/R/ordiellipse.R
===================================================================
--- pkg/R/ordiellipse.R 2008-05-09 13:16:59 UTC (rev 343)
+++ pkg/R/ordiellipse.R 2008-05-09 18:16:47 UTC (rev 344)
@@ -1,24 +1,27 @@
"ordiellipse" <-
- function (ord, groups, display = "sites", kind = c("sd", "se"),
- conf, draw = c("lines", "polygon"), w = weights(ord, display),
- show.groups, ...)
+ function (ord, groups, display = "sites", kind = c("sd", "se"),
+ conf, draw = c("lines", "polygon"), w = weights(ord, display),
+ show.groups, ...)
{
- if (!require(ellipse))
+ 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)
draw <- match.arg(draw)
pts <- scores(ord, display = display, ...)
w <- eval(w)
- if (length(w) == 1)
+ if (length(w) == 1)
w <- rep(1, nrow(pts))
- if (is.null(w))
+ if (is.null(w))
w <- rep(1, nrow(pts))
if (!missing(show.groups)) {
take <- groups %in% show.groups
pts <- pts[take, , drop = FALSE]
groups <- groups[take]
w <- w[take]
- }
+ }
out <- seq(along = groups)
inds <- names(table(groups))
for (is in inds) {
@@ -27,17 +30,17 @@
X <- pts[gr, ]
W <- w[gr]
mat <- cov.wt(X, W)
- if (kind == "se")
+ if (kind == "se")
mat$cov <- mat$cov/mat$n.obs
- if (missing(conf))
+ if (missing(conf))
t <- 1
else t <- sqrt(qchisq(conf, 2))
- if (draw == "lines")
- lines(ellipse(mat$cov, centre = mat$center, t = t),
+ if (draw == "lines")
+ localLines(ellipse(mat$cov, centre = mat$center, t = t),
...)
else {
xy <- ellipse(mat$cov, center = mat$center, t = t)
- polygon(xy[, 1] + mat$center[1], xy[, 2] + mat$center[2],
+ localPolygon(xy[, 1] + mat$center[1], xy[, 2] + mat$center[2],
...)
}
}
Modified: pkg/R/ordihull.R
===================================================================
--- pkg/R/ordihull.R 2008-05-09 13:16:59 UTC (rev 343)
+++ pkg/R/ordihull.R 2008-05-09 18:16:47 UTC (rev 344)
@@ -1,7 +1,10 @@
"ordihull" <-
- function (ord, groups, display = "sites", draw = c("lines", "polygon"),
- show.groups, ...)
+ 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)) {
@@ -17,9 +20,9 @@
X <- pts[gr, ]
hpts <- chull(X)
hpts <- c(hpts, hpts[1])
- if (draw == "lines")
- lines(X[hpts, ], ...)
- else polygon(X[hpts, ], ...)
+ if (draw == "lines")
+ localLines(X[hpts, ], ...)
+ else localPolygon(X[hpts,], ...)
}
}
invisible()
Modified: pkg/R/ordisegments.R
===================================================================
--- pkg/R/ordisegments.R 2008-05-09 13:16:59 UTC (rev 343)
+++ pkg/R/ordisegments.R 2008-05-09 18:16:47 UTC (rev 344)
@@ -1,10 +1,12 @@
"ordisegments" <-
- function (ord, groups, levels, replicates, display = "sites",
- show.groups, ...)
+ 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))
+ if (missing(groups))
groups <- gl(levels, replicates, npoints)
if (!missing(show.groups)) {
take <- groups %in% show.groups
@@ -19,7 +21,7 @@
X <- pts[gr, , drop = FALSE]
X0 <- X[-nrow(X), , drop = FALSE]
X1 <- X[-1, , drop = FALSE]
- segments(X0[, 1], X0[, 2], X1[, 1], X1[, 2], ...)
+ localSegments(X0[, 1], X0[, 2], X1[, 1], X1[, 2], ...)
}
}
invisible()
Modified: pkg/R/ordispider.R
===================================================================
--- pkg/R/ordispider.R 2008-05-09 13:16:59 UTC (rev 343)
+++ pkg/R/ordispider.R 2008-05-09 18:16:47 UTC (rev 344)
@@ -1,7 +1,9 @@
"ordispider" <-
- function (ord, groups, display = "sites", w = weights(ord, display),
- show.groups, ...)
+ 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", ...)
@@ -10,9 +12,9 @@
}
pts <- scores(ord, display = display, ...)
w <- eval(w)
- if (length(w) == 1)
+ if (length(w) == 1)
w <- rep(1, nrow(pts))
- if (is.null(w))
+ if (is.null(w))
w <- rep(1, nrow(pts))
if (!missing(show.groups)) {
take <- groups %in% show.groups
@@ -28,7 +30,7 @@
X <- pts[gr, ]
W <- w[gr]
ave <- apply(X, 2, weighted.mean, w = W)
- segments(ave[1], ave[2], X[, 1], X[, 2], ...)
+ localSegments(ave[1], ave[2], X[, 1], X[, 2], ...)
}
}
invisible()
Modified: pkg/R/orditorp.R
===================================================================
--- pkg/R/orditorp.R 2008-05-09 13:16:59 UTC (rev 343)
+++ pkg/R/orditorp.R 2008-05-09 18:16:47 UTC (rev 344)
@@ -1,29 +1,29 @@
`orditorp` <-
function (x, display, labels, choices = c(1, 2), priority,
cex = 0.7, pcex, col = par("col"),
- pcol, pch = par("pch"), air = 1, ...)
+ pcol, pch = par("pch"), air = 1, ...)
{
- if (missing(pcex))
+ if (missing(pcex))
pcex <- cex
- if (missing(pcol))
+ if (missing(pcol))
pcol <- col
## currently need to extract three arguments from '...'
- ## i) scaling, ii) origin and iii) shrink
+ ## 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) points(...)
- localText <- function(..., shrink, origin, scaling) text(...)
+ localPoints <- function(..., shrink, origin, scaling, triangular) points(...)
+ localText <- function(..., shrink, origin, scaling, triangular) text(...)
x <- scores(x, display = display, choices = choices, ...)
- if (missing(labels))
+ if (missing(labels))
labels <- rownames(x)
- if (missing(priority))
+ if (missing(priority))
priority <- rowSums((scale(x)^2))
w <- strwidth(labels, cex = cex)/2 * air
h <- strheight(labels, cex = cex)/2 * air
- xx <- cbind(x[, 1] - w, x[, 1] + w, x[, 2] - h, x[, 2] +
+ xx <- cbind(x[, 1] - w, x[, 1] + w, x[, 2] - h, x[, 2] +
h)
is.na(priority) <- w == 0
ord <- rev(order(priority, na.last = FALSE))
@@ -35,28 +35,24 @@
for (i in 2:(nrow(xx) - sum(is.na(priority)))) {
j <- 1:(i - 1)
j <- j[tt[j]]
- tt[i] <- all(xx[i, 1] > xx[j, 2] | xx[j, 1] > xx[i, 2] |
+ tt[i] <- all(xx[i, 1] > xx[j, 2] | xx[j, 1] > xx[i, 2] |
xx[i, 3] > xx[j, 4] | xx[j, 3] > xx[i, 4])
}
if (sum(!tt)) {
- if (length(pch) > 1)
+ if (length(pch) > 1)
pch <- (pch[ord])[!tt]
- if (length(pcex) > 1)
+ if (length(pcex) > 1)
pcex <- (pcex[ord])[!tt]
- if (length(pcol) > 1)
+ if (length(pcol) > 1)
pcol <- (pcol[ord])[!tt]
- ##points(x[!tt, , drop = FALSE], pch = pch, cex = pcex,
- ## col = pcol, ...)
- localPoints(x[!tt, , drop = FALSE], pch = pch, cex = pcex,
+ localPoints(x[!tt, , drop = FALSE], pch = pch, cex = pcex,
col = pcol, ...)
}
- if (length(cex) > 1)
+ if (length(cex) > 1)
cex <- (cex[ord])[tt]
- if (length(col) > 1)
+ if (length(col) > 1)
col <- (col[ord])[tt]
- ##text(x[tt, , drop = FALSE], labels[tt], cex = cex, col = col,
- ## ...)
- localText(x[tt, , drop = FALSE], labels[tt], cex = cex, col = col,
+ localText(x[tt, , drop = FALSE], labels[tt], cex = cex, col = col,
...)
names(tt) <- labels
tt <- tt[order(ord)]
Modified: pkg/R/points.decorana.R
===================================================================
--- pkg/R/points.decorana.R 2008-05-09 13:16:59 UTC (rev 343)
+++ pkg/R/points.decorana.R 2008-05-09 18:16:47 UTC (rev 344)
@@ -1,11 +1,13 @@
"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]
- points(x, ...)
+ localPoints(x, ...)
invisible()
}
Modified: pkg/R/text.decorana.R
===================================================================
--- pkg/R/text.decorana.R 2008-05-09 13:16:59 UTC (rev 343)
+++ pkg/R/text.decorana.R 2008-05-09 18:16:47 UTC (rev 344)
@@ -1,14 +1,16 @@
"text.decorana" <-
- function (x, display = c("sites", "species"), labels, choices = 1:2,
- origin = TRUE, select, ...)
+ function (x, display = c("sites", "species"), labels, choices = 1:2,
+ origin = TRUE, select, ...)
{
+ localText <- function(..., shrink, origin, scaling, triangular)
+ segments(...)
display <- match.arg(display)
- x <- scores(x, display = display, choices = choices, origin = origin,
+ x <- scores(x, display = display, choices = choices, origin = origin,
...)
if (!missing(labels))
rownames(x) <- labels
- if (!missing(select))
+ if (!missing(select))
x <- x[select, , drop = FALSE]
- text(x, rownames(x), ...)
+ localText(x, rownames(x), ...)
invisible()
}
More information about the Vegan-commits
mailing list