From noreply at r-forge.r-project.org Tue Oct 1 14:07:30 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 1 Oct 2013 14:07:30 +0200 (CEST) Subject: [Dplr-commits] r696 - branches/redfit/R Message-ID: <20131001120731.045FE184ED8@r-forge.r-project.org> Author: mvkorpel Date: 2013-10-01 14:07:30 +0200 (Tue, 01 Oct 2013) New Revision: 696 Modified: branches/redfit/R/rwi.stats.running.R Log: Avoid "parameter rwi changed by assignment" nag from checkUsagePackage(). Modified: branches/redfit/R/rwi.stats.running.R =================================================================== --- branches/redfit/R/rwi.stats.running.R 2013-09-24 13:46:43 UTC (rev 695) +++ branches/redfit/R/rwi.stats.running.R 2013-10-01 12:07:30 UTC (rev 696) @@ -82,8 +82,7 @@ cat(gettext("note that there is no error checking on column lengths if filtering is not performed\n", domain="R-dplR")) } - rwi <- tmp$master - rwi2 <- as.matrix(rwi) + rwi2 <- as.matrix(tmp$master) n.cores <- ncol(rwi2) zero.flag <- rwi2 == 0 From noreply at r-forge.r-project.org Tue Oct 1 14:59:27 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 1 Oct 2013 14:59:27 +0200 (CEST) Subject: [Dplr-commits] r697 - in branches/redfit: . R man Message-ID: <20131001125927.D5C081813AD@r-forge.r-project.org> Author: mvkorpel Date: 2013-10-01 14:59:27 +0200 (Tue, 01 Oct 2013) New Revision: 697 Modified: branches/redfit/ChangeLog branches/redfit/DESCRIPTION branches/redfit/NAMESPACE branches/redfit/R/redfit.R branches/redfit/man/redfit.Rd Log: - Import package "gmp" - Exports new function runcrit(): acceptance region of number of runs test - redfit() has changes inspired by differences between REDFIT 3.5 and 3.8e: * Ability to average data (x) at duplicate input times (t) (new elements "t" and "x" in return value, NULL if no duplicate times) * Ability to compute number-of-runs acceptance regions with user-specified significance levels (new argument p) * New architecture for obtaining the acceptance regions, implemented in runcrit() and a few non-exported functions: 1. check if the result has been precomputed (non-exported list runPrecomp) 2. if not, try to compute exact result. Limits for maximum allowed computing time and largest n for which to try this are set in new arguments 'maxTime' and 'nLimit'. 3. fall back to normal approximation if needed 4. new element "rcritexact" in the return value tells if the result is exact or an approximation * Make sure that tau resulting from an estimated rho is non-negative * In redfitTrig(), a robust method for computing arg2 Modified: branches/redfit/ChangeLog =================================================================== --- branches/redfit/ChangeLog 2013-10-01 12:07:30 UTC (rev 696) +++ branches/redfit/ChangeLog 2013-10-01 12:59:27 UTC (rev 697) @@ -1,5 +1,16 @@ * CHANGES IN dplR VERSION 1.5.7 +File: DESCRIPTION +----------------- + +- Import gmp (>= 0.5-2) + +File: NAMESPACE +--------------- + +- New imports from gmp and utils +- Export redfit() and runcrit() + Various .R files ---------------- @@ -41,7 +52,8 @@ Files: redfit.R, redfit.c ------------------------- -- New function redfit() based on REDFIT by Schulz and Mudelsee +- New function redfit() based on REDFIT by Schulz and Mudelsee. Also + another exported function runcrit(). * CHANGES IN dplR VERSION 1.5.6 Modified: branches/redfit/DESCRIPTION =================================================================== --- branches/redfit/DESCRIPTION 2013-10-01 12:07:30 UTC (rev 696) +++ branches/redfit/DESCRIPTION 2013-10-01 12:59:27 UTC (rev 697) @@ -3,7 +3,7 @@ Type: Package Title: Dendrochronology Program Library in R Version: 1.5.7 -Date: 2013-09-24 +Date: 2013-10-01 Authors at R: c(person(c("Andrew", "G."), "Bunn", role = c("aut", "cph", "cre", "trl"), email = "andrew.bunn at wwu.edu"), person("Mikko", "Korpela", role = c("aut", "trl")), person("Franco", "Biondi", @@ -17,8 +17,9 @@ Copyright: Authors and Aalto University (for work of M. Korpela) Maintainer: Andy Bunn Depends: R (>= 2.15.0) -Imports: graphics, grDevices, grid, stats, utils, digest (>= 0.2.3), - lattice (>= 0.13-6), stringr (>= 0.4), XML (>= 2.1-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. Modified: branches/redfit/NAMESPACE =================================================================== --- branches/redfit/NAMESPACE 2013-10-01 12:07:30 UTC (rev 696) +++ branches/redfit/NAMESPACE 2013-10-01 12:59:27 UTC (rev 697) @@ -7,6 +7,8 @@ importFrom(digest, digest) +importFrom(gmp, as.bigq, as.bigz, chooseZ, is.bigq) + importFrom(grDevices, rainbow) importFrom(grid, gpar, grid.lines, grid.newpage, grid.polygon, @@ -19,7 +21,7 @@ importFrom(stringr, str_pad, str_trim) importFrom(utils, head, installed.packages, read.fwf, tail, - packageVersion) + packageVersion, write.table) importFrom(XML, xmlEventParse) @@ -29,7 +31,7 @@ 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, rwi.stats, rwi.stats.legacy, + 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, Modified: branches/redfit/R/redfit.R =================================================================== --- branches/redfit/R/redfit.R 2013-10-01 12:07:30 UTC (rev 696) +++ branches/redfit/R/redfit.R 2013-10-01 12:59:27 UTC (rev 697) @@ -1,8 +1,8 @@ ### This part of dplR was (arguably non-trivially) translated and -### adapted from public domain Fortran program REDFIT (Michael Schulz -### and Manfred Mudelsee). The possibly non-free parts of REDFIT -### derived from Numerical Recipes were not used. -### http://www.ncdc.noaa.gov/paleo/softlib/redfit/redfit.html +### adapted from public domain Fortran program REDFIT, version 3.8e +### (Michael Schulz and Manfred Mudelsee). The possibly non-free parts +### of REDFIT derived from Numerical Recipes were not used. +### http://www.geo.uni-bremen.de/geomod/staff/mschulz/ ### Author of the dplR version is Mikko Korpela. ### ### Copyright (C) 2013 Aalto University @@ -31,11 +31,12 @@ ## ## Main Assumptions: ## ----------------- -## - The noise background can be apprximated by an AR(1) process. +## - The noise background can be approximated by an AR(1) process. ## - The distribution of data points along the time axis is not ## too clustered. ## - The potential effect of harmonic signal components on the ## estimation procedure is neglected. +## - The time series has to be weakly stationary. ## ## The first-order autoregressive model, AR(1) model, which is used ## to describe the noise background in a time series x(t_i), reads @@ -98,9 +99,35 @@ ## ## 11. Scale theorectical AR(1) spectrum for various significance levels. +## Notes: +## ------ +## * A linear trend is subtracted from each WOSA segment. +## +## * tau is estimated separately for each WOSA segment and subsequently +## averaged. +## +## * Default max. frequency = avg. Nyquist freq. (hifac = 1.0). +## +## dplR note: Authors of REDFIT +## Authors: Michael Schulz, MARUM and Faculty of Geosciences, Univ. Bremen +## -------- Klagenfurter Str., D-28334 Bremen +## mschulz at marum.de +## www.geo.uni-bremen.de/~mschulz +## +## Manfred Mudelsee, Inst. of Meteorology, Univ. Leipzig +## Stephanstr. 3, D-04103 Leipzig +## Mudelsee at rz.uni-leipzig.de +## +## Reference: Schulz, M. and Mudelsee, M. (2002) REDFIT: Estimating +## ---------- red-noise spectra directly from unevenly spaced paleoclimatic +## time series. Computers and Geosciences, 28, 421-426. + + redfit <- function(x, t, tType = c("time", "age"), nsim = 1000, mctest = TRUE, - ofac = 4, hifac = 1, n50 = 3, rhopre = NULL, iwin = 2, - txOrdered = FALSE, verbose = FALSE, seed = NULL) { + ofac = 4, hifac = 1, n50 = 3, rhopre = NULL, + p = c(0.10, 0.05, 0.02), iwin = 2, + txOrdered = FALSE, verbose = FALSE, seed = NULL, + maxTime = 10, nLimit = 10000) { cl <- match.call() if (!is.null(seed)) { set.seed(seed) @@ -115,9 +142,10 @@ NSIM_LIMIT <- 21 ## dplR: Check tType2 <- match.arg(tType) + tTime <- tType2 == "time" stopifnot(is.numeric(x)) if (!is.null(rhopre)) { - stopifnot(is.numeric(rhopre), length(rhopre) == 1, is.finite(rhopre)) + stopifnot(is.numeric(rhopre), length(rhopre) == 1, rhopre <= 1) } stopifnot(is.numeric(ofac), length(ofac) == 1, is.finite(ofac)) if (ofac < 1) { @@ -127,10 +155,16 @@ if (hifac <= 0) { stop("'hifac' must be positive") } - stopifnot(is.numeric(n50), length(n50) == 1, is.finite(n50), - round(n50) == n50, n50 >= 1) - stopifnot(is.numeric(nsim), length(nsim) == 1, is.finite(nsim), - round(nsim) == nsim, nsim >= 1) + stopifnot(is.numeric(n50), length(n50) == 1, is.finite(n50), n50 >= 1, + round(n50) == n50) + stopifnot(is.numeric(nsim), length(nsim) == 1, is.finite(nsim), nsim >= 1, + round(nsim) == nsim) + if (length(p) > 0) { + stopifnot(is.numeric(p) || is.bigq(p), p > 0, p < 1) + } + stopifnot(is.numeric(maxTime), length(maxTime) == 1, maxTime >= 0) + stopifnot(is.numeric(nLimit), length(nLimit) == 1, nLimit >= 0, + round(nLimit) == nLimit) stopifnot(identical(txOrdered, TRUE) || identical(txOrdered, FALSE)) stopifnot(identical(verbose, TRUE) || identical(verbose, FALSE)) stopifnot(identical(mctest, TRUE) || identical(mctest, FALSE)) @@ -192,28 +226,79 @@ stop(gettextf("too few points (%.0f), at least %.0f needed", np, MIN_POINTS, domain = "R-dplR"), domain = NA) } + duplT <- FALSE if (tGiven && !txOrdered) { idx <- order(t2) t2 <- t2[idx] x2 <- x2[idx] + dupl <- duplicated(t2) + if (any(dupl)) { + duplT <- TRUE + if (tTime) { + warning("Duplicate times in 't', averaging data") + } else { + warning("Duplicate ages in 't', averaging data") + } + if (verbose) { + if (tTime) { + cat(gettext("Number of duplicates by time,\n", + domain = "R-dplR"), file = stderr()) + } else { + cat(gettext("Number of duplicates by age,\n", + domain = "R-dplR"), file = stderr()) + } + cat(gettext("'k' duplicates means 'k + 1' total obsevations:\n", + domain = "R-dplR"), file = stderr()) + dtable <- table(t2[dupl]) + if (tTime) { + dtable <- data.frame(time = as.numeric(names(dtable)), + duplicates = as.vector(dtable)) + } else { + dtable <- data.frame(age = as.numeric(names(dtable)), + duplicates = as.vector(dtable)) + } + write.table(dtable, row.names = FALSE, file = stderr()) + } + notdupl <- !dupl + nunique <- sum(notdupl) + xnew <- numeric(nunique) + currentid <- 1 + currentstart <- 1 + for (k in 2:np) { + if (notdupl[k]) { + xnew[currentid] <- mean(x2[currentstart:(k - 1)]) + currentid <- currentid + 1 + currentstart <- k + } + } + if (currentid == nunique) { + xnew[nunique] <- mean(x2[currentstart:np]) + } + t2 <- t2[notdupl] + x2 <- xnew + np <- nunique + if (np < MIN_POINTS) { + stop(gettextf("too few points (%.0f), at least %.0f needed", + np, MIN_POINTS, domain = "R-dplR"), domain = NA) + } + } } ## dplR: The rest of the function assumes that t2 is age, not time - if (tType2 == "time") { + t2NoRev <- t2 + x2NoRev <- x2 + if (tTime) { t2 <- -rev(t2) x2 <- rev(x2) } if (tGiven) { difft <- diff(t2) - if (!txOrdered && any(difft == 0)) { - stop("duplicated values in 't'") - } } else { difft <- rep.int(1.0, np) } ## dplR: Setup params <- redfitSetdim(MIN_POINTS, t2, ofac, hifac, n50, verbose, iwin = iwin2, nsim = nsim, mctest = mctest, - rhopre = rhopre) + rhopre = rhopre, p = p) avgdt <- params[["avgdt"]] nseg <- params[["nseg"]] fnyq <- params[["fnyq"]] @@ -238,6 +323,13 @@ ## dplR: estimate lag-1 autocorrelation coefficient unless prescribed if (is.null(rhopre) || rhopre < 0) { rho <- redfitGetrho(t2, x2, dn50, nseg, segskip, lmfitfun) + ## make sure that tau is non-negative + if (rho > 1) { + warning(gettext("redfitGetrho returned rho = %f, forced to zero", + rho, domain = "R-dplR"), + domain = NA) + rho <- 0 + } } else { rho <- rhopre } @@ -325,43 +417,49 @@ rcnt <- 1 + sum(diff(spectrcomp) != 0) ## dplR: Old formulas for rcritlo, rcrithi (REDFIT). - ## ## Test equality of theoretical AR1 and estimated spectrum + ## + ## ## test equality of theoretical AR1 and estimated spectrum ## ## using a runs test (Bendat and Piersol, 1986, p. 95). The ## ## empirical equations for calculating critical values for - ## ## 5-% significance were derived from the tabulated - ## ## critical values in B&P. dplR: NOTE! Integer division is - ## ## used in REDFIT. We can assume that real(nout/2) was - ## ## supposed to be real(nout)/2. - ## ## sqrtHalfNfreq <- sqrt(nfreq %/% 2) - ## sqrtHalfNfreq <- sqrt(nfreq / 2) - ## rcritlo <- round((-0.79557086 + 1.0088719 * sqrtHalfNfreq)^2) - ## rcrithi <- round(( 0.75751462 + 0.9955133 * sqrtHalfNfreq)^2) + ## ## different significanes were derived from the tabulated + ## ## critical values in B&P. + ## sqrtHalfNfreq <- sqrt(nfreq %/% 2) + ## ## REDFIT >= 3.8a (at least until 3.8e) + ## 10-% level of significance + ## rcritlo10 <- round((-0.62899892 + 1.0030933 * sqrtHalfNfreq)^2) + ## rcrithi10 <- round(( 0.66522732 + 0.9944506 * sqrtHalfNfreq)^2) + ## 5-% level of significance + ## rcritlo5 <- round((-0.78161838 + 1.0069634 * sqrtHalfNfreq)^2) + ## rcrithi5 <- round(( 0.75701059 + 0.9956021 * sqrtHalfNfreq)^2) + ## 2-% level of significance + ## rcritlo2 <- round((-0.92210867 + 1.0064993 * sqrtHalfNfreq)^2) + ## rcrithi2 <- round(( 0.82670832 + 1.0014299 * sqrtHalfNfreq)^2) ## dplR: Updated formulas for rcritlo, rcrithi. ## - ## The REDFIT formulas seem to be very, very inexact, with - ## either definition of sqrtHalfNfreq. For example, the width - ## of the acceptance region increases, then decreases (*), and - ## goes to <= 0 at nfreq >= 27144 (original sqrtHalfNfreq) or - ## at nfreq >= 27144 || nfreq %in% seq(from = 27051, by = 2, - ## to = 27143) (updated sqrtHalfNfreq). Another example: - ## rcritlo is 0 (impossible number of runs) at some small - ## values of nfreq. + ## The REDFIT formulas seem to be quite inexact. For example, + ## the width of the acceptance region increases, then + ## decreases (*), and goes to <= 0 at nfreq >= 27144 (5 % + ## significance). Another example: rcritlo is 0 (impossible + ## number of runs) at some small values of nfreq. ## ## (*) The increase and decrease are general trends, but there ## are local fluctuations against the trend. ## ## About the new formulas: ## - ## Exact values were computed up to nfreq == 16000. For nfreq - ## > 16000, a normal approximation is used. For nfreq <= - ## 16000, the acceptance region obtained using the normal - ## approximation differs from the exact acceptance region at - ## 52 values of nfreq (diffIdx). The problem at hand - ## (comparison of two spectra) is analogous to studying the - ## number of runs of heads and tails with nfreq tosses of a - ## fair coin (p == 0.5). + ## Exact values were computed for nfreq <= NMAX (possibly + ## depending on significance levels, see redfitTablecrit() for + ## up-to-date values) at a selected few significance levels. + ## For non-tabulated significance levels, the exact solution + ## is computed if time permits and nfreq is not too large + ## (maxTime, nLimit), or finally a normal approximation is + ## used. ## + ## The problem at hand (comparison of two spectra) is + ## analogous to studying the number of runs of heads and tails + ## with nfreq tosses of a fair coin (p == 0.5). + ## ## The sequence of acceptance region widths is non-decreasing ## for both odd and even nfreq, individually. However, ## because of the symmetric distribution, if rcritlo increases @@ -370,180 +468,15 @@ ## ## Reference: Bradley, J. V. (1968) Distribution-Free ## Statistical Tests. Prentice-Hall. p. 253--254, 259--263. - ## - ## Code for computing the exact rcritlo, rcrithi can be found - ## below. It was used for obtaining 'diffIdx' and the - ## corrections +1 and -1. Requires the "gmp" package - ## (arbitrary precision numbers). Runs very slowly for large - ## values of n. - ## - ## library(gmp) - ## runprobZ <- function(k, n) { - ## invhalfpowM1 <- as.bigz(2)^(n - 1) - ## if (k %% 2 == 0) { - ## ## even number of runs - ## r <- k / 2 - ## n1 <- seq(from = r, by = 1, to = n - r) - ## nn1 <- length(n1) - ## halfn1 <- nn1 %/% 2 - ## if (nn1 %% 2 == 1) { - ## probsum <- chooseZ(n1[halfn1 + 1] - 1, r - 1) - ## probsum <- probsum * probsum - ## } else { - ## probsum <- 0 - ## } - ## lown1 <- n1[seq_len(halfn1)] - ## if (length(lown1) > 0) { - ## lown2 <- n - lown1 - ## probsum <- probsum + 2 * sum(chooseZ(lown1 - 1, r - 1) * - ## chooseZ(lown2 - 1, r - 1)) - ## } - ## probsum / invhalfpowM1 - ## } else if (k == 1) { - ## ## one run - ## as.bigq(2)^(1 - n) - ## } else { - ## ## odd number of runs - ## r <- (k - 1) / 2 - ## n1 <- seq(from = r + 1, by = 1, to = n - r) - ## n2 <- n - n1 - ## probsum <- sum(chooseZ(n1 - 1, r) * chooseZ(n2 - 1, r - 1)) - ## probsum / invhalfpowM1 - ## } - ## } - ## newcrit <- function(n, crit = 0.05, verbose = FALSE) { - ## stopifnot(is.numeric(n), length(n) >= 1, is.finite(n), - ## round(n) == n, n > 0, is.numeric(crit), - ## length(crit) == 1, is.finite(crit), crit < 1) - ## verbose2 <- isTRUE(verbose) - ## halfcrit <- crit / 2 - ## nn <- length(n) - ## res <- matrix(NA_real_, 2, nn) - ## for (j in seq_len(nn)) { - ## thisn <- n[j] - ## if (verbose2) { - ## cat("n = ", thisn, " (", j, " / ", nn, ")\n", sep = "") - ## } - ## halfn <- thisn %/% 2 - ## oddn <- thisn %% 2 - ## complength <- halfn + oddn - ## lowaccept <- NA_real_ - ## if (oddn == 1) { - ## csum <- (as.bigq(1) - runprobZ(complength, thisn)) / 2 - ## if (as.numeric(csum) <= halfcrit) { - ## lowaccept <- complength - ## } else { - ## for (k in seq(from = complength - 1, by = -1, - ## length.out = complength - 1)) { - ## csum <- csum - runprobZ(k, thisn) - ## if (csum <= halfcrit) { - ## lowaccept <- k - ## break - ## } - ## } - ## } - ## } else { - ## csum <- as.bigq(1, 2) - ## for (k in seq(from = complength, by = -1, - ## length.out = complength)) { - ## csum <- csum - runprobZ(k, thisn) - ## if (csum <= halfcrit) { - ## lowaccept <- k - ## break - ## } - ## } - ## } - ## highaccept <- thisn - lowaccept + 1 - ## res[, j] <- c(lowaccept, highaccept) - ## } - ## drop(res) - ## } - - ## dplR: Empirical mean and standard deviation (variance) of - ## the number of runs distribution, and code for computing - ## them. - ## library(gmp) - ## runtableZ <- function(n) { - ## stopifnot(is.numeric(n), length(n) == 1, - ## is.finite(n), round(n) == n, n > 0) - ## halfn <- n %/% 2 - ## oddn <- n %% 2 - ## res <- numeric(n) - ## invhalfpowM1 <- as.bigz(2)^(n - 1) - ## ## Symmetric distribution. Compute first half only. - ## complength <- halfn + oddn - ## evenlength <- complength %/% 2 - ## oddlength <- evenlength + complength %% 2 - 1 - ## ## one run - ## res[1] <- 0.5^(n - 1) - ## ## odd number of runs (>= 3) - ## oddseq <- seq(from = 3, by = 2, length.out = oddlength) - ## for (k in oddseq) { - ## r <- (k - 1) / 2 - ## n1 <- seq(from = r + 1, by = 1, to = n - r) - ## n2 <- n - n1 - ## probsum <- sum(chooseZ(n1 - 1, r) * chooseZ(n2 - 1, r - 1)) - ## res[k] <- as.numeric(probsum / invhalfpowM1) - ## } - ## ## even number of runs - ## evenseq <- seq(from = 2, by = 2, length.out = evenlength) - ## for (k in evenseq) { - ## r <- k / 2 - ## n1 <- seq(from = r, by = 1, to = n - r) - ## nn1 <- length(n1) - ## halfn1 <- nn1 %/% 2 - ## if (nn1 %% 2 == 1) { - ## probsum <- chooseZ(n1[halfn1 + 1] - 1, r - 1) - ## probsum <- probsum * probsum - ## } else { - ## probsum <- 0 - ## } - ## leftn1 <- n1[seq_len(halfn1)] - ## if (length(leftn1) > 0) { - ## leftn2 <- n - leftn1 - ## probsum <- probsum + 2 * sum(chooseZ(leftn1 - 1, r - 1) * - ## chooseZ(leftn2 - 1, r - 1)) - ## } - ## res[k] <- as.numeric(probsum / invhalfpowM1) - ## } - ## ## Last half is mirror image of first half - ## res[seq(from = n, by = -1, length.out = halfn)] <- - ## res[seq_len(halfn)] - ## res / sum(res) - ## } - ## meanvar <- function(n, crit = 0.05) { - ## nn <- length(n) - ## res <- matrix(NA_real_, 2, nn) - ## for (k in seq_len(nn)) { - ## thisn <- n[k] - ## rtable <- runtableZ(thisn) - ## nseq <- 1:thisn - ## res[1, k] <- sum(rtable * nseq) - ## res[2, k] <- sum(rtable * (nseq - res[1, k])^2) - ## } - ## drop(res) - ## } - nMean <- 0.5 * nfreq + 0.5 - nSd <- sqrt(0.25 * nfreq - 0.25) - - diffIdx <- - c(18, 45, 68, 95, 139, 191, 268, 302, 397, 439, - 552, 652, 847, 1002, 1101, 1709, 1838, 2063, 2110, 2157, - 2763, 2926, 3325, 3504, 3626, 3750, 3876, 4004, 4134, - 4333, 4816, 4887, 5031, 5550, 6095, 6500, 6749, 7613, - 8624, 8719, 9202, 10414, 10941, 11048, 11591, 13415, - 13772, 14500, 14623, 14871, 15627, 15883) - diffMatch <- match(nfreq, diffIdx) - rcritlo <- floor(qnorm(0.025, mean = nMean, sd = nSd) + 0.5) - rcrithi <- floor(qnorm(0.975, mean = nMean, sd = nSd) + 0.5) - if (!is.na(diffMatch)) { - rcritlo <- rcritlo + 1 - rcrithi <- rcrithi - 1 - } + tmp <- runcrit(nfreq, p, maxTime, nLimit) + rcritlo <- tmp[[1]] + rcrithi <- tmp[[2]] + rcritexact <- tmp[[3]] } else { rcnt <- NULL rcritlo <- NULL rcrithi <- NULL + rcritexact <- NULL } ## dplR: Elements of the list returned from this function: @@ -551,8 +484,9 @@ ## rho average autocorrelation coefficient (estimated or prescribed) ## tau average tau, tau == -avgdt / log(rho) ## rcnt runs count, test of equality of theoretical and data spectrum - ## rcritlo critical low value for rcnt - ## rcrithi critical high value for rcnt + ## rcritlo critical low value(s) for rcnt, one for each p + ## rcrithi critical high value(s) for rcnt, one for each p + ## rcritexact are the critical values (limits of acceptance region) exact? ## freq frequency vector ## gxx autospectrum of input data ## gxxc corrected autospectrum of input data @@ -567,6 +501,8 @@ ## params parameters dependent on the command line arguments ## vers version of dplR containing the function ## seed if not NULL, value used for set.seed(seed) + ## t t with duplicates removed (times or ages) or NULL + ## x x averaged over duplicate values of t or NULL dplrNS <- tryCatch(getNamespace("dplR"), error = function(...) NULL) if (!is.null(dplrNS) && exists("redfit", dplrNS) && identical(match.fun(as.list(cl)[[1]]), get("redfit", dplrNS))) { @@ -575,11 +511,12 @@ vers <- NULL } res <- list(varx = varx, rho = rho, tau = tau, rcnt = rcnt, - rcritlo = rcritlo, rcrithi = rcrithi, + rcritlo = rcritlo, rcrithi = rcrithi, rcritexact = rcritexact, freq = freq, gxx = gxx, gxxc = gxxc, grravg = grravg, gredth = gredth, corr = corr, ci80 = ci80, ci90 = ci90, ci95 = ci95, ci99 = ci99, - call = cl, params = params, vers = vers, seed = seed) + call = cl, params = params, vers = vers, seed = seed, + t = if (duplT) t2NoRev, x = if (duplT) x2NoRev) class(res) <- "redfit" res } @@ -733,13 +670,26 @@ precat(rep.int("-", nchar(gtxt))) rcnt <- x[["rcnt"]] if (!is.null(rcnt)) { - gtxt <- gettext("5-% acceptance region:", domain = "R-dplR") - precat(gtxt, newline = FALSE) - cat(" rcritlo = ", format(x[["rcritlo"]], digits = digits), "\n", - sep = "") - precat(rep.int(" ", nchar(gtxt)), newline = FALSE) - cat(" rcrithi = ", format(x[["rcrithi"]], digits = digits), "\n", - sep = "") + runP <- params[["p"]] + nP <- length(runP) + if (nP > 0) { + gtxt <- gettextf("%s-%% acceptance region:", + format(as.numeric(100 * (1 - runP)), + digits = digits), + domain = "R-dplR") + nC <- nchar(gtxt[1]) + rcritlo <- x[["rcritlo"]] + rcrithi <- x[["rcrithi"]] + } + for (k in seq_len(nP)) { + precat(gtxt[k], newline = FALSE) + cat(" rcritlo = ", format(rcritlo[k], digits = digits), "\n", + sep = "") + precat(rep.int(" ", nC), newline = FALSE) + cat(" rcrithi = ", format(rcrithi[k], digits = digits), "\n", + sep = "") + precat() + } precat("r_test = ", format(rcnt, digits = digits)) } else { if (iwin != 0) { @@ -789,6 +739,503 @@ invisible(x) } +## dplR: Utility function. +redfitRunprobZ <- function(k, n) { + invhalfpowM1 <- as.bigz(2)^(n - 1) + if (k %% 2 == 0) { + ## even number of runs + r <- k / 2 + n1 <- seq(from = r, by = 1, to = n - r) + nn1 <- length(n1) + halfn1 <- nn1 %/% 2 + if (nn1 %% 2 == 1) { + probsum <- chooseZ(n1[halfn1 + 1] - 1, r - 1) + probsum <- probsum * probsum + } else { + probsum <- 0 + } + lown1 <- n1[seq_len(halfn1)] + if (length(lown1) > 0) { + lown2 <- n - lown1 + probsum <- probsum + 2 * sum(chooseZ(lown1 - 1, r - 1) * + chooseZ(lown2 - 1, r - 1)) + } + probsum / invhalfpowM1 + } else if (k == 1) { + ## one run + as.bigq(2)^(1 - n) + } else { + ## odd number of runs + r <- (k - 1) / 2 + n1 <- seq(from = r + 1, by = 1, to = n - r) + n2 <- n - n1 + probsum <- sum(chooseZ(n1 - 1, r) * chooseZ(n2 - 1, r - 1)) + probsum / invhalfpowM1 + } +} + +## dplR: Utility function. +redfitRuncsum <- function(n, crit, verbose = FALSE, + timelimit = Inf) { + if (is.bigq(crit)) { + halfcrit <- crit / 2 + } else { + halfcrit <- as.bigq(crit, 2) + } + verbose2 <- isTRUE(verbose) + nn <- length(n) + csums <- vector(mode = "list", length = nn) + for (j in seq_len(nn)) { + thisn <- n[j] + if (verbose2) { + cat("n = ", thisn, " (", j, " / ", nn, ")\n", sep = "") + } + halfn <- thisn %/% 2 + oddn <- thisn %% 2 + complength <- halfn + oddn + tmpcsums <- as.bigq(rep.int(NA_real_, complength)) + if (oddn == 1) { + st <- system.time({ + csum <- (as.bigq(1) - redfitRunprobZ(complength, + thisn)) / 2 + tmpcsums[[complength]] <- csum + }) + } else { + st <- system.time({ + csum <- as.bigq(1, 2) - redfitRunprobZ(complength, thisn) + tmpcsums[[complength]] <- csum + }) + } + if (st[3] > timelimit) { + stop("timelimit exceeded") + } + if (csum > halfcrit) { + finalk <- 1 + for (k in seq(from = complength - 1, by = -1, + length.out = max(0, complength - 2))) { + csum <- csum - redfitRunprobZ(k, thisn) + tmpcsums[[k]] <- csum + if (csum <= halfcrit) { + finalk <- k + break + } + } + } else { + finalk <- complength + } + seqstart <- max(2, finalk) + seqlength <- complength - seqstart + 1 + ## store n, drop 0 and NA + csums[[j]] <- c(as.bigq(thisn), + tmpcsums[seq(from = seqstart, by = 1, + length.out = seqlength)]) + } + if (nn == 1) { + csums <- csums[[1]] + } + csums +} + +## dplR: Utility function. +## crit can be bigq or numeric +redfitCsumtocrit <- function(csums, crit, limits = FALSE) { + if (is.list(csums)) { + csums2 <- csums + } else { + csums2 <- list(csums) + } + nn <- length(csums2) + ## Our own sorting function iSort can handle bigq + tmp <- iSort(crit, decreasing = TRUE) + halfcrit <- tmp[[1]] / 2 + ncrit <- length(halfcrit) + if (limits) { + lowcrit <- matrix(NA_real_, ncrit, nn) + highcrit <- matrix(NA_real_, ncrit, nn) + tmp2 <- as.character(as.numeric(rev(tmp[[1]]))) + rownames(lowcrit) <- tmp2 + rownames(highcrit) <- tmp2 + } + noZeroCrit <- halfcrit[ncrit] != 0 + res <- matrix(NA_real_, 2 * ncrit, nn) + rownames(res) <- as.character(as.numeric(c(rev(halfcrit), 1 - halfcrit))) + for (j in seq_len(nn)) { + Csums <- csums2[[j]] + nthis <- length(Csums) + n <- as.numeric(Csums[[1]]) + complength <- n %/% 2 + n %% 2 + if (complength == 1) { + res[, j] <- rep(c(1, n), each = ncrit) + if (limits) { + lowcrit[, j] <- rep.int(0, ncrit) + highcrit[, j] <- rep.int(0.5, ncrit) + } + } else { + Csums <- c(Csums[seq(from = nthis, by = -1, + length.out = nthis - 1)], + rep.int(NA_real_, complength - nthis), + Csums[[1]]) + lowaccept <- rep.int(NA_real_, ncrit) + lowlow <- rep.int(NA_real_, ncrit) + lowhigh <- rep.int(NA_real_, ncrit) + allGood <- nthis == complength + l <- 1 + for (k in seq_len(ncrit)) { + thisHalfcrit <- halfcrit[k] + l <- l - 1 + which.max(Csums[l:complength] <= thisHalfcrit) + if (Csums[[l]] <= thisHalfcrit) { + lowaccept[k] <- complength + 1 - l + lowlow[k] <- as.numeric(Csums[[l]]) + if (l > 1) { + lowhigh[k] <- as.numeric(Csums[[l - 1]]) + } else { + lowhigh[k] <- 0.5 + } + } else if (allGood || thisHalfcrit == 0) { + lowaccept[k] <- 1 + lowlow[k] <- 0 + lowhigh[k] <- as.numeric(Csums[[complength - 1]]) + } else if (noZeroCrit) { + break + } + } + highaccept <- n + 1 - lowaccept + res[, j] <- c(rev(lowaccept), highaccept) + if (limits) { + lowcrit[, j] <- rev(lowlow) + highcrit[, j] <- rev(lowhigh) + } + } + } + ## When limits = TRUE, we also return the limits pmin and pmax such + ## that res holds when pmin < crit < pmax. + if (limits) { + list(drop(res), + pmin = 2 * apply(lowcrit, 1, max), + pmax = 2 * apply(highcrit, 1, min)) + } else { + drop(res) + } +} + +## dplR: Normal approximation of the acceptance region of the number +## of runs test. +## p must be numeric. If limits is TRUE, length(p) must be 1. [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/dplr -r 697 From noreply at r-forge.r-project.org Thu Oct 3 09:04:35 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 3 Oct 2013 09:04:35 +0200 (CEST) Subject: [Dplr-commits] r698 - in branches/redfit: . R Message-ID: <20131003070436.0E62A183AD8@r-forge.r-project.org> Author: mvkorpel Date: 2013-10-03 09:04:35 +0200 (Thu, 03 Oct 2013) New Revision: 698 Modified: branches/redfit/DESCRIPTION branches/redfit/R/redfit.R Log: Added precomputed run test criteria for 14001 <= n <= 16000 Modified: branches/redfit/DESCRIPTION =================================================================== --- branches/redfit/DESCRIPTION 2013-10-01 12:59:27 UTC (rev 697) +++ branches/redfit/DESCRIPTION 2013-10-03 07:04:35 UTC (rev 698) @@ -3,7 +3,7 @@ Type: Package Title: Dendrochronology Program Library in R Version: 1.5.7 -Date: 2013-10-01 +Date: 2013-10-03 Authors at R: c(person(c("Andrew", "G."), "Bunn", role = c("aut", "cph", "cre", "trl"), email = "andrew.bunn at wwu.edu"), person("Mikko", "Korpela", role = c("aut", "trl")), person("Franco", "Biondi", Modified: branches/redfit/R/redfit.R =================================================================== --- branches/redfit/R/redfit.R 2013-10-01 12:59:27 UTC (rev 697) +++ branches/redfit/R/redfit.R 2013-10-03 07:04:35 UTC (rev 698) @@ -1027,7 +1027,7 @@ ## runPrecomp <- structure(list(list(method = 1, - nMax = 14000, + nMax = 16000, pMin = 0.00999999574400225, pMax = 0.0100000215448173, diffIdx = @@ -1047,13 +1047,14 @@ 8325, 8396, 8467, 8611, 8755, 8828, 8901, 9122, 9197, 9497, 9649, 10034, 10190, 10269, 10506, 10666, 11152, 11650, 11818, 12158, 12330, 12852, - 13386, 13566, 13657, 13748, 13839, 13930) + 13386, 13566, 13657, 13748, 13839, 13930, 14114, + 14579, 14767, 14862, 15052, 15147, 15339, 15921) ), list(method = 1, - nMax = 14000, + nMax = 16000, pMin = 0.0199999755461175, - pMax = 0.0200001667871533, + pMax = 0.0200000250214551, diffIdx = c(8, 20, 28, 43, 55, 83, 99, 108, 117, 126, 146, @@ -1068,13 +1069,14 @@ 7100, 7319, 7767, 7919, 8073, 8150, 8306, 8543, 9108, 9523, 9691, 9776, 9861, 10033, 10468, 11002, 11093, 11366, 11550, 11829, 12589, 12880, 13472, - 13672, 13773, 13874, 13975) + 13672, 13773, 13874, 13975, 14179, 14282, 14385, + 14488, 14696, 15221, 15756) ), list(method = 1, - nMax = 14000, + nMax = 16000, pMin = 0.0499999631908032, - pMax = 0.0500000818150845, + pMax = 0.05000007522193, diffIdx = c(18, 45, 68, 95, 139, 191, 268, 302, 397, 439, 552, @@ -1082,19 +1084,20 @@ 2157, 2763, 2926, 3325, 3504, 3626, 3750, 3876, 4004, 4134, 4333, 4816, 4887, 5031, 5550, 6095, 6500, 6749, 7613, 8624, 8719, 9202, 10414, 10941, - 11048, 11591, 13415, 13772) + 11048, 11591, 13415, 13772, 14500, 14623, 14871, + 15627, 15883) ), list(method = 1, - nMax = 14000, + nMax = 16000, pMin = 0.0999999517957865, - pMax = 0.100000207070494, + pMax = 0.100000050804151, diffIdx = c(31, 38, 180, 214, 507, 1422, 1761, 2136, 2250, 3337, 4154, 4555, 5593, 6638, 7040, 7454, 8207, 8881, 8996, 9228, 10809, 11712, 12379, 12651, - 13344, 13485) + 13344, 13485, 14200, 15686, 15992) )), methodDescriptions = From noreply at r-forge.r-project.org Sat Oct 12 09:34:39 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 12 Oct 2013 09:34:39 +0200 (CEST) Subject: [Dplr-commits] r699 - in branches/redfit: . R Message-ID: <20131012073439.37BB5183EEB@r-forge.r-project.org> Author: mvkorpel Date: 2013-10-12 09:34:38 +0200 (Sat, 12 Oct 2013) New Revision: 699 Modified: branches/redfit/DESCRIPTION branches/redfit/R/redfit.R Log: In redfit.R, added precomputed run test criteria for 16001 <= n <= 20000 Modified: branches/redfit/DESCRIPTION =================================================================== --- branches/redfit/DESCRIPTION 2013-10-03 07:04:35 UTC (rev 698) +++ branches/redfit/DESCRIPTION 2013-10-12 07:34:38 UTC (rev 699) @@ -3,7 +3,7 @@ Type: Package Title: Dendrochronology Program Library in R Version: 1.5.7 -Date: 2013-10-03 +Date: 2013-10-12 Authors at R: c(person(c("Andrew", "G."), "Bunn", role = c("aut", "cph", "cre", "trl"), email = "andrew.bunn at wwu.edu"), person("Mikko", "Korpela", role = c("aut", "trl")), person("Franco", "Biondi", Modified: branches/redfit/R/redfit.R =================================================================== --- branches/redfit/R/redfit.R 2013-10-03 07:04:35 UTC (rev 698) +++ branches/redfit/R/redfit.R 2013-10-12 07:34:38 UTC (rev 699) @@ -1027,9 +1027,9 @@ ## runPrecomp <- structure(list(list(method = 1, - nMax = 16000, + nMax = 20000, pMin = 0.00999999574400225, - pMax = 0.0100000215448173, + pMax = 0.0100000131426446, diffIdx = c(9, 27, 35, 40, 45, 50, 62, 74, 81, 88, 111, 120, @@ -1048,11 +1048,14 @@ 9197, 9497, 9649, 10034, 10190, 10269, 10506, 10666, 11152, 11650, 11818, 12158, 12330, 12852, 13386, 13566, 13657, 13748, 13839, 13930, 14114, - 14579, 14767, 14862, 15052, 15147, 15339, 15921) + 14579, 14767, 14862, 15052, 15147, 15339, 15921, + 16216, 16315, 16614, 17220, 17527, 17630, 17733, + 17941, 18149, 18254, 18359, 18464, 18676, 19318, + 19643, 19752, 19861) ), list(method = 1, - nMax = 16000, + nMax = 20000, pMin = 0.0199999755461175, pMax = 0.0200000250214551, diffIdx = @@ -1070,13 +1073,14 @@ 9108, 9523, 9691, 9776, 9861, 10033, 10468, 11002, 11093, 11366, 11550, 11829, 12589, 12880, 13472, 13672, 13773, 13874, 13975, 14179, 14282, 14385, - 14488, 14696, 15221, 15756) + 14488, 14696, 15221, 15756, 16521, 16854, 17078, + 17530, 17873, 18220, 19041, 19160, 19279) ), list(method = 1, - nMax = 16000, + nMax = 20000, pMin = 0.0499999631908032, - pMax = 0.05000007522193, + pMax = 0.050000015182738, diffIdx = c(18, 45, 68, 95, 139, 191, 268, 302, 397, 439, 552, @@ -1085,19 +1089,20 @@ 4004, 4134, 4333, 4816, 4887, 5031, 5550, 6095, 6500, 6749, 7613, 8624, 8719, 9202, 10414, 10941, 11048, 11591, 13415, 13772, 14500, 14623, 14871, - 15627, 15883) + 15627, 15883, 16012, 16141, 16796, 17195, 18007, + 18559, 19119, 19975) ), list(method = 1, - nMax = 16000, + nMax = 20000, pMin = 0.0999999517957865, - pMax = 0.100000050804151, + pMax = 0.100000038090771, diffIdx = c(31, 38, 180, 214, 507, 1422, 1761, 2136, 2250, 3337, 4154, 4555, 5593, 6638, 7040, 7454, 8207, 8881, 8996, 9228, 10809, 11712, 12379, 12651, - 13344, 13485, 14200, 15686, 15992) + 13344, 13485, 14200, 15686, 15992, 16928) )), methodDescriptions = From noreply at r-forge.r-project.org Thu Oct 24 17:59:10 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 24 Oct 2013 17:59:10 +0200 (CEST) Subject: [Dplr-commits] r700 - branches/redfit Message-ID: <20131024155910.5127C185011@r-forge.r-project.org> Author: mvkorpel Date: 2013-10-24 17:59:10 +0200 (Thu, 24 Oct 2013) New Revision: 700 Modified: branches/redfit/ Log: Merged changes from trunk to redfit branch. Actually there were no changes in trunk after the branch up to this point. Property changes on: branches/redfit ___________________________________________________________________ Modified: svn:mergeinfo - /branches/dplR-R-2.15:466-506 + /branches/dplR-R-2.15:466-506 /pkg/dplR:662-699 From noreply at r-forge.r-project.org Thu Oct 24 19:00:51 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 24 Oct 2013 19:00:51 +0200 (CEST) Subject: [Dplr-commits] r701 - in pkg/dplR: . R man src Message-ID: <20131024170051.7CE6B18513A@r-forge.r-project.org> Author: mvkorpel Date: 2013-10-24 19:00:50 +0200 (Thu, 24 Oct 2013) New Revision: 701 Added: pkg/dplR/R/redfit.R pkg/dplR/man/print.redfit.Rd pkg/dplR/man/redfit.Rd pkg/dplR/src/redfit.c Modified: pkg/dplR/ pkg/dplR/ChangeLog pkg/dplR/DESCRIPTION pkg/dplR/NAMESPACE pkg/dplR/R/common.interval.R pkg/dplR/R/detrend.R pkg/dplR/R/detrend.series.R pkg/dplR/R/pointer.R pkg/dplR/R/powt.R pkg/dplR/R/rwi.stats.running.R pkg/dplR/R/wavelet.plot.R pkg/dplR/man/bai.in.Rd pkg/dplR/man/bai.out.Rd pkg/dplR/man/cms.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/hanning.Rd pkg/dplR/man/rwi.stats.running.Rd pkg/dplR/man/sea.Rd pkg/dplR/man/series.rwl.plot.Rd pkg/dplR/man/skel.plot.Rd pkg/dplR/man/wavelet.plot.Rd Log: Merge redfit branch back into trunk Property changes on: pkg/dplR ___________________________________________________________________ Modified: svn:mergeinfo - /branches/dplR-R-2.15:466-506 + /branches/dplR-R-2.15:466-506 /branches/redfit:662-700 Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2013-10-24 15:59:10 UTC (rev 700) +++ pkg/dplR/ChangeLog 2013-10-24 17:00:50 UTC (rev 701) @@ -1,11 +1,30 @@ * CHANGES IN dplR VERSION 1.5.7 +File: DESCRIPTION +----------------- + +- Import gmp (>= 0.5-2) + +File: NAMESPACE +--------------- + +- New imports from gmp and utils +- Export redfit() and runcrit() + Various .R files ---------------- - Check that length of vector does not overflow integer datatype before use of .C() +File: common.interval.R +----------------------- + +- Optimizations (for example, less subsetting of the 'rwl' data.frame) +- Better handling of corner cases (zero dimensions etc.) +- In the plot (make.plot = TRUE), length of lines was adjusted: + First year a, last year b is 'b - a + 1' years, not 'b - a' years + File: corr.rwl.seg.R -------------------- @@ -30,7 +49,13 @@ every round of a loop, so no need to reinitialize - Braces always used in if (else) constructs +Files: redfit.R, redfit.c +------------------------- +- New function redfit() based on REDFIT by Schulz and Mudelsee. Also + another exported function runcrit(). + + * CHANGES IN dplR VERSION 1.5.6 File: write.tucson.R Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2013-10-24 15:59:10 UTC (rev 700) +++ pkg/dplR/DESCRIPTION 2013-10-24 17:00:50 UTC (rev 701) @@ -3,19 +3,23 @@ Type: Package Title: Dendrochronology Program Library in R Version: 1.5.7 -Date: 2013-03-19 +Date: 2013-10-12 Authors at R: c(person(c("Andrew", "G."), "Bunn", role = c("aut", "cph", "cre", "trl"), email = "andrew.bunn at wwu.edu"), person("Mikko", - "Korpela", role = c("aut", "cph")), person("Franco", "Biondi", + "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("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] + "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] +Copyright: Authors and Aalto University (for work of M. Korpela) Maintainer: Andy Bunn Depends: R (>= 2.15.0) -Imports: graphics, grDevices, grid, stats, utils, digest (>= 0.2.3), - lattice (>= 0.13-6), stringr (>= 0.4), XML (>= 2.1-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. Modified: pkg/dplR/NAMESPACE =================================================================== --- pkg/dplR/NAMESPACE 2013-10-24 15:59:10 UTC (rev 700) +++ pkg/dplR/NAMESPACE 2013-10-24 17:00:50 UTC (rev 701) @@ -1,11 +1,14 @@ -useDynLib(dplR, dplR.gini=gini, dplR.mean=exactmean, - dplR.rcompact=rcompact, dplR.sens1=sens1, dplR.sens2=sens2, - dplR.tbrm=tbrm, rwl.readloop=readloop) +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, @@ -17,7 +20,8 @@ importFrom(stringr, str_pad, str_trim) -importFrom(utils, head, installed.packages, read.fwf, tail) +importFrom(utils, head, installed.packages, read.fwf, tail, + packageVersion, write.table) importFrom(XML, xmlEventParse) @@ -25,10 +29,13 @@ 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, + 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) Modified: pkg/dplR/R/common.interval.R =================================================================== --- pkg/dplR/R/common.interval.R 2013-10-24 15:59:10 UTC (rev 700) +++ pkg/dplR/R/common.interval.R 2013-10-24 17:00:50 UTC (rev 701) @@ -8,39 +8,64 @@ 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 overlap - rm.short <- function(rwl, flag=FALSE) { + ## series with overlaps + rm.short <- function(rwl, yrs, rwlNotNA, row.idx, 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))) + 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 - 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 + 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 + } } - 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) + 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 - rwl.output <- rwl.short + 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 @@ -49,101 +74,179 @@ } } } - rwl.output + list(nRow.output, nCol.output, keep.row.output, keep.col.output) } ########### - rwl.orig <- rwl - yrs <- as.numeric(row.names(rwl)) + 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 - rwl.output <- as.data.frame(matrix(0, 0, 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) { - tmp <- rowSums(!is.na(rwl)) + if (nCol.rwl > 0) { + samp.depth <- rowSums(rwlNotNA) } else { - tmp <- rep(0, nrow(rwl)) # R bug number 14959 + ## Workaround for R bug number 14959. Fixed in R >= 2.15.2. + samp.depth <- 0 } - 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){ + 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 (type2 == "series") { - rwl.output <- rm.short(rwl.common, flag=TRUE) + 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 (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) + } 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) } - if(opt > output) { + opt <- nRow * nCol + if (opt > output) { output <- opt - rwl.output <- rwl.common + 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) { - ## 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)) + 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 <- 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 + 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 { - segs2[, j] <- NA + 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.orig), nrow(rwl.orig), domain="R-dplR") + nCol.rwl, nRow.rwl, 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) + 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, + to = common.last + 1, by = 0.5) + n.common.seq <- length(common.seq) + common.everyother <- seq(from = 2, by = 2, length.out = nRow.output) + } + if (!yrs.ordered) { + order.yrs <- sort.list(yrs) + order.yrs2 <- sort.list(yrs2) + } + for (i in seq_len(nCol.rwl)) { + this.col <- neworder[i] + seg <- rwl[[this.col]] + seg[rwlNotNA[, this.col]] <- i + if (yrs.ordered) { + seg.ordered <- seg + } else { + seg.ordered <- seg[order.yrs] + } + seg.fill <- rep.int(i, n.rwl.seq) + seg.fill[rwl.everyother] <- seg.ordered + lines(rwl.seq, seg.fill, lwd = 2, col = "grey") + if (keep.col.output[this.col]) { + seg2 <- seg[keep.row.output] + if (!yrs.ordered) { + seg2 <- seg2[order.yrs2] + } + seg2.fill <- rep.int(i, n.common.seq) + seg2.fill[common.everyother] <- seg2 + lines(common.seq, seg2.fill, lwd = 2, col = "black") + } + } + if (nCol.rwl > 0) { + axis(2, at = seq_len(nCol.rwl), labels = names(rwl)[neworder], + srt = 45, tick = FALSE, las = 2) + } + if (nRow.rwl > 0) { + axis(1) + } + if (any.common) { + common.at <- c(common.first, common.last + 1) + common.labels <- as.character(c(common.first, common.last)) + abline(v = common.at, lty = "dashed") + axis(3, at = common.at, labels = common.labels, tcl = -0.25) + } box() } - rwl.output + if (nRow.output < nRow.rwl || nCol.output < nCol.rwl) { + rwl[keep.row.output, keep.col.output, drop = FALSE] + } else { + rwl + } } Modified: pkg/dplR/R/detrend.R =================================================================== --- pkg/dplR/R/detrend.R 2013-10-24 15:59:10 UTC (rev 700) +++ pkg/dplR/R/detrend.R 2013-10-24 17:00:50 UTC (rev 701) @@ -14,24 +14,29 @@ if(!make.plot && ("Spline" %in% method2 || "ModNegExp" %in% method2) && !inherits(try(suppressWarnings(req.it <- - require(iterators, quietly=TRUE)), + requireNamespace("iterators", + quietly=TRUE)), silent = TRUE), "try-error") && req.it && !inherits(try(suppressWarnings(req.fe <- - require(foreach, quietly=TRUE)), + requireNamespace("foreach", + quietly=TRUE)), silent = TRUE), "try-error") && req.fe){ - it.rwl <- iter(rwl, by = "col") + it.rwl <- iterators::iter(rwl, by = "col") ## a way to get rid of "no visible binding" NOTE in R CMD check rwl.i <- NULL - out <- foreach(rwl.i=it.rwl, .packages="dplR") %dopar% { - fits <- detrend.series(rwl.i, make.plot=FALSE, - method=method2, nyrs=nyrs, f=f, - pos.slope=pos.slope) - if(is.data.frame(fits)) - row.names(fits) <- rn - fits - } + out <- foreach::"%dopar%"(foreach::foreach(rwl.i=it.rwl, + .packages="dplR"), + { + fits <- detrend.series(rwl.i, make.plot=FALSE, + method=method2, + nyrs=nyrs, f=f, + pos.slope=pos.slope) + if(is.data.frame(fits)) + row.names(fits) <- rn + fits + }) } else{ out <- list() for(i in seq_len(ncol(rwl))){ Modified: pkg/dplR/R/detrend.series.R =================================================================== --- pkg/dplR/R/detrend.series.R 2013-10-24 15:59:10 UTC (rev 700) +++ pkg/dplR/R/detrend.series.R 2013-10-24 17:00:50 UTC (rev 701) @@ -3,6 +3,8 @@ method = c("Spline", "ModNegExp", "Mean"), nyrs = NULL, f = 0.5, pos.slope = FALSE) { + stopifnot(identical(make.plot, TRUE) || identical(make.plot, FALSE), + identical(pos.slope, FALSE) || identical(pos.slope, TRUE)) known.methods <- c("Spline", "ModNegExp", "Mean") method2 <- match.arg(arg = method, choices = known.methods, @@ -37,11 +39,14 @@ ModNegExp <- try(nec.func(y2), silent=TRUE) if(class(ModNegExp)=="try-error") { ## Straight line via linear regression - tm <- seq_along(y2) - lm1 <- lm(y2 ~ tm) - ModNegExp <- predict(lm1) - if(coef(lm1)[2] > 0 && !pos.slope) + tm <- cbind(1, seq_along(y2)) + lm1 <- lm.fit(tm, y2) + coefs <- lm1[["coefficients"]] + if (all(is.finite(coefs)) && (coefs[2] <= 0 || pos.slope)) { + ModNegExp <- drop(tm %*% coefs) + } else { ModNegExp <- rep(mean(y2), length(y2)) + } } resids$ModNegExp <- y2 / ModNegExp do.mne <- TRUE Modified: pkg/dplR/R/pointer.R =================================================================== --- pkg/dplR/R/pointer.R 2013-10-24 15:59:10 UTC (rev 700) +++ pkg/dplR/R/pointer.R 2013-10-24 17:00:50 UTC (rev 701) @@ -26,7 +26,6 @@ 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) colnames(out) <- c("Year", "Nb.series", "Perc.pos", "Perc.neg", Modified: pkg/dplR/R/powt.R =================================================================== --- pkg/dplR/R/powt.R 2013-10-24 15:59:10 UTC (rev 700) +++ pkg/dplR/R/powt.R 2013-10-24 17:00:50 UTC (rev 701) @@ -28,8 +28,8 @@ runn.M <- (drop.1 + drop.n) / 2 runn.S <- abs(drop.1 - drop.n) runn.S[runn.S == 0] <- prec # add minimal difference - mod <- lm(log(runn.S) ~ log(runn.M)) - b <- coef(mod)[2] + mod <- lm.fit(cbind(1, log(runn.M)), log(runn.S)) + b <- mod[["coefficients"]][2] 1 - b } transf <- function(x) { Copied: pkg/dplR/R/redfit.R (from rev 700, branches/redfit/R/redfit.R) =================================================================== --- pkg/dplR/R/redfit.R (rev 0) +++ pkg/dplR/R/redfit.R 2013-10-24 17:00:50 UTC (rev 701) @@ -0,0 +1,1529 @@ +### This part of dplR was (arguably non-trivially) translated and +### adapted from public domain Fortran program REDFIT, version 3.8e +### (Michael Schulz and Manfred Mudelsee). The possibly non-free parts +### of REDFIT derived from Numerical Recipes were not used. +### http://www.geo.uni-bremen.de/geomod/staff/mschulz/ +### Author of the dplR version is Mikko Korpela. +### +### Copyright (C) 2013 Aalto University +### +### This program is free software; you can redistribute it and/or modify +### it under the terms of the GNU General Public License as published by +### the Free Software Foundation; either version 2 of the License, or +### (at your option) any later version. +### +### This program is distributed in the hope that it will be useful, +### but WITHOUT ANY WARRANTY; without even the implied warranty of +### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +### GNU General Public License for more details. +### +### A copy of the GNU General Public License is available at +### http://www.r-project.org/Licenses/ + +## Comments have mostly been copied verbatim from the original version +## (a few typos were fixed). New comments are prefixed with "dplR:". + +## Estimate red-noise background of an autospectrum, which is estimated from +## an unevenly spaced time series. In addition, the program corrects for the +## bias of Lomb-Scargle Fourier transform (correlation of Fourier components), +## which depends on the distribution of the sampling times t(i) along the +## time axis. +## +## Main Assumptions: +## ----------------- +## - The noise background can be approximated by an AR(1) process. +## - The distribution of data points along the time axis is not +## too clustered. +## - The potential effect of harmonic signal components on the +## estimation procedure is neglected. +## - The time series has to be weakly stationary. +## +## The first-order autoregressive model, AR(1) model, which is used +## to describe the noise background in a time series x(t_i), reads +## +## +## x(i) = rho(i) * x(i-1) + eps(i) (1) +## +## +## with t(i) - t(i-1) +## rho(i) = exp(- -------------) +## tau +## +## and eps ~ NV(0, vareps). To ensure Var[red] = 1, we set +## +## 2 * (t(i) - t(i-1)) +## vareps = 1 - exp(- -------------------). +## tau +## +## Stationarity of the generated AR(1) time series is assured by dropping +## the first N generated points. +## +## +## Computational Steps: +## -------------------- +## +## 1. Estimate autospectrum Gxx of the unevenly spaced input time series in the +## interval [0,fNyq], using the Lomb-Scargle Fourier transform in combination +## with the Welch-Overlapped-Segment-Averaging (WOSA) procudure, as described +## in Schulz and Stattegger (1997). +## +## 2. Estimate tau from the unevenly sampled time series using the time- +## domain algorithm of Mudelsee (200?). +## +## 3. Determine the area under Gxx -> estimator of data variance ==> varx. +## +## 4. Repeat Nsim times +## - create AR(1) time series (red) acc. to Eq. 1, using the observation +## times of the input data, but each time with different eps(i) +## - estimate autospectrum of red ==> Grr +## - scale Grr such that area under the spectrum is identical to varx +## - sum Grr ==> GrrSum +## +## 5. Determine arithmetic mean of GrrSum ==> GrrAvg. +## +## 6. Ensure that area under GrrAvg is identical to varx (account for rounding +## errors). +## +## 7. Calculate theoretical AR(1) spectrum for the estimated tau ==> GRedth. +## +## 8. Scale GRedth such that area under the spectrum is identical to varx (this +## step is required since the true noise variance of the data set is +## unknown). +## +## 9. Estimate the frequency-dependent correction factor (corr) for the +## Lomb-Scargle FT from the ratio between mean of the estimated AR(1) spectra +## (GrrAvg) and the scaled theoretical AR(1) spectrum (GRedth). +## +## 10. Use correction factors to eliminate the bias in the estimated spectrum +## Gxx ==> Gxxc. +## +## 11. Scale theorectical AR(1) spectrum for various significance levels. + +## Notes: +## ------ +## * A linear trend is subtracted from each WOSA segment. +## +## * tau is estimated separately for each WOSA segment and subsequently +## averaged. +## +## * Default max. frequency = avg. Nyquist freq. (hifac = 1.0). +## +## dplR note: Authors of REDFIT +## Authors: Michael Schulz, MARUM and Faculty of Geosciences, Univ. Bremen +## -------- Klagenfurter Str., D-28334 Bremen +## mschulz at marum.de +## www.geo.uni-bremen.de/~mschulz +## +## Manfred Mudelsee, Inst. of Meteorology, Univ. Leipzig +## Stephanstr. 3, D-04103 Leipzig +## Mudelsee at rz.uni-leipzig.de +## +## Reference: Schulz, M. and Mudelsee, M. (2002) REDFIT: Estimating +## ---------- red-noise spectra directly from unevenly spaced paleoclimatic +## time series. Computers and Geosciences, 28, 421-426. + + +redfit <- function(x, t, tType = c("time", "age"), nsim = 1000, mctest = TRUE, + ofac = 4, hifac = 1, n50 = 3, rhopre = NULL, + p = c(0.10, 0.05, 0.02), iwin = 2, + txOrdered = FALSE, verbose = FALSE, seed = NULL, + maxTime = 10, nLimit = 10000) { + cl <- match.call() + if (!is.null(seed)) { + set.seed(seed) + } + MIN_POINTS <- 2 + WIN_NAMES <- c("rectangular", "welch i", "hanning", + "triangular", "blackman-harris") + ## dplR: 21 is the lower limit of nsim where !anyDuplicated(c(idx80, + ## idx90, idx95, idx99)) is TRUE. (Also, none of the indices is + ## 0.) For more reliable results, a much greated value is + ## recommended. + NSIM_LIMIT <- 21 + ## dplR: Check + tType2 <- match.arg(tType) + tTime <- tType2 == "time" + stopifnot(is.numeric(x)) + if (!is.null(rhopre)) { + stopifnot(is.numeric(rhopre), length(rhopre) == 1, rhopre <= 1) + } + stopifnot(is.numeric(ofac), length(ofac) == 1, is.finite(ofac)) + if (ofac < 1) { + stop("oversampling factor 'ofac' must be >= 1") + } + stopifnot(is.numeric(hifac), length(hifac) == 1, is.finite(hifac)) + if (hifac <= 0) { + stop("'hifac' must be positive") + } + stopifnot(is.numeric(n50), length(n50) == 1, is.finite(n50), n50 >= 1, + round(n50) == n50) + stopifnot(is.numeric(nsim), length(nsim) == 1, is.finite(nsim), nsim >= 1, + round(nsim) == nsim) + if (length(p) > 0) { + stopifnot(is.numeric(p) || is.bigq(p), p > 0, p < 1) + } + stopifnot(is.numeric(maxTime), length(maxTime) == 1, maxTime >= 0) + stopifnot(is.numeric(nLimit), length(nLimit) == 1, nLimit >= 0, + round(nLimit) == nLimit) + stopifnot(identical(txOrdered, TRUE) || identical(txOrdered, FALSE)) + stopifnot(identical(verbose, TRUE) || identical(verbose, FALSE)) + stopifnot(identical(mctest, TRUE) || identical(mctest, FALSE)) + if (mctest && nsim < NSIM_LIMIT) { + stop(gettextf("if 'mctest' is TRUE, 'nsim' must be at least %.0f", + NSIM_LIMIT, domain = "R-dplR"), + domain = NA) + } + ## dplR: iwin can be a number or a string. iwin2 is a number %in% 0:4 + if (is.numeric(iwin)) { + if (length(iwin) != 1 || !(iwin %in% 0:4)) { + stop("numeric 'iwin' must be 0, 1, 2, 3 or 4") + } + iwin2 <- iwin + } else if (is.character(iwin)) { + iwin2 <- match.arg(tolower(iwin), WIN_NAMES) + winvec <- 0:4 + names(winvec) <- WIN_NAMES + iwin2 <- winvec[iwin2] + } else { + stop("'iwin' must be numeric or character") + } + if (is.double(x)) { + x2 <- x + } else { + x2 <- as.numeric(x) + } + np <- as.numeric(length(x2)) + tGiven <- !missing(t) + if (tGiven) { + if (is.double(t)) { + t2 <- t + } else { + t2 <- as.numeric(t) + } + if (length(t2) != np) { + stop("lengths of 't' and 'x' must match") + } + } else { + t2 <- as.numeric(seq_len(np)) + } + naidx <- is.na(x2) + if (tGiven) { + naidx <- naidx | is.na(t2) + } + if (any(naidx)) { + goodidx <- which(!naidx) + t2 <- t2[goodidx] + x2 <- x2[goodidx] + nporig <- np + np <- as.numeric(length(x2)) + nna <- nporig - np + warning(sprintf(ngettext(nna, + "%.0f NA value removed", + "%.0f NA values removed", + domain = "R-dplR"), nna), domain = NA) + } + if (np < MIN_POINTS) { + stop(gettextf("too few points (%.0f), at least %.0f needed", + np, MIN_POINTS, domain = "R-dplR"), domain = NA) + } + duplT <- FALSE + if (tGiven && !txOrdered) { + idx <- order(t2) + t2 <- t2[idx] + x2 <- x2[idx] + dupl <- duplicated(t2) + if (any(dupl)) { + duplT <- TRUE [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/dplr -r 701 From noreply at r-forge.r-project.org Thu Oct 24 19:03:46 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 24 Oct 2013 19:03:46 +0200 (CEST) Subject: [Dplr-commits] r702 - branches Message-ID: <20131024170346.8B9BB1861D3@r-forge.r-project.org> Author: mvkorpel Date: 2013-10-24 19:03:46 +0200 (Thu, 24 Oct 2013) New Revision: 702 Removed: branches/redfit/ Log: Remove redfit branch, reintegrated with trunk in r701 From noreply at r-forge.r-project.org Thu Oct 24 19:58:36 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 24 Oct 2013 19:58:36 +0200 (CEST) Subject: [Dplr-commits] r703 - pkg/dplR/man Message-ID: <20131024175836.7966A186112@r-forge.r-project.org> Author: andybunn Date: 2013-10-24 19:58:36 +0200 (Thu, 24 Oct 2013) New Revision: 703 Modified: pkg/dplR/man/redfit.Rd Log: edited redfit example by adding some more notes. Modified: pkg/dplR/man/redfit.Rd =================================================================== --- pkg/dplR/man/redfit.Rd 2013-10-24 17:03:46 UTC (rev 702) +++ pkg/dplR/man/redfit.Rd 2013-10-24 17:58:36 UTC (rev 703) @@ -302,7 +302,8 @@ } \examples{ # Create a simulated tree-ring width series that has a red-noise -# background and an embedded signal. +# background ar1=phi and sd=sigma and an embedded signal with +# a period of 10 and an amplitude of have the rednoise sd. library(graphics) library(stats) set.seed(123) From noreply at r-forge.r-project.org Fri Oct 25 11:04:04 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 25 Oct 2013 11:04:04 +0200 (CEST) Subject: [Dplr-commits] r704 - in pkg/dplR: . R Message-ID: <20131025090404.4C3D418515F@r-forge.r-project.org> Author: mvkorpel Date: 2013-10-25 11:04:03 +0200 (Fri, 25 Oct 2013) New Revision: 704 Modified: pkg/dplR/ChangeLog pkg/dplR/DESCRIPTION pkg/dplR/R/detrend.R pkg/dplR/R/rwi.stats.running.R Log: * Safer use of foreach, also avoids use of ::: * Small optimization to rwi.stats.running() Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2013-10-24 17:58:36 UTC (rev 703) +++ pkg/dplR/ChangeLog 2013-10-25 09:04:03 UTC (rev 704) @@ -16,6 +16,7 @@ - Check that length of vector does not overflow integer datatype before use of .C() +- Avoid possible name clashes when using foreach with parallel backends File: common.interval.R ----------------------- @@ -39,6 +40,11 @@ The bug affected read.tridas(), write.compact(), write.tridas() and write.tucson() but probably manifested itself quite rarely. +File: rwi.stats.running.R +------------------------- + +- Speedup by using rep.int() instead of rep() + File: sea.R ----------- Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2013-10-24 17:58:36 UTC (rev 703) +++ pkg/dplR/DESCRIPTION 2013-10-25 09:04:03 UTC (rev 704) @@ -3,7 +3,7 @@ Type: Package Title: Dendrochronology Program Library in R Version: 1.5.7 -Date: 2013-10-12 +Date: 2013-10-25 Authors at R: c(person(c("Andrew", "G."), "Bunn", role = c("aut", "cph", "cre", "trl"), email = "andrew.bunn at wwu.edu"), person("Mikko", "Korpela", role = c("aut", "trl")), person("Franco", "Biondi", Modified: pkg/dplR/R/detrend.R =================================================================== --- pkg/dplR/R/detrend.R 2013-10-24 17:58:36 UTC (rev 703) +++ pkg/dplR/R/detrend.R 2013-10-25 09:04:03 UTC (rev 704) @@ -26,8 +26,12 @@ it.rwl <- iterators::iter(rwl, by = "col") ## a way to get rid of "no visible binding" NOTE in R CMD check rwl.i <- NULL + + exportFun <- c("detrend.series", "is.data.frame", + "row.names<-", "<-", "if") + out <- foreach::"%dopar%"(foreach::foreach(rwl.i=it.rwl, - .packages="dplR"), + .export=exportFun), { fits <- detrend.series(rwl.i, make.plot=FALSE, method=method2, Modified: pkg/dplR/R/rwi.stats.running.R =================================================================== --- pkg/dplR/R/rwi.stats.running.R 2013-10-24 17:58:36 UTC (rev 703) +++ pkg/dplR/R/rwi.stats.running.R 2013-10-25 09:04:03 UTC (rev 704) @@ -25,7 +25,7 @@ ### Computes the correlation coefficients between different columns of x. cor.with.limit.upper <- function(limit, x) { n.x <- ncol(x) # caller makes sure that n.x >= 2 - r.vec <- rep(NA_real_, n.x * (n.x - 1) / 2) + r.vec <- rep.int(NA_real_, n.x * (n.x - 1) / 2) good.x <- !is.na(x) k <- 0 for (i in seq_len(n.x - 1)) { @@ -96,7 +96,7 @@ ## If 'ids' is NULL then assume one core per tree if (is.null(ids)) { - ids3 <- data.frame(tree=seq_len(n.cores), core=rep(1, n.cores)) + ids3 <- data.frame(tree=seq_len(n.cores), core=rep.int(1, n.cores)) rwi3 <- rwi2 } else { ## Make error checks here @@ -195,7 +195,7 @@ min(min.offset + window.advance - 1, n.years - window.length) offsets <- min.offset:max.offset n.offsets <- length(offsets) - n.data <- rep(NA_real_, n.offsets) + n.data <- rep.int(NA_real_, n.offsets) for (i in seq_len(n.offsets)) { offset <- offsets[i] n.windows.minusone <- @@ -237,13 +237,12 @@ ## Sum of all correlations among different cores (between trees) rsum.bt <- 0 n.bt <- 0 - good.flag <- rep(FALSE, n.trees) + good.flag <- rep.int(FALSE, n.trees) for (i in seq_len(n.trees - 1)) { i.data <- rwi3[year.idx, cores.of.tree[[i]], drop=FALSE] for (j in (i + 1):n.trees) { j.data <- rwi3[year.idx, cores.of.tree[[j]], drop=FALSE] - bt.r.mat <- dplR:::cor.with.limit(min.corr.overlap, - i.data, j.data) + bt.r.mat <- cor.with.limit(min.corr.overlap, i.data, j.data) bt.r.mat <- bt.r.mat[!is.na(bt.r.mat)] n.bt.temp <- length(bt.r.mat) if (n.bt.temp > 0) { @@ -258,15 +257,14 @@ good.trees <- which(good.flag) rsum.wt <- 0 n.wt <- 0 - n.cores.tree <- rep(NA_real_, n.trees) + n.cores.tree <- rep.int(NA_real_, n.trees) for (i in good.trees) { these.cores <- cores.of.tree[[i]] if (length(these.cores)==1) { # make simple case fast n.cores.tree[i] <- 1 } else { these.data <- rwi3[year.idx, these.cores, drop=FALSE] - wt.r.vec <- - dplR:::cor.with.limit.upper(min.corr.overlap, these.data) + wt.r.vec <- cor.with.limit.upper(min.corr.overlap, these.data) wt.r.vec <- wt.r.vec[!is.na(wt.r.vec)] n.wt.temp <- length(wt.r.vec) if (n.wt.temp > 0) { @@ -331,10 +329,17 @@ quietly=TRUE)), silent = TRUE), "try-error") && req.fe) { + + exportFun <- c("<-", "+", "-", "floor", ":", "rep.int", "for", + "seq_len", "[", "[[", "cor.with.limit", "!", + "is.na", "length", "if", ">", "sum", "c", + "[<-", "which", "==", "cor.with.limit.upper", + "sqrt", "*", "/", "(", "{", "mean") + compos.stats <- foreach::"%dopar%"(foreach::foreach(s.idx=window.start, .combine="rbind", - .packages="dplR"), + .export=exportFun), loop.body(s.idx)) } else { compos.stats <- NULL From noreply at r-forge.r-project.org Fri Oct 25 12:21:02 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 25 Oct 2013 12:21:02 +0200 (CEST) Subject: [Dplr-commits] r705 - pkg/dplR Message-ID: <20131025102102.5D97B184BC1@r-forge.r-project.org> Author: mvkorpel Date: 2013-10-25 12:21:02 +0200 (Fri, 25 Oct 2013) New Revision: 705 Modified: pkg/dplR/DESCRIPTION Log: R CMD check --as-cran gave a NOTE about Andrew vs Andy Bunn. Now only Andy. Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2013-10-25 09:04:03 UTC (rev 704) +++ pkg/dplR/DESCRIPTION 2013-10-25 10:21:02 UTC (rev 705) @@ -4,8 +4,8 @@ Title: Dendrochronology Program Library in R Version: 1.5.7 Date: 2013-10-25 -Authors at R: c(person(c("Andrew", "G."), "Bunn", role = c("aut", "cph", - "cre", "trl"), email = "andrew.bunn at wwu.edu"), person("Mikko", +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", From noreply at r-forge.r-project.org Mon Oct 28 11:33:01 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 28 Oct 2013 11:33:01 +0100 (CET) Subject: [Dplr-commits] r706 - in tags: . dplR-1.5.7 Message-ID: <20131028103301.7387E180484@r-forge.r-project.org> Author: mvkorpel Date: 2013-10-28 11:33:00 +0100 (Mon, 28 Oct 2013) New Revision: 706 Added: tags/dplR-1.5.7/ Log: dplR 1.5.7 Property changes on: tags/dplR-1.5.7 ___________________________________________________________________ Added: svn:ignore + dplR-Ex.R Added: svn:mergeinfo + /branches/dplR-R-2.15:466-506 /branches/redfit:662-700 From noreply at r-forge.r-project.org Mon Oct 28 11:37:20 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 28 Oct 2013 11:37:20 +0100 (CET) Subject: [Dplr-commits] r707 - pkg/dplR Message-ID: <20131028103720.CF9A7184475@r-forge.r-project.org> Author: mvkorpel Date: 2013-10-28 11:37:20 +0100 (Mon, 28 Oct 2013) New Revision: 707 Modified: pkg/dplR/ChangeLog pkg/dplR/DESCRIPTION Log: Changed version number to 1.5.8 Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2013-10-28 10:33:00 UTC (rev 706) +++ pkg/dplR/ChangeLog 2013-10-28 10:37:20 UTC (rev 707) @@ -1,3 +1,7 @@ +* CHANGES IN dplR VERSION 1.5.8 + + + * CHANGES IN dplR VERSION 1.5.7 File: DESCRIPTION Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2013-10-28 10:33:00 UTC (rev 706) +++ pkg/dplR/DESCRIPTION 2013-10-28 10:37:20 UTC (rev 707) @@ -2,8 +2,8 @@ Package: dplR Type: Package Title: Dendrochronology Program Library in R -Version: 1.5.7 -Date: 2013-10-25 +Version: 1.5.8 +Date: 2013-10-28 Authors at R: c(person("Andy", "Bunn", role = c("aut", "cph", "cre", "trl"), email = "andy.bunn at wwu.edu"), person("Mikko", "Korpela", role = c("aut", "trl")), person("Franco", "Biondi", From noreply at r-forge.r-project.org Mon Oct 28 11:48:42 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 28 Oct 2013 11:48:42 +0100 (CET) Subject: [Dplr-commits] r708 - pkg/dplR Message-ID: <20131028104842.D8A771853F5@r-forge.r-project.org> Author: mvkorpel Date: 2013-10-28 11:48:42 +0100 (Mon, 28 Oct 2013) New Revision: 708 Modified: pkg/dplR/DESCRIPTION Log: Added version to license: GPL (>= 2). R-exts recommends against bare GPL. Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2013-10-28 10:37:20 UTC (rev 707) +++ pkg/dplR/DESCRIPTION 2013-10-28 10:48:42 UTC (rev 708) @@ -24,6 +24,6 @@ Description: This package contains functions for performing tree-ring analyses, IO, and graphics. LazyData: no -License: GPL +License: GPL (>= 2) URL: http://www.wwu.edu/huxley/treering/dplR.shtml, http://R-Forge.R-project.org/projects/dplr/ From noreply at r-forge.r-project.org Tue Oct 29 14:46:45 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 29 Oct 2013 14:46:45 +0100 (CET) Subject: [Dplr-commits] r709 - in pkg/dplR: . R Message-ID: <20131029134645.3AF8B18517C@r-forge.r-project.org> Author: mvkorpel Date: 2013-10-29 14:46:44 +0100 (Tue, 29 Oct 2013) New Revision: 709 Modified: pkg/dplR/ChangeLog pkg/dplR/DESCRIPTION pkg/dplR/R/redfit.R Log: In redfit(), use slightly faster .rowSums() instead of rowSums() Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2013-10-28 10:48:42 UTC (rev 708) +++ pkg/dplR/ChangeLog 2013-10-29 13:46:44 UTC (rev 709) @@ -1,6 +1,9 @@ * CHANGES IN dplR VERSION 1.5.8 +File: redfit.R +-------------- +- Use slightly faster .rowSums() instead of rowSums() * CHANGES IN dplR VERSION 1.5.7 Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2013-10-28 10:48:42 UTC (rev 708) +++ pkg/dplR/DESCRIPTION 2013-10-29 13:46:44 UTC (rev 709) @@ -3,7 +3,7 @@ Type: Package Title: Dendrochronology Program Library in R Version: 1.5.8 -Date: 2013-10-28 +Date: 2013-10-29 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-28 10:48:42 UTC (rev 708) +++ pkg/dplR/R/redfit.R 2013-10-29 13:46:44 UTC (rev 709) @@ -353,7 +353,7 @@ varr1 <- df * sum(grr[, i]) grr[, i] <- varx / varr1 * grr[, i] } - grrsum <- rowSums(grr) + grrsum <- .rowSums(grr, nfreq, nsim) } else { grrsum <- numeric(nfreq) for (i in seq_len(nsim)) { From noreply at r-forge.r-project.org Tue Oct 29 15:19:47 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 29 Oct 2013 15:19:47 +0100 (CET) Subject: [Dplr-commits] r710 - in pkg/dplR: . R Message-ID: <20131029141947.3B094186183@r-forge.r-project.org> Author: mvkorpel Date: 2013-10-29 15:19:46 +0100 (Tue, 29 Oct 2013) New Revision: 710 Modified: pkg/dplR/ChangeLog pkg/dplR/R/redfit.R Log: redfit.R: simplified arithmetic expressions in getdof(): no multiplying by 2 Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2013-10-29 13:46:44 UTC (rev 709) +++ pkg/dplR/ChangeLog 2013-10-29 14:19:46 UTC (rev 710) @@ -4,6 +4,7 @@ -------------- - Use slightly faster .rowSums() instead of rowSums() +- Simplified arithmetic expressions in getdof(): no multiplying by 2 * CHANGES IN dplR VERSION 1.5.7 Modified: pkg/dplR/R/redfit.R =================================================================== --- pkg/dplR/R/redfit.R 2013-10-29 13:46:44 UTC (rev 709) +++ pkg/dplR/R/redfit.R 2013-10-29 14:19:46 UTC (rev 710) @@ -551,8 +551,8 @@ getdof <- function(iwin, n50) { ## dplR: Rectangular, Welch, Hanning, Triangular, Blackman-Harris c50 <- c(0.5, 0.34375, 1 / 6, 0.25, 0.0955489871755) - c2 <- 2 * c50[iwin + 1]^2 - 2 * n50 / (1 + c2 - c2 / n50) + c2 <- c50[iwin + 1]^2 + n50 / (0.5 + c2 - c2 / n50) } ## dplR: Automatically adds prefix (for example "# " from REDFIT) and ## newline (if newline = TRUE) to output. From noreply at r-forge.r-project.org Tue Oct 29 15:36:18 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 29 Oct 2013 15:36:18 +0100 (CET) Subject: [Dplr-commits] r711 - in pkg/dplR: . R Message-ID: <20131029143618.B132B1844AC@r-forge.r-project.org> Author: mvkorpel Date: 2013-10-29 15:36:18 +0100 (Tue, 29 Oct 2013) New Revision: 711 Modified: pkg/dplR/ChangeLog pkg/dplR/R/redfit.R Log: redfit.R: Precomputed squared numbers in getdof() Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2013-10-29 14:19:46 UTC (rev 710) +++ pkg/dplR/ChangeLog 2013-10-29 14:36:18 UTC (rev 711) @@ -5,6 +5,7 @@ - Use slightly faster .rowSums() instead of rowSums() - Simplified arithmetic expressions in getdof(): no multiplying by 2 +- Precomputed squared numbers in getdof() * CHANGES IN dplR VERSION 1.5.7 Modified: pkg/dplR/R/redfit.R =================================================================== --- pkg/dplR/R/redfit.R 2013-10-29 14:19:46 UTC (rev 710) +++ pkg/dplR/R/redfit.R 2013-10-29 14:36:18 UTC (rev 711) @@ -550,8 +550,11 @@ ## 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 + ## 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 From noreply at r-forge.r-project.org Tue Oct 29 16:33:25 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 29 Oct 2013 16:33:25 +0100 (CET) Subject: [Dplr-commits] r712 - pkg/dplR/R Message-ID: <20131029153325.7A3F5186168@r-forge.r-project.org> Author: mvkorpel Date: 2013-10-29 16:33:25 +0100 (Tue, 29 Oct 2013) New Revision: 712 Modified: pkg/dplR/R/redfit.R Log: fixed a typo Modified: pkg/dplR/R/redfit.R =================================================================== --- pkg/dplR/R/redfit.R 2013-10-29 14:36:18 UTC (rev 711) +++ pkg/dplR/R/redfit.R 2013-10-29 15:33:25 UTC (rev 712) @@ -541,7 +541,7 @@ ## 3: Parzen (Triangular) ## 4: Blackman-Harris 3-Term winbw <- function(iwin, df, ofac) { - ## dplR NOTE: bw could be defined with greated precision + ## 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] } From noreply at r-forge.r-project.org Tue Oct 29 21:09:03 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 29 Oct 2013 21:09:03 +0100 (CET) Subject: [Dplr-commits] r713 - in pkg/dplR: . R Message-ID: <20131029200903.29208184AD5@r-forge.r-project.org> Author: mvkorpel Date: 2013-10-29 21:09:02 +0100 (Tue, 29 Oct 2013) New Revision: 713 Modified: pkg/dplR/ChangeLog pkg/dplR/R/redfit.R Log: redfit.R: Small optimizations in redfitWinwgt() Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2013-10-29 15:33:25 UTC (rev 712) +++ pkg/dplR/ChangeLog 2013-10-29 20:09:02 UTC (rev 713) @@ -6,6 +6,7 @@ - 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() * CHANGES IN dplR VERSION 1.5.7 Modified: pkg/dplR/R/redfit.R =================================================================== --- pkg/dplR/R/redfit.R 2013-10-29 15:33:25 UTC (rev 712) +++ pkg/dplR/R/redfit.R 2013-10-29 20:09:02 UTC (rev 713) @@ -1374,8 +1374,8 @@ redfitWinwgt <- function(t, iwin) { nseg <- length(t) ## useful factor for various windows - fac1 <- (nseg / 2) - 0.5 - fac2 <- 1 / ((nseg / 2) + 0.5) + fac1 <- nseg / 2 - 0.5 + fac2 <- 1 / (fac1 + 1) tlen <- t[nseg] - t[1] if (iwin == 0) { # rectangle ww <- rep.int(1, nseg)