[Dplr-commits] r660 - in branches/zero-is-missing: . R data inst inst/po/fi/LC_MESSAGES inst/unitTests man po src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Jan 10 10:42:13 CET 2013
Author: mvkorpel
Date: 2013-01-10 10:42:12 +0100 (Thu, 10 Jan 2013)
New Revision: 660
Added:
branches/zero-is-missing/R/common.interval.R
branches/zero-is-missing/R/fill.internal.NA.R
branches/zero-is-missing/R/pointer.R
branches/zero-is-missing/inst/unitTests/runit.io.R
branches/zero-is-missing/man/common.interval.Rd
branches/zero-is-missing/man/fill.internal.NA.Rd
branches/zero-is-missing/man/pointer.Rd
Modified:
branches/zero-is-missing/
branches/zero-is-missing/ChangeLog
branches/zero-is-missing/DESCRIPTION
branches/zero-is-missing/NAMESPACE
branches/zero-is-missing/R/bai.in.R
branches/zero-is-missing/R/bai.out.R
branches/zero-is-missing/R/chron.R
branches/zero-is-missing/R/combine.rwl.R
branches/zero-is-missing/R/corr.rwl.seg.R
branches/zero-is-missing/R/crn.plot.R
branches/zero-is-missing/R/detrend.R
branches/zero-is-missing/R/detrend.series.R
branches/zero-is-missing/R/exactmean.R
branches/zero-is-missing/R/gini.coef.R
branches/zero-is-missing/R/glk.R
branches/zero-is-missing/R/hanning.R
branches/zero-is-missing/R/helpers.R
branches/zero-is-missing/R/i.detrend.R
branches/zero-is-missing/R/i.detrend.series.R
branches/zero-is-missing/R/morlet.R
branches/zero-is-missing/R/normalize1.R
branches/zero-is-missing/R/read.compact.R
branches/zero-is-missing/R/read.crn.R
branches/zero-is-missing/R/read.fh.R
branches/zero-is-missing/R/read.ids.R
branches/zero-is-missing/R/read.rwl.R
branches/zero-is-missing/R/read.tridas.R
branches/zero-is-missing/R/read.tucson.R
branches/zero-is-missing/R/rwi.stats.R
branches/zero-is-missing/R/rwi.stats.running.R
branches/zero-is-missing/R/rwl.stats.R
branches/zero-is-missing/R/sea.R
branches/zero-is-missing/R/seg.plot.R
branches/zero-is-missing/R/sens1.R
branches/zero-is-missing/R/sens2.R
branches/zero-is-missing/R/series.rwl.plot.R
branches/zero-is-missing/R/simpleXML.R
branches/zero-is-missing/R/skel.plot.R
branches/zero-is-missing/R/spag.plot.R
branches/zero-is-missing/R/tbrm.R
branches/zero-is-missing/R/tridas.vocabulary.R
branches/zero-is-missing/R/uuid.gen.R
branches/zero-is-missing/R/wavelet.plot.R
branches/zero-is-missing/R/write.compact.R
branches/zero-is-missing/R/write.crn.R
branches/zero-is-missing/R/write.rwl.R
branches/zero-is-missing/R/write.tridas.R
branches/zero-is-missing/R/write.tucson.R
branches/zero-is-missing/data/ca533.rda
branches/zero-is-missing/data/cana157.rda
branches/zero-is-missing/data/co021.rda
branches/zero-is-missing/data/gp.d2pith.rda
branches/zero-is-missing/data/gp.dbh.rda
branches/zero-is-missing/inst/CITATION
branches/zero-is-missing/inst/po/fi/LC_MESSAGES/R-dplR.mo
branches/zero-is-missing/inst/unitTests/runit.chron.R
branches/zero-is-missing/man/anos1.Rd
branches/zero-is-missing/man/bai.in.Rd
branches/zero-is-missing/man/bai.out.Rd
branches/zero-is-missing/man/ca533.Rd
branches/zero-is-missing/man/cana157.Rd
branches/zero-is-missing/man/chron.Rd
branches/zero-is-missing/man/cms.Rd
branches/zero-is-missing/man/co021.Rd
branches/zero-is-missing/man/combine.rwl.Rd
branches/zero-is-missing/man/corr.rwl.seg.Rd
branches/zero-is-missing/man/crn.plot.Rd
branches/zero-is-missing/man/detrend.Rd
branches/zero-is-missing/man/detrend.series.Rd
branches/zero-is-missing/man/dplR-package.Rd
branches/zero-is-missing/man/ffcsaps.Rd
branches/zero-is-missing/man/gini.coef.Rd
branches/zero-is-missing/man/glk.Rd
branches/zero-is-missing/man/gp.d2pith.Rd
branches/zero-is-missing/man/gp.dbh.Rd
branches/zero-is-missing/man/gp.po.Rd
branches/zero-is-missing/man/gp.rwl.Rd
branches/zero-is-missing/man/hanning.Rd
branches/zero-is-missing/man/i.detrend.Rd
branches/zero-is-missing/man/i.detrend.series.Rd
branches/zero-is-missing/man/morlet.Rd
branches/zero-is-missing/man/po.to.wc.Rd
branches/zero-is-missing/man/powt.Rd
branches/zero-is-missing/man/rcs.Rd
branches/zero-is-missing/man/read.compact.Rd
branches/zero-is-missing/man/read.crn.Rd
branches/zero-is-missing/man/read.fh.Rd
branches/zero-is-missing/man/read.ids.Rd
branches/zero-is-missing/man/read.rwl.Rd
branches/zero-is-missing/man/read.tridas.Rd
branches/zero-is-missing/man/read.tucson.Rd
branches/zero-is-missing/man/rwi.stats.running.Rd
branches/zero-is-missing/man/rwl.stats.Rd
branches/zero-is-missing/man/sea.Rd
branches/zero-is-missing/man/seg.plot.Rd
branches/zero-is-missing/man/sens1.Rd
branches/zero-is-missing/man/sens2.Rd
branches/zero-is-missing/man/skel.plot.Rd
branches/zero-is-missing/man/spag.plot.Rd
branches/zero-is-missing/man/strip.rwl.Rd
branches/zero-is-missing/man/tbrm.Rd
branches/zero-is-missing/man/tridas.vocabulary.Rd
branches/zero-is-missing/man/uuid.gen.Rd
branches/zero-is-missing/man/wavelet.plot.Rd
branches/zero-is-missing/man/wc.to.po.Rd
branches/zero-is-missing/man/write.compact.Rd
branches/zero-is-missing/man/write.crn.Rd
branches/zero-is-missing/man/write.rwl.Rd
branches/zero-is-missing/man/write.tridas.Rd
branches/zero-is-missing/man/write.tucson.Rd
branches/zero-is-missing/po/R-dplR.pot
branches/zero-is-missing/po/R-fi.po
branches/zero-is-missing/src/
branches/zero-is-missing/src/exactmean.c
branches/zero-is-missing/src/exactsum.c
branches/zero-is-missing/src/exactsum.h
branches/zero-is-missing/src/gini.c
branches/zero-is-missing/src/rcompact.c
branches/zero-is-missing/src/readloop.c
branches/zero-is-missing/src/sens.c
branches/zero-is-missing/src/tbrm.c
Log:
In my experimental zero-is-missing branch: merged changes from dplR main development line (and applied fix.names() bug fix), now up-to-date. Also bug fixes and additional documentation.
Property changes on: branches/zero-is-missing
___________________________________________________________________
Modified: svn:mergeinfo
- /branches/dplR-R-2.15:482-506
/pkg/dplR:466-531
+ /branches/dplR-R-2.15:482-506
/pkg/dplR:466-658
Added: svn:ignore
+ dplR-Ex.R
Modified: branches/zero-is-missing/ChangeLog
===================================================================
--- branches/zero-is-missing/ChangeLog 2013-01-10 09:08:22 UTC (rev 659)
+++ branches/zero-is-missing/ChangeLog 2013-01-10 09:42:12 UTC (rev 660)
@@ -1,5 +1,10 @@
-* CHANGES IN zero-is-missing branch
+* CHANGES IN zero-is-missing branch (list may be incomplete)
+File: NAMESPACE
+---------------
+
+- Imports from package Matrix
+
Various .R files
----------------
@@ -10,11 +15,32 @@
change.
- Many (not all) functions have been updated to handle NA data.
+Files: bai.in.R, bai.out.R
+--------------------------
+
+- Warn about NA values if 'warn.na' is TRUE
+
+File: chron.R
+-------------
+
+- New parameters 'ids' and 'x.out'
+
File: detrend.R
---------------
-- Support for input of length 1
+- Arguments to detrend.series() are passed in '...'
+Files: gini.coef.R, sens1.R, sens2.R
+------------------------------------
+
+- New parameter na.rm
+
+File: helpers.R
+---------------
+
+- Complete overhaul of ar.func(). Tricks to enable handling of NA values
+ in series. Uses new function levDurb(). Experimental.
+
File: skel.plot.R
-----------------
@@ -23,24 +49,177 @@
origin: originally in the data, due to processing, or due to
thresholding.
+* CHANGES IN dplR VERSION 1.5.7
+
+File: corr.rwl.seg.R
+--------------------
+
+- New feature: allow the master series to be built from a second set of
+ tree ring series by using a data.frame 'master' argument
+- Replaced some for loops with cleaner vectorized operations or apply().
+
+File: helpers.R
+---------------
+
+- Fixed a bug in fix.names(), related to creating unique short names.
+ The bug affected read.tridas(), write.compact(), write.tridas() and
+ write.tucson() but probably manifested itself quite rarely.
+
+File: sea.R
+-----------
+
+- Extra input checks (e.g. x must have explicit, non-automatic row-names)
+- Some matrices now have the correct type (numeric instead of logical)
+ right from the beginning
+- Small optimization: a temporary matrix is completely overwritten on
+ every round of a loop, so no need to reinitialize
+- Braces always used in if (else) constructs
+
+
+* CHANGES IN dplR VERSION 1.5.6
+
+File: write.tucson.R
+------------------------
+
+- Changed series IDs to justify left instead of right. I'm not sure why
+ they ever wanted to be justified left. Silly. (AGB)
+
+File: NAMESPACE
+---------------
+- Exporting new function common.interval()
+
+File: common.interval.R
+------------------------
+
+- New function common.interval() trims a rwl object to a common interval
+ using one of three methods. Contributed by a user Filipe Campelo (fcampelo at ci.uc.pt).
+ This is his first contribution. Added to author list in DESCRIPTION.
+
+File: corr.rwl.seg.R
+--------------------
+
+- Bug fix: series names were not shown (numbers were shown instead)
+- Bug fix: there were off-by-one errors in the length of the bars
+
+File: DESCRIPTION
+-----------------
+- Changed author and maintainer to Andy Bunn from Andrew G. Bunn to keep parity between
+ the names and the email address AGB uses to submit to CRAN. This was made at the
+ request of Kurt Hornik at CRAN
+
* CHANGES IN dplR VERSION 1.5.5
+File: NAMESPACE
+---------------
+
+- Exporting new functions
+
+Various .R files:
+-----------------
+
+- Use 'nzchar(x)' instead of 'nchar(x) > 0'
+
+File: rwi.stats.running.R
+-------------------------
+
+- Added prewhitening option to rwi.stats.running() and by extension rwi.stats().
+ There are two new arguments prewhiten and n that are passed to normalize1()
+ as in the xdating functions e.g., corr.rwl.seg(). Help file changed.
+
Files: corr.rwl.seg.R, seg.plot.R, rwl.stats.R, spag.plot.R
-----------------------------------------------------------
- Support for input of length 1
+
File: corr.rwl.seg.R
--------------------
- Fixed 'ylim' in plot()
- Fixed "no guides" case
+- stops with a clear error message if 'rwl' has too few rows for the given
+ 'seg.length' and 'bin.floor' combination
+File: fill.internal.NA.R
+------------------------
+
+- New function fill.internal.NA() fills NA values internal to a series.
+ Written by Andy Bunn and Mikko Korpela. Help page added as well.
+
+File: pointer.R
+---------------
+
+- New function pointer() calculates pointer years from a group of
+ ring-width series. Written by Pierre Mérian, adapted for dplR and
+ improved by Andy Bunn and Mikko Korpela. Help page added as well.
+
File: rcs.R
-----------
- Graceful handling of empty input
+File: read.compact.R
+--------------------
+
+- Pretty printing of summary output, no more ragged lines
+
+File: read.fh.R
+---------------
+
+- Pretty printing of summary output, no more ragged lines
+- More robust detection of block and single column data representations
+- Data block, when using block representation, is interpreted as fixed
+ width fields (10*6)). Reference: TRiCYCLE Users Manual, Version 0.2.6.
+- Different units are supported. Default is 1/100 mm.
+- Each data block is mapped to the correct header block. Previously, there
+ was a risk of using the wrong header if the file contained data in
+ formats other than "Tree" or "Single". Also, the end position
+ of any data block could be off if data with different formats was
+ present in the file. Presumably the function would have failed with an
+ obscure error message.
+- Added support for site, tree, core, etc. metadata. Results are given as
+ an attribute of the return value, named "ids".
+- Added support for MissingRingsBefore (pith offset) metadata. Results are
+ given as an attribute named "po".
+
+File: read.tucson.R
+-------------------
+
+- Fixed trimming of all-NA rows
+- Fixed a bug that could crash R if the fided-width columns of the input
+ file did not follow the (loose) specifications of the Tucson format
+- AB: Note to dplR developers that this is a result of a poor standard in
+ the Tucson format but this fix is needed to work with files that are
+ on the ITRDB. Interestingly, dpl and ARSTAN are more robust to these
+ kinds of inconsistencies. Mikko's note: always check that your
+ assumptions a piece of input are correct before using the said input
+ to compute array indices, particularly in C code.
+- Can deal with CR CR LF newlines by reading the whole file into memory
+ at first and stripping empty lines
+- Can read non-standard files where one or more of the stop markers is
+ the 11th data column of its row
+- Can read non-standard files where columns don't have their proper
+ widths, including tab-delimited files
+- Can read non-standard files where missing data is marked with
+ non-numeric characters
+- Printed summary is justified, no more ragged lines
+- Interprets lines containing "#" characters (in positions 1-78) as
+ comments. For now, comments are ignored.
+- Fixed a bug that could cause mixing of values from two or more
+ measurement series sharing the same ID. Now it is an error if the input
+ file contains more than one measurement for any year, ID pair.
+- Accommodate mid-series upper and lower case differences: If a series
+ does not end with a stop marker, see if the series ID of the next row
+ after the last belonging to the series without a stop marker matches
+ when case differences are ignored. If so, interpret these as the same
+ series.
+
+File: write.tucson.R
+--------------------
+
+- Instead of always using 1000, 999 is now randomly converted to either
+ 998 or 1000 (prec == 0.01) => no bias (even if small)
+
* CHANGES IN dplR VERSION 1.5.4
File: DESCRIPTION
Property changes on: branches/zero-is-missing/ChangeLog
___________________________________________________________________
Deleted: svn:executable
- *
Modified: branches/zero-is-missing/DESCRIPTION
===================================================================
--- branches/zero-is-missing/DESCRIPTION 2013-01-10 09:08:22 UTC (rev 659)
+++ branches/zero-is-missing/DESCRIPTION 2013-01-10 09:42:12 UTC (rev 660)
@@ -2,14 +2,17 @@
Package: dplR
Type: Package
Title: Dendrochronology Program Library in R
-Version: 1.5.5-0
-Date: 2012-07-05
+Version: 1.5.7-660
+Date: 2013-01-10
Authors at R: c(person(c("Andrew", "G."), "Bunn", role = c("aut", "cph",
- "cre", "trl"), email = "andy.bunn at wwu.edu"), person("Mikko",
+ "cre", "trl"), email = "andrew.bunn at wwu.edu"), person("Mikko",
"Korpela", role = c("aut", "cph")), person("Franco", "Biondi",
- role = c("aut", "cph")), person("Fares", "Qeadan", role =
- c("aut", "cph")), person("Christian", "Zang", role = c("aut",
- "cph")))
+ role = c("aut", "cph")), person("Filipe", "Campelo", role =
+ c("aut", "cph")), person("Pierre", "Mérian", role = c("aut",
+ "cph")), person("Fares", "Qeadan", role = c("aut", "cph")),
+ person("Christian", "Zang", role = c("aut", "cph")))
+Author: Andy Bunn [aut, cph, cre, trl], Mikko Korpela [aut, cph], Franco Biondi [aut, cph], Filipe Campelo [aut, cph], Pierre Mérian [aut, cph], Fares Qeadan [aut, cph], Christian Zang [aut, cph]
+Maintainer: Andy Bunn <andy.bunn at wwu.edu>
Depends: R (>= 2.15.0)
Imports: graphics, grDevices, grid, Matrix (>= 0.9996875-1), stats, utils,
digest (>= 0.2.3), lattice (>= 0.13-6), stringr (>= 0.4),
Property changes on: branches/zero-is-missing/DESCRIPTION
___________________________________________________________________
Deleted: svn:executable
-
Modified: branches/zero-is-missing/NAMESPACE
===================================================================
--- branches/zero-is-missing/NAMESPACE 2013-01-10 09:08:22 UTC (rev 659)
+++ branches/zero-is-missing/NAMESPACE 2013-01-10 09:42:12 UTC (rev 660)
@@ -17,19 +17,20 @@
importFrom(Matrix, nearPD)
-importFrom(stringr, str_pad)
+importFrom(stringr, str_pad, str_trim)
importFrom(utils, head, installed.packages, read.fwf, tail)
importFrom(XML, xmlEventParse)
export(autoread.ids, bai.in, bai.out, ccf.series.rwl, chron, cms,
- combine.rwl, corr.rwl.seg, corr.series.seg, crn.plot, detrend,
- detrend.series, ffcsaps, gini.coef, glk, hanning, i.detrend,
- i.detrend.series, morlet, po.to.wc, powt, rcs, read.compact,
- read.crn, read.fh, read.ids, read.rwl, read.tridas,
- read.tucson, 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)
+ 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, rcs, read.compact, read.crn, read.fh,
+ read.ids, read.rwl, read.tridas, read.tucson, 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)
Property changes on: branches/zero-is-missing/NAMESPACE
___________________________________________________________________
Deleted: svn:executable
- *
Modified: branches/zero-is-missing/R/bai.in.R
===================================================================
--- branches/zero-is-missing/R/bai.in.R 2013-01-10 09:08:22 UTC (rev 659)
+++ branches/zero-is-missing/R/bai.in.R 2013-01-10 09:42:12 UTC (rev 660)
@@ -32,9 +32,9 @@
first.good <- idx.good[1]
last.good <- idx.good[n.good]
idx.seq <- first.good:last.good
- dat2 <- dat2[idx.seq]
+ dat <- dat[idx.seq]
## get ring area
- bai <- pi*dat2*(dat2+2*(cumsum(dat2) + d2pith.vec[i] - dat2))
+ bai <- pi*dat*(dat+2*(cumsum(dat) + d2pith.vec[i] - dat))
if (warn.na && any(is.na(bai))) {
warning(gettextf("NA values in series %s",
names(rwl2)[i]), domain=NA)
Property changes on: branches/zero-is-missing/R/bai.in.R
___________________________________________________________________
Deleted: svn:executable
- *
Modified: branches/zero-is-missing/R/bai.out.R
===================================================================
--- branches/zero-is-missing/R/bai.out.R 2013-01-10 09:08:22 UTC (rev 659)
+++ branches/zero-is-missing/R/bai.out.R 2013-01-10 09:42:12 UTC (rev 660)
@@ -29,15 +29,15 @@
first.good <- idx.good[1]
last.good <- idx.good[n.good]
idx.seq <- first.good:last.good
- dat2 <- dat2[idx.seq]
+ dat <- dat[idx.seq]
## get diameter if not given
if (is.null(diam)) {
- d <- sum(dat2)*2
+ d <- sum(dat)*2
} else {
d <- diam.vec[i]
}
## get ring area
- r0 <- d/2 - c(0, cumsum(rev(dat2)))
+ r0 <- d/2 - c(0, cumsum(rev(dat)))
bai <- -pi*rev(diff(r0*r0))
if (warn.na && any(is.na(bai))) {
warning(gettextf("NA values in series %s",
Property changes on: branches/zero-is-missing/R/bai.out.R
___________________________________________________________________
Deleted: svn:executable
- *
Property changes on: branches/zero-is-missing/R/chron.R
___________________________________________________________________
Deleted: svn:executable
-
Property changes on: branches/zero-is-missing/R/combine.rwl.R
___________________________________________________________________
Deleted: svn:executable
- *
Copied: branches/zero-is-missing/R/common.interval.R (from rev 658, pkg/dplR/R/common.interval.R)
===================================================================
--- branches/zero-is-missing/R/common.interval.R (rev 0)
+++ branches/zero-is-missing/R/common.interval.R 2013-01-10 09:42:12 UTC (rev 660)
@@ -0,0 +1,149 @@
+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")
+ }
+
+ 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 overlap
+ rm.short <- function(rwl, flag=FALSE) {
+ n <- 0
+ rwl <- rwl[!vapply(rwl, function(x) all(is.na(x)), TRUE)]
+ series.range <- vapply(rwl, yr.range, numeric(2),
+ yr = as.numeric(row.names(rwl)))
+
+ span.order <- order(series.range[2, ] - series.range[1, ])
+ to.keep <- rep(TRUE, length(span.order))
+
+ rwl.output <- rwl
+
+ for (i in seq(0, max(0, length(span.order) - 2))) {
+ if(i > 0) {
+ to.keep[span.order[i]] <- FALSE
+ }
+ rwl.short <- rwl[to.keep]
+ if (ncol(rwl.short) * nrow(rwl.short) < n) {
+ ## to break if it is not possible to improve the
+ ## common interval
+ break
+ }
+ rwl.short <- na.omit(rwl.short)
+ n.years <- ncol(rwl.short) * nrow(rwl.short)
+ ## to keep the rwl if has more years
+ if (n.years > n) {
+ n <- n.years
+ rwl.output <- rwl.short
+ if (flag) {
+ ## to give the common interval with the highest
+ ## sample depth for the case of
+ ## common.interval(rwl, type="series")
+ break
+ }
+ }
+ }
+ rwl.output
+ }
+
+###########
+ rwl.orig <- rwl
+ yrs <- as.numeric(row.names(rwl))
+ output <- 0
+ opt <- 0
+ rwl.output <- as.data.frame(matrix(0, 0, 0))
+
+ ## to get sample depth
+ if (ncol(rwl) > 0) {
+ tmp <- rowSums(!is.na(rwl))
+ } else {
+ tmp <- rep(0, nrow(rwl)) # R bug number 14959
+ }
+
+ for (i in dec(max(tmp), 2)) { # dec() forces a decreasing sequence
+ tmp[tmp > i] <- i
+ common.range <- range(as.integer(names(tmp)[tmp %in% i]))
+ rwl.common <- subset(rwl,
+ yrs >= common.range[1] & yrs <= common.range[2])
+ if (i * nrow(rwl.common) < output){
+ break
+ }
+ if (type2 == "series") {
+ rwl.output <- rm.short(rwl.common, flag=TRUE)
+ break
+ } else if (type2 == "years") {
+ rwl.common <- rm.short(rwl.common)
+ opt <- ncol(rwl.common) * nrow(rwl.common)
+ } else if (type2 == "both") {
+ rwl.common <- rwl.common[!vapply(rwl.common,
+ function(x) any(is.na(x)),
+ TRUE)]
+ opt <- ncol(rwl.common) * nrow(rwl.common)
+ }
+ if(opt > output) {
+ output <- opt
+ rwl.output <- rwl.common
+ }
+ }
+
+ if (make.plot) {
+ ## original rwl
+ series.range <- vapply(rwl.orig, yr.range, numeric(2),
+ yr = as.numeric(row.names(rwl)))
+ ## ensure that series.range is a matrix
+ dim(series.range) <- c(2, length(rwl))
+ first.year <- series.range[1, ]
+ yr <- as.numeric(row.names(rwl.orig))
+
+ neworder <- order(first.year, decreasing = FALSE)
+ segs <- rwl.orig[neworder]
+ n.col <- ncol(segs)
+ seq.col <- seq_len(n.col)
+ for (i in seq.col) {
+ segs[[i]][!is.na(segs[[i]])] <- i
+ }
+
+ ## common.rwl
+ yr2 <- as.numeric(row.names(rwl.output))
+ segs2 <- segs
+ for (j in seq_len(ncol(segs2))) {
+ if (names(segs)[j] %in% colnames(rwl.output)) {
+ ## get correct vector
+ segs2[!(yr %in% yr2), j] <- NA
+ } else {
+ segs2[, j] <- NA
+ }
+ }
+
+ sub.str1 <- gettextf("Original: %d series, %d years",
+ ncol(rwl.orig), nrow(rwl.orig), domain="R-dplR")
+ sub.str2 <-
+ gettextf("Common Interval (type='%s'): %d series x %d years = %d",
+ type2, ncol(rwl.output), nrow(rwl.output),
+ ncol(rwl.output) * nrow(rwl.output), domain="R-dplR")
+ sub.str <- paste(sub.str1, sub.str2, sep='\n')
+ 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)
+ plot(yr, segs[[1]], type = "n", ylim = c(1, n.col), axes = FALSE,
+ ylab = "", xlab = gettext("Year", domain = "R-dplR"))
+ mtext(text=sub.str, side=1, line=3)
+ apply(segs, 2, lines, x = yr, lwd = 2, col="grey")
+ apply(segs2, 2, lines, x = yr, lwd = 2, col="black")
+ axis(2, at = seq.col, labels = names(segs), srt = 45, tick = FALSE,
+ las = 2)
+ axis(1)
+ range.output <- range(as.numeric(rownames(rwl.output)))
+ abline(v=range.output, lty="dashed")
+ axis(3, at=range.output, labels=range.output, tcl=-0.25)
+ box()
+ }
+
+ rwl.output
+}
Modified: branches/zero-is-missing/R/corr.rwl.seg.R
===================================================================
--- branches/zero-is-missing/R/corr.rwl.seg.R 2013-01-10 09:08:22 UTC (rev 659)
+++ branches/zero-is-missing/R/corr.rwl.seg.R 2013-01-10 09:42:12 UTC (rev 660)
@@ -2,7 +2,12 @@
prewhiten = TRUE, pcrit=0.05, biweight=TRUE,
make.plot = TRUE, label.cex=1,
floor.plus1 = FALSE, master = NULL,
- master.yrs = as.numeric(names(master)), ...) {
+ master.yrs = as.numeric(if (is.null(dim(master))) {
+ names(master)
+ } else {
+ rownames(master)
+ }),
+ ...) {
## helper function
yr.range <- function(x, yr.vec=as.numeric(names(x))) {
@@ -44,11 +49,46 @@
## Pad rwl and master (if present) to same number of years
if (!is.null(master)) {
+ master.dim <- dim(master)
min.master.yr <- min(master.yrs)
max.master.yr <- max(master.yrs)
- master2 <- rep(NA_real_, max.master.yr - min.master.yr + 1)
- names(master2) <- min.master.yr : max.master.yr
- master2[as.character(master.yrs)] <- master
+
+ if (!is.null(master.dim) && length(master.dim) == 2 &&
+ master.dim[2] > 1) {
+ ## A. master is a data.frame or a matrix. Normalize and
+ ## compute master chronology as a mean of series
+ ## (columns).
+
+ ## Ensure that master has consecutive years in increasing order
+ if (!all(diff(master.yrs) == 1)) {
+ char.yrs <- as.character(min.master.yr : max.master.yr)
+ master.inc <- matrix(NA_real_,
+ nrow = max.master.yr - min.master.yr + 1,
+ ncol = master.dim[2],
+ dimnames = list(char.yrs,
+ colnames(master)))
+ master.inc[rownames(master), ] <- as.matrix(master)
+ } else {
+ master.inc <- master
+ }
+
+ ## normalize all series (columns in master matrix)
+ tmp <- normalize1(master.inc, n, prewhiten)
+ master.norm <- tmp$master[, tmp$idx.good, drop=FALSE]
+
+ ## compute master series by normal mean or robust mean
+ if (!biweight) {
+ master2 <- apply(master.norm, 1, exactmean)
+ } else {
+ master2 <- apply(master.norm, 1, tbrm, C=9)
+ }
+ } else {
+ ## B. master is a vector
+ master2 <- rep(NA_real_, max.master.yr - min.master.yr + 1)
+ names(master2) <- as.character(min.master.yr : max.master.yr)
+ master2[as.character(master.yrs)] <- master
+ }
+
if (min.master.yr < min.yr) {
n.pad <- min.yr - min.master.yr
padding <- matrix(NA_real_, n.pad, nseries)
@@ -87,7 +127,11 @@
} else {
min.bin <- ceiling(min.yr / bin.floor) * bin.floor
}
- bins <- seq(from=min.bin, to=max.yr - seg.length + 1, by=seg.lag)
+ max.bin <- max.yr - seg.length + 1
+ if (max.bin < min.bin) {
+ stop("shorten 'seg.length' or adjust 'bin.floor'")
+ }
+ bins <- seq(from=min.bin, to=max.bin, by=seg.lag)
bins <- cbind(bins, bins + (seg.length - 1))
nbins <- nrow(bins)
bin.names <- paste0(bins[, 1], ".", bins[, 2])
@@ -118,16 +162,10 @@
master.norm <- rwi[, idx.good & idx.noti, drop=FALSE]
## compute master series by normal mean or robust mean
- master2 <- vector(mode="numeric", length=nyrs)
if (!biweight) {
- for (j in seq_len(nyrs)) {
- master2[j] <- exactmean(master.norm[j, ])
- }
+ master2 <- apply(master.norm, 1, exactmean)
} else {
- ## surprisingly, for loop is faster than apply
- for (j in seq_len(nyrs)) {
- master2[j] <- tbrm(master.norm[j, ], C=9)
- }
+ master2 <- apply(master.norm, 1, tbrm, C=9)
}
}
series <- rwi[, i]
@@ -237,18 +275,18 @@
for (i in seq_len(nseries)) {
y.deviation <- y.deviation + 1
## whole segs
- xx <- segs.mat[i, ]
+ xx <- c(segs.mat[i, 1], segs.mat[i, 2] + 1)
xx <- c(xx, rev(xx))
yy <- c(i, i, y.deviation, y.deviation)
polygon(xx, yy, col=col.pal[3], border=NA)
## complete segs
- xx <- com.segs.mat[i, ]
+ xx <- c(com.segs.mat[i, 1], com.segs.mat[i, 2] + 1)
xx <- c(xx, rev(xx))
polygon(xx, yy, col=col.pal[2], border=NA)
## flags
flag.segs.mat <- yr.ranges(flag.segs[, i], yrs)
for (j in seq_len(nrow(flag.segs.mat))) {
- xx <- flag.segs.mat[j, ]
+ xx <- c(flag.segs.mat[j, 1], flag.segs.mat[j, 2] + 1)
xx <- c(xx, rev(xx))
polygon(xx, yy, col=col.pal[1], border=NA)
}
@@ -264,7 +302,7 @@
## finish up plotting
odd.seq <- seq(from=1, to=nsegs, by=2)
even.seq <- seq(from=2, to=nsegs, by=2)
- cnames.segs <- names(segs)
+ cnames.segs <- colnames(segs)
axis(2, at=odd.seq,
labels=cnames.segs[odd.seq], srt=45,
tick=FALSE, las=2, cex.axis=label.cex)
Property changes on: branches/zero-is-missing/R/crn.plot.R
___________________________________________________________________
Deleted: svn:executable
-
Property changes on: branches/zero-is-missing/R/detrend.R
___________________________________________________________________
Deleted: svn:executable
-
Property changes on: branches/zero-is-missing/R/detrend.series.R
___________________________________________________________________
Deleted: svn:executable
-
Property changes on: branches/zero-is-missing/R/exactmean.R
___________________________________________________________________
Deleted: svn:executable
- *
Copied: branches/zero-is-missing/R/fill.internal.NA.R (from rev 658, pkg/dplR/R/fill.internal.NA.R)
===================================================================
--- branches/zero-is-missing/R/fill.internal.NA.R (rev 0)
+++ branches/zero-is-missing/R/fill.internal.NA.R 2013-01-10 09:42:12 UTC (rev 660)
@@ -0,0 +1,65 @@
+fill.internal.NA <- function(x, fill=c("Mean", "Spline", "Linear")){
+ fillInternalNA.series <- function(x, fill=0){
+ x.na <- is.na(x)
+ x.ok <- which(!x.na)
+ n.ok <- length(x.ok)
+ if (n.ok <= 1) {
+ return(x)
+ }
+ ## find first and last
+ first.ok <- x.ok[1]
+ last.ok <- x.ok[n.ok]
+ ## fill internal NA
+ if (last.ok - first.ok + 1 > n.ok) {
+ first.to.last <- first.ok:last.ok
+ x2 <- x[first.to.last]
+ x2.na <- x.na[first.to.last]
+ if (fill == "Mean") {
+ ## fill internal NA with series mean
+ x2[x2.na] <- mean(x2[!x2.na])
+ } else if (is.numeric(fill)) {
+ ## fill internal NA with user supplied value
+ x2[x2.na] <- fill
+ } else {
+ good.x <- which(!x2.na)
+ good.y <- x2[good.x]
+ bad.x <- which(x2.na)
+ if (fill == "Spline") {
+ ## fill internal NA with spline
+ x2.aprx <- spline(x=good.x, y=good.y, xout=bad.x)
+ } else {
+ ## fill internal NA with linear interpolation
+ x2.aprx <- approx(x=good.x, y=good.y, xout=bad.x)
+ }
+ x2[bad.x] <- x2.aprx$y
+ }
+ ## repad x
+ x3 <- x
+ x3[first.to.last] <- x2
+ x3
+ } else {
+ x
+ }
+ }
+ if (!is.data.frame(x)) {
+ stop("'x' must be a data.frame")
+ }
+ if (!all(vapply(x, is.numeric, FALSE, USE.NAMES=FALSE))) {
+ stop("'x' must have numeric columns")
+ }
+ if (is.numeric(fill)) {
+ if (length(fill) == 1) {
+ fill2 <- fill[1]
+ } else {
+ stop("'fill' must be a single number or character string")
+ }
+ } else {
+ fill2 <- match.arg(fill)
+ }
+ y <- vapply(x, fillInternalNA.series, numeric(nrow(x)), fill=fill2)
+ dim(y) <- dim(x)
+ y <- as.data.frame(y)
+ row.names(y) <- row.names(x)
+ names(y) <- names(x)
+ y
+}
Property changes on: branches/zero-is-missing/R/gini.coef.R
___________________________________________________________________
Deleted: svn:executable
- *
Property changes on: branches/zero-is-missing/R/glk.R
___________________________________________________________________
Deleted: svn:executable
- *
Property changes on: branches/zero-is-missing/R/hanning.R
___________________________________________________________________
Deleted: svn:executable
- *
Modified: branches/zero-is-missing/R/helpers.R
===================================================================
--- branches/zero-is-missing/R/helpers.R 2013-01-10 09:08:22 UTC (rev 659)
+++ branches/zero-is-missing/R/helpers.R 2013-01-10 09:42:12 UTC (rev 660)
@@ -330,7 +330,14 @@
### Range of years. Used in cms, rcs, rwl.stats, seg.plot, spag.plot, ...
yr.range <- function(x, yr.vec = as.numeric(names(x))) {
- range(yr.vec[!is.na(x)])
+ na.flag <- is.na(x)
+ if (all(na.flag)) {
+ res <- rep(NA, 2)
+ mode(res) <- mode(yr.vec)
+ res
+ } else {
+ range(yr.vec[!na.flag])
+ }
}
### Multiple ranges of years.
@@ -420,7 +427,7 @@
idx.bad <- grep(bad.chars, x.cut, perl=TRUE)
if (length(idx.bad) > 0) {
warning("characters outside a-z, A-Z, 0-9 present: renaming series")
- if (nchar(mapping.fname) > 0) {
+ if (nzchar(mapping.fname)) {
write.map <- TRUE
}
rename.flag[idx.bad] <- TRUE
@@ -432,7 +439,7 @@
over.limit <- nchar(x.cut) > limit
if (any(over.limit)) {
warning("some names are too long: renaming series")
- if (nchar(mapping.fname) > 0) {
+ if (nzchar(mapping.fname)) {
write.map <- TRUE
}
rename.flag[over.limit] <- TRUE
@@ -448,7 +455,7 @@
y <- x.cut
} else {
warning("duplicate names present: renaming series")
- if (nchar(mapping.fname) > 0) {
+ if (nzchar(mapping.fname)) {
write.map <- TRUE
}
@@ -487,7 +494,7 @@
suffix.count <- count.base(suffix.count, n.an)
proposed <-
compose.name(unique.cut[i],alphanumeric,suffix.count,limit)
- if (nchar(proposed) == 0) {
+ if (!nzchar(proposed)) {
warning("could not remap a name: some series will be missing")
still.looking <- FALSE
## F for Fail...
Property changes on: branches/zero-is-missing/R/helpers.R
___________________________________________________________________
Deleted: svn:executable
- *
Property changes on: branches/zero-is-missing/R/i.detrend.R
___________________________________________________________________
Deleted: svn:executable
-
Property changes on: branches/zero-is-missing/R/i.detrend.series.R
___________________________________________________________________
Deleted: svn:executable
-
Property changes on: branches/zero-is-missing/R/morlet.R
___________________________________________________________________
Deleted: svn:executable
-
Property changes on: branches/zero-is-missing/R/normalize1.R
___________________________________________________________________
Deleted: svn:executable
- *
Copied: branches/zero-is-missing/R/pointer.R (from rev 658, pkg/dplR/R/pointer.R)
===================================================================
--- branches/zero-is-missing/R/pointer.R (rev 0)
+++ branches/zero-is-missing/R/pointer.R 2013-01-10 09:42:12 UTC (rev 660)
@@ -0,0 +1,52 @@
+pointer <- function(rwl, rgv.thresh=10, nseries.thresh=75,
+ round.decimals=2) {
+ stopifnot(is.numeric(rgv.thresh), length(rgv.thresh) == 1,
+ is.finite(rgv.thresh))
+ if (rgv.thresh < 0) {
+ stop("'rgv.thresh' must be > 0")
+ }
+ if (rgv.thresh >= 100) {
+ warning("'rgv.thresh' > 100 is unusual.")
+ }
+ stopifnot(is.numeric(nseries.thresh), length(nseries.thresh) == 1,
+ is.finite(nseries.thresh))
+ if (nseries.thresh < 0 || nseries.thresh > 100) {
+ stop("'nseries.thresh' must range from 0 to 100")
+ }
+ rwl2 <- as.matrix(rwl)
+ if (!is.matrix(rwl2)) {
+ stop("'rwl' must be coercible to a matrix")
+ }
+ rnames <- rownames(rwl2)
+ if (is.null(rnames)) {
+ stop("'rwl' must have explicit row names")
+ }
+ yrs <- as.numeric(rnames)
+ nyrs <- length(yrs)
+ if (nyrs < 2) {
+ stop("'rwl' must have at least 2 rows")
+ }
+ nseries <- ncol(rwl2)
+ gv <- rwl2[-1, , drop=FALSE] / rwl2[-nyrs, , drop=FALSE]
+ out <- matrix(NA_real_, nrow=nyrs - 1, ncol=7)
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/dplr -r 660
More information about the Dplr-commits
mailing list