[Dplr-commits] r881 - in pkg/dplR: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat May 17 10:40:28 CEST 2014
Author: mvkorpel
Date: 2014-05-17 10:40:28 +0200 (Sat, 17 May 2014)
New Revision: 881
Modified:
pkg/dplR/ChangeLog
pkg/dplR/DESCRIPTION
pkg/dplR/R/corr.rwl.seg.R
Log:
Performance optimization in corr.rwl.seg()
Modified: pkg/dplR/ChangeLog
===================================================================
--- pkg/dplR/ChangeLog 2014-05-16 23:07:10 UTC (rev 880)
+++ pkg/dplR/ChangeLog 2014-05-17 08:40:28 UTC (rev 881)
@@ -24,6 +24,11 @@
- Bug fix: make.plot=TRUE threw an error when input data.frame had leading
or trailing all-NA rows
+File: corr.rwl.seg.R, skel.plot.R
+---------------------------------
+
+- Performance optimization, including the use of dev.hold() and dev.flush()
+
File: latexify.R
----------------
@@ -75,11 +80,6 @@
will speed up otherwise unbearable computation times on some
systems.
-File: skel.plot.R
------------------
-
-- Performance optimization
-
File: timeseries-dplR.Rnw
-------------------------
Modified: pkg/dplR/DESCRIPTION
===================================================================
--- pkg/dplR/DESCRIPTION 2014-05-16 23:07:10 UTC (rev 880)
+++ pkg/dplR/DESCRIPTION 2014-05-17 08:40:28 UTC (rev 881)
@@ -3,7 +3,7 @@
Type: Package
Title: Dendrochronology Program Library in R
Version: 1.6.1
-Date: 2014-05-16
+Date: 2014-05-17
Authors at R: c(person("Andy", "Bunn", role = c("aut", "cph",
"cre", "trl"), email = "andy.bunn at wwu.edu"), person("Mikko",
"Korpela", role = c("aut", "trl")), person("Franco", "Biondi",
Modified: pkg/dplR/R/corr.rwl.seg.R
===================================================================
--- pkg/dplR/R/corr.rwl.seg.R 2014-05-16 23:07:10 UTC (rev 880)
+++ pkg/dplR/R/corr.rwl.seg.R 2014-05-17 08:40:28 UTC (rev 881)
@@ -151,7 +151,8 @@
idx.good <- norm.one$idx.good
## loop through series
- for (i in seq_len(nseries)) {
+ seq.series <- seq_len(nseries)
+ for (i in seq.series) {
if (is.null(master)) {
idx.noti <- rep(TRUE, nseries)
idx.noti[i] <- FALSE
@@ -217,18 +218,18 @@
on.exit(par(op), add=TRUE)
col.pal <- c("#E41A1C", "#377EB8", "#4DAF4A")
par(mar=c(4, 5, 4, 5) + 0.1, mgp=c(1.25, 0.25, 0), tcl=0.25)
+ dev.hold()
+ on.exit(dev.flush(), add=TRUE)
plot(yrs, segs[, 1], type="n", ylim=c(0.5, nsegs + 0.5),
axes=FALSE, ylab="", xlab=gettext("Year"),
sub=gettextf("Segments: length=%d,lag=%d", seg.length, seg.lag,
domain="R-dplR"),
...)
## bounding poly for even series
- xx <- c(min.yr - 100, max.yr + 100)
- xx <- c(xx, rev(xx))
- for (i in seq(from=1, to=nseries, by=2)) {
- yy <- c(i - 0.5, i - 0.5, i + 0.5, i + 0.5)
- polygon(xx, yy, col="grey90", border=NA)
- }
+ iEven <- seq(from=1, to=nseries, by=2)
+ rect(xleft = min.yr - 100, ybottom = iEven - 0.5,
+ xright = max.yr + 100, ytop = iEven + 0.5,
+ col="grey90", border=NA)
abline(v=c(bins[, 1], bins[c(nbins - 1, nbins), 2] + 1),
col="grey", lty="dotted")
@@ -242,7 +243,7 @@
flag.segs <- matrix(NA, ncol=nseries, nrow=nyrs)
## loop through these.bins
tmp <- res.pval[neworder, this.seq, drop=FALSE] > pcrit
- for (i in seq_len(nseries)) {
+ for (i in seq.series) {
for (j in seq_len(nrow(these.bins))) {
mask <- yrs %in% seq(from = these.bins[j, 1],
to = these.bins[j, 2])
@@ -265,29 +266,36 @@
## Ticks at 1) first year of each bin,
## and 2) first year larger than any of these bins
axis(ax[odd.even], at=guides.x.base)
- for (i in seq_len(nseries)) {
- y.deviation <- y.deviation + 1
- ## whole segs
- xx <- c(segs.mat[i, 1], segs.mat[i, 2] + 1)
- xx <- c(xx, rev(xx))
- yy <- c(i, i, y.deviation, y.deviation)
- polygon(xx, yy, col=col.pal[3], border=NA)
- ## complete segs
- xx <- c(com.segs.mat[i, 1], com.segs.mat[i, 2] + 1)
- xx <- c(xx, rev(xx))
- polygon(xx, yy, col=col.pal[2], border=NA)
+ ## whole segs
+ if (odd.even == 1) {
+ ytop <- seq.series
+ ybottom <- ytop - 0.25
+ } else {
+ ybottom <- seq.series
+ ytop <- ybottom + 0.25
+ }
+ rect(xleft = segs.mat[, 1], ybottom = ybottom,
+ xright = segs.mat[, 2] + 1, ytop = ytop,
+ col=col.pal[3], border=NA)
+ ## complete segs
+ rect(xleft = com.segs.mat[, 1], ybottom = ybottom,
+ xright = com.segs.mat[, 2] + 1, ytop = ytop,
+ col=col.pal[2], border=NA)
+ for (i in seq.series) {
+ yb <- ybottom[i]
+ yt <- ytop[i]
## flags
flag.segs.mat <- yr.ranges(flag.segs[, i], yrs)
- for (j in seq_len(nrow(flag.segs.mat))) {
- xx <- c(flag.segs.mat[j, 1], flag.segs.mat[j, 2] + 1)
- xx <- c(xx, rev(xx))
- polygon(xx, yy, col=col.pal[1], border=NA)
+ if (nrow(flag.segs.mat) > 0) {
+ rect(xleft = flag.segs.mat[, 1], ybottom = yb,
+ xright = flag.segs.mat[, 2] + 1, ytop = yt,
+ col=col.pal[1], border=NA)
}
## guides
guides.x <- guides.x.base[guides.x.base >= segs.mat[i, 1]]
guides.x <- guides.x[guides.x <= segs.mat[i, 2]]
if (length(guides.x) > 0) {
- segments(guides.x, i, guides.x, y.deviation, col="white")
+ segments(guides.x, yb, guides.x, yt, col="white")
}
}
}
@@ -302,7 +310,7 @@
axis(4, at=even.seq,
labels=cnames.segs[even.seq], srt=45,
tick=FALSE, las=2, cex.axis=label.cex)
- abline(h=seq_len(nseries), col="white")
+ abline(h=seq.series, col="white")
box()
}
More information about the Dplr-commits
mailing list