From noreply at r-forge.r-project.org Sat Nov 9 20:25:19 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 9 Nov 2013 20:25:19 +0100 (CET) Subject: [Dplr-commits] r714 - in pkg/dplR: . R Message-ID: <20131109192519.B3A051839CA@r-forge.r-project.org> Author: mvkorpel Date: 2013-11-09 20:25:19 +0100 (Sat, 09 Nov 2013) New Revision: 714 Modified: pkg/dplR/ChangeLog pkg/dplR/DESCRIPTION pkg/dplR/R/redfit.R Log: In redfit.R: * Fixed windows to be DFT-even * Computed 6dB bandwidths for windows of different length Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2013-10-29 20:09:02 UTC (rev 713) +++ pkg/dplR/ChangeLog 2013-11-09 19:25:19 UTC (rev 714) @@ -6,7 +6,11 @@ - Use slightly faster .rowSums() instead of rowSums() - Simplified arithmetic expressions in getdof(): no multiplying by 2 - Precomputed squared numbers in getdof() -- Small optimizations in redfitWinwgt() +- Fixed Welch, Hanning, Triangular and Blackman-Harris windows to + be DFT-even +- Computed more precise values for the 6 dB bandwidths of each window, + also for short windows. Uniform sampling was assumed. +- Two internal functions moved to top level, previously inside print.redfit() * CHANGES IN dplR VERSION 1.5.7 Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2013-10-29 20:09:02 UTC (rev 713) +++ pkg/dplR/DESCRIPTION 2013-11-09 19:25:19 UTC (rev 714) @@ -3,7 +3,7 @@ Type: Package Title: Dendrochronology Program Library in R Version: 1.5.8 -Date: 2013-10-29 +Date: 2013-11-09 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/redfit.R =================================================================== --- pkg/dplR/R/redfit.R 2013-10-29 20:09:02 UTC (rev 713) +++ pkg/dplR/R/redfit.R 2013-11-09 19:25:19 UTC (rev 714) @@ -132,7 +132,7 @@ if (!is.null(seed)) { set.seed(seed) } - MIN_POINTS <- 2 + MIN_POINTS <- 3 # with 2 points, some windows have just 1 non-zero point WIN_NAMES <- c("rectangular", "welch i", "hanning", "triangular", "blackman-harris") ## dplR: 21 is the lower limit of nsim where !anyDuplicated(c(idx80, @@ -521,6 +521,160 @@ res } +## Determine 6dB bandwidth from OFAC corrected fundamental frequency. +## Note that the bandwidth for the Blackman-Harris taper is higher than +## reported by Harris (1978, cf. Nuttall, 1981)} +## +## window type (iwin) 0: Rectangular +## 1: Welch 1 +## 2: Hanning +## 3: Parzen (Triangular) +## 4: Blackman-Harris 3-Term +redfitWinbw <- function(iwin, df, ofac, nseg) { + + ## dplR: bw has been computed with higher precision. We also + ## have results for short windows which shows the aliasing + ## caused by sampling. FFT() from package "fftw" and fft() + ## were used. Note that the results are for uniformly sampled + ## windows. For some reason, the asymptotic (approaching + ## continuous time) bandwidths of the triangular and + ## Blackman-Harris (defined by Nuttall) windows slightly + ## differ from the bandwidths used by REDFIT (below, commented + ## out): now 1.77 instead of 1.78 and 2.27 instead of 2.26, + ## respectively. + + ## bw <- c(1.21, 1.59, 2.00, 1.78, 2.26) + + approxX <- + switch(iwin + 1, + ## 1 (Rectangular) + c(2:49, 51, 52, 54, 55, 57, 60, 62, 65, 68, 72, 77, + 82, 89, 99, 104), + ## 2 (Welch) + c(3:84, 86:89, 91, 92, 94, 95, 97, 99, 100, 102, + 104, 106, 109, 111, 114, 117, 120, 123, 127, 131, + 135, 140, 146, 152, 155, 489), + ## 3 (Hanning) + 3, + ## 4 (Triangular) + c(3, 5:137, 171:219), + ## 5 (Blackman-Harris) + c(3:11, 13, 15, 18, 19)) + + approxY <- + switch(iwin + 1, + ## 1 (Rectangular), results agree with exact formula + ## given by Harris + c(1.33333333333333, 1.258708, 1.2351995, 1.2247266, + 1.2191411, 1.215808, 1.213658, 1.212190, + 1.211143, 1.210370, 1.209784, 1.209327, + 1.208966, 1.208674, 1.208436, 1.208238, + 1.208073, 1.207933, 1.207813, 1.2077106, + 1.20762, 1.207544, 1.207476, 1.207416, + 1.2073622, 1.207315, 1.207272, 1.207234, + 1.207200, 1.207168, 1.207140, 1.2071144, + 1.207091, 1.2070694, 1.207050, 1.2070315, + 1.207015, 1.206999, 1.2069849, 1.20697, + 1.206959, 1.206948, 1.206937, 1.2069270, + 1.206918, 1.206909, 1.206901, 1.20689, + 1.2068788, 1.20687, 1.206860, 1.20685, + 1.20684, 1.20683, 1.20682, 1.20681, + 1.20680, 1.20679, 1.20678, 1.20677, + 1.20676, 1.20675, 1.2067), + ## 2 (Welch) + c(2.00000000000000, 1.78680, 1.70821, 1.66954, + 1.64744, 1.63354, 1.62421, 1.617630, + 1.61281, 1.60918, 1.60636, 1.60414, + 1.60236, 1.60090, 1.59969, 1.59869, + 1.59784, 1.59711, 1.59649, 1.59595, + 1.59548, 1.59506, 1.59470, 1.59438, + 1.59409, 1.59383, 1.59360, 1.59339, + 1.59321, 1.59304, 1.59288, 1.59274, + 1.592608, 1.592489, 1.59238, 1.59228, + 1.59219, 1.592099, 1.59202, 1.59194, + 1.59188, 1.59181, 1.591750, 1.59169, + 1.59164, 1.59159, 1.59154, 1.59150, + 1.59146, 1.59142, 1.59138, 1.591349, + 1.59132, 1.59129, 1.59126, 1.591228, + 1.59120, 1.59118, 1.59115, 1.59113, + 1.59111, 1.591087, 1.59107, 1.59105, + 1.59103, 1.59101, 1.590996, 1.59098, + 1.590965, 1.590951, 1.59094, 1.59092, + 1.59091, 1.59090, 1.59089, 1.5908750, + 1.59086, 1.59085, 1.59084, 1.59083, + 1.590824, 1.59081, 1.59080, 1.59079, + 1.59078, 1.59077, 1.59076, 1.59075, + 1.59074, 1.59073, 1.59072, 1.59071, + 1.59070, 1.59069, 1.59068, 1.59067, + 1.59066, 1.59065, 1.59064, 1.59063, + 1.59062, 1.59061, 1.59060, 1.59059, + 1.59058, 1.59057, 1.59056, 1.59055, + 1.5905, 1.5904), + ## 3 (Hanning) + 2.000, + ## 4 (Triangular), results agree with exact formula + ## given by Harris (for even number of points) + c(2.0000, 1.84975, 1.86328, 1.81083, 1.82157, + 1.79521, 1.80317, 1.78740, 1.79341, 1.78294, + 1.78760, 1.78015, 1.78385, 1.77829, 1.78130, + 1.77699, 1.77948, 1.776045, 1.77814, 1.775335, + 1.77712, 1.774789, 1.77633, 1.77436, 1.77570, + 1.77402, 1.77519, 1.77374, 1.774780, 1.77351, + 1.77444, 1.77332, 1.77415, 1.77316, 1.77391, + 1.77302, 1.77370, 1.77290, 1.77352, 1.77280, + 1.77337, 1.77271, 1.77323, 1.772635, 1.77311, + 1.77257, 1.77301, 1.77251, 1.77292, 1.77245, + 1.77284, 1.77241, 1.77276, 1.77236, 1.77270, + 1.77232, 1.772636, 1.77229, 1.77258, 1.77226, + 1.77253, 1.77223, 1.77249, 1.77220, 1.77245, + 1.77218, 1.77241, 1.772158, 1.772376, 1.77214, + 1.77234, 1.77212, 1.77232, 1.77210, 1.77229, + 1.77209, 1.77226, 1.77207, 1.77224, 1.77206, + 1.77222, 1.77205, 1.77220, 1.77203, 1.77218, + 1.77202, 1.77216, 1.77201, 1.77215, 1.77200, + 1.77213, 1.77199, 1.77212, 1.771985, 1.77210, + 1.771977, 1.77209, 1.77197, 1.77208, 1.77196, + 1.77207, 1.77196, 1.77206, 1.77195, 1.77205, + 1.77194, 1.7720387, 1.77194, 1.77203, 1.77193, + 1.772021, 1.77193, 1.77201, 1.77192, 1.77201, + 1.771918, 1.77200, 1.77191, 1.77199, 1.77191, + 1.771985, 1.77191, 1.77198, 1.77190, 1.77197, + 1.77190, 1.77197, 1.771895, 1.77196, 1.77189, + 1.77196, 1.77189, 1.77195, 1.7719, 1.771850, + 1.77189, 1.77185, 1.77189, 1.771847, 1.77188, + 1.77185, 1.77188, 1.77184, 1.77188, 1.77184, + 1.77188, 1.77184, 1.77188, 1.77184, 1.77187, + 1.77184, 1.77187, 1.77184, 1.77187, 1.771837, + 1.77187, 1.771836, 1.77187, 1.771835, 1.77187, + 1.77183, 1.77186, 1.77183, 1.77186, 1.77183, + 1.77186, 1.77183, 1.77186, 1.77183, 1.77186, + 1.77183, 1.77186, 1.77183, 1.77186, 1.77183, + 1.77185, 1.771827, 1.77185, 1.77183, 1.77185, + 1.77183, 1.77185, 1.7718), + ## 5 (Blackman-Harris) + c(1.9860952, 2.271338, 2.267059, 2.267229, + 2.267416, 2.267511, 2.26755, 2.267572, + 2.26758, 2.26757, 2.26756, 2.267552, + 2.2675)) + + ## df * ofac * bw[iwin + 1] + df * ofac * approx(approxX, approxY, nseg, + method = "constant", rule = c(1, 2), f = 0)[["y"]] +} + +## Effective number of degrees of freedom for the selected window +## and n50 overlapping segments (Harris, 1978). +## dplR: Computed more precise values for c50. +redfitGetdof <- function(iwin, n50) { + ## dplR: Rectangular, Welch, Hanning, Triangular, Blackman-Harris + ## c50 <- c(0.5, 0.34375, 1 / 6, 0.25, 0.0955489871755) + ## c2 <- c50[iwin + 1]^2 + ## dplR: Precomputed squared c50. Note: (1/6)^2 == 1/36 + c2 <- c(0.25, 0.1181640625, 0.0277777777777778, + 0.0625, 0.00912960895026386)[iwin + 1] + n50 / (0.5 + c2 - c2 / n50) +} + ## dplR: print.redfit() is a separate function for printing the ## results of redfit(), with an output format very close to that in ## the original REDFIT. @@ -531,32 +685,7 @@ } stopifnot(identical(csv.out, TRUE) || identical(csv.out, FALSE)) stopifnot(identical(do.table, TRUE) || identical(do.table, FALSE)) - ## Determine 6dB bandwidth from OFAC corrected fundamental frequency. - ## Note that the bandwidth for the Blackman-Harris taper is higher than - ## reported by Harris (1978, cf. Nuttall, 1981)} - ## - ## window type (iwin) 0: Rectangular - ## 1: Welch 1 - ## 2: Hanning - ## 3: Parzen (Triangular) - ## 4: Blackman-Harris 3-Term - winbw <- function(iwin, df, ofac) { - ## dplR NOTE: bw could be defined with greater precision - bw <- c(1.21, 1.59, 2.00, 1.78, 2.26) - df * ofac * bw[iwin + 1] - } - ## Effective number of degrees of freedom for the selected window - ## and n50 overlapping segments (Harris, 1978). - ## dplR: Computed more precise values for c50. - getdof <- function(iwin, n50) { - ## dplR: Rectangular, Welch, Hanning, Triangular, Blackman-Harris - ## c50 <- c(0.5, 0.34375, 1 / 6, 0.25, 0.0955489871755) - ## c2 <- c50[iwin + 1]^2 - ## dplR: Precomputed squared c50. Note: (1/6)^2 == 1/36 - c2 <- c(0.25, 0.1181640625, 0.0277777777777778, - 0.0625, 0.00912960895026386)[iwin + 1] - n50 / (0.5 + c2 - c2 / n50) - } + ## dplR: Automatically adds prefix (for example "# " from REDFIT) and ## newline (if newline = TRUE) to output. precat <- function(..., newline = TRUE, sep = "") { @@ -573,7 +702,7 @@ gredth <- x[["gredth"]] ## scaling factors for red noise from chi^2 distribution - dof <- getdof(iwin, n50) + dof <- redfitGetdof(iwin, n50) ## dplR: getchi2() in the original Fortran version uses upper tail ## probabilities. qchisq() uses lower tail probabilities unless ## lower.tail = FALSE. @@ -657,7 +786,7 @@ format(dof, digits = digits), domain = "R-dplR")) precat(gettextf("6-dB Bandwidth = %s", - format(winbw(iwin, params[["df"]], ofac), + format(redfitWinbw(iwin, params[["df"]], ofac, nseg), digits = digits), domain = "R-dplR")) precat(gettextf("Critical false-alarm level (Thomson, 1990) = %s", @@ -1371,25 +1500,35 @@ ## 2: Hanning ## 3: Parzen (Triangular) ## 4: Blackman-Harris 3-Term +## dplR: Fixed the Welch, Hann(ing), Triangular and Blacman-Harris (by +## Nuttall) windows to be DFT-even. The old definitions have been +## commented out. redfitWinwgt <- function(t, iwin) { nseg <- length(t) ## useful factor for various windows fac1 <- nseg / 2 - 0.5 fac2 <- 1 / (fac1 + 1) tlen <- t[nseg] - t[1] + tlenFull <- nseg * tlen / (nseg - 1) + tPeak <- t[nseg] - tlenFull / 2 if (iwin == 0) { # rectangle ww <- rep.int(1, nseg) } else if (iwin == 1) { # welch I - ww <- (nseg / tlen * (t - t[1]) - fac1) * fac2 + ## ww <- (nseg / tlen * (t - t[1]) - fac1) * fac2 + ww <- abs(t - tPeak) / (t[nseg] - tPeak) ww <- 1 - ww * ww } else if (iwin == 2) { # hanning - fac3 <- nseg - 1 - ww <- 1 - cos(2 * pi / fac3 * nseg / tlen * (t - t[1])) + ## fac3 <- nseg - 1 + ## ww <- 1 - cos(2 * pi / fac3 * nseg / tlen * (t - t[1])) + ww <- 1 - cos(2 * pi / nseg * (1 + (nseg - 1) / tlen * (t - t[1]))) } else if (iwin == 3) { # triangular - ww <- 1 - abs((nseg / tlen * (t - t[1]) - fac1) * fac2) + ## ww <- 1 - abs((nseg / tlen * (t - t[1]) - fac1) * fac2) + ww <- 1 - abs(t - tPeak) / (t[nseg] - tPeak) } else { # blackman-harris - fac4 <- 2 * pi / (nseg - 1) - jeff <- nseg / tlen * (t - t[1]) + ## fac4 <- 2 * pi / (nseg - 1) + ## jeff <- nseg / tlen * (t - t[1]) + fac4 <- 2 * pi / nseg + jeff <- 1 + (nseg - 1) / tlen * (t - t[1]) ww <- 0.4243801 - 0.4973406 * cos(fac4 * jeff) + 0.0782793 * cos(fac4 * 2.0 * jeff) } From noreply at r-forge.r-project.org Sat Nov 9 22:58:17 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 9 Nov 2013 22:58:17 +0100 (CET) Subject: [Dplr-commits] r715 - pkg/dplR/man Message-ID: <20131109215817.EEF1C184EED@r-forge.r-project.org> Author: mvkorpel Date: 2013-11-09 22:58:17 +0100 (Sat, 09 Nov 2013) New Revision: 715 Modified: pkg/dplR/man/redfit.Rd Log: Added a note about changes wrt. window functions Modified: pkg/dplR/man/redfit.Rd =================================================================== --- pkg/dplR/man/redfit.Rd 2013-11-09 19:25:19 UTC (rev 714) +++ pkg/dplR/man/redfit.Rd 2013-11-09 21:58:17 UTC (rev 715) @@ -124,6 +124,10 @@ \item The user can select the significance levels of the runs test. + \item Most of the window functions have been adjusted. + + \item 6 dB bandwidths have been computed for discrete-time windows. + } Function \code{runcrit} computes the limits of the acceptance region From noreply at r-forge.r-project.org Sat Nov 9 22:59:24 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 9 Nov 2013 22:59:24 +0100 (CET) Subject: [Dplr-commits] r716 - pkg/dplR/R Message-ID: <20131109215924.A2395184EED@r-forge.r-project.org> Author: mvkorpel Date: 2013-11-09 22:59:24 +0100 (Sat, 09 Nov 2013) New Revision: 716 Modified: pkg/dplR/R/redfit.R Log: Commented out unused variable fac2 Modified: pkg/dplR/R/redfit.R =================================================================== --- pkg/dplR/R/redfit.R 2013-11-09 21:58:17 UTC (rev 715) +++ pkg/dplR/R/redfit.R 2013-11-09 21:59:24 UTC (rev 716) @@ -1507,7 +1507,7 @@ nseg <- length(t) ## useful factor for various windows fac1 <- nseg / 2 - 0.5 - fac2 <- 1 / (fac1 + 1) + ## fac2 <- 1 / (fac1 + 1) tlen <- t[nseg] - t[1] tlenFull <- nseg * tlen / (nseg - 1) tPeak <- t[nseg] - tlenFull / 2 From noreply at r-forge.r-project.org Wed Nov 27 11:28:43 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 27 Nov 2013 11:28:43 +0100 (CET) Subject: [Dplr-commits] r717 - in pkg/dplR: . R man Message-ID: <20131127102843.173F31844AA@r-forge.r-project.org> Author: mvkorpel Date: 2013-11-27 11:28:42 +0100 (Wed, 27 Nov 2013) New Revision: 717 Modified: pkg/dplR/ChangeLog pkg/dplR/DESCRIPTION pkg/dplR/R/detrend.R pkg/dplR/R/detrend.series.R pkg/dplR/man/detrend.Rd pkg/dplR/man/detrend.series.Rd pkg/dplR/man/dplR-package.Rd Log: Fixed a bug in detrend.series() where RWI could go negative. Thanks to Jacob Cecile (added to DESCRIPTION as a contributor). Also, detrend() and detrend.series() have a new argument 'constrain.modnegexp'. Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2013-11-09 21:59:24 UTC (rev 716) +++ pkg/dplR/ChangeLog 2013-11-27 10:28:42 UTC (rev 717) @@ -1,5 +1,24 @@ * CHANGES IN dplR VERSION 1.5.8 +File: DESCRIPTION + +- Added Jacob Cecile as a contributor + +File: detrend.R +--------------- + +- Adjusted for the changes in detrend.series(), + i.e. added the argument constrain.modnegexp. + +File: detrend.series.R +---------------------- + +- Fixed a bug where RWI could go negative. Thanks to Jacob Cecile for + reporting the bug and contributing a proposed solution. +- A new argument: constrain.modnegexp. It is now possible to constrain + the modified negative exponential function to non-negative values at + infinity. + File: redfit.R -------------- Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2013-11-09 21:59:24 UTC (rev 716) +++ pkg/dplR/DESCRIPTION 2013-11-27 10:28:42 UTC (rev 717) @@ -3,7 +3,7 @@ Type: Package Title: Dendrochronology Program Library in R Version: 1.5.8 -Date: 2013-11-09 +Date: 2013-11-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", @@ -12,8 +12,9 @@ "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"))) -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] + "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) Modified: pkg/dplR/R/detrend.R =================================================================== --- pkg/dplR/R/detrend.R 2013-11-09 21:59:24 UTC (rev 716) +++ pkg/dplR/R/detrend.R 2013-11-27 10:28:42 UTC (rev 717) @@ -1,9 +1,13 @@ `detrend` <- function(rwl, y.name = names(rwl), make.plot = FALSE, method=c("Spline", "ModNegExp", "Mean"), - nyrs = NULL, f = 0.5, pos.slope = FALSE) + nyrs = NULL, f = 0.5, pos.slope = FALSE, + constrain.modnegexp = c("never", "when.fail", "always")) { + stopifnot(identical(make.plot, TRUE) || identical(make.plot, FALSE), + identical(pos.slope, FALSE) || identical(pos.slope, TRUE)) known.methods <- c("Spline", "ModNegExp", "Mean") + constrain2 <- match.arg(constrain.modnegexp) method2 <- match.arg(arg = method, choices = known.methods, several.ok = TRUE) @@ -36,7 +40,9 @@ fits <- detrend.series(rwl.i, make.plot=FALSE, method=method2, nyrs=nyrs, f=f, - pos.slope=pos.slope) + pos.slope=pos.slope, + constrain.modnegexp= + constrain2) if(is.data.frame(fits)) row.names(fits) <- rn fits @@ -47,7 +53,8 @@ fits <- detrend.series(rwl[[i]], y.name=y.name[i], make.plot=make.plot, method=method2, nyrs=nyrs, f=f, - pos.slope=pos.slope) + pos.slope=pos.slope, + constrain.modnegexp=constrain2) if(is.data.frame(fits)) row.names(fits) <- rn out[[i]] <- fits Modified: pkg/dplR/R/detrend.series.R =================================================================== --- pkg/dplR/R/detrend.series.R 2013-11-09 21:59:24 UTC (rev 716) +++ pkg/dplR/R/detrend.series.R 2013-11-27 10:28:42 UTC (rev 717) @@ -1,11 +1,13 @@ `detrend.series` <- function(y, y.name = "", make.plot = TRUE, method = c("Spline", "ModNegExp", "Mean"), - nyrs = NULL, f = 0.5, pos.slope = FALSE) + nyrs = NULL, f = 0.5, pos.slope = FALSE, + constrain.modnegexp = c("never", "when.fail", "always")) { stopifnot(identical(make.plot, TRUE) || identical(make.plot, FALSE), identical(pos.slope, FALSE) || identical(pos.slope, TRUE)) known.methods <- c("Spline", "ModNegExp", "Mean") + constrain2 <- match.arg(constrain.modnegexp) method2 <- match.arg(arg = method, choices = known.methods, several.ok = TRUE) @@ -24,27 +26,54 @@ if("ModNegExp" %in% method2){ ## Nec or lm - nec.func <- function(Y) { + nec.func <- function(Y, constrain) { a <- mean(Y[seq_len(floor(length(Y) * 0.1))]) b <- -0.01 k <- mean(Y[floor(length(Y) * 0.9):length(Y)]) - nec <- nls(formula = Y ~ a * exp(b * seq_along(Y)) + k, - start = list(a=a, b=b, k=k)) - if(coef(nec)[2] >= 0) stop() - fits <- predict(nec) - if(fits[1] < fits[length(fits)]) stop() - if(fits[length(fits)] < 0) stop() + nlsForm <- Y ~ a * exp(b * seq_along(Y)) + k + nlsStart <- list(a=a, b=b, k=k) + checked <- FALSE + if (constrain == "never") { + nec <- nls(formula = nlsForm, start = nlsStart) + } else if (constrain == "always") { + nec <- nls(formula = nlsForm, start = nlsStart, + lower = c(a=0, b=-Inf, k=0), + upper = c(a=Inf, b=0, k=Inf), + algorithm = "port") + } else { + nec <- nls(formula = nlsForm, start = nlsStart) + if(coef(nec)[2] >= 0) stop() + fits <- predict(nec) + if(fits[1] < fits[length(fits)]) stop() + if(fits[length(fits)] > 0) { + checked <- TRUE + } else { + nec <- nls(formula = nlsForm, start = nlsStart, + lower = c(a=0, b=-Inf, k=0), + upper = c(a=Inf, b=0, k=Inf), + algorithm = "port") + } + } + if (!checked) { + if(coef(nec)[2] >= 0) stop() + fits <- predict(nec) + if(fits[1] < fits[length(fits)]) stop() + if(fits[length(fits)] <= 0) stop() + } fits } - ModNegExp <- try(nec.func(y2), silent=TRUE) + ModNegExp <- try(nec.func(y2, constrain2), silent=TRUE) if(class(ModNegExp)=="try-error") { ## Straight line via linear regression tm <- cbind(1, seq_along(y2)) lm1 <- lm.fit(tm, y2) coefs <- lm1[["coefficients"]] + ModNegExp <- NULL if (all(is.finite(coefs)) && (coefs[2] <= 0 || pos.slope)) { ModNegExp <- drop(tm %*% coefs) - } else { + } + if (is.null(ModNegExp) || + ModNegExp[1] <= 0 || ModNegExp[length(y2)] <= 0) { ModNegExp <- rep(mean(y2), length(y2)) } } @@ -64,6 +93,9 @@ else nyrs2 <- nyrs Spline <- ffcsaps(y=y2, x=seq_along(y2), nyrs=nyrs2, f=f) + if (any(Spline <= 0)) { + Spline <- rep(mean(y2), length(y2)) + } resids$Spline <- y2 / Spline do.spline <- TRUE } else { Modified: pkg/dplR/man/detrend.Rd =================================================================== --- pkg/dplR/man/detrend.Rd 2013-11-09 21:59:24 UTC (rev 716) +++ pkg/dplR/man/detrend.Rd 2013-11-27 10:28:42 UTC (rev 717) @@ -8,7 +8,8 @@ \usage{ detrend(rwl, y.name = names(rwl), make.plot = FALSE, method = c("Spline", "ModNegExp", "Mean"), nyrs = NULL, - f = 0.5, pos.slope = FALSE) + f = 0.5, pos.slope = FALSE, + constrain.modnegexp = c("never", "when.fail", "always")) } \arguments{ @@ -38,6 +39,9 @@ slope to be used in method \code{"ModNegExp"}. If \code{FALSE} the line will be horizontal. } + \item{constrain.modnegexp}{ a \code{character} string which controls + the constraints of the \code{"ModNegExp"} model. } + } \details{ See \code{\link{detrend.series}} for details on detrending Modified: pkg/dplR/man/detrend.series.Rd =================================================================== --- pkg/dplR/man/detrend.series.Rd 2013-11-09 21:59:24 UTC (rev 716) +++ pkg/dplR/man/detrend.series.Rd 2013-11-27 10:28:42 UTC (rev 717) @@ -8,7 +8,8 @@ \usage{ detrend.series(y, y.name = "", make.plot = TRUE, method = c("Spline", "ModNegExp", "Mean"), - nyrs = NULL, f = 0.5, pos.slope = FALSE) + nyrs = NULL, f = 0.5, pos.slope = FALSE, + constrain.modnegexp = c("never", "when.fail", "always")) } \arguments{ @@ -35,6 +36,16 @@ \item{pos.slope}{ a \code{logical} flag. Will allow for a positive slope to be used in method \code{"ModNegExp"}. If \code{FALSE} the line will be horizontal. } + + \item{constrain.modnegexp}{ a \code{character} string which controls + the constraints of the \code{"ModNegExp"} model. The value is an + answer to the question: When should the parameters of the modified + negative exponential function be constrained? The options are + \code{"never"}: do not constrain (the default), \code{"when.fail"}: + only compute the constrained solution if the unconstrained fit + contains other than positive values, and \code{"always"}: return the + constrained solution, even if the unconstrained one would have been + valid. See \sQuote{Details}. } } \details{ @@ -57,16 +68,25 @@ stand effects. The \code{"ModNegExp"} approach attempts to fit a classic nonlinear - model of biological growth of the form \code{\var{Y} ~ \var{a} * - exp(\var{b} * 1:length(\var{Y})) + \var{k}} using - \code{\link{nls}}. See Fritts (2001) for details about the - parameters. If a nonlinear model cannot be fit then a linear model is - fit. That linear model can have a positive slope unless - \code{\var{pos.slope}} is \code{FALSE} in which case method + model of biological growth of the form \eqn{f(t) = a e^{b t} + k}{f(t) + = a exp(b t) + k}, where the argument of the function is time, using + \code{\link{nls}}. See Fritts (2001) for details about the + parameters. Option \code{\var{constrain.modnegexp}} gives a + possibility to constrain the parameters of the modified negative + exponential function. If the constraints are enabled, the nonlinear + optimization algorithm is instructed to keep the parameters in the + following ranges: \eqn{a \ge 0}{a >= 0}, \eqn{b \le 0}{b <= 0} and + \eqn{k \ge 0}{k >= 0}. If a suitable nonlinear model cannot be fit + (function is non-decreasing or some values are not positive) then a + linear model is fit. That linear model can have a positive slope + unless \code{\var{pos.slope}} is \code{FALSE} in which case method \code{"Mean"} is used. The \code{"Mean"} approach fits a horizontal line using the mean of - the series. + the series. This method is the fallback solution in cases where the + \code{"Spline"} or the linear fit (also a fallback solution itself) + contains zeros or negative values, which would lead to invalid + ring-width indices. These methods are chosen because they are commonly used in dendrochronology. It is, of course, up to the user to determine the @@ -86,7 +106,8 @@ Fritts, H. C. (2001) \emph{Tree Rings and Climate}. Blackburn. \acronym{ISBN-13}: 978-1-930665-39-2. } -\author{ Andy Bunn. Patched and improved by Mikko Korpela. } +\author{ Andy Bunn. Patched and improved by Mikko Korpela. A bug fix + related to negative output values is based on work by Jacob Cecile. } \seealso{ \code{\link{detrend}} } \examples{library(stats) ## Using a plausible representation of a tree-ring series Modified: pkg/dplR/man/dplR-package.Rd =================================================================== --- pkg/dplR/man/dplR-package.Rd 2013-11-09 21:59:24 UTC (rev 716) +++ pkg/dplR/man/dplR-package.Rd 2013-11-27 10:28:42 UTC (rev 717) @@ -29,7 +29,8 @@ Campelo, Pierre \enc{M?rian}{Merian}, Fares Qeadan and Christian Zang. Function \code{\link{redfit}} is an improved translation of program REDFIT which is original work of Manfred Mudelsee and Michael - Schulz. + Schulz. Jacob Cecile contributed a bug fix to + \code{\link{detrend.series}}. } \references{ Cook, E. R. and Kairiukstis, L. A. (1990) \emph{Methods of