[Dplr-commits] r739 - in pkg/dplR: . R inst inst/unitTests man po src tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Mar 26 12:04:47 CET 2014
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 <andy.bunn at wwu.edu>
-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 <andy.bunn at wwu.edu>
+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
More information about the Dplr-commits
mailing list