From noreply at r-forge.r-project.org Mon Mar 24 09:53:29 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 24 Mar 2014 09:53:29 +0100 (CET) Subject: [Dplr-commits] r731 - in pkg/dplR: . R Message-ID: <20140324085330.0C9FC1864B5@r-forge.r-project.org> Author: mvkorpel Date: 2014-03-24 09:53:29 +0100 (Mon, 24 Mar 2014) New Revision: 731 Modified: pkg/dplR/ChangeLog pkg/dplR/DESCRIPTION pkg/dplR/R/rwi.stats.running.R Log: rwi.stats() / rwi.stats.running(): fixed 'n' (used in EPS) when period = "common". Thanks to Donald Zhao for reporting. Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2014-01-19 20:00:33 UTC (rev 730) +++ pkg/dplR/ChangeLog 2014-03-24 08:53:29 UTC (rev 731) @@ -43,6 +43,16 @@ bounds. However, in most cases that would probably not have been a problem. +File: rwi.stats.running.R +------------------------- + +- Bug fix: when using period = "common" in rwi.stats() or + rwi.stats.running(), the number of trees 'n' used in EPS and shown + in the return value is now the total number of trees in the + data.frame, taking into account the fact that rows with any + missing values are effectively dropped. Thanks to Donald Zhao for + reporting. + * CHANGES IN dplR VERSION 1.5.8 File: tbrm.Rd Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2014-01-19 20:00:33 UTC (rev 730) +++ pkg/dplR/DESCRIPTION 2014-03-24 08:53:29 UTC (rev 731) @@ -3,7 +3,7 @@ Type: Package Title: Dendrochronology Program Library in R Version: 1.5.9 -Date: 2014-01-19 +Date: 2014-03-24 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/rwi.stats.running.R =================================================================== --- pkg/dplR/R/rwi.stats.running.R 2014-01-19 20:00:33 UTC (rev 730) +++ pkg/dplR/R/rwi.stats.running.R 2014-03-24 08:53:29 UTC (rev 731) @@ -170,6 +170,9 @@ bad.rows <- which(apply(is.na(rwi3), 1, any)) rwi3[bad.rows, ] <- NA good.rows <- setdiff(good.rows, bad.rows) + period.common <- TRUE + } else { + period.common <- FALSE } if (length(good.rows) < min.corr.overlap) { @@ -291,11 +294,18 @@ rbar.bt <- rsum.bt / n.bt } - ## Number of trees averaged over the years in the window. - ## We keep this number separate of the correlation estimates, - ## i.e. the data from some tree / year may contribute to n - ## without taking part in the correlation estimates. - n <- mean(n.trees.by.year[year.idx], na.rm=TRUE) + if (period.common) { + ## If period is "common", we are only looking at the rows + ## with no missing values. + n <- n.trees + } else { + ## Number of trees averaged over the years in the window. + ## We keep this number separate of the correlation + ## estimates, i.e. the data from some tree / year may + ## contribute to n without taking part in the correlation + ## estimates. + n <- mean(n.trees.by.year[year.idx], na.rm=TRUE) + } ## Expressed population signal if (n.wt == 0) { From noreply at r-forge.r-project.org Mon Mar 24 10:23:13 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 24 Mar 2014 10:23:13 +0100 (CET) Subject: [Dplr-commits] r732 - pkg/dplR/inst/unitTests Message-ID: <20140324092313.4D073186BB3@r-forge.r-project.org> Author: mvkorpel Date: 2014-03-24 10:23:12 +0100 (Mon, 24 Mar 2014) New Revision: 732 Modified: pkg/dplR/inst/unitTests/runit.dplR.R Log: A unit test for rwi.stats(), testing that 'n' is correct when period="common" Modified: pkg/dplR/inst/unitTests/runit.dplR.R =================================================================== --- pkg/dplR/inst/unitTests/runit.dplR.R 2014-03-24 08:53:29 UTC (rev 731) +++ pkg/dplR/inst/unitTests/runit.dplR.R 2014-03-24 09:23:12 UTC (rev 732) @@ -590,6 +590,20 @@ msg="Reordered input is handled correctly") } +test.rwi.stats <- function() { + ## Setup + v.1 <- 1 + runif(300) + range.1 <- 51:400 + rnames.1 <- as.character(range.1) + df.1 <- data.frame(col1 = c(v.1, rep(NA, 50)), + col2 = c(rep(NA, 25), v.1, rep(NA, 25)), + col3 = c(rep(NA, 50), v.1), + row.names = rnames.1) + ## Test + checkEquals(3, rwi.stats(df.1, period="common")[["n"]]) + ## Needs more tests +} + test.sens1 <- function() { ## Setup SAMP.SIZE <- 1000 From noreply at r-forge.r-project.org Tue Mar 25 09:39:48 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 25 Mar 2014 09:39:48 +0100 (CET) Subject: [Dplr-commits] r733 - in tags: . dplR-1.5.9 Message-ID: <20140325083948.993E618447B@r-forge.r-project.org> Author: mvkorpel Date: 2014-03-25 09:39:47 +0100 (Tue, 25 Mar 2014) New Revision: 733 Added: tags/dplR-1.5.9/ Log: dplR 1.5.9 Property changes on: tags/dplR-1.5.9 ___________________________________________________________________ Added: svn:ignore + dplR-Ex.R Added: svn:mergeinfo + /branches/dplR-R-2.15:466-506 /branches/redfit:662-700 From noreply at r-forge.r-project.org Tue Mar 25 09:44:04 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 25 Mar 2014 09:44:04 +0100 (CET) Subject: [Dplr-commits] r734 - pkg/dplR Message-ID: <20140325084405.0884F18716C@r-forge.r-project.org> Author: mvkorpel Date: 2014-03-25 09:44:04 +0100 (Tue, 25 Mar 2014) New Revision: 734 Modified: pkg/dplR/ChangeLog pkg/dplR/DESCRIPTION Log: Preparing for dplR 1.6.0, assuming the current version number scheme Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2014-03-25 08:39:47 UTC (rev 733) +++ pkg/dplR/ChangeLog 2014-03-25 08:44:04 UTC (rev 734) @@ -1,3 +1,5 @@ +* CHANGES IN dplR VERSION 1.6.0 + * CHANGES IN dplR VERSION 1.5.9 Files: dplR.h, rcompact.c, redfit.c Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2014-03-25 08:39:47 UTC (rev 733) +++ pkg/dplR/DESCRIPTION 2014-03-25 08:44:04 UTC (rev 734) @@ -2,8 +2,8 @@ Package: dplR Type: Package Title: Dendrochronology Program Library in R -Version: 1.5.9 -Date: 2014-03-24 +Version: 1.6.0 +Date: 2014-03-25 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", From noreply at r-forge.r-project.org Wed Mar 26 01:50:22 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 26 Mar 2014 01:50:22 +0100 (CET) Subject: [Dplr-commits] r735 - in pkg/dplR: . R man Message-ID: <20140326005022.66C6118737D@r-forge.r-project.org> Author: andybunn Date: 2014-03-26 01:50:21 +0100 (Wed, 26 Mar 2014) New Revision: 735 Modified: pkg/dplR/ChangeLog pkg/dplR/R/rwi.stats.running.R pkg/dplR/man/rwi.stats.running.Rd Log: added SNR to rwi.stats at request of user. modified examples. Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2014-03-25 08:44:04 UTC (rev 734) +++ pkg/dplR/ChangeLog 2014-03-26 00:50:21 UTC (rev 735) @@ -1,5 +1,12 @@ * CHANGES IN dplR VERSION 1.6.0 +File: rwi.stats.running.R +------------------------- + +- Added signal-to-noise ratio as an output. Followed pg 109 in + Cook's chapter in Huhges et al. 2011. + + * CHANGES IN dplR VERSION 1.5.9 Files: dplR.h, rcompact.c, redfit.c Modified: pkg/dplR/R/rwi.stats.running.R =================================================================== --- pkg/dplR/R/rwi.stats.running.R 2014-03-25 08:44:04 UTC (rev 734) +++ pkg/dplR/R/rwi.stats.running.R 2014-03-26 00:50:21 UTC (rev 735) @@ -1,368 +1,370 @@ -### Helper functions - -### Computes the correlation coefficients between columns of x and y. -### Requires "limit" overlapping values in each pair. -cor.with.limit <- function(limit, x, y) { - n.x <- ncol(x) # caller makes sure that n.x - n.y <- ncol(y) # and n.y >= 1 - r.mat <- matrix(NA_real_, n.x, n.y) - for (i in seq_len(n.x)) { - this.x <- x[, i] - good.x <- !is.na(this.x) - for (j in seq_len(n.y)) { - this.y <- y[, j] - good.y <- !is.na(this.y) - good.both <- which(good.x & good.y) - n.good <- length(good.both) - if (n.good >= limit && n.good > 0) { - r.mat[i, j] <- cor(this.x[good.both], this.y[good.both]) - } - } - } - r.mat -} - -### Computes the correlation coefficients between different columns of x. -cor.with.limit.upper <- function(limit, x) { - n.x <- ncol(x) # caller makes sure that n.x >= 2 - r.vec <- rep.int(NA_real_, n.x * (n.x - 1) / 2) - good.x <- !is.na(x) - k <- 0 - for (i in seq_len(n.x - 1)) { - good.i <- good.x[, i] - for (j in (i + 1):n.x) { - k <- k + 1 - good.both <- which(good.i & good.x[, j]) - if (length(good.both) >= limit) { - r.vec[k] <- cor(x[good.both, i], x[good.both, j]) - } - } - } - r.vec -} - -rwi.stats <- function(rwi, ids=NULL, period=c("max", "common"), ...) { - args <- list(...) - args[["rwi"]] <- rwi - args[["ids"]] <- ids - args[["period"]] <- period - args[["running.window"]] <- FALSE - do.call(rwi.stats.running, args) -} - -### Main function, exported to user -rwi.stats.running <- function(rwi, ids=NULL, period=c("max", "common"), - prewhiten=FALSE,n=NULL, - running.window=TRUE, - window.length=min(50, nrow(rwi)), - window.overlap=floor(window.length / 2), - first.start=NULL, - min.corr.overlap=min(30, window.length), - round.decimals=3, - zero.is.missing=TRUE) { - period2 <- match.arg(period) - - if (running.window) { - if (window.length < 3) { - stop("minimum 'window.length' is 3") - } - window.advance <- window.length - window.overlap - if (window.advance < 1) { - stop(gettextf("'window.overlap' is too large, max value is 'window.length'-1 (%d)", - window.length - 1)) - } - if (window.length < min.corr.overlap) { - stop("'window.length' is smaller than 'min.corr.overlap'") - } - } - tmp <- normalize1(rwi, n, prewhiten) - if(!all(tmp$idx.good)) { - warning("after prewhitening, 'rwi' contains column(s) without at least four observations", - call.=FALSE) - cat(gettext("note that there is no error checking on column lengths if filtering is not performed\n", - domain="R-dplR")) - } - rwi2 <- as.matrix(tmp$master) - n.cores <- ncol(rwi2) - - zero.flag <- rwi2 == 0 - if (any(zero.flag, na.rm=TRUE)) { - if (!zero.is.missing) { - warning("There are zeros in the data. Consider the option 'zero.is.missing'.") - } else { - rwi2[zero.flag] <- NA - } - } - - ## If 'ids' is NULL then assume one core per tree - if (is.null(ids)) { - ids3 <- data.frame(tree=seq_len(n.cores), core=rep.int(1, n.cores)) - rwi3 <- rwi2 - } else { - ## Make error checks here - if (!is.data.frame(ids) || !all(c("tree", "core") %in% names(ids))) { - stop("'ids' must be a data.frame with columns 'tree' and 'core'") - } - if (!all(vapply(ids, is.numeric, TRUE))) { - stop("'ids' must have numeric columns") - } - colnames.rwi <- colnames(rwi2) - ## If all column names in 'rwi' are present in the set of row - ## names in 'ids', arrange 'ids' to matching order - rownames.ids <- row.names(ids) - if (!is.null(rownames.ids) && all(colnames.rwi %in% rownames.ids)) { - ids2 <- ids[colnames.rwi, c("tree", "core")] - } else if (nrow(ids) == n.cores) { - ids2 <- ids[c("tree", "core")] - } else { - stop("dimension problem: ", "'ncol(rwi)' != 'nrow(ids)'") - } - row.names(ids2) <- NULL - unique.ids <- unique(ids2) - n.unique <- nrow(unique.ids) - if (n.unique < n.cores) { - ## If more than one columns of 'rwi' share a tree/core ID pair, - ## the columns are averaged and treated as one core - ids3 <- unique.ids - rwi3 <- matrix(data=as.numeric(NA), nrow=nrow(rwi2), ncol=n.unique, - dimnames=list(rownames(rwi2))) - for (i in seq_len(n.unique)) { - these.cols <- row.match(ids2, unique.ids[i, ]) - rwi3[, i] <- - rowMeans(rwi2[, these.cols, drop=FALSE], na.rm=TRUE) - } - message("Series with matching tree/core IDs have been averaged") - } else { - ids3 <- ids2 - rwi3 <- rwi2 - } - } - - n.years <- nrow(rwi3) - if (running.window && window.length > n.years) { - stop("'window.length' is larger than the number of years in 'rwi'") - } - - unique.trees <- unique(ids3$tree) - n.trees <- length(unique.trees) - if (n.trees < 2) { - stop("at least 2 trees are needed") - } - cores.of.tree <- list() - seq.tree <- seq_len(n.trees) - for (i in seq.tree) { - cores.of.tree[[i]] <- which(ids3$tree==unique.trees[i]) - } - - ## n.trees.by.year is recorded before setting rows with missing - ## data to NA - tree.any <- matrix(FALSE, n.years, n.trees) - for (i in seq.tree) { - tree.any[, i] <- - apply(!is.na(rwi3[, ids3$tree == unique.trees[i], drop=FALSE]), - 1, any) - } - n.trees.by.year <- rowSums(tree.any) - good.rows <- which(n.trees.by.year > 1) - - ## Easy way to force complete overlap of data - if (period2 == "common") { - bad.rows <- which(apply(is.na(rwi3), 1, any)) - rwi3[bad.rows, ] <- NA - good.rows <- setdiff(good.rows, bad.rows) - period.common <- TRUE - } else { - period.common <- FALSE - } - - if (length(good.rows) < min.corr.overlap) { - stop("too few years with enough trees for correlation calculations") - } - - if (running.window) { - if (is.numeric(first.start)) { - if (first.start < 1) { - stop("'first.start' too small, must be >= 1") - } else if (first.start > n.years - window.length + 1) { - stop("'first.start' too large") - } - first.start2 <- first.start - } else { - ## Select locations of running windows by maximizing the - ## number of data points (sum of number of series for each - ## selected year), but don't count rows with less than two - ## trees - min.offset <- - max(0, min(good.rows) - (window.length - min.corr.overlap) - 1) - max.offset <- - min(min.offset + window.advance - 1, n.years - window.length) - offsets <- min.offset:max.offset - n.offsets <- length(offsets) - n.data <- rep.int(NA_real_, n.offsets) - for (i in seq_len(n.offsets)) { - offset <- offsets[i] - n.windows.minusone <- - (n.years - offset - window.length) %/% window.advance - max.idx <- - offset + window.length + n.windows.minusone * window.advance - n.data[i] <- sum(!is.na(rwi3[intersect(good.rows, - (1 + offset):max.idx), ])) - } - ## In case of a tie, choose large offset. - ## In practice, this prefers recent years. - first.start2 <- - offsets[n.offsets - which.max(rev(n.data)) + 1] + 1 - } - window.start <- seq(from = first.start2, - to = n.years - window.length + 1, - by = window.advance) - window.length2 <- window.length - } else { - window.start <- 1 - window.length2 <- n.years - } - - all.years <- as.numeric(rownames(rwi3)) - - loop.body <- function(s.idx) { - rbar.tot <- NA_real_ - rbar.wt <- NA_real_ - rbar.bt <- NA_real_ - - ## Location of window - start.year <- all.years[s.idx] - e.idx <- s.idx + window.length2 - 1 - end.year <- all.years[e.idx] - mid.year <- floor((start.year + end.year) / 2) - year.idx <- s.idx:e.idx - - ## See p 138 in C&K - ## Sum of all correlations among different cores (between trees) - rsum.bt <- 0 - n.bt <- 0 - good.flag <- rep.int(FALSE, n.trees) - for (i in seq_len(n.trees - 1)) { - i.data <- rwi3[year.idx, cores.of.tree[[i]], drop=FALSE] - for (j in (i + 1):n.trees) { - j.data <- rwi3[year.idx, cores.of.tree[[j]], drop=FALSE] - bt.r.mat <- cor.with.limit(min.corr.overlap, i.data, j.data) - bt.r.mat <- bt.r.mat[!is.na(bt.r.mat)] - n.bt.temp <- length(bt.r.mat) - if (n.bt.temp > 0) { - rsum.bt <- rsum.bt + sum(bt.r.mat) - n.bt <- n.bt + n.bt.temp - good.flag[c(i, j)] <- TRUE - } - } - } - - ## Sum of all correlations among different cores (within trees) - good.trees <- which(good.flag) - rsum.wt <- 0 - n.wt <- 0 - n.cores.tree <- rep.int(NA_real_, n.trees) - for (i in good.trees) { - these.cores <- cores.of.tree[[i]] - if (length(these.cores)==1) { # make simple case fast - n.cores.tree[i] <- 1 - } else { - these.data <- rwi3[year.idx, these.cores, drop=FALSE] - wt.r.vec <- cor.with.limit.upper(min.corr.overlap, these.data) - wt.r.vec <- wt.r.vec[!is.na(wt.r.vec)] - n.wt.temp <- length(wt.r.vec) - if (n.wt.temp > 0) { - rsum.wt <- rsum.wt + sum(wt.r.vec) - n.wt <- n.wt + n.wt.temp - ## Solving c (> 0) in the formula n = 0.5 * c * (c-1) - ## leads to c = 0.5 + sqrt(0.25+2*n) - n.cores.tree[i] <- 0.5 + sqrt(0.25 + 2 * n.wt.temp) - } else { - n.cores.tree[i] <- 1 - } - } - } - - ## Mean correlations - n.tot <- n.wt + n.bt - if (n.tot > 0) { - rbar.tot <- (rsum.wt + rsum.bt) / n.tot - } - if (n.wt > 0) { - rbar.wt <- rsum.wt / n.wt - } - if (n.bt > 0) { - rbar.bt <- rsum.bt / n.bt - } - - if (period.common) { - ## If period is "common", we are only looking at the rows - ## with no missing values. - n <- n.trees - } else { - ## Number of trees averaged over the years in the window. - ## We keep this number separate of the correlation - ## estimates, i.e. the data from some tree / year may - ## contribute to n without taking part in the correlation - ## estimates. - n <- mean(n.trees.by.year[year.idx], na.rm=TRUE) - } - - ## Expressed population signal - if (n.wt == 0) { - c.eff <- 1 - rbar.eff <- rbar.bt - } else { - c.eff.rproc <- mean(1 / n.cores.tree, na.rm=TRUE) - c.eff <- 1 / c.eff.rproc # bookkeeping only - rbar.eff <- rbar.bt / (rbar.wt + (1 - rbar.wt) * c.eff.rproc) - } - ## EPS is on page 146 of C&K. - ## In our interpretation of EPS, we use the average number of trees. - eps <- n * rbar.eff / ((n - 1) * rbar.eff + 1) - - if (running.window) { - c(start.year = start.year, mid.year = mid.year, end.year = end.year, - n.tot = n.tot, n.wt = n.wt, n.bt = n.bt, rbar.tot = rbar.tot, - rbar.wt = rbar.wt, rbar.bt = rbar.bt, c.eff = c.eff, - rbar.eff = rbar.eff, eps = eps, n = n) - } else { - c(n.tot = n.tot, n.wt = n.wt, n.bt = n.bt, rbar.tot = rbar.tot, - rbar.wt = rbar.wt, rbar.bt = rbar.bt, c.eff = c.eff, - rbar.eff = rbar.eff, eps = eps, n = n) - } - } - - ## Iterate over all windows - if (running.window && - !inherits(try(suppressWarnings(req.fe <- - requireNamespace("foreach", - quietly=TRUE)), - silent = TRUE), - "try-error") && req.fe) { - - exportFun <- c("<-", "+", "-", "floor", ":", "rep.int", "for", - "seq_len", "[", "[[", "cor.with.limit", "!", - "is.na", "length", "if", ">", "sum", "c", - "[<-", "which", "==", "cor.with.limit.upper", - "sqrt", "*", "/", "(", "{", "mean") - - compos.stats <- - foreach::"%dopar%"(foreach::foreach(s.idx=window.start, - .combine="rbind", - .export=exportFun), - loop.body(s.idx)) - } else { - compos.stats <- NULL - for (s.idx in window.start) { - compos.stats <- rbind(compos.stats, loop.body(s.idx)) - } - } - - rownames(compos.stats) <- NULL - if (is.numeric(round.decimals) && length(round.decimals) > 0 && - is.finite(round.decimals[1]) && round.decimals[1] >= 0) { - data.frame(round(compos.stats, round.decimals[1])) - } else { - data.frame(compos.stats) - } -} +### Helper functions + +### Computes the correlation coefficients between columns of x and y. +### Requires "limit" overlapping values in each pair. +cor.with.limit <- function(limit, x, y) { + n.x <- ncol(x) # caller makes sure that n.x + n.y <- ncol(y) # and n.y >= 1 + r.mat <- matrix(NA_real_, n.x, n.y) + for (i in seq_len(n.x)) { + this.x <- x[, i] + good.x <- !is.na(this.x) + for (j in seq_len(n.y)) { + this.y <- y[, j] + good.y <- !is.na(this.y) + good.both <- which(good.x & good.y) + n.good <- length(good.both) + if (n.good >= limit && n.good > 0) { + r.mat[i, j] <- cor(this.x[good.both], this.y[good.both]) + } + } + } + r.mat +} + +### Computes the correlation coefficients between different columns of x. +cor.with.limit.upper <- function(limit, x) { + n.x <- ncol(x) # caller makes sure that n.x >= 2 + r.vec <- rep.int(NA_real_, n.x * (n.x - 1) / 2) + good.x <- !is.na(x) + k <- 0 + for (i in seq_len(n.x - 1)) { + good.i <- good.x[, i] + for (j in (i + 1):n.x) { + k <- k + 1 + good.both <- which(good.i & good.x[, j]) + if (length(good.both) >= limit) { + r.vec[k] <- cor(x[good.both, i], x[good.both, j]) + } + } + } + r.vec +} + +rwi.stats <- function(rwi, ids=NULL, period=c("max", "common"), ...) { + args <- list(...) + args[["rwi"]] <- rwi + args[["ids"]] <- ids + args[["period"]] <- period + args[["running.window"]] <- FALSE + do.call(rwi.stats.running, args) +} + +### Main function, exported to user +rwi.stats.running <- function(rwi, ids=NULL, period=c("max", "common"), + prewhiten=FALSE,n=NULL, + running.window=TRUE, + window.length=min(50, nrow(rwi)), + window.overlap=floor(window.length / 2), + first.start=NULL, + min.corr.overlap=min(30, window.length), + round.decimals=3, + zero.is.missing=TRUE) { + period2 <- match.arg(period) + + if (running.window) { + if (window.length < 3) { + stop("minimum 'window.length' is 3") + } + window.advance <- window.length - window.overlap + if (window.advance < 1) { + stop(gettextf("'window.overlap' is too large, max value is 'window.length'-1 (%d)", + window.length - 1)) + } + if (window.length < min.corr.overlap) { + stop("'window.length' is smaller than 'min.corr.overlap'") + } + } + tmp <- normalize1(rwi, n, prewhiten) + if(!all(tmp$idx.good)) { + warning("after prewhitening, 'rwi' contains column(s) without at least four observations", + call.=FALSE) + cat(gettext("note that there is no error checking on column lengths if filtering is not performed\n", + domain="R-dplR")) + } + rwi2 <- as.matrix(tmp$master) + n.cores <- ncol(rwi2) + + zero.flag <- rwi2 == 0 + if (any(zero.flag, na.rm=TRUE)) { + if (!zero.is.missing) { + warning("There are zeros in the data. Consider the option 'zero.is.missing'.") + } else { + rwi2[zero.flag] <- NA + } + } + + ## If 'ids' is NULL then assume one core per tree + if (is.null(ids)) { + ids3 <- data.frame(tree=seq_len(n.cores), core=rep.int(1, n.cores)) + rwi3 <- rwi2 + } else { + ## Make error checks here + if (!is.data.frame(ids) || !all(c("tree", "core") %in% names(ids))) { + stop("'ids' must be a data.frame with columns 'tree' and 'core'") + } + if (!all(vapply(ids, is.numeric, TRUE))) { + stop("'ids' must have numeric columns") + } + colnames.rwi <- colnames(rwi2) + ## If all column names in 'rwi' are present in the set of row + ## names in 'ids', arrange 'ids' to matching order + rownames.ids <- row.names(ids) + if (!is.null(rownames.ids) && all(colnames.rwi %in% rownames.ids)) { + ids2 <- ids[colnames.rwi, c("tree", "core")] + } else if (nrow(ids) == n.cores) { + ids2 <- ids[c("tree", "core")] + } else { + stop("dimension problem: ", "'ncol(rwi)' != 'nrow(ids)'") + } + row.names(ids2) <- NULL + unique.ids <- unique(ids2) + n.unique <- nrow(unique.ids) + if (n.unique < n.cores) { + ## If more than one columns of 'rwi' share a tree/core ID pair, + ## the columns are averaged and treated as one core + ids3 <- unique.ids + rwi3 <- matrix(data=as.numeric(NA), nrow=nrow(rwi2), ncol=n.unique, + dimnames=list(rownames(rwi2))) + for (i in seq_len(n.unique)) { + these.cols <- row.match(ids2, unique.ids[i, ]) + rwi3[, i] <- + rowMeans(rwi2[, these.cols, drop=FALSE], na.rm=TRUE) + } + message("Series with matching tree/core IDs have been averaged") + } else { + ids3 <- ids2 + rwi3 <- rwi2 + } + } + + n.years <- nrow(rwi3) + if (running.window && window.length > n.years) { + stop("'window.length' is larger than the number of years in 'rwi'") + } + + unique.trees <- unique(ids3$tree) + n.trees <- length(unique.trees) + if (n.trees < 2) { + stop("at least 2 trees are needed") + } + cores.of.tree <- list() + seq.tree <- seq_len(n.trees) + for (i in seq.tree) { + cores.of.tree[[i]] <- which(ids3$tree==unique.trees[i]) + } + + ## n.trees.by.year is recorded before setting rows with missing + ## data to NA + tree.any <- matrix(FALSE, n.years, n.trees) + for (i in seq.tree) { + tree.any[, i] <- + apply(!is.na(rwi3[, ids3$tree == unique.trees[i], drop=FALSE]), + 1, any) + } + n.trees.by.year <- rowSums(tree.any) + good.rows <- which(n.trees.by.year > 1) + + ## Easy way to force complete overlap of data + if (period2 == "common") { + bad.rows <- which(apply(is.na(rwi3), 1, any)) + rwi3[bad.rows, ] <- NA + good.rows <- setdiff(good.rows, bad.rows) + period.common <- TRUE + } else { + period.common <- FALSE + } + + if (length(good.rows) < min.corr.overlap) { + stop("too few years with enough trees for correlation calculations") + } + + if (running.window) { + if (is.numeric(first.start)) { + if (first.start < 1) { + stop("'first.start' too small, must be >= 1") + } else if (first.start > n.years - window.length + 1) { + stop("'first.start' too large") + } + first.start2 <- first.start + } else { + ## Select locations of running windows by maximizing the + ## number of data points (sum of number of series for each + ## selected year), but don't count rows with less than two + ## trees + min.offset <- + max(0, min(good.rows) - (window.length - min.corr.overlap) - 1) + max.offset <- + min(min.offset + window.advance - 1, n.years - window.length) + offsets <- min.offset:max.offset + n.offsets <- length(offsets) + n.data <- rep.int(NA_real_, n.offsets) + for (i in seq_len(n.offsets)) { + offset <- offsets[i] + n.windows.minusone <- + (n.years - offset - window.length) %/% window.advance + max.idx <- + offset + window.length + n.windows.minusone * window.advance + n.data[i] <- sum(!is.na(rwi3[intersect(good.rows, + (1 + offset):max.idx), ])) + } + ## In case of a tie, choose large offset. + ## In practice, this prefers recent years. + first.start2 <- + offsets[n.offsets - which.max(rev(n.data)) + 1] + 1 + } + window.start <- seq(from = first.start2, + to = n.years - window.length + 1, + by = window.advance) + window.length2 <- window.length + } else { + window.start <- 1 + window.length2 <- n.years + } + + all.years <- as.numeric(rownames(rwi3)) + + loop.body <- function(s.idx) { + rbar.tot <- NA_real_ + rbar.wt <- NA_real_ + rbar.bt <- NA_real_ + + ## Location of window + start.year <- all.years[s.idx] + e.idx <- s.idx + window.length2 - 1 + end.year <- all.years[e.idx] + mid.year <- floor((start.year + end.year) / 2) + year.idx <- s.idx:e.idx + + ## See p 138 in C&K + ## Sum of all correlations among different cores (between trees) + rsum.bt <- 0 + n.bt <- 0 + good.flag <- rep.int(FALSE, n.trees) + for (i in seq_len(n.trees - 1)) { + i.data <- rwi3[year.idx, cores.of.tree[[i]], drop=FALSE] + for (j in (i + 1):n.trees) { + j.data <- rwi3[year.idx, cores.of.tree[[j]], drop=FALSE] + bt.r.mat <- cor.with.limit(min.corr.overlap, i.data, j.data) + bt.r.mat <- bt.r.mat[!is.na(bt.r.mat)] + n.bt.temp <- length(bt.r.mat) + if (n.bt.temp > 0) { + rsum.bt <- rsum.bt + sum(bt.r.mat) + n.bt <- n.bt + n.bt.temp + good.flag[c(i, j)] <- TRUE + } + } + } + + ## Sum of all correlations among different cores (within trees) + good.trees <- which(good.flag) + rsum.wt <- 0 + n.wt <- 0 + n.cores.tree <- rep.int(NA_real_, n.trees) + for (i in good.trees) { + these.cores <- cores.of.tree[[i]] + if (length(these.cores)==1) { # make simple case fast + n.cores.tree[i] <- 1 + } else { + these.data <- rwi3[year.idx, these.cores, drop=FALSE] + wt.r.vec <- cor.with.limit.upper(min.corr.overlap, these.data) + wt.r.vec <- wt.r.vec[!is.na(wt.r.vec)] + n.wt.temp <- length(wt.r.vec) + if (n.wt.temp > 0) { + rsum.wt <- rsum.wt + sum(wt.r.vec) + n.wt <- n.wt + n.wt.temp + ## Solving c (> 0) in the formula n = 0.5 * c * (c-1) + ## leads to c = 0.5 + sqrt(0.25+2*n) + n.cores.tree[i] <- 0.5 + sqrt(0.25 + 2 * n.wt.temp) + } else { + n.cores.tree[i] <- 1 + } + } + } + + ## Mean correlations + n.tot <- n.wt + n.bt + if (n.tot > 0) { + rbar.tot <- (rsum.wt + rsum.bt) / n.tot + } + if (n.wt > 0) { + rbar.wt <- rsum.wt / n.wt + } + if (n.bt > 0) { + rbar.bt <- rsum.bt / n.bt + } + + if (period.common) { + ## If period is "common", we are only looking at the rows + ## with no missing values. + n <- n.trees + } else { + ## Number of trees averaged over the years in the window. + ## We keep this number separate of the correlation + ## estimates, i.e. the data from some tree / year may + ## contribute to n without taking part in the correlation + ## estimates. + n <- mean(n.trees.by.year[year.idx], na.rm=TRUE) + } + + ## Expressed population signal + if (n.wt == 0) { + c.eff <- 1 + rbar.eff <- rbar.bt + } else { + c.eff.rproc <- mean(1 / n.cores.tree, na.rm=TRUE) + c.eff <- 1 / c.eff.rproc # bookkeeping only + rbar.eff <- rbar.bt / (rbar.wt + (1 - rbar.wt) * c.eff.rproc) + } + ## EPS is on page 146 of C&K. + ## In our interpretation of EPS, we use the average number of trees. + eps <- n * rbar.eff / ((n - 1) * rbar.eff + 1) + ## SNR is on page 109 of Hughes et al. 2011 + snr <- n * rbar.eff / (1-rbar.eff) + + if (running.window) { + c(start.year = start.year, mid.year = mid.year, end.year = end.year, + n.tot = n.tot, n.wt = n.wt, n.bt = n.bt, rbar.tot = rbar.tot, + rbar.wt = rbar.wt, rbar.bt = rbar.bt, c.eff = c.eff, + rbar.eff = rbar.eff, eps = eps, snr = snr, n = n) + } else { + c(n.tot = n.tot, n.wt = n.wt, n.bt = n.bt, rbar.tot = rbar.tot, + rbar.wt = rbar.wt, rbar.bt = rbar.bt, c.eff = c.eff, + rbar.eff = rbar.eff, eps = eps, snr = snr, n = n) + } + } + + ## Iterate over all windows + if (running.window && + !inherits(try(suppressWarnings(req.fe <- + requireNamespace("foreach", + quietly=TRUE)), + silent = TRUE), + "try-error") && req.fe) { + + exportFun <- c("<-", "+", "-", "floor", ":", "rep.int", "for", + "seq_len", "[", "[[", "cor.with.limit", "!", + "is.na", "length", "if", ">", "sum", "c", + "[<-", "which", "==", "cor.with.limit.upper", + "sqrt", "*", "/", "(", "{", "mean") + + compos.stats <- + foreach::"%dopar%"(foreach::foreach(s.idx=window.start, + .combine="rbind", + .export=exportFun), + loop.body(s.idx)) + } else { + compos.stats <- NULL + for (s.idx in window.start) { + compos.stats <- rbind(compos.stats, loop.body(s.idx)) + } + } + + rownames(compos.stats) <- NULL + if (is.numeric(round.decimals) && length(round.decimals) > 0 && + is.finite(round.decimals[1]) && round.decimals[1] >= 0) { + data.frame(round(compos.stats, round.decimals[1])) + } else { + data.frame(compos.stats) + } +} Modified: pkg/dplR/man/rwi.stats.running.Rd =================================================================== --- pkg/dplR/man/rwi.stats.running.Rd 2014-03-25 08:44:04 UTC (rev 734) +++ pkg/dplR/man/rwi.stats.running.Rd 2014-03-26 00:50:21 UTC (rev 735) @@ -1,242 +1,248 @@ -\name{rwi.stats.running} -\alias{rwi.stats.running} -\alias{rwi.stats} -\alias{rwi.stats.legacy} -\title{ (Running Window) Statistics on Detrended Ring-Width Series } -\description{ - These functions calculate descriptive statistics on a - \code{data.frame} of (usually) ring-width indices. The statistics are - optionally computed in a running window with adjustable length and - overlap. The data can be filtered so that the comparisons are made to - on just high-frequency data. -} -\usage{ -rwi.stats.running(rwi, ids = NULL, period = c("max", "common"), - prewhiten=FALSE,n=NULL, - running.window = TRUE, - window.length = min(50, nrow(rwi)), - window.overlap = floor(window.length / 2), - first.start = NULL, - min.corr.overlap = min(30, window.length), - round.decimals = 3, - zero.is.missing = TRUE) - -rwi.stats(rwi, ids=NULL, period=c("max", "common"), \dots) - -rwi.stats.legacy(rwi, ids=NULL, period=c("max", "common")) -} -\arguments{ - - \item{rwi}{ a \code{data.frame} with detrended and standardized ring - width indices as columns and years as rows such as that produced by - \code{\link{detrend}}. } - - \item{ids}{ an optional \code{data.frame} with column one named - \code{"tree"} giving a \code{numeric} \acronym{ID} for each tree and - column two named \code{"core"} giving a \code{numeric} \acronym{ID} - for each core. Defaults to one core per tree as - \code{data.frame(tree = 1:ncol(\var{rwi}), core = rep(1, - ncol(\var{rwi})))}. } - \item{period}{ a \code{character} string, either \code{"common"} or - \code{"max"} indicating whether correlations should be limited to - complete observations over the period common to all cores (i.e. rows - common to all samples) or the maximum pairwise overlap. Defaults - to \code{"max"}. } - \item{n}{ \code{NULL} or an integral value giving the filter length - for the \code{\link{hanning}} filter used for removal of low - frequency variation. } - \item{prewhiten}{ \code{logical} flag. If \code{TRUE} each series is - whitened using \code{\link{ar}}. } - \item{running.window}{ \code{logical} flag indicating whether to use a - running window (\code{TRUE}, the default) or to ignore the other - window parameters and effectively use one window covering all years - (\code{FALSE}). } - \item{window.length}{ \code{numeric} value indicating the length of - the running window in years. The default is 50 years or the number - of years (rows) in \code{\var{rwi}}, whichever is smaller. } - \item{window.overlap}{ \code{numeric} value indicating the overlap of - consecutive window positions, i.e. the number of common years. The - default is half of the window length, rounded down. } - \item{first.start}{ an optional \code{numeric} value setting the - position of the first window. Must be a value between \code{1} and - \code{\var{n.years}-\var{window.length}+1}, where - \code{\var{n.years}} is the number of years in \code{\var{rwi}}. The - default value \code{NULL} lets the function make the decision using - some heuristic rules. } - \item{min.corr.overlap}{ \code{numeric} value setting the minimum - number of common years in any pair of ring-width series required for - their correlation to be included in the calculations. Smaller - overlaps are considered to yield unreliable correlation values which - are ignored. Defaults to the minimum of 30 and the length of the - window. One way to lift the restriction and include all correlations - is to set \code{\var{min.corr.overlap} = 0}. } - \item{round.decimals}{ non-negative integer \code{numeric} value [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/dplr -r 735 From noreply at r-forge.r-project.org Wed Mar 26 01:56:44 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 26 Mar 2014 01:56:44 +0100 (CET) Subject: [Dplr-commits] r736 - pkg/dplR/man Message-ID: <20140326005644.7EEF2187552@r-forge.r-project.org> Author: andybunn Date: 2014-03-26 01:56:44 +0100 (Wed, 26 Mar 2014) New Revision: 736 Modified: pkg/dplR/man/rwi.stats.running.Rd Log: fixed plot in rwi.stats example Modified: pkg/dplR/man/rwi.stats.running.Rd =================================================================== --- pkg/dplR/man/rwi.stats.running.Rd 2014-03-26 00:50:21 UTC (rev 735) +++ pkg/dplR/man/rwi.stats.running.Rd 2014-03-26 00:56:44 UTC (rev 736) @@ -226,13 +226,14 @@ abline(h = 1, lwd = 1.5) lines(yrs, gp.crn[, 1], col = "grey50") lines(yrs, ffcsaps(gp.crn[, 1], nyrs = 32), col = "red", lwd = 2) + axis(1);axis(2);axis(3); par(new = TRUE) - ## Second plot is the chronology after the cut off only plot(bar$yrs, bar$eps, type = "b", xlab = "", ylab = "", axes = FALSE, pch = 20, col = "blue") - axis(1);axis(2);axis(3);axis(4,at = pretty(foo$eps)) - mtext("EPS", side = 4, line = 1.25) + axis(4,at = pretty(foo$eps)) + mtext("EPS", side = 4, line = 1.1) + axis(4,at = pretty(foo$eps)) box() yr.mask <- yrs > max(bar$yrs[bar$eps Author: mvkorpel Date: 2014-03-26 08:23:03 +0100 (Wed, 26 Mar 2014) New Revision: 737 Modified: pkg/dplR/ChangeLog Log: Fixed a typo. Andy: add Hughes et al. to \references in rwi.stats.running.Rd? Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2014-03-26 00:56:44 UTC (rev 736) +++ pkg/dplR/ChangeLog 2014-03-26 07:23:03 UTC (rev 737) @@ -4,7 +4,7 @@ ------------------------- - Added signal-to-noise ratio as an output. Followed pg 109 in - Cook's chapter in Huhges et al. 2011. + Cook's chapter in Hughes et al. 2011. * CHANGES IN dplR VERSION 1.5.9 From noreply at r-forge.r-project.org Wed Mar 26 11:29:10 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 26 Mar 2014 11:29:10 +0100 (CET) Subject: [Dplr-commits] r738 - pkg/dplR/src Message-ID: <20140326102910.4786F187186@r-forge.r-project.org> Author: mvkorpel Date: 2014-03-26 11:29:09 +0100 (Wed, 26 Mar 2014) New Revision: 738 Modified: pkg/dplR/src/redfit.c Log: Removed non-ASCII character from comment Modified: pkg/dplR/src/redfit.c =================================================================== --- pkg/dplR/src/redfit.c 2014-03-26 07:23:03 UTC (rev 737) +++ pkg/dplR/src/redfit.c 2014-03-26 10:29:09 UTC (rev 738) @@ -238,7 +238,7 @@ xwk_data[j] *= ww_data[wwidx++]; sumx += xwk_data[j]; } - /* Lomb?Scargle Fourier transform */ + /* Lomb-Scargle Fourier transform */ ftfix(xwk_data, twk_data, nseg_val, freq_data, nfreq_val, si, lfreq, tzero, tcos_data, tsin_data, wtau_data, sumx / sqrt_nseg, ftrx_data, ftix_data); From noreply at r-forge.r-project.org Wed Mar 26 12:04:47 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 26 Mar 2014 12:04:47 +0100 (CET) Subject: [Dplr-commits] r739 - in pkg/dplR: . R inst inst/unitTests man po src tests Message-ID: <20140326110447.51D901872AC@r-forge.r-project.org> Author: mvkorpel Date: 2014-03-26 12:04:46 +0100 (Wed, 26 Mar 2014) New Revision: 739 Modified: pkg/dplR/ChangeLog pkg/dplR/DESCRIPTION pkg/dplR/NAMESPACE pkg/dplR/R/bai.in.R pkg/dplR/R/bai.out.R pkg/dplR/R/ccf.series.rwl.R pkg/dplR/R/chron.R pkg/dplR/R/cms.R pkg/dplR/R/combine.rwl.R pkg/dplR/R/common.interval.R pkg/dplR/R/corr.rwl.seg.R pkg/dplR/R/corr.series.seg.R pkg/dplR/R/crn.plot.R pkg/dplR/R/detrend.R pkg/dplR/R/detrend.series.R pkg/dplR/R/exactmean.R pkg/dplR/R/ffcsaps.R pkg/dplR/R/fill.internal.NA.R pkg/dplR/R/gini.coef.R pkg/dplR/R/glk.R pkg/dplR/R/hanning.R pkg/dplR/R/helpers.R pkg/dplR/R/i.detrend.R pkg/dplR/R/i.detrend.series.R pkg/dplR/R/morlet.R pkg/dplR/R/normalize.xdate.R pkg/dplR/R/normalize1.R pkg/dplR/R/pointer.R pkg/dplR/R/powt.R pkg/dplR/R/qa.xdate.R pkg/dplR/R/rcs.R pkg/dplR/R/read.compact.R pkg/dplR/R/read.crn.R pkg/dplR/R/read.fh.R pkg/dplR/R/read.ids.R pkg/dplR/R/read.rwl.R pkg/dplR/R/read.tridas.R pkg/dplR/R/read.tucson.R pkg/dplR/R/redfit.R pkg/dplR/R/rwi.stats.R pkg/dplR/R/rwi.stats.running.R pkg/dplR/R/rwl.stats.R pkg/dplR/R/sea.R pkg/dplR/R/seg.plot.R pkg/dplR/R/sens1.R pkg/dplR/R/sens2.R pkg/dplR/R/series.rwl.plot.R pkg/dplR/R/simpleXML.R pkg/dplR/R/skel.plot.R pkg/dplR/R/spag.plot.R pkg/dplR/R/strip.rwl.R pkg/dplR/R/tbrm.R pkg/dplR/R/tridas.vocabulary.R pkg/dplR/R/uuid.gen.R pkg/dplR/R/wavelet.plot.R pkg/dplR/R/wc.to.po.R pkg/dplR/R/write.compact.R pkg/dplR/R/write.crn.R pkg/dplR/R/write.rwl.R pkg/dplR/R/write.tridas.R pkg/dplR/R/write.tucson.R pkg/dplR/inst/CITATION pkg/dplR/inst/unitTests/Makefile pkg/dplR/inst/unitTests/runit.chron.R pkg/dplR/inst/unitTests/runit.dplR.R pkg/dplR/inst/unitTests/runit.io.R pkg/dplR/man/anos1.Rd pkg/dplR/man/bai.in.Rd pkg/dplR/man/bai.out.Rd pkg/dplR/man/ca533.Rd pkg/dplR/man/cana157.Rd pkg/dplR/man/ccf.series.rwl.Rd pkg/dplR/man/chron.Rd pkg/dplR/man/cms.Rd pkg/dplR/man/co021.Rd pkg/dplR/man/combine.rwl.Rd pkg/dplR/man/common.interval.Rd pkg/dplR/man/corr.rwl.seg.Rd pkg/dplR/man/corr.series.seg.Rd pkg/dplR/man/crn.plot.Rd pkg/dplR/man/detrend.Rd pkg/dplR/man/detrend.series.Rd pkg/dplR/man/dplR-package.Rd pkg/dplR/man/ffcsaps.Rd pkg/dplR/man/fill.internal.NA.Rd pkg/dplR/man/gini.coef.Rd pkg/dplR/man/glk.Rd pkg/dplR/man/gp.d2pith.Rd pkg/dplR/man/gp.dbh.Rd pkg/dplR/man/gp.po.Rd pkg/dplR/man/gp.rwl.Rd pkg/dplR/man/hanning.Rd pkg/dplR/man/i.detrend.Rd pkg/dplR/man/i.detrend.series.Rd pkg/dplR/man/morlet.Rd pkg/dplR/man/po.to.wc.Rd pkg/dplR/man/pointer.Rd pkg/dplR/man/powt.Rd pkg/dplR/man/print.redfit.Rd pkg/dplR/man/rcs.Rd pkg/dplR/man/read.compact.Rd pkg/dplR/man/read.crn.Rd pkg/dplR/man/read.fh.Rd pkg/dplR/man/read.ids.Rd pkg/dplR/man/read.rwl.Rd pkg/dplR/man/read.tridas.Rd pkg/dplR/man/read.tucson.Rd pkg/dplR/man/redfit.Rd pkg/dplR/man/rwi.stats.running.Rd pkg/dplR/man/rwl.stats.Rd pkg/dplR/man/sea.Rd pkg/dplR/man/seg.plot.Rd pkg/dplR/man/sens1.Rd pkg/dplR/man/sens2.Rd pkg/dplR/man/series.rwl.plot.Rd pkg/dplR/man/skel.plot.Rd pkg/dplR/man/spag.plot.Rd pkg/dplR/man/strip.rwl.Rd pkg/dplR/man/tbrm.Rd pkg/dplR/man/tridas.vocabulary.Rd pkg/dplR/man/uuid.gen.Rd pkg/dplR/man/wavelet.plot.Rd pkg/dplR/man/wc.to.po.Rd pkg/dplR/man/write.compact.Rd pkg/dplR/man/write.crn.Rd pkg/dplR/man/write.rwl.Rd pkg/dplR/man/write.tridas.Rd pkg/dplR/man/write.tucson.Rd pkg/dplR/po/R-dplR.pot pkg/dplR/po/R-fi.po pkg/dplR/po/dplR.pot pkg/dplR/po/fi.po pkg/dplR/src/dplR.c pkg/dplR/src/dplR.h pkg/dplR/src/exactmean.c pkg/dplR/src/exactsum.c pkg/dplR/src/exactsum.h pkg/dplR/src/gini.c pkg/dplR/src/rcompact.c pkg/dplR/src/readloop.c pkg/dplR/src/redfit.c pkg/dplR/src/sens.c pkg/dplR/src/tbrm.c pkg/dplR/tests/doRUnit.R Log: Set 'svn:eol-style' property of text / source files to "LF" or "native". Hoping to get rid of the alternating newline encoding syndrome. Property changes on: pkg/dplR/ChangeLog ___________________________________________________________________ Added: svn:eol-style + native Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2014-03-26 10:29:09 UTC (rev 738) +++ pkg/dplR/DESCRIPTION 2014-03-26 11:04:46 UTC (rev 739) @@ -1,30 +1,30 @@ -Encoding: UTF-8 -Package: dplR -Type: Package -Title: Dendrochronology Program Library in R -Version: 1.6.0 -Date: 2014-03-25 -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", - role = c("aut", "cph")), person("Filipe", "Campelo", role = - c("aut", "cph")), person("Pierre", "M?rian", role = c("aut", - "cph")), person("Manfred", "Mudelsee", role = "aut"), - person("Fares", "Qeadan", role = c("aut", "cph")), - person("Michael", "Schulz", role = "aut"), person("Christian", - "Zang", role = c("aut", "cph")), person("Jacob", "Cecile", - role = "ctb")) -Author: Andy Bunn [aut, cph, cre, trl], Mikko Korpela [aut, trl], Franco Biondi [aut, cph], Filipe Campelo [aut, cph], Pierre M?rian [aut, cph], Manfred Mudelsee [aut], Fares Qeadan [aut, cph], Michael Schulz [aut], Christian Zang [aut, cph], Jacob Cecile [ctb] -Copyright: Authors and Aalto University (for work of M. Korpela) -Maintainer: Andy Bunn -Depends: R (>= 2.15.0) -Imports: gmp (>= 0.5-2), graphics, grDevices, grid, stats, utils, - digest (>= 0.2.3), lattice (>= 0.13-6), stringr (>= 0.4), XML - (>= 2.1-0) -Suggests: foreach, iterators, RUnit (>= 0.4.25) -Description: This package contains functions for performing tree-ring - analyses, IO, and graphics. -LazyData: no -License: GPL (>= 2) -URL: http://www.wwu.edu/huxley/treering/dplR.shtml, - http://R-Forge.R-project.org/projects/dplr/ +Encoding: UTF-8 +Package: dplR +Type: Package +Title: Dendrochronology Program Library in R +Version: 1.6.0 +Date: 2014-03-26 +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", + role = c("aut", "cph")), person("Filipe", "Campelo", role = + c("aut", "cph")), person("Pierre", "M?rian", role = c("aut", + "cph")), person("Manfred", "Mudelsee", role = "aut"), + person("Fares", "Qeadan", role = c("aut", "cph")), + person("Michael", "Schulz", role = "aut"), person("Christian", + "Zang", role = c("aut", "cph")), person("Jacob", "Cecile", + role = "ctb")) +Author: Andy Bunn [aut, cph, cre, trl], Mikko Korpela [aut, trl], Franco Biondi [aut, cph], Filipe Campelo [aut, cph], Pierre M?rian [aut, cph], Manfred Mudelsee [aut], Fares Qeadan [aut, cph], Michael Schulz [aut], Christian Zang [aut, cph], Jacob Cecile [ctb] +Copyright: Authors and Aalto University (for work of M. Korpela) +Maintainer: Andy Bunn +Depends: R (>= 2.15.0) +Imports: gmp (>= 0.5-2), graphics, grDevices, grid, stats, utils, + digest (>= 0.2.3), lattice (>= 0.13-6), stringr (>= 0.4), XML + (>= 2.1-0) +Suggests: foreach, iterators, RUnit (>= 0.4.25) +Description: This package contains functions for performing tree-ring + analyses, IO, and graphics. +LazyData: no +License: GPL (>= 2) +URL: http://www.wwu.edu/huxley/treering/dplR.shtml, + http://R-Forge.R-project.org/projects/dplr/ Property changes on: pkg/dplR/DESCRIPTION ___________________________________________________________________ Added: svn:eol-style + native Modified: pkg/dplR/NAMESPACE =================================================================== --- pkg/dplR/NAMESPACE 2014-03-26 10:29:09 UTC (rev 738) +++ pkg/dplR/NAMESPACE 2014-03-26 11:04:46 UTC (rev 739) @@ -1,41 +1,41 @@ -useDynLib(dplR, dplR.gini=gini, dplR.makear1=makear1, - dplR.mean=exactmean, dplR.rcompact=rcompact, - dplR.seg50=seg50, dplR.sens1=sens1, dplR.sens2=sens2, - dplR.spectr=spectr, dplR.tbrm=tbrm, rwl.readloop=readloop) - -import(graphics, stats) - -importFrom(digest, digest) - -importFrom(gmp, as.bigq, as.bigz, chooseZ, is.bigq) - -importFrom(grDevices, rainbow) - -importFrom(grid, gpar, grid.lines, grid.newpage, grid.polygon, - grid.segments, grid.text, pushViewport, seekViewport, unit, - viewport, vpList, vpTree) - -importFrom(lattice, panel.abline, panel.dotplot, panel.segments, - trellis.par.set, xyplot) - -importFrom(stringr, str_pad, str_trim) - -importFrom(utils, head, installed.packages, read.fwf, tail, - packageVersion, write.table) - -importFrom(XML, xmlEventParse) - -export(autoread.ids, bai.in, bai.out, ccf.series.rwl, chron, cms, - combine.rwl, common.interval, corr.rwl.seg, corr.series.seg, - crn.plot, detrend, detrend.series, ffcsaps, fill.internal.NA, - gini.coef, glk, hanning, i.detrend, i.detrend.series, morlet, - po.to.wc, pointer, powt, print.redfit, rcs, read.compact, - read.crn, read.fh, read.ids, read.rwl, read.tridas, - read.tucson, redfit, runcrit, rwi.stats, rwi.stats.legacy, - rwi.stats.running, rwl.stats, sea, seg.plot, sens1, sens2, - series.rwl.plot, skel.plot, spag.plot, strip.rwl, tbrm, - tridas.vocabulary, uuid.gen, wavelet.plot, wc.to.po, - write.compact, write.crn, write.rwl, write.tridas, - write.tucson) - -S3method(print, redfit) +useDynLib(dplR, dplR.gini=gini, dplR.makear1=makear1, + dplR.mean=exactmean, dplR.rcompact=rcompact, + dplR.seg50=seg50, dplR.sens1=sens1, dplR.sens2=sens2, + dplR.spectr=spectr, dplR.tbrm=tbrm, rwl.readloop=readloop) + +import(graphics, stats) + +importFrom(digest, digest) + +importFrom(gmp, as.bigq, as.bigz, chooseZ, is.bigq) + +importFrom(grDevices, rainbow) + +importFrom(grid, gpar, grid.lines, grid.newpage, grid.polygon, + grid.segments, grid.text, pushViewport, seekViewport, unit, + viewport, vpList, vpTree) + +importFrom(lattice, panel.abline, panel.dotplot, panel.segments, + trellis.par.set, xyplot) + +importFrom(stringr, str_pad, str_trim) + +importFrom(utils, head, installed.packages, read.fwf, tail, + packageVersion, write.table) + +importFrom(XML, xmlEventParse) + +export(autoread.ids, bai.in, bai.out, ccf.series.rwl, chron, cms, + combine.rwl, common.interval, corr.rwl.seg, corr.series.seg, + crn.plot, detrend, detrend.series, ffcsaps, fill.internal.NA, + gini.coef, glk, hanning, i.detrend, i.detrend.series, morlet, + po.to.wc, pointer, powt, print.redfit, rcs, read.compact, + read.crn, read.fh, read.ids, read.rwl, read.tridas, + read.tucson, redfit, runcrit, rwi.stats, rwi.stats.legacy, + rwi.stats.running, rwl.stats, sea, seg.plot, sens1, sens2, + series.rwl.plot, skel.plot, spag.plot, strip.rwl, tbrm, + tridas.vocabulary, uuid.gen, wavelet.plot, wc.to.po, + write.compact, write.crn, write.rwl, write.tridas, + write.tucson) + +S3method(print, redfit) Property changes on: pkg/dplR/NAMESPACE ___________________________________________________________________ Added: svn:eol-style + native Modified: pkg/dplR/R/bai.in.R =================================================================== --- pkg/dplR/R/bai.in.R 2014-03-26 10:29:09 UTC (rev 738) +++ pkg/dplR/R/bai.in.R 2014-03-26 11:04:46 UTC (rev 739) @@ -1,34 +1,34 @@ -bai.in <- function(rwl, d2pith = NULL) { - - if(!is.data.frame(rwl)) - stop("'rwl' must be a data.frame") - if(!is.null(d2pith)) { - if(ncol(rwl) != nrow(d2pith)) - stop("dimension problem: ", "'ncol(rw)' != 'nrow(d2pith)'") - if(!all(d2pith[, 1] %in% names(rwl))) - stop("series ids in 'd2pith' and 'rwl' do not match") - d2pith.vec <- d2pith[, 2] - } else { - ## distance offset if not given - d2pith.vec <- rep(0, ncol(rwl)) - } - - out <- rwl - ## vector of years - n.vec <- seq_len(nrow(rwl)) - for(i in seq_len(ncol(rwl))){ - ## series to work with - dat <- rwl[[i]] - ## strip out data from NA - dat2 <- na.omit(dat) - ## get ring area - bai <- pi*dat2*(dat2+2*(cumsum(dat2) + d2pith.vec[i] - dat2)) - ## find NA / not NA locations - na <- attributes(dat2)$na.action - no.na <- n.vec[!n.vec %in% na] - ## write result - out[no.na, i] <- bai - } - ## return result - out -} +bai.in <- function(rwl, d2pith = NULL) { + + if(!is.data.frame(rwl)) + stop("'rwl' must be a data.frame") + if(!is.null(d2pith)) { + if(ncol(rwl) != nrow(d2pith)) + stop("dimension problem: ", "'ncol(rw)' != 'nrow(d2pith)'") + if(!all(d2pith[, 1] %in% names(rwl))) + stop("series ids in 'd2pith' and 'rwl' do not match") + d2pith.vec <- d2pith[, 2] + } else { + ## distance offset if not given + d2pith.vec <- rep(0, ncol(rwl)) + } + + out <- rwl + ## vector of years + n.vec <- seq_len(nrow(rwl)) + for(i in seq_len(ncol(rwl))){ + ## series to work with + dat <- rwl[[i]] + ## strip out data from NA + dat2 <- na.omit(dat) + ## get ring area + bai <- pi*dat2*(dat2+2*(cumsum(dat2) + d2pith.vec[i] - dat2)) + ## find NA / not NA locations + na <- attributes(dat2)$na.action + no.na <- n.vec[!n.vec %in% na] + ## write result + out[no.na, i] <- bai + } + ## return result + out +} Property changes on: pkg/dplR/R/bai.in.R ___________________________________________________________________ Added: svn:eol-style + native Modified: pkg/dplR/R/bai.out.R =================================================================== --- pkg/dplR/R/bai.out.R 2014-03-26 10:29:09 UTC (rev 738) +++ pkg/dplR/R/bai.out.R 2014-03-26 11:04:46 UTC (rev 739) @@ -1,35 +1,35 @@ -bai.out <- function(rwl, diam = NULL) { - - if(!is.data.frame(rwl)) - stop("'rwl' must be a data.frame") - if(!is.null(diam)) { - if(ncol(rwl) != nrow(diam)) - stop("dimension problem: ", "'ncol(rw)' != 'nrow(diam)'") - if(!all(diam[, 1] %in% names(rwl))) - stop("series ids in 'diam' and 'rwl' do not match") - diam.vec <- diam[, 2] - } - - out <- rwl - ## vector of years - n.vec <- seq_len(nrow(rwl)) - for(i in seq_len(ncol(rwl))){ - ## series to work with - dat <- rwl[[i]] - ## strip out data from NA - dat2 <- na.omit(dat) - ## get diameter if not given - if(is.null(diam)) d <- sum(dat2)*2 - else d <- diam.vec[i] - ## get ring area - r0 <- d/2 - c(0, cumsum(rev(dat2))) - bai <- -pi*rev(diff(r0*r0)) - ## find NA / not NA locations - na <- attributes(dat2)$na.action - no.na <- n.vec[!n.vec %in% na] - ## write result - out[no.na, i] <- bai - } - ## return result - out -} +bai.out <- function(rwl, diam = NULL) { + + if(!is.data.frame(rwl)) + stop("'rwl' must be a data.frame") + if(!is.null(diam)) { + if(ncol(rwl) != nrow(diam)) + stop("dimension problem: ", "'ncol(rw)' != 'nrow(diam)'") + if(!all(diam[, 1] %in% names(rwl))) + stop("series ids in 'diam' and 'rwl' do not match") + diam.vec <- diam[, 2] + } + + out <- rwl + ## vector of years + n.vec <- seq_len(nrow(rwl)) + for(i in seq_len(ncol(rwl))){ + ## series to work with + dat <- rwl[[i]] + ## strip out data from NA + dat2 <- na.omit(dat) + ## get diameter if not given + if(is.null(diam)) d <- sum(dat2)*2 + else d <- diam.vec[i] + ## get ring area + r0 <- d/2 - c(0, cumsum(rev(dat2))) + bai <- -pi*rev(diff(r0*r0)) + ## find NA / not NA locations + na <- attributes(dat2)$na.action + no.na <- n.vec[!n.vec %in% na] + ## write result + out[no.na, i] <- bai + } + ## return result + out +} Property changes on: pkg/dplR/R/bai.out.R ___________________________________________________________________ Added: svn:eol-style + native Modified: pkg/dplR/R/ccf.series.rwl.R =================================================================== --- pkg/dplR/R/ccf.series.rwl.R 2014-03-26 10:29:09 UTC (rev 738) +++ pkg/dplR/R/ccf.series.rwl.R 2014-03-26 11:04:46 UTC (rev 739) @@ -1,128 +1,128 @@ -ccf.series.rwl <- function(rwl, series, - series.yrs = as.numeric(names(series)), - seg.length = 50, bin.floor = 100, n = NULL, - prewhiten = TRUE, biweight = TRUE, - pcrit = 0.05, lag.max = 5, make.plot = TRUE, - floor.plus1 = FALSE, ...) { - - ## run error checks - qa.xdate(rwl, seg.length, n, bin.floor) - if (lag.max > seg.length) { - stop("'lag.max' > 'seg.length'") - } - seg.lag <- seg.length / 2 - - ## Normalize. - series2 <- series - names(series2) <- series.yrs - tmp <- normalize.xdate(rwl, series2, n, prewhiten, biweight) - master <- tmp$master - - ## trim master so there are no NaN like dividing when only one - ## series for instance. - idx.good <- !is.nan(master) - master <- master[idx.good] - yrs <- as.numeric(names(master)) - - series2 <- tmp$series - series.yrs2 <- as.numeric(names(series2)) - ## trim series in case it was submitted stright from the rwl - idx.good <- !is.na(series2) - series.yrs2 <- series.yrs2[idx.good] - series2 <- series2[idx.good] - - ## clip series to master dimensions - series2 <- series2[series.yrs2 %in% yrs] - series.yrs2 <- as.numeric(names(series2)) - ## clip master to series dimensions - master <- master[yrs %in% series.yrs2] - yrs <- as.numeric(names(master)) - - if (is.null(bin.floor) || bin.floor == 0) { - min.bin <- min(series.yrs2) - } else if(floor.plus1) { - min.bin <- ceiling((min(series.yrs2) - 1) / bin.floor) * bin.floor + 1 - } else { - min.bin <- ceiling(min(series.yrs2) / bin.floor) * bin.floor - } - to <- max(series.yrs2) - seg.length - seg.lag + 1 - if (min.bin > to) { - cat(gettextf("maximum year in (filtered) series: %d\n", - max(series.yrs2), domain="R-dplR")) - cat(gettextf("first bin begins: %d\n", min.bin, domain="R-dplR")) - cat(gettext("cannot fit two segments (not enough years in the series)\n", - domain="R-dplR")) - stop("shorten 'seg.length' or adjust 'bin.floor'") - } - bins <- seq(from=min.bin, to=to + seg.lag, by=seg.lag) - bins <- cbind(bins, bins + (seg.length - 1)) - nbins <- nrow(bins) - bin.names <- paste0(bins[, 1], ".", bins[, 2]) - - ## structures for results - lag.vec <- seq(from=-lag.max, to=lag.max, by=1) - res.cor <- matrix(NA, length(lag.vec), nbins) - rownames(res.cor) <- paste("lag", lag.vec, sep=".") - colnames(res.cor) <- bin.names - - ## loop through bins - for (j in seq_len(nbins)) { - mask <- yrs%in%seq(from=bins[j, 1], to=bins[j, 2]) - ## cor is NA if there is not complete overlap - if (!any(mask) || - any(is.na(series2[mask])) || - any(is.na(master[mask])) || - table(mask)[2] < seg.length) { - bin.ccf <- NA - } - else { - tmp <- ccf(master[mask], series2[mask], lag.max=lag.max, plot=FALSE) - bin.ccf <- as.vector(tmp$acf) - } - res.cor[, j] <- bin.ccf - } - ## plot - if (make.plot) { - ccf.df <- data.frame(r = c(res.cor, recursive=TRUE), - bin = rep(colnames(res.cor), - each=length(lag.vec)), - lag = rep(lag.vec, nbins)) - ## reorder bins so that lattice definitely keeps them in - ## ascending order (i.e., no factor order funnies with long - ## series) - num.bins <- bins[, 1] - ord.num <- order(num.bins) - char.bins <- as.character(bins[, 1]) - ord.char <- order(char.bins) - foo <- data.frame(num.bins, ord.num, char.bins, ord.char) - ccf.df$bin <- factor(ccf.df$bin, - levels(ccf.df$bin)[order(foo$ord.char)]) - - sig <- qnorm(1 - pcrit / 2) / sqrt(seg.length) - sig <- c(-sig, sig) - ccf.plot <- - xyplot(r ~ lag | bin, data = ccf.df, - ylim = range(ccf.df$r, sig, na.rm=TRUE) * 1.1, - xlab = gettext("Lag", domain="R-dplR"), - ylab = gettext("Correlation", domain="R-dplR"), - col.line = NA, - cex = 1.25, - panel = function(x, y, ...) { - panel.abline(h=seq(from=-1, to=1, by=0.1), - lty="solid", col="gray") - panel.abline(v=lag.vec, lty="solid", col="gray") - panel.abline(h=0, v=0, lwd=2) - panel.abline(h=sig, lwd=2, lty="dashed") - col <- ifelse(y > 0, "#E41A1C", "#377EB8") - ## segments, dots for all r - panel.segments(x1=x, y1=0, x2=x, y2=y, col=col, lwd=2) - panel.dotplot(x, y, col = col, ...) - }, ...) - trellis.par.set(strip.background = list(col = "transparent"), - warn = FALSE) - print(ccf.plot) - } - res <- list(res.cor,bins) - names(res) <- c("ccf", "bins") - res -} +ccf.series.rwl <- function(rwl, series, + series.yrs = as.numeric(names(series)), + seg.length = 50, bin.floor = 100, n = NULL, + prewhiten = TRUE, biweight = TRUE, + pcrit = 0.05, lag.max = 5, make.plot = TRUE, + floor.plus1 = FALSE, ...) { + + ## run error checks + qa.xdate(rwl, seg.length, n, bin.floor) + if (lag.max > seg.length) { + stop("'lag.max' > 'seg.length'") + } + seg.lag <- seg.length / 2 + + ## Normalize. + series2 <- series + names(series2) <- series.yrs + tmp <- normalize.xdate(rwl, series2, n, prewhiten, biweight) + master <- tmp$master + + ## trim master so there are no NaN like dividing when only one + ## series for instance. + idx.good <- !is.nan(master) + master <- master[idx.good] + yrs <- as.numeric(names(master)) + + series2 <- tmp$series + series.yrs2 <- as.numeric(names(series2)) + ## trim series in case it was submitted stright from the rwl + idx.good <- !is.na(series2) + series.yrs2 <- series.yrs2[idx.good] + series2 <- series2[idx.good] + + ## clip series to master dimensions + series2 <- series2[series.yrs2 %in% yrs] + series.yrs2 <- as.numeric(names(series2)) + ## clip master to series dimensions + master <- master[yrs %in% series.yrs2] + yrs <- as.numeric(names(master)) + + if (is.null(bin.floor) || bin.floor == 0) { + min.bin <- min(series.yrs2) + } else if(floor.plus1) { + min.bin <- ceiling((min(series.yrs2) - 1) / bin.floor) * bin.floor + 1 + } else { + min.bin <- ceiling(min(series.yrs2) / bin.floor) * bin.floor + } + to <- max(series.yrs2) - seg.length - seg.lag + 1 + if (min.bin > to) { + cat(gettextf("maximum year in (filtered) series: %d\n", + max(series.yrs2), domain="R-dplR")) + cat(gettextf("first bin begins: %d\n", min.bin, domain="R-dplR")) + cat(gettext("cannot fit two segments (not enough years in the series)\n", + domain="R-dplR")) + stop("shorten 'seg.length' or adjust 'bin.floor'") + } + bins <- seq(from=min.bin, to=to + seg.lag, by=seg.lag) + bins <- cbind(bins, bins + (seg.length - 1)) + nbins <- nrow(bins) + bin.names <- paste0(bins[, 1], ".", bins[, 2]) + + ## structures for results + lag.vec <- seq(from=-lag.max, to=lag.max, by=1) + res.cor <- matrix(NA, length(lag.vec), nbins) + rownames(res.cor) <- paste("lag", lag.vec, sep=".") + colnames(res.cor) <- bin.names + + ## loop through bins + for (j in seq_len(nbins)) { + mask <- yrs%in%seq(from=bins[j, 1], to=bins[j, 2]) + ## cor is NA if there is not complete overlap + if (!any(mask) || + any(is.na(series2[mask])) || + any(is.na(master[mask])) || + table(mask)[2] < seg.length) { + bin.ccf <- NA + } + else { + tmp <- ccf(master[mask], series2[mask], lag.max=lag.max, plot=FALSE) + bin.ccf <- as.vector(tmp$acf) + } + res.cor[, j] <- bin.ccf + } + ## plot + if (make.plot) { + ccf.df <- data.frame(r = c(res.cor, recursive=TRUE), + bin = rep(colnames(res.cor), + each=length(lag.vec)), + lag = rep(lag.vec, nbins)) + ## reorder bins so that lattice definitely keeps them in + ## ascending order (i.e., no factor order funnies with long + ## series) + num.bins <- bins[, 1] + ord.num <- order(num.bins) + char.bins <- as.character(bins[, 1]) + ord.char <- order(char.bins) + foo <- data.frame(num.bins, ord.num, char.bins, ord.char) + ccf.df$bin <- factor(ccf.df$bin, + levels(ccf.df$bin)[order(foo$ord.char)]) + + sig <- qnorm(1 - pcrit / 2) / sqrt(seg.length) + sig <- c(-sig, sig) + ccf.plot <- + xyplot(r ~ lag | bin, data = ccf.df, + ylim = range(ccf.df$r, sig, na.rm=TRUE) * 1.1, + xlab = gettext("Lag", domain="R-dplR"), + ylab = gettext("Correlation", domain="R-dplR"), + col.line = NA, + cex = 1.25, + panel = function(x, y, ...) { + panel.abline(h=seq(from=-1, to=1, by=0.1), + lty="solid", col="gray") + panel.abline(v=lag.vec, lty="solid", col="gray") + panel.abline(h=0, v=0, lwd=2) + panel.abline(h=sig, lwd=2, lty="dashed") + col <- ifelse(y > 0, "#E41A1C", "#377EB8") + ## segments, dots for all r + panel.segments(x1=x, y1=0, x2=x, y2=y, col=col, lwd=2) + panel.dotplot(x, y, col = col, ...) + }, ...) + trellis.par.set(strip.background = list(col = "transparent"), + warn = FALSE) + print(ccf.plot) + } + res <- list(res.cor,bins) + names(res) <- c("ccf", "bins") + res +} Property changes on: pkg/dplR/R/ccf.series.rwl.R ___________________________________________________________________ Added: svn:eol-style + native Modified: pkg/dplR/R/chron.R =================================================================== --- pkg/dplR/R/chron.R 2014-03-26 10:29:09 UTC (rev 738) +++ pkg/dplR/R/chron.R 2014-03-26 11:04:46 UTC (rev 739) @@ -1,32 +1,32 @@ -`chron` <- - function(x, prefix="xxx", biweight=TRUE, prewhiten=FALSE) -{ - prefix.str <- as.character(prefix) - if (length(prefix.str) != 1 || nchar(prefix.str) > 3) { - stop("'prefix' must be a character string with less than 4 characters") - } - samps <- rowSums(!is.na(x)) - if (!biweight) { - std <- rowMeans(x, na.rm=TRUE) - } else { - std <- apply(x, 1, tbrm, C=9) - } - if (prewhiten) { - x.ar <- apply(x, 2, ar.func) - if (!biweight) { - res <- rowMeans(x.ar, na.rm=TRUE) - } else { - res <- apply(x.ar, 1, tbrm, C=9) - } - res[is.nan(res)] <- NA - out <- data.frame(std, res, samps) - names(out) <- c(paste0(prefix.str, "std"), - paste0(prefix.str, "res"), - "samp.depth") - } else { - out <- data.frame(std, samps) - names(out) <- c(paste0(prefix.str, "std"), "samp.depth") - } - row.names(out) <- row.names(x) - out -} +`chron` <- + function(x, prefix="xxx", biweight=TRUE, prewhiten=FALSE) +{ + prefix.str <- as.character(prefix) + if (length(prefix.str) != 1 || nchar(prefix.str) > 3) { + stop("'prefix' must be a character string with less than 4 characters") + } + samps <- rowSums(!is.na(x)) + if (!biweight) { + std <- rowMeans(x, na.rm=TRUE) + } else { + std <- apply(x, 1, tbrm, C=9) + } + if (prewhiten) { + x.ar <- apply(x, 2, ar.func) + if (!biweight) { + res <- rowMeans(x.ar, na.rm=TRUE) + } else { + res <- apply(x.ar, 1, tbrm, C=9) + } + res[is.nan(res)] <- NA + out <- data.frame(std, res, samps) + names(out) <- c(paste0(prefix.str, "std"), + paste0(prefix.str, "res"), + "samp.depth") + } else { + out <- data.frame(std, samps) + names(out) <- c(paste0(prefix.str, "std"), "samp.depth") + } + row.names(out) <- row.names(x) + out +} Property changes on: pkg/dplR/R/chron.R ___________________________________________________________________ Added: svn:eol-style + native Property changes on: pkg/dplR/R/cms.R ___________________________________________________________________ Added: svn:eol-style + native Property changes on: pkg/dplR/R/combine.rwl.R ___________________________________________________________________ Added: svn:eol-style + native Modified: pkg/dplR/R/common.interval.R =================================================================== --- pkg/dplR/R/common.interval.R 2014-03-26 10:29:09 UTC (rev 738) +++ pkg/dplR/R/common.interval.R 2014-03-26 11:04:46 UTC (rev 739) @@ -1,252 +1,252 @@ -common.interval <- function(rwl, type=c("series", "years", "both"), - make.plot=TRUE) { - - if (!is.data.frame(rwl)) { - stop("'rwl' must be a data.frame") - } - - if (!all(vapply(rwl, is.numeric, FALSE, USE.NAMES=FALSE))) { - stop("'rwl' must have numeric columns") - } - rnames <- row.names(rwl) - if (is.null(rnames)) { - stop("'rwl' must have row names") - } - yrs <- as.numeric(rnames) - if (!is.numeric(yrs) || any(is.na(yrs)) || any(round(yrs) != yrs)) { - stop("row names of 'rwl' must be interpretable as years") - } - - check.flags(make.plot) - type2 <- match.arg(type, c("series", "years", "both")) - - ## rm.short is a function to remove short series and keep the - ## series with overlaps - rm.short <- function(rwl, yrs, rwlNotNA, row.idx, flag=FALSE) { - n <- 0 - anyNotNA <- apply(rwlNotNA, 2, any) - which.good <- which(anyNotNA) - nCol.orig <- length(which.good) - series.range <- matrix(NA_real_, 2, nCol.orig) - for (k in seq_len(nCol.orig)) { - series.range[, k] <- yr.range(rwl[[which.good[k]]][row.idx], - yr.vec = yrs) - } - span.order <- - which.good[sort.list(series.range[2, ] - series.range[1, ])] - nRow.orig <- nrow(rwlNotNA) - keep.col <- logical(length(rwl)) - keep.col[which.good] <- TRUE - keep.col.output <- keep.col - dontkeep.row <- rep.int(TRUE, nRow.orig) - keep.row.output <- rep.int(FALSE, nRow.orig) - nRow <- 0 - nRow.output <- 0 - nCol.output <- nCol.orig - nCol <- nCol.orig - - for (i in seq(0, max(0, nCol.orig - 2))) { - if (i > 0) { - keep.col[span.order[i]] <- FALSE - nCol <- nCol - 1 - if (nCol * nRow.orig < n) { - ## to break if it is not possible to improve the - ## common interval - break - } - } - tmp <- apply(rwlNotNA[dontkeep.row, keep.col, drop = FALSE], 1, all) - dontkeep.row[dontkeep.row] <- !tmp - nRow <- nRow + sum(tmp) - n.years <- nCol * nRow - ## to keep the rwl if has more years - if (n.years > n) { - n <- n.years - keep.col.output <- keep.col - keep.row.output <- !dontkeep.row - nCol.output <- nCol - nRow.output <- nRow - if (flag) { - ## to give the common interval with the highest - ## sample depth for the case of - ## common.interval(rwl, type="series") - break - } - } - } - list(nRow.output, nCol.output, keep.row.output, keep.col.output) - } - -########### - nCol.rwl <- length(rwl) - nRow.rwl <- nrow(rwl) - yrs.ordered <- all(diff(yrs) >= 0) - if (!yrs.ordered) { - order.yrs <- sort.list(yrs) - } - output <- 0 - opt <- 0 - keep.row.output <- numeric(0) - keep.col.output <- logical(nCol.rwl) - nCol.output <- 0 - nRow.output <- 0 - nCol <- 0 - nRow <- 0 - rwlNotNA <- !is.na(rwl) - - ## to get sample depth - if (nCol.rwl > 0) { - samp.depth <- rowSums(rwlNotNA) - } else { - ## Workaround for R bug number 14959. Fixed in R >= 2.15.2. - samp.depth <- 0 - } - - type.series <- type2 == "series" - type.years <- type2 == "years" - for (i in dec(max(samp.depth), 2)) { # dec() forces a decreasing sequence - if (yrs.ordered) { - tmp <- which(samp.depth >= i) - row.idx <- tmp[1]:tmp[length(tmp)] - } else { - common.range <- range(yrs[samp.depth >= i]) - row.idx <- which(yrs >= common.range[1] & yrs <= common.range[2]) - } - nRow <- length(row.idx) - if (i * nRow < output) { - break - } - if (type.series) { - tmp <- rm.short(rwl, yrs[row.idx], - rwlNotNA[row.idx, , drop = FALSE], row.idx, - flag = TRUE) - nRow.output <- tmp[[1]] - nCol.output <- tmp[[2]] - keep.row.output <- row.idx[tmp[[3]]] - keep.col.output <- tmp[[4]] - break - } else if (type.years) { - tmp <- rm.short(rwl, yrs[row.idx], - rwlNotNA[row.idx, , drop = FALSE], row.idx) - nRow <- tmp[[1]] - nCol <- tmp[[2]] - keep.row <- tmp[[3]] - keep.col <- tmp[[4]] - } else { # type2 == "both" - keep.col <- apply(rwlNotNA[row.idx, , drop = FALSE], 2, all) - nCol <- sum(keep.col) - } - opt <- nRow * nCol - if (opt > output) { - output <- opt - nRow.output <- nRow - nCol.output <- nCol - if (type.years) { - keep.row.output <- row.idx[keep.row] - } else { - keep.row.output <- row.idx - } - keep.col.output <- keep.col - } - } - - if (make.plot) { - op <- par(no.readonly = TRUE) - on.exit(par(op)) - par(mar = c(5, 5, 2, 2) + 0.1, mgp = c(1.25, 0.25, 0), tcl = 0.25) - if (nRow.rwl > 0 && nCol.rwl > 0) { - ## original rwl - series.range <- vapply(rwl, yr.range, numeric(2), yr.vec = yrs) - ## ensure that series.range is a matrix - dim(series.range) <- c(2, length(rwl)) - first.year <- series.range[1, ] - - neworder <- sort.list(first.year, na.last = TRUE) - rwl.first <- first.year[neworder[1]] - if (is.na(rwl.first)) { - if (yrs.ordered) { - rwl.first <- yrs[1] - rwl.last <- yrs[nRow.rwl] - } else { - rwl.first <- min(yrs) - rwl.last <- max(yrs) - } - } else { - rwl.last <- max(series.range[2, ], na.rm = TRUE) - } - plot(1, 1, type = "n", xlim = c(rwl.first, rwl.last + 1), - ylim = c(1, nCol.rwl), axes = FALSE, ylab = "", - xlab = gettext("Year", domain = "R-dplR")) - rwl.seq <- seq(from = rwl.first, to = rwl.last + 1, by = 0.5) - n.rwl.seq <- length(rwl.seq) - rwl.everyother <- seq(from = 2, by = 2, length.out = nRow.rwl) - } else { - plot(1, 1, type = "n", axes = FALSE, ylab = "", xlab = "") - } - sub.str1 <- gettextf("Original: %d series, %d years", - nCol.rwl, nRow.rwl, domain="R-dplR") - sub.str2 <- - gettextf("Common Interval (type='%s'): %d series x %d years = %d", - type2, nCol.output, nRow.output, - nCol.output * nRow.output, domain="R-dplR") - sub.str <- paste(sub.str1, sub.str2, sep="\n") - mtext(text = sub.str, side = 1, line = 3) - ## common.rwl - yrs2 <- yrs[keep.row.output] - any.common <- length(yrs2) > 0 - if (any.common) { - common.first <- min(yrs2) - common.last <- max(yrs2) - common.seq <- seq(from = common.first, [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/dplr -r 739 From noreply at r-forge.r-project.org Wed Mar 26 13:43:26 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 26 Mar 2014 13:43:26 +0100 (CET) Subject: [Dplr-commits] r740 - pkg/dplR Message-ID: <20140326124326.E78B218717A@r-forge.r-project.org> Author: mvkorpel Date: 2014-03-26 13:43:26 +0100 (Wed, 26 Mar 2014) New Revision: 740 Modified: pkg/dplR/ Log: svn:auto-props (svn >= 1.8) for automatically setting svn:eol-style of new files Property changes on: pkg/dplR ___________________________________________________________________ Added: svn:auto-props + *.c = svn:eol-style=LF *.h = svn:eol-style=LF Makefile = svn:eol-style=LF *.po = svn:eol-style=native *.pot = svn:eol-style=native *.R = svn:eol-style=native *.Rd = svn:eol-style=native From noreply at r-forge.r-project.org Wed Mar 26 17:10:01 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 26 Mar 2014 17:10:01 +0100 (CET) Subject: [Dplr-commits] r741 - pkg/dplR/man Message-ID: <20140326161001.579A7180FB0@r-forge.r-project.org> Author: andybunn Date: 2014-03-26 17:10:00 +0100 (Wed, 26 Mar 2014) New Revision: 741 Modified: pkg/dplR/man/rwi.stats.running.Rd Log: adding ref to rwi.stats help. Other small changes to that file. Modified: pkg/dplR/man/rwi.stats.running.Rd =================================================================== --- pkg/dplR/man/rwi.stats.running.Rd 2014-03-26 12:43:26 UTC (rev 740) +++ pkg/dplR/man/rwi.stats.running.Rd 2014-03-26 16:10:00 UTC (rev 741) @@ -124,7 +124,9 @@ Some of the statistics are specific to dendrochronology (e.g., the effective number of cores or the expressed population signal). Users unfamiliar with these should see Cook and Kairiukstis (1990) and - Fritts (2001) for further details. + Fritts (2001) for further details for computational details on the + output. The singal-to-noise ratio is calculated following Cook and + Pederson (2011). If desired, the \code{\var{rwi}} can be filtered in the same manner as the family of cross-dating functions using \code{\var{prewhiten}} and @@ -183,8 +185,10 @@ Dendrochronology: Applications in the Environmental Sciences}. Springer. \acronym{ISBN-13}: 978-0-7923-0586-6. + Cook, E. R. and Pederson, N. (2011) \emph{Uncertainty, Emergence, and Statistics in Dendrochronology} In M.K. Hughes, T.W. Swetnam, and H.F. Diaz (Eds.), \emph{Dendroclimatology}(77-112), \acronym{ISBN-13}: 978-1-4020-4010-8. + Fritts, H. C. (2001) \emph{Tree Rings and Climate}. Blackburn. - \acronym{ISBN-13}: 978-1-930665-39-2. + \acronym{ISBN-13}: 978-1-930665-39-2. } \note{ @@ -216,8 +220,8 @@ bar <- data.frame(yrs = c(min(yrs), foo$mid.year, max(yrs)), eps = c(NA, foo$eps, NA)) par(mar = c(2, 2, 2, 2), mgp = c(1.1, 0.1, 0), tcl = 0.25, - mfcol = c(2, 1)) - plot(yrs, gp.crn[, 1], type = "n", xlab = "Years", ylab = "RWI", + mfcol = c(2, 1),xaxs='i') + plot(yrs, gp.crn[, 1], type = "n", xlab = "Year", ylab = "RWI", axes=FALSE) xx <- c(500, 500, max(bar$yrs[bar$eps < eps.cut], na.rm = TRUE), max(bar$yrs[bar$eps < eps.cut], na.rm = TRUE)) @@ -228,16 +232,17 @@ lines(yrs, ffcsaps(gp.crn[, 1], nyrs = 32), col = "red", lwd = 2) axis(1);axis(2);axis(3); par(new = TRUE) - ## Second plot is the chronology after the cut off only + ## Add EPS plot(bar$yrs, bar$eps, type = "b", xlab = "", ylab = "", axes = FALSE, pch = 20, col = "blue") axis(4,at = pretty(foo$eps)) mtext("EPS", side = 4, line = 1.1) axis(4,at = pretty(foo$eps)) box() + ## Second plot is the chronology after the cut off only yr.mask <- yrs > max(bar$yrs[bar$eps Author: andybunn Date: 2014-03-26 17:11:30 +0100 (Wed, 26 Mar 2014) New Revision: 742 Modified: pkg/dplR/R/rwi.stats.running.R Log: added ref to SNR calc Modified: pkg/dplR/R/rwi.stats.running.R =================================================================== --- pkg/dplR/R/rwi.stats.running.R 2014-03-26 16:10:00 UTC (rev 741) +++ pkg/dplR/R/rwi.stats.running.R 2014-03-26 16:11:30 UTC (rev 742) @@ -319,7 +319,8 @@ ## EPS is on page 146 of C&K. ## In our interpretation of EPS, we use the average number of trees. eps <- n * rbar.eff / ((n - 1) * rbar.eff + 1) - ## SNR is on page 109 of Hughes et al. 2011 + ## SNR is on page 109 of Cook and Pederson (2011). + ## See help file for ref. snr <- n * rbar.eff / (1-rbar.eff) if (running.window) { From noreply at r-forge.r-project.org Thu Mar 27 01:42:18 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 27 Mar 2014 01:42:18 +0100 (CET) Subject: [Dplr-commits] r743 - in pkg/dplR: R man Message-ID: <20140327004218.32F58183ACD@r-forge.r-project.org> Author: andybunn Date: 2014-03-27 01:42:17 +0100 (Thu, 27 Mar 2014) New Revision: 743 Modified: pkg/dplR/R/rwi.stats.running.R pkg/dplR/man/rwi.stats.running.Rd Log: changed outputs to rwi.stats to include n.cores and n.trees. But this needs to be modified to work inside the loop to get an accurate count. Modified: pkg/dplR/R/rwi.stats.running.R =================================================================== --- pkg/dplR/R/rwi.stats.running.R 2014-03-26 16:11:30 UTC (rev 742) +++ pkg/dplR/R/rwi.stats.running.R 2014-03-27 00:42:17 UTC (rev 743) @@ -325,13 +325,15 @@ if (running.window) { c(start.year = start.year, mid.year = mid.year, end.year = end.year, + n.cores = n.cores, n.trees = n.trees, n = n, n.tot = n.tot, n.wt = n.wt, n.bt = n.bt, rbar.tot = rbar.tot, rbar.wt = rbar.wt, rbar.bt = rbar.bt, c.eff = c.eff, - rbar.eff = rbar.eff, eps = eps, snr = snr, n = n) + rbar.eff = rbar.eff, eps = eps, snr = snr) } else { - c(n.tot = n.tot, n.wt = n.wt, n.bt = n.bt, rbar.tot = rbar.tot, + c(n.cores = n.cores, n.trees = n.trees, n = n, + n.tot = n.tot, n.wt = n.wt, n.bt = n.bt, rbar.tot = rbar.tot, rbar.wt = rbar.wt, rbar.bt = rbar.bt, c.eff = c.eff, - rbar.eff = rbar.eff, eps = eps, snr = snr, n = n) + rbar.eff = rbar.eff, eps = eps, snr = snr) } } Modified: pkg/dplR/man/rwi.stats.running.Rd =================================================================== --- pkg/dplR/man/rwi.stats.running.Rd 2014-03-26 16:11:30 UTC (rev 742) +++ pkg/dplR/man/rwi.stats.running.Rd 2014-03-27 00:42:17 UTC (rev 743) @@ -150,13 +150,24 @@ \code{running.window} is \code{FALSE} or called as \code{rwi.stats} or \code{rwi.stats.legacy}.} - \item{n.tot}{total number of correlations computed} + \item{n.cores}{the number of cores} + \item{n.trees}{the number of trees} + + \item{n}{the average number of trees (for each year, a tree needs at + least one non-\code{NA} core in order to be counted). Not returned + in the results of \code{rwi.stats.legacy}} + + \item{n.tot}{total number of correlations calculated as \code{ + \var{n.wt} + \var{n.bt}}. Equal to \code{\var{n.cores} * + (\var{n.cores}-1)/2} if there is overlap between all samples } + \item{n.wt}{number of within-tree correlations computed} \item{n.bt}{number of between-tree correlations computed} - \item{rbar.tot}{the mean of all correlation between different cores} + \item{rbar.tot}{the mean of all the correlations between different + cores} \item{rbar.wt}{the mean of the correlations between series from the same tree over all trees} @@ -170,14 +181,12 @@ \item{rbar.eff}{the effective signal calculated as \code{ \var{rbar.bt} / (\var{rbar.wt} + (1-\var{rbar.wt}) / \var{c.eff}) }} - \item{eps}{the expressed population signal} + \item{eps}{the expressed population signal calculated using the average + number of trees as \code{\var{n} * \var{rbar.eff} / ((\var{n} - 1) * + \var{rbar.eff} + 1)} } - \item{snr}{the signal to noise ratio} - - \item{n}{the average number of trees (for each year, a tree needs at - least one non-\code{NA} core in order to be counted). Not returned - in the results of \code{rwi.stats.legacy}.} - + \item{snr}{the signal to noise ratio calculated using the average + number of trees as \code{\var{n} * \var{rbar.eff} / (1-\var{rbar.eff})} } } \references{ @@ -206,13 +215,19 @@ data(gp.po) gp.rwi <- cms(rwl = gp.rwl, po = gp.po) gp.ids <- read.ids(gp.rwl, stc = c(0, 2, 1)) +# On a running window rwi.stats.running(gp.rwi, gp.ids) -rwi.stats(gp.rwi, gp.ids) # i.e. running.window = FALSE +## With no running window (i.e. running.window = FALSE) +rwi.stats(gp.rwi, gp.ids) +## Restrict to common overlap (in this case 1899 to 1987) +rwi.stats(gp.rwi, gp.ids, period="common") rwi.stats.legacy(gp.rwi, gp.ids) # rwi.stats prior to dplR 1.5.3 + \dontrun{ library(graphics) - ## Plot the chronology showing a potential cutoff year based on eps - eps.cut <- 0.92 # arbitrary + def.par <- par(no.readonly=TRUE) + ## Plot the chronology showing a potential cutoff year based on EPS + eps.cut <- 0.92 # An arbitrary EPS cutoff for demonstration gp.crn <- chron(gp.rwi) ## Running stats on the rwi with an window foo <- rwi.stats.running(gp.rwi, gp.ids, window.length = 80) @@ -240,15 +255,20 @@ axis(4,at = pretty(foo$eps)) box() ## Second plot is the chronology after the cut off only + ## Chronology is rebuilt using just years after cutoff but + ## that difference is essentially nil. yr.mask <- yrs > max(bar$yrs[bar$eps Author: mvkorpel Date: 2014-03-27 12:35:13 +0100 (Thu, 27 Mar 2014) New Revision: 744 Modified: pkg/dplR/ChangeLog pkg/dplR/DESCRIPTION pkg/dplR/R/rwi.stats.running.R Log: rwi.stats.running.R: * 'n.trees' and 'n.cores' should now be OK * 'c.eff' is now 0 if no correlations were computed * When using period = "common", 'n' is now 0 instead of the full number in case there are no complete cases in the running window. * Technical optimizations Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2014-03-27 00:42:17 UTC (rev 743) +++ pkg/dplR/ChangeLog 2014-03-27 11:35:13 UTC (rev 744) @@ -5,8 +5,17 @@ - Added signal-to-noise ratio as an output. Followed pg 109 in Cook's chapter in Hughes et al. 2011. +- New outputs 'n.cores' and 'n.trees' show the total number of cores and + trees in the window, respectively. At least one non-missing value is + required for a core and tree to be counted. +- When using period = "common" in rwi.stats() or + rwi.stats.running(), the number of trees 'n' in the return value + is now 0 instead of the full number in case there are no complete + cases in the running window. +- 'c.eff' in the return value is now 0 if no correlations were + computed +- Optimizations - * CHANGES IN dplR VERSION 1.5.9 Files: dplR.h, rcompact.c, redfit.c Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2014-03-27 00:42:17 UTC (rev 743) +++ pkg/dplR/DESCRIPTION 2014-03-27 11:35:13 UTC (rev 744) @@ -3,7 +3,7 @@ Type: Package Title: Dendrochronology Program Library in R Version: 1.6.0 -Date: 2014-03-26 +Date: 2014-03-27 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/rwi.stats.running.R =================================================================== --- pkg/dplR/R/rwi.stats.running.R 2014-03-27 00:42:17 UTC (rev 743) +++ pkg/dplR/R/rwi.stats.running.R 2014-03-27 11:35:13 UTC (rev 744) @@ -137,13 +137,15 @@ rwi3 <- rwi2 } } + rwiNotNA <- !is.na(rwi3) n.years <- nrow(rwi3) if (running.window && window.length > n.years) { stop("'window.length' is larger than the number of years in 'rwi'") } - unique.trees <- unique(ids3$tree) + treeIds <- ids3$tree + unique.trees <- unique(treeIds) n.trees <- length(unique.trees) if (n.trees < 2) { stop("at least 2 trees are needed") @@ -151,7 +153,7 @@ cores.of.tree <- list() seq.tree <- seq_len(n.trees) for (i in seq.tree) { - cores.of.tree[[i]] <- which(ids3$tree==unique.trees[i]) + cores.of.tree[[i]] <- which(treeIds==unique.trees[i]) } ## n.trees.by.year is recorded before setting rows with missing @@ -159,21 +161,22 @@ tree.any <- matrix(FALSE, n.years, n.trees) for (i in seq.tree) { tree.any[, i] <- - apply(!is.na(rwi3[, ids3$tree == unique.trees[i], drop=FALSE]), - 1, any) + apply(rwiNotNA[, treeIds == unique.trees[i], drop=FALSE], 1, any) } n.trees.by.year <- rowSums(tree.any) - good.rows <- which(n.trees.by.year > 1) ## Easy way to force complete overlap of data if (period2 == "common") { - bad.rows <- which(apply(is.na(rwi3), 1, any)) + bad.rows <- !apply(rwiNotNA, 1, all) rwi3[bad.rows, ] <- NA - good.rows <- setdiff(good.rows, bad.rows) + rwiNotNA[bad.rows, ] <- FALSE + good.rows.flag <- !bad.rows period.common <- TRUE } else { + good.rows.flag <- n.trees.by.year > 1 period.common <- FALSE } + good.rows <- which(good.rows.flag) if (length(good.rows) < min.corr.overlap) { stop("too few years with enough trees for correlation calculations") @@ -205,8 +208,8 @@ (n.years - offset - window.length) %/% window.advance max.idx <- offset + window.length + n.windows.minusone * window.advance - n.data[i] <- sum(!is.na(rwi3[intersect(good.rows, - (1 + offset):max.idx), ])) + rowIdx <- seq(1 + offset, max.idx) + n.data[i] <- sum(rwiNotNA[rowIdx[good.rows.flag[rowIdx]], ]) } ## In case of a tie, choose large offset. ## In practice, this prefers recent years. @@ -294,27 +297,45 @@ rbar.bt <- rsum.bt / n.bt } + coresPresent <- + which(apply(rwiNotNA[year.idx, , drop = FALSE], 2, any)) + treesPresent <- unique(treeIds[coresPresent]) + nCores <- length(coresPresent) + nTrees <- length(treesPresent) if (period.common) { ## If period is "common", we are only looking at the rows - ## with no missing values. - n <- n.trees + ## with no missing values (if any, so all or nothing). + n <- nTrees } else { ## Number of trees averaged over the years in the window. ## We keep this number separate of the correlation ## estimates, i.e. the data from some tree / year may ## contribute to n without taking part in the correlation ## estimates. - n <- mean(n.trees.by.year[year.idx], na.rm=TRUE) + n <- mean(n.trees.by.year[year.idx]) } ## Expressed population signal if (n.wt == 0) { - c.eff <- 1 + if (n.bt > 0) { + c.eff <- 1 + } else { + c.eff <- 0 + } rbar.eff <- rbar.bt } else { - c.eff.rproc <- mean(1 / n.cores.tree, na.rm=TRUE) - c.eff <- 1 / c.eff.rproc # bookkeeping only - rbar.eff <- rbar.bt / (rbar.wt + (1 - rbar.wt) * c.eff.rproc) + nCoresTree <- na.omit(n.cores.tree) + uniqueNC <- unique(nCoresTree) + ## The branches are equivalent but optimized for numerical + ## precision in each situation + if (length(uniqueNC) == 1) { + c.eff <- uniqueNC + rbar.eff <- rbar.bt / (rbar.wt + (1 - rbar.wt) / c.eff) + } else { + c.eff.rproc <- mean(1 / nCoresTree) + c.eff <- 1 / c.eff.rproc # bookkeeping only + rbar.eff <- rbar.bt / (rbar.wt + (1 - rbar.wt) * c.eff.rproc) + } } ## EPS is on page 146 of C&K. ## In our interpretation of EPS, we use the average number of trees. @@ -324,17 +345,16 @@ snr <- n * rbar.eff / (1-rbar.eff) if (running.window) { - c(start.year = start.year, mid.year = mid.year, end.year = end.year, - n.cores = n.cores, n.trees = n.trees, n = n, - n.tot = n.tot, n.wt = n.wt, n.bt = n.bt, rbar.tot = rbar.tot, - rbar.wt = rbar.wt, rbar.bt = rbar.bt, c.eff = c.eff, - rbar.eff = rbar.eff, eps = eps, snr = snr) + out <- c(start.year = start.year, + mid.year = mid.year, end.year = end.year) } else { - c(n.cores = n.cores, n.trees = n.trees, n = n, - n.tot = n.tot, n.wt = n.wt, n.bt = n.bt, rbar.tot = rbar.tot, - rbar.wt = rbar.wt, rbar.bt = rbar.bt, c.eff = c.eff, - rbar.eff = rbar.eff, eps = eps, snr = snr) + out <- numeric(0) } + c(out, + n.cores = nCores, n.trees = nTrees, n = n, + n.tot = n.tot, n.wt = n.wt, n.bt = n.bt, rbar.tot = rbar.tot, + rbar.wt = rbar.wt, rbar.bt = rbar.bt, c.eff = c.eff, + rbar.eff = rbar.eff, eps = eps, snr = snr) } ## Iterate over all windows From noreply at r-forge.r-project.org Fri Mar 28 04:53:47 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 28 Mar 2014 04:53:47 +0100 (CET) Subject: [Dplr-commits] r745 - in pkg/dplR: . R man Message-ID: <20140328035347.3FC78186CE3@r-forge.r-project.org> Author: andybunn Date: 2014-03-28 04:53:46 +0100 (Fri, 28 Mar 2014) New Revision: 745 Modified: pkg/dplR/ChangeLog pkg/dplR/NAMESPACE pkg/dplR/R/crn.plot.R pkg/dplR/man/cms.Rd pkg/dplR/man/crn.plot.Rd Log: changes to crn.plot(). Mostly cosmetic. Well, all cosmetic. But adding chron.plot() as an alias since it makes more sense. Consider making chron an S3Method so that plot(chron(foo)) would work? Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2014-03-27 11:35:13 UTC (rev 744) +++ pkg/dplR/ChangeLog 2014-03-28 03:53:46 UTC (rev 745) @@ -1,5 +1,18 @@ * CHANGES IN dplR VERSION 1.6.0 +File: NAMESPACE +------------------------- +- Added chron.plot to export list + +File: crn.plot.R +------------------------- +- Added several new plotting options to give users more control of plot +- Aliased crn.plot to chron.plot to be consistent with the chron() function. + It was confusing to use bar <- chon(foo) but not be able to use + chron.plot(bar). It would be nice to make chron an S3method to thus be + able to just do plot(bar) I suppose. +- Help revised considerably + File: rwi.stats.running.R ------------------------- Modified: pkg/dplR/NAMESPACE =================================================================== --- pkg/dplR/NAMESPACE 2014-03-27 11:35:13 UTC (rev 744) +++ pkg/dplR/NAMESPACE 2014-03-28 03:53:46 UTC (rev 745) @@ -36,6 +36,6 @@ series.rwl.plot, skel.plot, spag.plot, strip.rwl, tbrm, tridas.vocabulary, uuid.gen, wavelet.plot, wc.to.po, write.compact, write.crn, write.rwl, write.tridas, - write.tucson) + write.tucson, chron.plot) S3method(print, redfit) Modified: pkg/dplR/R/crn.plot.R =================================================================== --- pkg/dplR/R/crn.plot.R 2014-03-27 11:35:13 UTC (rev 744) +++ pkg/dplR/R/crn.plot.R 2014-03-28 03:53:46 UTC (rev 745) @@ -1,40 +1,89 @@ -`crn.plot` <- function(crn, add.spline=FALSE, nyrs=NULL, f=0.5, ...){ - if(!is.data.frame(crn)) stop("'crn' must be a data.frame") +`chron.plot` <- function(crn, add.spline=FALSE, nyrs=NULL, f=0.5, + crn.line.col='grey50',spline.line.col='red', + samp.depth.col='grey90', + samp.depth.border.col='grey80', + crn.lwd=1,spline.lwd=1.5, + abline.pos=1,abline.col='black', + abline.lty=1,abline.lwd=1, + xlab='Year',ylab='RWI'){ + args <- list() + args[["crn"]] <- crn + args[["add.spline"]] <- add.spline + args[["nyrs"]] <- nyrs + args[["f"]] <- f + args[["crn.line.col"]] <- crn.line.col + args[["spline.line.col"]] <- spline.line.col + args[["samp.depth.col"]] <- samp.depth.col + args[["samp.depth.border.col"]] <- samp.depth.border.col + args[["crn.lwd"]] <- crn.lwd + args[["spline.lwd"]] <- spline.lwd + args[["abline.pos"]] <- abline.pos + args[["abline.col"]] <- abline.col + args[["abline.lty"]] <- abline.lty + args[["abline.lwd"]] <- abline.lwd + args[["xlab"]] <- xlab + args[["ylab"]] <- ylab + do.call(crn.plot, args) +} - op <- par(no.readonly=TRUE) # Save par - on.exit(par(op)) # Reset par on exit - par(mar=c(3, 3, 3, 3), mgp=c(1.25, 0.25, 0), tcl=0.25) - - yr.vec <- as.numeric(row.names(crn)) - crn.names <- names(crn) - nCrn <- ncol(crn) - ## Check to see if the crn has sample depth - sd.exist <- crn.names[nCrn] == "samp.depth" +`crn.plot` <- function(crn, add.spline=FALSE, nyrs=NULL, f=0.5, + crn.line.col='grey50',spline.line.col='red', + samp.depth.col='grey90', + samp.depth.border.col='grey80', + crn.lwd=1,spline.lwd=1.5, + abline.pos=1,abline.col='black', + abline.lty=1,abline.lwd=1, + xlab='Year',ylab='RWI'){ + if(!is.data.frame(crn)) stop("'crn' must be a data.frame") + + op <- par(no.readonly=TRUE) # Save par + on.exit(par(op)) # Reset par on exit + par(mar=c(3, 3, 3, 3), mgp=c(1.1, 0.1, 0), + tcl=0.5, xaxs='i') + + yr.vec <- as.numeric(row.names(crn)) + crn.names <- names(crn) + nCrn <- ncol(crn) + ## Check to see if the crn has sample depth + sd.exist <- crn.names[nCrn] == "samp.depth" + if(sd.exist) { + samp.depth <- crn[[nCrn]] + nCrn <- nCrn-1 + } + if(nCrn > 1) layout(matrix(seq_len(nCrn), nrow=nCrn, ncol=1)) + # strike these? +# text.years <- gettext("Years", domain="R-dplR") +# text.rwi <- gettext("RWI", domain="R-dplR") + text.samp <- gettext("Sample Depth", domain="R-dplR") + nyrs2 <- nyrs + for(i in seq_len(nCrn)){ + spl <- crn[[i]] + plot(yr.vec, spl, type="n",axes=FALSE, + xlab=xlab, ylab=ylab, main=crn.names[i]) if(sd.exist) { - samp.depth <- crn[[nCrn]] - nCrn <- nCrn-1 + par(new=TRUE) + plot(yr.vec, samp.depth, type="n", + xlab="", ylab="", axes=FALSE) + xx <- c(yr.vec,max(yr.vec,na.rm=TRUE),min(yr.vec,na.rm=TRUE)) + yy <- c(samp.depth, 0, 0) + polygon(xx,yy,col=samp.depth.col,border=samp.depth.border.col) + axis(4, at=pretty(samp.depth)) + mtext(text.samp, side=4, line=1.25) } - if(nCrn > 1) layout(matrix(seq_len(nCrn), nrow=nCrn, ncol=1)) - text.years <- gettext("Years", domain="R-dplR") - text.rwi <- gettext("RWI", domain="R-dplR") - text.samp <- gettext("Sample Depth", domain="R-dplR") - nyrs2 <- nyrs - for(i in seq_len(nCrn)){ - spl <- crn[[i]] - plot(yr.vec, spl, type="l", - xlab=text.years, ylab=text.rwi, main=crn.names[i], ...) - tmp <- na.omit(spl) - ## Only possibly NULL in the first round of the for loop - if(is.null(nyrs2)) nyrs2 <- length(tmp)*0.33 - spl[!is.na(spl)] <- ffcsaps(y=tmp, x=seq_along(tmp), nyrs=nyrs2, f=f) - if(add.spline) lines(yr.vec, spl, col="red", lwd=2) - abline(h=1) - if(sd.exist) { - par(new=TRUE) - plot(yr.vec, samp.depth, type="l", lty="dashed", - xlab="", ylab="", axes=FALSE) - axis(4, at=pretty(samp.depth)) - mtext(text.samp, side=4, line=1.25) - } + par(new=TRUE) + plot(yr.vec, spl, type="n",axes=FALSE,xlab='',ylab='') + if(!is.null(abline.pos)) { + abline(h=abline.pos,lwd=abline.lwd, + lty=abline.lty,col=abline.col) } + lines(yr.vec, spl, col=crn.line.col,lwd=crn.lwd) + tmp <- na.omit(spl) + if(add.spline) { + ## Only possibly NULL in the first round of the for loop + if(is.null(nyrs2)) nyrs2 <- length(tmp)*0.33 + spl[!is.na(spl)] <- ffcsaps(y=tmp, x=seq_along(tmp), nyrs=nyrs2, f=f) + lines(yr.vec, spl, col=spline.line.col, lwd=spline.lwd) + } + axis(1);axis(2);axis(3);box() + } } Modified: pkg/dplR/man/cms.Rd =================================================================== --- pkg/dplR/man/cms.Rd 2014-03-27 11:35:13 UTC (rev 744) +++ pkg/dplR/man/cms.Rd 2014-03-28 03:53:46 UTC (rev 745) @@ -42,7 +42,7 @@ data(gp.po) gp.rwi <- cms(rwl = gp.rwl, po = gp.po) gp.crn <- chron(gp.rwi) -crn.plot(gp.crn, add.spline = TRUE, ylim = c(0, 2.5)) +crn.plot(gp.crn, add.spline = TRUE) ## c.hat gp.rwi <- cms(rwl = gp.rwl, po = gp.po, c.hat.t = TRUE, c.hat.i = TRUE) dotchart(gp.rwi$c.hat.i, ylab = "Series", xlab = expression(hat(c)[i])) Modified: pkg/dplR/man/crn.plot.Rd =================================================================== --- pkg/dplR/man/crn.plot.Rd 2014-03-27 11:35:13 UTC (rev 744) +++ pkg/dplR/man/crn.plot.Rd 2014-03-28 03:53:46 UTC (rev 745) @@ -1,12 +1,29 @@ \name{crn.plot} \alias{crn.plot} +\alias{chron.plot} \title{ Plot a Tree-Ring Chronology } \description{ This function makes a default plot of a tree-ring chronology from a \code{data.frame} of the type produced by \code{\link{chron}}. } \usage{ -crn.plot(crn, add.spline = FALSE, nyrs = NULL, f = 0.5, \dots) +chron.plot(crn, add.spline = FALSE, nyrs = NULL, f = 0.5, + crn.line.col='grey50',spline.line.col='red', + samp.depth.col='grey90', + samp.depth.border.col='grey80', + crn.lwd=1,spline.lwd=1.5, + abline.pos=1,abline.col='black', + abline.lty=1,abline.lwd=1, + xlab='Year',ylab='RWI') + +crn.plot(crn, add.spline = FALSE, nyrs = NULL, f = 0.5, + crn.line.col='grey50',spline.line.col='red', + samp.depth.col='grey90', + samp.depth.border.col='grey80', + crn.lwd=1,spline.lwd=1.5, + abline.pos=1,abline.col='black', + abline.lty=1,abline.lwd=1, + xlab='Year',ylab='RWI') } \arguments{ \item{crn}{ a \code{data.frame} as produced by @@ -21,8 +38,20 @@ \code{\var{nyrs}} is \code{NULL}. } \item{f}{ a number between 0 and 1 giving the frequency response or wavelength cutoff. Defaults to 0.5. } - \item{\dots}{ other arguments passed to - \code{\link[graphics]{plot}}. } + \item{crn.line.col}{ color for the crn line } + \item{spline.line.col}{ color for the spline (if added) } + \item{samp.depth.col}{ color for the sample depth polygon (if present) } + \item{samp.depth.border.col}{ border color for the sample depth + polygon (if present)} + \item{crn.lwd}{ line width for the crn line} + \item{spline.lwd}{ line width for the spline (if added) } + \item{abline.pos}{ position for a refernce abline on the y-axis. + No line added if NULL } + \item{abline.col}{ color for the reference abline (if added) } + \item{abline.lty}{ line type the reference abline (if added) } + \item{abline.lwd}{ line width for the reference abline (if added)} + \item{xlab}{ label for x-axis } + \item{ylab}{ label for y-axis } } \details{ This makes a simple plot of one or more tree-ring chronologies. @@ -35,18 +64,34 @@ } \examples{data(cana157) crn.plot(cana157) - +chron.plot(cana157) +# with added spline +chron.plot(cana157,add.spline=TRUE, nyrs=32) ## Without sample depth -cana157.mod <- data.frame(TTRSTD = cana157[, 1]) -rownames(cana157.mod) <- rownames(cana157) +cana157.mod <- cana157 +cana157.mod$samp.depth <- NULL crn.plot(cana157.mod, add.spline = TRUE) - +## With multiple chronologies +data(gp.rwl) +data(gp.po) +gp.rwi <- cms(rwl = gp.rwl, po = gp.po) +gp.crn <- chron(gp.rwi,prefix="GP",prewhiten=TRUE) +crn.plot(gp.crn, add.spline = TRUE) \dontrun{ -## With multiple chronologies -data(ca533) -ca533.rwi <- detrend(rwl = ca533, method = "ModNegExp") -ca533.crn <- chron(ca533.rwi, prefix = "CAM", prewhiten = TRUE) -crn.plot(ca533.crn, add.spline = TRUE, nyrs = 64) + # not pretty - but illustrates the coloring options + my.cols <- c("#3182BD","#9ECAE1","#DEEBF7","#31A354","#A1D99B","#E5F5E0") + chron.plot(cana157,add.spline=TRUE,nyrs=32, + crn.line.col=my.cols[5], + spline.line.col=my.cols[4], + samp.depth.col=my.cols[3], + samp.depth.border.col=my.cols[2], + abline.col=my.cols[1], + crn.lwd=1.5,spline.lwd=3, + abline.lwd=1) + # a raw ring-width chronology + data(ca533) + ca533.raw.crn <- chron(ca533, prefix = "CAM") + chron.plot(ca533.raw.crn,abline.pos=NULL,ylab='mm') } } \keyword{ hplot } From noreply at r-forge.r-project.org Fri Mar 28 05:22:50 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 28 Mar 2014 05:22:50 +0100 (CET) Subject: [Dplr-commits] r746 - pkg/dplR/R Message-ID: <20140328042251.018A81872A5@r-forge.r-project.org> Author: andybunn Date: 2014-03-28 05:22:50 +0100 (Fri, 28 Mar 2014) New Revision: 746 Modified: pkg/dplR/R/crn.plot.R Log: slightly more gracefull axes. Modified: pkg/dplR/R/crn.plot.R =================================================================== --- pkg/dplR/R/crn.plot.R 2014-03-28 03:53:46 UTC (rev 745) +++ pkg/dplR/R/crn.plot.R 2014-03-28 04:22:50 UTC (rev 746) @@ -72,10 +72,8 @@ } par(new=TRUE) plot(yr.vec, spl, type="n",axes=FALSE,xlab='',ylab='') - if(!is.null(abline.pos)) { - abline(h=abline.pos,lwd=abline.lwd, - lty=abline.lty,col=abline.col) - } + abline(h=abline.pos,lwd=abline.lwd, + lty=abline.lty,col=abline.col) lines(yr.vec, spl, col=crn.line.col,lwd=crn.lwd) tmp <- na.omit(spl) if(add.spline) { @@ -84,6 +82,10 @@ spl[!is.na(spl)] <- ffcsaps(y=tmp, x=seq_along(tmp), nyrs=nyrs2, f=f) lines(yr.vec, spl, col=spline.line.col, lwd=spline.lwd) } - axis(1);axis(2);axis(3);box() + axis(1) + axis(2) + axis(3) + if(!sd.exist) axis(4) + box() } } From noreply at r-forge.r-project.org Sat Mar 29 04:21:57 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 29 Mar 2014 04:21:57 +0100 (CET) Subject: [Dplr-commits] r747 - in pkg/dplR: . R Message-ID: <20140329032158.DD5EF1872E8@r-forge.r-project.org> Author: andybunn Date: 2014-03-29 04:21:54 +0100 (Sat, 29 Mar 2014) New Revision: 747 Modified: pkg/dplR/ChangeLog pkg/dplR/R/seg.plot.R Log: cosmetic changes to seg.plot. Will do the same with spag.plot. Would like to have an S3 plot method for rwl objects that uses these. Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2014-03-28 04:22:50 UTC (rev 746) +++ pkg/dplR/ChangeLog 2014-03-29 03:21:54 UTC (rev 747) @@ -2,8 +2,12 @@ File: NAMESPACE ------------------------- -- Added chron.plot to export list +- Added chron.plot to export list. +File: seg.plot.R +------------------------- +- Cosmetic changes to plot. + File: crn.plot.R ------------------------- - Added several new plotting options to give users more control of plot Modified: pkg/dplR/R/seg.plot.R =================================================================== --- pkg/dplR/R/seg.plot.R 2014-03-28 04:22:50 UTC (rev 746) +++ pkg/dplR/R/seg.plot.R 2014-03-29 03:21:54 UTC (rev 747) @@ -13,14 +13,21 @@ for (i in seq.col) { segs[[i]][!is.na(segs[[i]])] <- i } + segs.axis2 <- names(segs) + segs.axis4 <- names(segs) + segs.axis2[seq(1,n.col,by=2)] <- NA + segs.axis4[seq(2,n.col,by=2)] <- NA op <- par(no.readonly=TRUE) # Save par on.exit(par(op)) # Reset par on exit - par(mar=c(4, 5, 2, 2) + 0.1, mgp=c(1.25, 0.25, 0), tcl=0.25) + par(mar=c(2, 5, 2, 5) + 0.1, mgp=c(1.1, 0.1, 0), tcl=0.5, + xaxs="i") plot(yr, segs[[1]], type="n", ylim=c(0, n.col), axes=FALSE, ylab="", xlab=gettext("Year", domain="R-dplR"), ...) - apply(segs, 2, lines, x=yr, lwd=2) - axis(2, at=seq.col, labels=names(segs), srt=45, tick=FALSE, las=2) + abline(h=seq.col,lwd=1,col="grey") + apply(segs, 2, lines, x=yr, lwd=4,lend=2) + axis(2, at=seq.col, labels=segs.axis2, srt=45, tick=FALSE, las=2) + axis(4, at=seq.col, labels=segs.axis4, srt=45, tick=FALSE, las=2) axis(1) + axis(3) box() } - From noreply at r-forge.r-project.org Sun Mar 30 00:31:49 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 30 Mar 2014 00:31:49 +0100 (CET) Subject: [Dplr-commits] r748 - in pkg/dplR: . R man Message-ID: <20140329233149.AD4441872B0@r-forge.r-project.org> Author: andybunn Date: 2014-03-30 00:31:48 +0100 (Sun, 30 Mar 2014) New Revision: 748 Added: pkg/dplR/R/plot.rwl.R pkg/dplR/man/plot.rwl.Rd Modified: pkg/dplR/ChangeLog pkg/dplR/NAMESPACE pkg/dplR/R/seg.plot.R pkg/dplR/R/spag.plot.R Log: The main thing in this commit is the new wrapper to plot rwl objects. This is setting the stage for having plot, summary, etc. methods for rwl objects. There are still several things to work on. Like setting the class() of rwl data objects via read.rwl (and in the onboard data sets). And will this class change break any existing functions? Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2014-03-29 03:21:54 UTC (rev 747) +++ pkg/dplR/ChangeLog 2014-03-29 23:31:48 UTC (rev 748) @@ -3,7 +3,21 @@ File: NAMESPACE ------------------------- - Added chron.plot to export list. +- Added rwl.plot as an S3Method. +File: rwl.plot.R +------------------------- +- New wrapper to plot rwl objects. This is setting the + stage for having plot, summary, etc. methods for rwl + objects. There are still several things to work on. Like + setting the class() of rwl data objects via read.rwl (and in + the onboard data sets). And will this class change break any + existing functions? + +File: spag.plot.R +------------------------- +- Cosmetic changes to plot. + File: seg.plot.R ------------------------- - Cosmetic changes to plot. Modified: pkg/dplR/NAMESPACE =================================================================== --- pkg/dplR/NAMESPACE 2014-03-29 03:21:54 UTC (rev 747) +++ pkg/dplR/NAMESPACE 2014-03-29 23:31:48 UTC (rev 748) @@ -36,6 +36,7 @@ series.rwl.plot, skel.plot, spag.plot, strip.rwl, tbrm, tridas.vocabulary, uuid.gen, wavelet.plot, wc.to.po, write.compact, write.crn, write.rwl, write.tridas, - write.tucson, chron.plot) + write.tucson, chron.plot, plot.rwl) S3method(print, redfit) +S3method(plot, rwl) Added: pkg/dplR/R/plot.rwl.R =================================================================== --- pkg/dplR/R/plot.rwl.R (rev 0) +++ pkg/dplR/R/plot.rwl.R 2014-03-29 23:31:48 UTC (rev 748) @@ -0,0 +1,5 @@ +plot.rwl <- function(rwl,type=c("seg","spag"),...){ + switch(match.arg(type), + seg = seg.plot(rwl,...), + spag = spag.plot(rwl,...)) +} Modified: pkg/dplR/R/seg.plot.R =================================================================== --- pkg/dplR/R/seg.plot.R 2014-03-29 03:21:54 UTC (rev 747) +++ pkg/dplR/R/seg.plot.R 2014-03-29 23:31:48 UTC (rev 748) @@ -15,8 +15,8 @@ } segs.axis2 <- names(segs) segs.axis4 <- names(segs) - segs.axis2[seq(1,n.col,by=2)] <- NA - segs.axis4[seq(2,n.col,by=2)] <- NA + segs.axis2[seq(2,n.col,by=2)] <- NA + segs.axis4[seq(1,n.col,by=2)] <- NA op <- par(no.readonly=TRUE) # Save par on.exit(par(op)) # Reset par on exit par(mar=c(2, 5, 2, 5) + 0.1, mgp=c(1.1, 0.1, 0), tcl=0.5, @@ -24,6 +24,7 @@ plot(yr, segs[[1]], type="n", ylim=c(0, n.col), axes=FALSE, ylab="", xlab=gettext("Year", domain="R-dplR"), ...) abline(h=seq.col,lwd=1,col="grey") + grid(ny = NA) apply(segs, 2, lines, x=yr, lwd=4,lend=2) axis(2, at=seq.col, labels=segs.axis2, srt=45, tick=FALSE, las=2) axis(4, at=seq.col, labels=segs.axis4, srt=45, tick=FALSE, las=2) Modified: pkg/dplR/R/spag.plot.R =================================================================== --- pkg/dplR/R/spag.plot.R 2014-03-29 03:21:54 UTC (rev 747) +++ pkg/dplR/R/spag.plot.R 2014-03-29 23:31:48 UTC (rev 748) @@ -10,7 +10,8 @@ rwl2 <- rwl2[, neworder, drop=FALSE] op <- par(no.readonly=TRUE) on.exit(par(op)) - par(mar=c(4, 4, 4, 4) + 0.1, mgp=c(1.25, 0.25, 0), tcl=0.25) + par(mar=c(2, 5, 2, 5) + 0.1, mgp=c(1.1, 0.1, 0), tcl=0.5, + xaxs="i") ## Set vertical offset for plotting each series for (i in 1:nseries) { rwl2[, i] <- rwl2[, i] + i Added: pkg/dplR/man/plot.rwl.Rd =================================================================== --- pkg/dplR/man/plot.rwl.Rd (rev 0) +++ pkg/dplR/man/plot.rwl.Rd 2014-03-29 23:31:48 UTC (rev 748) @@ -0,0 +1,40 @@ +\name{plot.rwl} +\alias{plot.rwl} +\title{ + Plotting rwl objects +} +\description{ + Plots rwl objects +} +\usage{ +\method{plot}{rwl}(rwl, type=c("seg","spag"), ...) +} +\arguments{ + + \item{rwl}{ An object of class \code{"rwl"}. } + + \item{type}{ Character. Type "seg" calls \code{\link{seg.plot}} + while "spag" calls \code{\link{spag.plot}} } + + \item{\dots}{ Additional arguemnts for each \code{type} } + +} +\value{ + None. A plot is produced. +} +\author{ + Andy Bunn +} +\seealso{ + \code{\link{rwl}} +} +\examples{data(ca533) +class(ca533) <- c(class(ca533),'rwl') +plot.rwl(ca533,type=c('seg')) +plot.rwl(ca533,type=c('spag')) +plot.rwl(ca533,type=c('spag'),zfac=2) +## to use as S3Method the class of rwl must be set: +class(ca533) <- c('rwl','data.frame') +plot(ca533,type=c('seg')) +} +\keyword{ plot } From noreply at r-forge.r-project.org Sun Mar 30 00:41:41 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 30 Mar 2014 00:41:41 +0100 (CET) Subject: [Dplr-commits] r749 - pkg/dplR/man Message-ID: <20140329234141.5944018560F@r-forge.r-project.org> Author: andybunn Date: 2014-03-30 00:41:40 +0100 (Sun, 30 Mar 2014) New Revision: 749 Modified: pkg/dplR/man/plot.rwl.Rd Log: fixed typo. need to resolve warning when checking S3 generic/method consistency. Modified: pkg/dplR/man/plot.rwl.Rd =================================================================== --- pkg/dplR/man/plot.rwl.Rd 2014-03-29 23:31:48 UTC (rev 748) +++ pkg/dplR/man/plot.rwl.Rd 2014-03-29 23:41:40 UTC (rev 749) @@ -26,7 +26,7 @@ Andy Bunn } \seealso{ - \code{\link{rwl}} + \code{\link{read.rwl}} } \examples{data(ca533) class(ca533) <- c(class(ca533),'rwl') From noreply at r-forge.r-project.org Sun Mar 30 05:19:27 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 30 Mar 2014 05:19:27 +0200 (CEST) Subject: [Dplr-commits] r750 - in pkg/dplR: R man Message-ID: <20140330031927.61EC618731F@r-forge.r-project.org> Author: andybunn Date: 2014-03-30 05:19:21 +0200 (Sun, 30 Mar 2014) New Revision: 750 Modified: pkg/dplR/R/plot.rwl.R pkg/dplR/man/plot.rwl.Rd Log: Fixed the warning from: * checking S3 generic/method consistency ... OK The issue was reusing an argument name incorrectly in plot.rwl. Seems like there is more to the S3Method than we are using. Modified: pkg/dplR/R/plot.rwl.R =================================================================== --- pkg/dplR/R/plot.rwl.R 2014-03-29 23:41:40 UTC (rev 749) +++ pkg/dplR/R/plot.rwl.R 2014-03-30 03:19:21 UTC (rev 750) @@ -1,5 +1,8 @@ -plot.rwl <- function(rwl,type=c("seg","spag"),...){ - switch(match.arg(type), - seg = seg.plot(rwl,...), - spag = spag.plot(rwl,...)) +plot.rwl <- function(x, plot.type=c("seg","spag"),...){ + if (!inherits(x, "rwl")) { + stop('use only with "rwl" objects') + } + switch(match.arg(plot.type), + seg = seg.plot(x,...), + spag = spag.plot(x,...)) } Modified: pkg/dplR/man/plot.rwl.Rd =================================================================== --- pkg/dplR/man/plot.rwl.Rd 2014-03-29 23:41:40 UTC (rev 749) +++ pkg/dplR/man/plot.rwl.Rd 2014-03-30 03:19:21 UTC (rev 750) @@ -7,13 +7,13 @@ Plots rwl objects } \usage{ -\method{plot}{rwl}(rwl, type=c("seg","spag"), ...) +\method{plot}{rwl}(x, plot.type=c("seg","spag"), ...) } \arguments{ - \item{rwl}{ An object of class \code{"rwl"}. } + \item{x}{ An object of class \code{"rwl"}. } - \item{type}{ Character. Type "seg" calls \code{\link{seg.plot}} + \item{plot.type}{ Character. Type "seg" calls \code{\link{seg.plot}} while "spag" calls \code{\link{spag.plot}} } \item{\dots}{ Additional arguemnts for each \code{type} } @@ -29,12 +29,10 @@ \code{\link{read.rwl}} } \examples{data(ca533) -class(ca533) <- c(class(ca533),'rwl') -plot.rwl(ca533,type=c('seg')) -plot.rwl(ca533,type=c('spag')) -plot.rwl(ca533,type=c('spag'),zfac=2) ## to use as S3Method the class of rwl must be set: class(ca533) <- c('rwl','data.frame') -plot(ca533,type=c('seg')) +plot(ca533,plot.type=c('seg')) +plot(ca533,plot.type=c('spag')) +plot(ca533,plot.type=c('spag'),zfac=2) } \keyword{ plot } From noreply at r-forge.r-project.org Sun Mar 30 20:01:15 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 30 Mar 2014 20:01:15 +0200 (CEST) Subject: [Dplr-commits] r751 - in pkg/dplR: . R data man Message-ID: <20140330180115.537CC18736A@r-forge.r-project.org> Author: andybunn Date: 2014-03-30 20:01:14 +0200 (Sun, 30 Mar 2014) New Revision: 751 Modified: pkg/dplR/ChangeLog pkg/dplR/R/read.compact.R pkg/dplR/R/read.fh.R pkg/dplR/R/read.tridas.R pkg/dplR/R/read.tucson.R pkg/dplR/data/anos1.rda pkg/dplR/data/ca533.rda pkg/dplR/data/co021.rda pkg/dplR/data/gp.rwl.rda pkg/dplR/man/plot.rwl.Rd pkg/dplR/man/seg.plot.Rd pkg/dplR/man/spag.plot.Rd Log: Added class changes to the read.rwl family so that classes are now c("rwl","data.frame"). I'll stop now because I know Mikko will want to fixed everything I've done wrong! Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2014-03-30 03:19:21 UTC (rev 750) +++ pkg/dplR/ChangeLog 2014-03-30 18:01:14 UTC (rev 751) @@ -1,5 +1,37 @@ * CHANGES IN dplR VERSION 1.6.0 +File: read.compact.R +------------------------- +- Added class "rwl" to output object. + +File: read.fh.R +------------------------- +- Added class "rwl" to output object. + +File: read.tridas.R +------------------------- +- Added class "rwl" to output object $results. + +File: read.tucson.R +------------------------- +- Added class "rwl" to output object. + +File: anos1.rda +------------------------- +- Added class "rwl" to object. + +File: ca533.rda +------------------------- +- Added class "rwl" to object. + +File: co021.rda +------------------------- +- Added class "rwl" to object. + +File: gp.rwl.rda +------------------------- +- Added class "rwl" to object. + File: NAMESPACE ------------------------- - Added chron.plot to export list. Modified: pkg/dplR/R/read.compact.R =================================================================== --- pkg/dplR/R/read.compact.R 2014-03-30 03:19:21 UTC (rev 750) +++ pkg/dplR/R/read.compact.R 2014-03-30 18:01:14 UTC (rev 751) @@ -33,5 +33,6 @@ rw.df <- as.data.frame(rw.mat) names(rw.df) <- series.ids + class(rw.df) <- c("rwl", "data.frame") rw.df } Modified: pkg/dplR/R/read.fh.R =================================================================== --- pkg/dplR/R/read.fh.R 2014-03-30 03:19:21 UTC (rev 750) +++ pkg/dplR/R/read.fh.R 2014-03-30 18:01:14 UTC (rev 751) @@ -320,5 +320,6 @@ domain="R-dplR")) } } + class(rwl) <- c("rwl", "data.frame") rwl } Modified: pkg/dplR/R/read.tridas.R =================================================================== --- pkg/dplR/R/read.tridas.R 2014-03-30 03:19:21 UTC (rev 750) +++ pkg/dplR/R/read.tridas.R 2014-03-30 18:01:14 UTC (rev 751) @@ -2599,5 +2599,7 @@ saxVersion = 2, validate = FALSE, useDotNames = TRUE) - h$get.results() + res <- h$get.results() + class(res$measurements) <- c("rwl", "data.frame") + res } Modified: pkg/dplR/R/read.tucson.R =================================================================== --- pkg/dplR/R/read.tucson.R 2014-03-30 03:19:21 UTC (rev 750) +++ pkg/dplR/R/read.tucson.R 2014-03-30 18:01:14 UTC (rev 751) @@ -484,5 +484,6 @@ } rw.df <- as.data.frame(apply(rw.mat, 2, fix.internal.na)) names(rw.df) <- as.character(series.ids) + class(rw.df) <- c("rwl", "data.frame") rw.df } Modified: pkg/dplR/data/anos1.rda =================================================================== (Binary files differ) Modified: pkg/dplR/data/ca533.rda =================================================================== (Binary files differ) Modified: pkg/dplR/data/co021.rda =================================================================== (Binary files differ) Modified: pkg/dplR/data/gp.rwl.rda =================================================================== (Binary files differ) Modified: pkg/dplR/man/plot.rwl.Rd =================================================================== --- pkg/dplR/man/plot.rwl.Rd 2014-03-30 03:19:21 UTC (rev 750) +++ pkg/dplR/man/plot.rwl.Rd 2014-03-30 18:01:14 UTC (rev 751) @@ -28,11 +28,9 @@ \seealso{ \code{\link{read.rwl}} } -\examples{data(ca533) -## to use as S3Method the class of rwl must be set: -class(ca533) <- c('rwl','data.frame') -plot(ca533,plot.type=c('seg')) -plot(ca533,plot.type=c('spag')) -plot(ca533,plot.type=c('spag'),zfac=2) +\examples{data(co021) +plot(co021,plot.type=c('seg')) +plot(co021,plot.type=c('spag')) +plot(co021,plot.type=c('spag'),zfac=2) } -\keyword{ plot } +\keyword{ hplot } Modified: pkg/dplR/man/seg.plot.Rd =================================================================== --- pkg/dplR/man/seg.plot.Rd 2014-03-30 03:19:21 UTC (rev 750) +++ pkg/dplR/man/seg.plot.Rd 2014-03-30 18:01:14 UTC (rev 751) @@ -22,7 +22,7 @@ } \author{ Andy Bunn. Patched and improved by Mikko Korpela. } \seealso{ \code{\link{spag.plot}} } -\examples{data(ca533) -seg.plot(ca533, main = "Campito Mountain") +\examples{data(co021) +seg.plot(co021, main = "Campito Mountain") } \keyword{ hplot } Modified: pkg/dplR/man/spag.plot.Rd =================================================================== --- pkg/dplR/man/spag.plot.Rd 2014-03-30 03:19:21 UTC (rev 750) +++ pkg/dplR/man/spag.plot.Rd 2014-03-30 18:01:14 UTC (rev 751) @@ -27,8 +27,8 @@ } \author{ Andy Bunn. Patched and improved by Mikko Korpela. } \seealso{ \code{\link{seg.plot}} } -\examples{data(ca533) -spag.plot(ca533, main = "Campito Mountain") -spag.plot(ca533, zfac = 2, main = "Campito Mountain") +\examples{data(co021) +spag.plot(co021) +spag.plot(co021, zfac = 2) } \keyword{ hplot } From noreply at r-forge.r-project.org Mon Mar 31 13:31:36 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 31 Mar 2014 13:31:36 +0200 (CEST) Subject: [Dplr-commits] r752 - in pkg/dplR: R man Message-ID: <20140331113137.08159186F17@r-forge.r-project.org> Author: mvkorpel Date: 2014-03-31 13:31:36 +0200 (Mon, 31 Mar 2014) New Revision: 752 Modified: pkg/dplR/R/plot.rwl.R pkg/dplR/man/plot.rwl.Rd Log: file properties Property changes on: pkg/dplR/R/plot.rwl.R ___________________________________________________________________ Added: svn:eol-style + native Property changes on: pkg/dplR/man/plot.rwl.Rd ___________________________________________________________________ Added: svn:eol-style + native From noreply at r-forge.r-project.org Mon Mar 31 14:56:11 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 31 Mar 2014 14:56:11 +0200 (CEST) Subject: [Dplr-commits] r753 - pkg/dplR/R Message-ID: <20140331125611.8121C186D73@r-forge.r-project.org> Author: mvkorpel Date: 2014-03-31 14:56:11 +0200 (Mon, 31 Mar 2014) New Revision: 753 Modified: pkg/dplR/R/read.tridas.R Log: Set class of rwl data.frame in a different place. Also works when res$measurements is a list of rwl data.frames. Modified: pkg/dplR/R/read.tridas.R =================================================================== --- pkg/dplR/R/read.tridas.R 2014-03-31 11:31:36 UTC (rev 752) +++ pkg/dplR/R/read.tridas.R 2014-03-31 12:56:11 UTC (rev 753) @@ -1586,6 +1586,7 @@ ## ... fixing the col numbers remark.data.col[idx.adjust] <<- l } + class(this.df) <- c("rwl", "data.frame") res.df[[length.res]] <<- this.df res.ids[[length.res]] <<- data.frame(i.i.s) res.titles[[length.res]] <<- data.frame(t.i.s) @@ -2599,7 +2600,5 @@ saxVersion = 2, validate = FALSE, useDotNames = TRUE) - res <- h$get.results() - class(res$measurements) <- c("rwl", "data.frame") - res + h$get.results() } From noreply at r-forge.r-project.org Mon Mar 31 15:36:43 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 31 Mar 2014 15:36:43 +0200 (CEST) Subject: [Dplr-commits] r754 - pkg/dplR/R Message-ID: <20140331133643.6D440186EF3@r-forge.r-project.org> Author: mvkorpel Date: 2014-03-31 15:36:42 +0200 (Mon, 31 Mar 2014) New Revision: 754 Modified: pkg/dplR/R/crn.plot.R Log: * Arguably cleaner way to define function aliases * (Automatic removal of trailing spaces performed by text editor) Modified: pkg/dplR/R/crn.plot.R =================================================================== --- pkg/dplR/R/crn.plot.R 2014-03-31 12:56:11 UTC (rev 753) +++ pkg/dplR/R/crn.plot.R 2014-03-31 13:36:42 UTC (rev 754) @@ -1,46 +1,19 @@ -`chron.plot` <- function(crn, add.spline=FALSE, nyrs=NULL, f=0.5, - crn.line.col='grey50',spline.line.col='red', - samp.depth.col='grey90', - samp.depth.border.col='grey80', - crn.lwd=1,spline.lwd=1.5, - abline.pos=1,abline.col='black', - abline.lty=1,abline.lwd=1, - xlab='Year',ylab='RWI'){ - args <- list() - args[["crn"]] <- crn - args[["add.spline"]] <- add.spline - args[["nyrs"]] <- nyrs - args[["f"]] <- f - args[["crn.line.col"]] <- crn.line.col - args[["spline.line.col"]] <- spline.line.col - args[["samp.depth.col"]] <- samp.depth.col - args[["samp.depth.border.col"]] <- samp.depth.border.col - args[["crn.lwd"]] <- crn.lwd - args[["spline.lwd"]] <- spline.lwd - args[["abline.pos"]] <- abline.pos - args[["abline.col"]] <- abline.col - args[["abline.lty"]] <- abline.lty - args[["abline.lwd"]] <- abline.lwd - args[["xlab"]] <- xlab - args[["ylab"]] <- ylab - do.call(crn.plot, args) -} - -`crn.plot` <- function(crn, add.spline=FALSE, nyrs=NULL, f=0.5, - crn.line.col='grey50',spline.line.col='red', - samp.depth.col='grey90', - samp.depth.border.col='grey80', - crn.lwd=1,spline.lwd=1.5, - abline.pos=1,abline.col='black', - abline.lty=1,abline.lwd=1, - xlab='Year',ylab='RWI'){ +`chron.plot` <- `crn.plot` <- function(crn, add.spline=FALSE, nyrs=NULL, f=0.5, + crn.line.col='grey50', + spline.line.col='red', + samp.depth.col='grey90', + samp.depth.border.col='grey80', + crn.lwd=1, spline.lwd=1.5, + abline.pos=1, abline.col='black', + abline.lty=1, abline.lwd=1, + xlab='Year', ylab='RWI') { if(!is.data.frame(crn)) stop("'crn' must be a data.frame") - + op <- par(no.readonly=TRUE) # Save par on.exit(par(op)) # Reset par on exit - par(mar=c(3, 3, 3, 3), mgp=c(1.1, 0.1, 0), + par(mar=c(3, 3, 3, 3), mgp=c(1.1, 0.1, 0), tcl=0.5, xaxs='i') - + yr.vec <- as.numeric(row.names(crn)) crn.names <- names(crn) nCrn <- ncol(crn) @@ -68,7 +41,7 @@ yy <- c(samp.depth, 0, 0) polygon(xx,yy,col=samp.depth.col,border=samp.depth.border.col) axis(4, at=pretty(samp.depth)) - mtext(text.samp, side=4, line=1.25) + mtext(text.samp, side=4, line=1.25) } par(new=TRUE) plot(yr.vec, spl, type="n",axes=FALSE,xlab='',ylab='')