From noreply at r-forge.r-project.org Mon Aug 19 13:01:14 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 19 Aug 2013 13:01:14 +0200 (CEST) Subject: [Dplr-commits] r662 - in branches: . redfit Message-ID: <20130819110114.2278918431D@r-forge.r-project.org> Author: mvkorpel Date: 2013-08-19 13:01:13 +0200 (Mon, 19 Aug 2013) New Revision: 662 Added: branches/redfit/ Log: Branching from trunk to redfit at 661 Property changes on: branches/redfit ___________________________________________________________________ Added: svn:ignore + dplR-Ex.R Added: svn:mergeinfo + /branches/dplR-R-2.15:466-506 From noreply at r-forge.r-project.org Mon Aug 19 13:17:47 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 19 Aug 2013 13:17:47 +0200 (CEST) Subject: [Dplr-commits] r663 - in branches/redfit: . R man src Message-ID: <20130819111748.0470518424F@r-forge.r-project.org> Author: mvkorpel Date: 2013-08-19 13:17:47 +0200 (Mon, 19 Aug 2013) New Revision: 663 Added: branches/redfit/R/redfit.R branches/redfit/man/print.redfit.Rd branches/redfit/man/redfit.Rd branches/redfit/src/redfit.c Modified: branches/redfit/ChangeLog branches/redfit/DESCRIPTION branches/redfit/NAMESPACE Log: - Added function redfit() based on REDFIT by Schulz and Mudelsee - Added Copyright field to DESCRIPTION: Work of Mikko Korpela is (C) Aalto University Modified: branches/redfit/ChangeLog =================================================================== --- branches/redfit/ChangeLog 2013-08-19 11:01:13 UTC (rev 662) +++ branches/redfit/ChangeLog 2013-08-19 11:17:47 UTC (rev 663) @@ -30,7 +30,12 @@ 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 + + * CHANGES IN dplR VERSION 1.5.6 File: write.tucson.R Modified: branches/redfit/DESCRIPTION =================================================================== --- branches/redfit/DESCRIPTION 2013-08-19 11:01:13 UTC (rev 662) +++ branches/redfit/DESCRIPTION 2013-08-19 11:17:47 UTC (rev 663) @@ -3,7 +3,7 @@ Type: Package Title: Dendrochronology Program Library in R Version: 1.5.7 -Date: 2013-03-19 +Date: 2013-08-19 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", @@ -11,7 +11,8 @@ 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] +Author: Andy Bunn [aut, cph, cre, trl], Mikko Korpela [aut], Franco Biondi [aut, cph], Filipe Campelo [aut, cph], Pierre M?rian [aut, cph], Fares Qeadan [aut, cph], 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), Modified: branches/redfit/NAMESPACE =================================================================== --- branches/redfit/NAMESPACE 2013-08-19 11:01:13 UTC (rev 662) +++ branches/redfit/NAMESPACE 2013-08-19 11:17:47 UTC (rev 663) @@ -1,6 +1,7 @@ -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) @@ -17,7 +18,8 @@ importFrom(stringr, str_pad, str_trim) -importFrom(utils, head, installed.packages, read.fwf, tail) +importFrom(utils, head, installed.packages, read.fwf, tail, + packageVersion) importFrom(XML, xmlEventParse) @@ -25,10 +27,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, 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) Added: branches/redfit/R/redfit.R =================================================================== --- branches/redfit/R/redfit.R (rev 0) +++ branches/redfit/R/redfit.R 2013-08-19 11:17:47 UTC (rev 663) @@ -0,0 +1,847 @@ +### 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 +### 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 apprximated 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 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. + +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) { + cl <- match.call() + if (!is.null(seed)) { + set.seed(seed) + } + MIN_POINTS <- 2 + WIN_NAMES <- c("rectangular", "welch i", "hanning", + "triangular", "blackman-harris") + ## 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) + stopifnot(is.numeric(x)) + if (!is.null(rhopre)) { + stopifnot(is.numeric(rhopre), length(rhopre) == 1, is.finite(rhopre)) + } + 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), + round(n50) == n50, n50 >= 1) + stopifnot(is.numeric(nsim), length(nsim) == 1, is.finite(nsim), + round(nsim) == nsim, nsim >= 1) + 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) + } + ## 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") + } + x <- as.numeric(x) + np <- as.numeric(length(x)) + tGiven <- !missing(t) + if (tGiven) { + t <- as.numeric(t) + if (length(t) != np) { + stop("lengths of 't' and 'x' must match") + } + } else { + t <- as.numeric(seq_len(np)) + } + naidx <- is.na(x) + if (tGiven) { + naidx <- naidx | is.na(t) + } + if (any(naidx)) { + goodidx <- which(!naidx) + t <- t[goodidx] + x <- x[goodidx] + nporig <- np + np <- as.numeric(length(x)) + 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) + } + if (tGiven && !txOrdered) { + idx <- order(t) + t <- t[idx] + x <- x[idx] + } + ## The rest of the function assumes that t is age, not time + if (tType2 == "time") { + t <- -rev(t) + x <- rev(x) + } + if (tGiven) { + difft <- diff(t) + if (!txOrdered && any(difft == 0)) { + stop("duplicated values in 't'") + } + } else { + difft <- rep.int(1.0, np) + } + ## dplR: Setup + params <- redfitSetdim(MIN_POINTS, t, np, ofac, hifac, n50, verbose, + iwin = iwin2, nsim = nsim, mctest = mctest, + rhopre = rhopre) + avgdt <- params[["avgdt"]] + nseg <- params[["nseg"]] + fnyq <- params[["fnyq"]] + nfreq <- params[["nfreq"]] + df <- params[["df"]] + wz <- params[["wz"]] + ofac <- params[["ofac"]] + segskip <- params[["segskip"]] + ia <- redfitInitArrays(t, x, params) + ## determine autospectrum of input data + dn50 <- as.numeric(n50) + cbindfun <- match.fun("cbind") + lmfitfun <- tryCatch(match.fun(".lm.fit"), + error = function(...) match.fun("lm.fit")) + gxx <- .Call(dplR.spectr, t, x, np, ia[[1]], ia[[2]], ia[[3]], ia[[4]], + nseg, nfreq, avgdt, wz, dn50, segskip, cbindfun, lmfitfun) + freq <- seq(from = 0, by = 1, length.out = nfreq) * df + ## estimate data variance from autospectrum + varx <- freq[2] * sum(gxx) # NB: freq[2] = df + ## dplR: estimate lag-1 autocorrelation coefficient unless prescribed + if (is.null(rhopre) || rhopre < 0) { + rho <- redfitGetrho(t, x, np, n50, nseg, avgdt, segskip) + } else { + rho <- rhopre + } + ## dplR: determine tau from rho. + ## Avoids the rho -> tau -> rho mess of REDFIT. + tau <- as.numeric(-avgdt / log(rho)) + + ## Generate nsim AR(1) spectra + if (mctest) { + grr <- matrix(NA_real_, nfreq, nsim) + for (i in seq_len(nsim)) { + if (verbose && (i %% 50 == 0 || i == 1)) { + cat("ISim = ", i, "\n", sep="") + } + ## setup AR(1) time series and estimate its spectrum + grr[, i] <- + .Call(dplR.spectr, t, .Call(dplR.makear1, difft, np, tau), np, + ia[[1]], ia[[2]], ia[[3]], ia[[4]], nseg, nfreq, avgdt, + wz, dn50, segskip, cbindfun, lmfitfun) + ## scale and sum red-noise spectra + varr1 <- freq[2] * sum(grr[, i]) # NB: freq[2] = df + grr[, i] <- varx / varr1 * grr[, i] + } + grrsum <- rowSums(grr) + } else { + grrsum <- numeric(nfreq) + for (i in seq_len(nsim)) { + if (verbose && (i %% 50 == 0 || i == 1)) { + cat("ISim = ", i, "\n", sep="") + } + ## setup AR(1) time series and estimate its spectrum + grr <- .Call(dplR.spectr, t, .Call(dplR.makear1, difft, np, tau), + np, ia[[1]], ia[[2]], ia[[3]], ia[[4]], nseg, nfreq, + avgdt, wz, dn50, segskip, cbindfun, lmfitfun) + ## scale and sum red-noise spectra + varr1 <- freq[2] * sum(grr) # NB: freq[2] = df + grr <- varx / varr1 * grr + grrsum <- grrsum + grr + } + } + + ## determine average red-noise spectrum; scale average again to + ## make sure that roundoff errors do not affect the scaling + grravg <- grrsum / nsim + varr2 <- freq[2] * sum(grravg) + grravg <- varx / varr2 * grravg + rhosq <- rho * rho + ## set theoretical spectrum (e.g., Mann and Lees, 1996, Eq. 4) + ## make area equal to that of the input time series + gredth <- (1 - rhosq) / (1 + rhosq - 2 * rho * cos(pi / fnyq * freq)) + varr3 <- freq[2] * sum(gredth) + gredth <- varx / varr3 * gredth + ## determine correction factor + corr <- grravg / gredth + invcorr <- gredth / grravg + ## correct for bias in autospectrum + gxxc <- gxx * invcorr + + ## red-noise false-alarm levels from percentiles of MC simulation + if (mctest) { + ## dplR: Sort the rows of grr. apply() turns the result + ## around: the sorted rows are the columns of the result. + grr <- apply(grr, 1, sort) + ## set percentile indices + idx80 <- floor(0.80 * nsim) + idx90 <- floor(0.90 * nsim) + idx95 <- floor(0.95 * nsim) + idx99 <- floor(0.99 * nsim) + ## find frequency-dependent percentile and apply bias correction + ci80 <- grr[idx80, ] * invcorr + ci90 <- grr[idx90, ] * invcorr + ci95 <- grr[idx95, ] * invcorr + ci99 <- grr[idx99, ] * invcorr + } else { + ci80 <- NULL + ci90 <- NULL + ci95 <- NULL + ci99 <- NULL + } + + + ## Test equality of theoretical AR1 and estimated spectrum using a + ## runs test (Bendat and Piersol, 1986, p. 95). + rcnt <- 1 + sum(diff(sign(gxxc - gredth)) != 0) + + ## dplR: Elements of the list returned from this function: + ## varx data variance estimated from spectrum + ## 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 + ## freq frequency vector + ## gxx autospectrum of input data + ## gxxc corrected autospectrum of input data + ## grravg average AR(1) spectrum + ## gredth theoretical AR(1) spectrum + ## corr correction factor + ## ci80 80% false-alarm level from MC + ## ci90 90% false-alarm level from MC + ## ci95 95% false-alarm level from MC + ## ci99 99% false-alarm level from MC + ## call dplR: how the function was called + ## params dplR: parameters dependent on the command line arguments + ## vers dplR: version of dplR containing the function + ## seed dplR: if not NULL, value used for set.seed(seed) + dplrNS <- tryCatch(getNamespace("dplR"), error = function(...) NULL) + if (!is.null(dplrNS) && exists("redfit", dplrNS) && + identical(match.fun(as.list(cl)[[1]]), get("redfit", dplrNS))) { + vers <- tryCatch(packageVersion("dplR"), error = function(...) NULL) + } else { + vers <- NULL + } + res <- list(varx = varx, rho = rho, tau = tau, rcnt = rcnt, + 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) + class(res) <- "redfit" + res +} + +## 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. +print.redfit <- function(x, digits = NULL, csv.out = FALSE, do.table = FALSE, + prefix = "", row.names = FALSE, file = "", ...) { + if (!inherits(x, "redfit")) { + stop('use only with "redfit" objects') + } + 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) { + ## NOTE: bw could be defined with greated 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) { + ## 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) + } + ## Automatically adds prefix (for example "# " from REDFIT) and + ## newline (if newline = TRUE) to output. + precat <- function(..., newline = TRUE, sep = "") { + cat(prefix) + do.call("cat", c(alist(...), alist(sep = sep))) + if (newline) { + cat("\n") + } + } + params <- x[["params"]] + iwin <- params[["iwin"]] + n50 <- params[["n50"]] + nseg <- params[["nseg"]] + ofac <- params[["ofac"]] + rhopre <- params[["rhopre"]] + mctest <- params[["mctest"]] + nfreq <- params[["nfreq"]] + gredth <- x[["gredth"]] + + ## scaling factors for red noise from chi^2 distribution + dof <- getdof(iwin, n50) + ## dplR: getchi2() in the original Fortran version uses upper tail + ## probabilities. qchisq() uses lower tail probabilities unless + ## lower.tail = FALSE. + fac80 <- qchisq(0.80, dof) / dof + fac90 <- qchisq(0.90, dof) / dof + fac95 <- qchisq(0.95, dof) / dof + fac99 <- qchisq(0.99, dof) / dof + + ## critical false alarm level after Thomson (1990) + ## dplR: modified from original REDFIT code to accommodate for + ## lower / upper tail difference + alphacrit <- (nseg - 1) / nseg + faccrit <- qchisq(alphacrit, dof) / dof + + ## 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. This should be + ## checked (by finding a copy of Bendat and Piersol). For now, we + ## can assume that real(nout/2) was supposed to be real(nout)/2. + ## sqrtHalfNfreq <- sqrt(nfreq %/% 2) + sqrtHalfNfreq <- sqrt(nfreq / 2) + ## dplR: NOTE! Is round() the right function to use? Maybe floor() + ## for the lower limit and ceiling for the higher limit? + rcritlo <- round((-0.79557086 + 1.0088719 * sqrtHalfNfreq)^2) + rcrithi <- round(( 0.75751462 + 0.9955133 * sqrtHalfNfreq)^2) + + if (csv.out || do.table) { + dframe <- c(x[c("freq", "gxx", "gxxc", "gredth", "grravg", "corr")], + list(gredth * fac80, gredth * fac90, + gredth * fac95, gredth * fac99)) + pct <- c("80", "90", "95", "99") + names(dframe) <- c("Freq", "Gxx", "Gxx_corr", "Gred_th", "Gred_avg", + "CorrFac", paste0("Chi2_", pct, "pct")) + if (mctest) { + dframe <- c(dframe, x[paste0("ci", pct)]) + names(dframe)[11:14] <- paste0("MC_", pct, "pct") + } + dframe <- as.data.frame(dframe) + } + if (!csv.out) { + ## dplR: print miscellaneous information AND if (do.table) print(dframe) + precat("redfit()", newline = FALSE) + vers <- x[["vers"]] + if (!is.null(vers)) { + cat(" in dplR version ", as.character(vers), "\n", sep="") + } else { + cat("\n") + } + precat() + gtxt <- gettext("Input:", domain = "R-dplR") + precat(gtxt) + precat(rep.int("-", nchar(gtxt))) + precat("ofac = ", format(ofac, digits = digits)) + precat("hifac = ", format(params[["hifac"]], digits = digits)) + precat("n50 = ", format(n50, digits = digits)) + precat("iwin = ", format(iwin, digits = digits)) + precat("nsim = ", format(params[["nsim"]], digits = digits)) + precat() + gtxt <- gettext("Initial values:", domain = "R-dplR") + precat(gtxt) + precat(rep.int("-", nchar(gtxt))) + seed <- x[["seed"]] + if (!is.null(seed)) { + precat("seed = ", format(seed, digits = digits)) + } + precat(gettextf("Data variance (from data spectrum) = %s", + format(x[["varx"]], digits = digits), + domain = "R-dplR")) + precat(gettextf("Avg. dt = %s", + format(params[["avgdt"]], digits = digits), + domain = "R-dplR")) + precat() + gtxt <- gettext("Results:", domain = "R-dplR") + precat(gtxt) + precat(rep.int("-", nchar(gtxt))) + if (is.null(rhopre) || rhopre < 0) { + precat(gettextf("Avg. autocorr. coeff., rho = %s", + format(x[["rho"]], digits = digits), + domain = "R-dplR")) + } else { + precat(gettextf("PRESCRIBED avg. autocorr. coeff., rho = %s", + format(rhopre, digits = digits), + domain = "R-dplR")) + } + precat(gettextf("Avg. tau = %s", + format(x[["tau"]], digits = digits), + domain = "R-dplR")) + precat(gettextf("Degrees of freedom = %s", + format(dof, digits = digits), + domain = "R-dplR")) + precat(gettextf("6-dB Bandwidth = %s", + format(winbw(iwin, params[["df"]], ofac), + digits = digits), + domain = "R-dplR")) + precat(gettextf("Critical false-alarm level (Thomson, 1990) = %s", + format(alphacrit * 100, digits = digits), + domain = "R-dplR")) + precat(gettextf(" ==> corresponding scaling factor for red noise = %s", + format(faccrit, digits = digits), + domain = "R-dplR")) + precat() + gtxt <- gettext("Equality of theoretical and data spectrum: Runs test", + domain = "R-dplR") + precat(gtxt) + precat(rep.int("-", nchar(gtxt))) + if (iwin == 0 && ofac == 1 && n50 == 1) { + gtxt <- gettext("5-% acceptance region:", domain = "R-dplR") + precat(gtxt, newline = FALSE) + cat(" rcritlo = ", format(rcritlo, digits = digits), "\n", sep = "") + precat(rep.int(" ", nchar(gtxt)), newline = FALSE) + cat(" rcrithi = ", format(rcrithi, digits = digits), "\n", sep = "") + precat("r_test = ", format(x[["rcnt"]], digits = digits)) + } else { + if (iwin != 0) { + precat(gettext("Test requires iwin = 0", domain = "R-dplR")) + } + if (ofac != 1) { + precat(gettext("Test requires ofac = 1", domain = "R-dplR")) + } + if (n50 != 1) { + precat(gettext("Test requires n50 = 1", domain = "R-dplR")) + } + } + if (do.table) { + precat() + gtxt <- gettext("Data Columns:", domain = "R-dplR") + precat(gtxt) + precat(rep.int("-", nchar(gtxt))) + precat(gettext(" 1: Freq = frequency", domain = "R-dplR")) + precat(gettext(" 2: Gxx = spectrum of input data", + domain = "R-dplR")) + precat(gettext(" 3: Gxx_corr = bias-corrected spectrum of input data", + domain = "R-dplR")) + precat(gettext(" 4: Gred_th = theoretical AR(1) spectrum", + domain = "R-dplR")) + precat(gettext(" 5: Gred_avg = average spectrum of Nsim AR(1) time series (uncorrected)", + domain = "R-dplR")) + precat(gettext(" 6: CorrFac = Gxx / Gxx_corr", domain = "R-dplR")) + gtxt <- + gettext("%.0f: Chi2_%.0fpct = %.0f%% false-alarm level (Chi^2)") + precat(" ", sprintf(gtxt, 7, 80, 80)) + precat(" ", sprintf(gtxt, 8, 90, 90)) + precat(" ", sprintf(gtxt, 9, 95, 95)) + precat(sprintf(gtxt, 10, 99, 99)) + if (mctest) { + gtxt <- + gettext("%.0f: MC_%.0fpct = %.0f%% false-alarm level (MC)") + precat(sprintf(gtxt, 11, 80, 80)) + precat(sprintf(gtxt, 12, 90, 90)) + precat(sprintf(gtxt, 13, 95, 95)) + precat(sprintf(gtxt, 14, 99, 99)) + } + print(dframe, digits = digits, row.names = row.names) + } + } else { # csv.out + write.csv(dframe, file = file, row.names = row.names, ...) + } + invisible(x) +} + +redfitInitArrays <- function(t, x, params) { + np <- params[["np"]] + nseg <- params[["nseg"]] + nfreq <- params[["nfreq"]] + n50 <- params[["n50"]] + iwin <- params[["iwin"]] + wz <- params[["wz"]] + segskip <- params[["segskip"]] + ww <- matrix(NA_real_, nseg, n50) + tsin <- array(NA_real_, c(nseg, nfreq - 1, n50)) + tcos <- array(NA_real_, c(nseg, nfreq - 1, n50)) + wtau <- matrix(NA_real_, nfreq - 1, n50) + for (i in as.numeric(seq_len(n50))) { + twk <- t[.Call(dplR.seg50, i, nseg, segskip, np)] + tr <- redfitTrig(twk, nseg, wz, nfreq) + ww[, i] <- redfitWinwgt(twk, iwin) + wtau[, i] <- tr[[3]] + tsin[, , i] <- tr[[1]] + tcos[, , i] <- tr[[2]] + } + list(ww = ww, tsin = tsin, tcos = tcos, wtau = wtau) +} + +redfitSetdim <- function(min.nseg, t, np, ofac, hifac, n50, verbose, ...) { + ## Formula for nseg from the original Fortran version: + ## Integer division (or truncation, or "floor"). + ## nseg <- (2 * np) %/% (n50 + 1) + ## New version: rounding instead of truncation, order of operations changed. + nseg <- round(np / (n50 + 1) * 2) # points per segment + if (nseg < min.nseg) { + stop(gettextf("too few points per segment (%.0f), at least %.0f needed", + nseg, min.nseg, domain = "R-dplR"), domain = NA) + } + if (n50 == 1) { + segskip <- 0 + } else { + ## (ideal, not rounded) difference between starting indices of + ## consecutive segments + segskip <- (np - nseg) / (n50 - 1) + if (segskip < 1) { + stop("too many segments: overlap of more than nseg - 1 points") + } + } + ## It seems that avgdt, fnyq, etc. were somewhat off in the + ## original Fortran version because it would not use all of the + ## data (t[np]) with some combinations of np and n50. + avgdt <- (t[np] - t[1]) / (np - 1) # avg. sampling interval + tp <- avgdt * nseg # average period of a segment + fnyq <- hifac / (2 * avgdt) # average Nyquist freq. + nfreq <- floor(hifac * ofac * nseg / 2 + 1) # f[1] == f0; f[nfreq] == fNyq + df <- fnyq / (nfreq - 1) # freq. spacing + wz <- 2 * pi * fnyq / (nfreq - 1) # omega == 2*pi*f + if (verbose) { + cat(" N = ", np, "\n", sep="") + cat(" t[1] = ", t[1], "\n", sep="") + cat(" t[N] = ", t[np], "\n", sep="") + cat("
= ", avgdt, "\n", sep="") + cat("Nfreq = ", nfreq, "\n", sep="") + cat("\n") + } + ## dplR: ditched nout (nout == nfreq) + res <- list(np = np, nseg = nseg, nfreq = nfreq, avgdt = avgdt, df = df, + wz = wz, fnyq = fnyq, n50 = n50, ofac = ofac, hifac = hifac, + segskip = segskip) + args <- list(...) + argnames <- names(args) + for (k in which(nzchar(argnames))) { + res[[argnames[k]]] <- args[[k]] + } + ## Convert integers (if any) to numeric + for (k in seq_along(res)) { + elem <- res[[k]] + if (is.integer(elem)) { + res[[k]] <- as.numeric(elem) + } + } + res +} + +redfitTrig <- function(tsamp, nn, wz, nfreq) { + tol1 <- 1.0e-4 + nfreqM1 <- nfreq - 1 + tcos <- matrix(NA_real_, nn, nfreqM1) + tsin <- matrix(NA_real_, nn, nfreqM1) + wtau <- numeric(nfreqM1) + ## start frequency loop + ## dplR: In the original Fortran code, the variables ww (not used + ## in this function), wtau, tsin and tcos have unused elements + ## (one extra frequency). The unused elements have now been + ## dropped. + for (k in seq_len(nfreqM1)) { + wrun <- k * wz + ## calc. tau + arg2 <- wrun * tsamp + arg1 <- arg2 + arg2 + tc <- cos(arg1) + ts <- sin(arg1) + csum <- sum(tc) + ssum <- sum(ts) + sumtc <- sum(tsamp * tc) + sumts <- sum(tsamp * ts) + if (abs(ssum) > tol1 || abs(csum) > tol1) { + watan <- atan2(ssum, csum) + } else { + watan <- atan2(-sumtc, sumts) + } + wtnew <- 0.5 * watan + wtau[k] <- wtnew + ## summations over the sample + arg2 <- arg2 - wtnew + tcos[, k] <- cos(arg2) + tsin[, k] <- sin(arg2) + } + list(tsin = tsin, tcos = tcos, wtau = wtau) +} + +## calc. normalized window weights +## window type (iwin) 0: Rectangular +## 1: Welch 1 +## 2: Hanning +## 3: Parzen (Triangular) +## 4: Blackman-Harris 3-Term +redfitWinwgt <- function(t, iwin) { + nseg <- length(t) + ## useful factor for various windows + fac1 <- (nseg / 2) - 0.5 + fac2 <- 1 / ((nseg / 2) + 0.5) + tlen <- t[nseg] - t[1] + if (iwin == 0) { # rectangle + ww <- rep.int(1, nseg) + } else if (iwin == 1) { # welch I + ww <- (nseg / tlen * (t - t[1]) - fac1) * fac2 + ww <- 1 - ww * ww + } else if (iwin == 2) { # hanning + fac3 <- nseg - 1 + ww <- 1 - cos(2 * pi / fac3 * nseg / tlen * (t - t[1])) [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/dplr -r 663 From noreply at r-forge.r-project.org Mon Aug 19 13:30:03 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 19 Aug 2013 13:30:03 +0200 (CEST) Subject: [Dplr-commits] r664 - branches/redfit Message-ID: <20130819113003.3FD1F184BE0@r-forge.r-project.org> Author: mvkorpel Date: 2013-08-19 13:30:02 +0200 (Mon, 19 Aug 2013) New Revision: 664 Modified: branches/redfit/DESCRIPTION Log: Enforce consistency between Authors at R and Author Modified: branches/redfit/DESCRIPTION =================================================================== --- branches/redfit/DESCRIPTION 2013-08-19 11:17:47 UTC (rev 663) +++ branches/redfit/DESCRIPTION 2013-08-19 11:30:02 UTC (rev 664) @@ -6,7 +6,7 @@ Date: 2013-08-19 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 = "aut"), 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")), From noreply at r-forge.r-project.org Wed Aug 21 19:49:32 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 21 Aug 2013 19:49:32 +0200 (CEST) Subject: [Dplr-commits] r665 - / branches/redfit/man Message-ID: <20130821174932.E4A7C181234@r-forge.r-project.org> Author: andybunn Date: 2013-08-21 19:49:32 +0200 (Wed, 21 Aug 2013) New Revision: 665 Modified: / branches/redfit/man/redfit.Rd Log: Testing redfit and messing about with the examples in the Rd file. Property changes on: ___________________________________________________________________ Added: svn:ignore + .Rproj.user .Rhistory .RData Modified: branches/redfit/man/redfit.Rd =================================================================== --- branches/redfit/man/redfit.Rd 2013-08-19 11:30:02 UTC (rev 664) +++ branches/redfit/man/redfit.Rd 2013-08-21 17:49:32 UTC (rev 665) @@ -208,6 +208,25 @@ \code{\link{print.redfit}} } \examples{data(ca533) +# I'd like the first example to be a simple run with an ar1 dataset +# will fuss around with this some. I think a dedicated plot function +nyrs <- 100 +phi <- 0.7 +sigma <- 0.3 +sigma0 <-(1 - phi^2)*sigma^2 +sigma0 <- sqrt(sigma0) +x.ar <- arima.sim(list(ar=phi),n = nyrs, sd = sigma0)+1 +x.ar[x.ar<=0] <- 0.001 + +redf <- redfit(x.ar, nsim=1000) +plot(redf[["freq"]], redf[["gxxc"]], + ylim=range(redf[["ci99"]],redf[["gxxc"]]), + type='n') +grid() +lines(redf[["freq"]], redf[["gxxc"]]) +lines(redf[["freq"]], redf[["ci99"]],col='red') + +# second example with tree-ring data t <- as.numeric(row.names(ca533)) x <- ca533[[2]] idx <- which(!is.na(x)) From noreply at r-forge.r-project.org Wed Aug 21 20:41:38 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 21 Aug 2013 20:41:38 +0200 (CEST) Subject: [Dplr-commits] r666 - branches/redfit/man Message-ID: <20130821184138.A1E491842B0@r-forge.r-project.org> Author: andybunn Date: 2013-08-21 20:41:38 +0200 (Wed, 21 Aug 2013) New Revision: 666 Modified: branches/redfit/man/redfit.Rd Log: last bit of messing about with the example to redfit.Rd - looking good. Modified: branches/redfit/man/redfit.Rd =================================================================== --- branches/redfit/man/redfit.Rd 2013-08-21 17:49:32 UTC (rev 665) +++ branches/redfit/man/redfit.Rd 2013-08-21 18:41:38 UTC (rev 666) @@ -207,17 +207,29 @@ \seealso{ \code{\link{print.redfit}} } -\examples{data(ca533) +\examples{ # I'd like the first example to be a simple run with an ar1 dataset # will fuss around with this some. I think a dedicated plot function +# here is a 100-yr series with ar1 of phi and +# std of sigma. this should not have any peaks above the CI nyrs <- 100 +yrs <- 1:nyrs + phi <- 0.7 sigma <- 0.3 -sigma0 <-(1 - phi^2)*sigma^2 -sigma0 <- sqrt(sigma0) +sigma0 <-sqrt((1 - phi^2)*sigma^2) x.ar <- arima.sim(list(ar=phi),n = nyrs, sd = sigma0)+1 x.ar[x.ar<=0] <- 0.001 +# now let's add in a 10-yr sin wave +per <- 10 +amp <- 0.4 +wav <- amp * sin(2*pi*1/per*yrs) +x10.ar <- x.ar+wav +plot(yrs,x10.ar,type='l') +lines(yrs,x.ar,col='red') + +# the first should not show a peak and the second should redf <- redfit(x.ar, nsim=1000) plot(redf[["freq"]], redf[["gxxc"]], ylim=range(redf[["ci99"]],redf[["gxxc"]]), @@ -226,7 +238,17 @@ lines(redf[["freq"]], redf[["gxxc"]]) lines(redf[["freq"]], redf[["ci99"]],col='red') +redf10 <- redfit(x10.ar, nsim=1000) +plot(redf10[["freq"]], redf10[["gxxc"]], + ylim=range(redf10[["ci99"]],redf10[["gxxc"]]), + type='n') +grid() +lines(redf10[["freq"]], redf10[["gxxc"]]) +lines(redf10[["freq"]], redf10[["ci99"]],col='red') + + # second example with tree-ring data +data(ca533) t <- as.numeric(row.names(ca533)) x <- ca533[[2]] idx <- which(!is.na(x)) From noreply at r-forge.r-project.org Tue Aug 27 18:32:53 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 27 Aug 2013 18:32:53 +0200 (CEST) Subject: [Dplr-commits] r667 - branches/redfit/man Message-ID: <20130827163253.6CD7218112C@r-forge.r-project.org> Author: andybunn Date: 2013-08-27 18:32:53 +0200 (Tue, 27 Aug 2013) New Revision: 667 Modified: branches/redfit/man/redfit.Rd Log: Examples for redfit. Mikko, care to comment? Modified: branches/redfit/man/redfit.Rd =================================================================== --- branches/redfit/man/redfit.Rd 2013-08-21 18:41:38 UTC (rev 666) +++ branches/redfit/man/redfit.Rd 2013-08-27 16:32:53 UTC (rev 667) @@ -208,52 +208,89 @@ \code{\link{print.redfit}} } \examples{ -# I'd like the first example to be a simple run with an ar1 dataset -# will fuss around with this some. I think a dedicated plot function -# here is a 100-yr series with ar1 of phi and -# std of sigma. this should not have any peaks above the CI -nyrs <- 100 +# Create a simulated tree-ring width series that has a red-noise +# background and an embedded signal. +set.seed(123) +nyrs <- 500 yrs <- 1:nyrs +# Here is an ar1 time series with a mean of 2mm, +# an ar1 of phi, and sd of sigma phi <- 0.7 sigma <- 0.3 sigma0 <-sqrt((1 - phi^2)*sigma^2) -x.ar <- arima.sim(list(ar=phi),n = nyrs, sd = sigma0)+1 -x.ar[x.ar<=0] <- 0.001 -# now let's add in a 10-yr sin wave +x <- arima.sim(list(ar=phi),n = nyrs, sd = sigma0)+2 + +# Here is a sine wave at f=0.1 to add in with an amplitude +# equal to half the sd of the red noise background per <- 10 -amp <- 0.4 +amp <- sigma0/2 wav <- amp * sin(2*pi*1/per*yrs) -x10.ar <- x.ar+wav -plot(yrs,x10.ar,type='l') -lines(yrs,x.ar,col='red') +# Add them together so we have signal and noise +x <- x+wav -# the first should not show a peak and the second should -redf <- redfit(x.ar, nsim=1000) -plot(redf[["freq"]], redf[["gxxc"]], - ylim=range(redf[["ci99"]],redf[["gxxc"]]), - type='n') +# Here is the redfit spec +redf.x <- redfit(x, nsim=500) + +op <- par(no.readonly = TRUE) # Save to reset on exit +par(tcl=0.5,mar=rep(2.2,4),mgp=c(1.1,0.1,0)) + +plot(redf.x[["freq"]], redf.x[["gxxc"]], + ylim=range(redf.x[["ci99"]],redf.x[["gxxc"]]), + type='n',ylab='Spectrum (dB)',xlab='Frequency (1/yr)',axes=F) grid() -lines(redf[["freq"]], redf[["gxxc"]]) -lines(redf[["freq"]], redf[["ci99"]],col='red') +lines(redf.x[["freq"]], redf.x[["gxxc"]],col='#1B9E77') +lines(redf.x[["freq"]], redf.x[["ci99"]],col='#D95F02') +lines(redf.x[["freq"]], redf.x[["ci95"]],col='#7570B3') +lines(redf.x[["freq"]], redf.x[["ci90"]],col='#E7298A') +freqs <- pretty(redf.x[["freq"]]) +pers <- round(1/freqs,2) +axis(1,at=freqs,labels=TRUE) +axis(3,at=freqs,labels=pers) +mtext(text='Period (yr)',side=3,line=1.1) +axis(2);axis(4) +legend('topright',c('x','CI99','CI95','CI90'),lwd=2, + col=c('#1B9E77','#D95F02', '#7570B3', '#E7298A'), + bg='white') +box() -redf10 <- redfit(x10.ar, nsim=1000) -plot(redf10[["freq"]], redf10[["gxxc"]], - ylim=range(redf10[["ci99"]],redf10[["gxxc"]]), - type='n') +# Second example with tree-ring data +# Note the long-term low-freq signal in the data. E.g., +# crn.plot(cana157) + +data(cana157) +yrs <- as.numeric(rownames(cana157)) +x <- cana157[,1] + +redf.x <- redfit(x, nsim=1000) + +plot(yrs,x,type='n',axes=F,xlab='Time',ylab='Ring Width (mm)') grid() -lines(redf10[["freq"]], redf10[["gxxc"]]) -lines(redf10[["freq"]], redf10[["ci99"]],col='red') +lines(yrs,x) +axis(1);axis(2);axis(3);axis(4); +box() +plot(redf.x[["freq"]], redf.x[["gxxc"]], + ylim=range(redf.x[["ci99"]],redf.x[["gxxc"]]), + type='n',ylab='Spectrum (dB)',xlab='Frequency (1/yr)',axes=F) +grid() +lines(redf.x[["freq"]], redf.x[["gxxc"]],col='#1B9E77') +lines(redf.x[["freq"]], redf.x[["ci99"]],col='#D95F02') +lines(redf.x[["freq"]], redf.x[["ci95"]],col='#7570B3') +lines(redf.x[["freq"]], redf.x[["ci90"]],col='#E7298A') +freqs <- pretty(redf.x[["freq"]]) +pers <- round(1/freqs,2) +axis(1,at=freqs,labels=TRUE) +axis(3,at=freqs,labels=pers) +mtext(text='Period (yr)',side=3,line=1.1) +axis(2);axis(4) +legend('topright',c('x','CI99','CI95','CI90'),lwd=2, + col=c('#1B9E77','#D95F02', '#7570B3', '#E7298A'), + bg='white') +box() +par(op) -# second example with tree-ring data -data(ca533) -t <- as.numeric(row.names(ca533)) -x <- ca533[[2]] -idx <- which(!is.na(x)) -redf <- redfit(x[idx], t[idx], "time", nsim = 100) -plot(redf[["freq"]], redf[["gxxc"]]) } \keyword{ ts } \keyword{ htest } From noreply at r-forge.r-project.org Tue Aug 27 23:38:11 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 27 Aug 2013 23:38:11 +0200 (CEST) Subject: [Dplr-commits] r668 - in branches/redfit: R man Message-ID: <20130827213811.575C1185D1B@r-forge.r-project.org> Author: andybunn Date: 2013-08-27 23:38:10 +0200 (Tue, 27 Aug 2013) New Revision: 668 Modified: branches/redfit/R/wavelet.plot.R branches/redfit/man/wavelet.plot.Rd Log: added a coi.col argument at the request of a useR. Modified: branches/redfit/R/wavelet.plot.R =================================================================== --- branches/redfit/R/wavelet.plot.R 2013-08-27 16:32:53 UTC (rev 667) +++ branches/redfit/R/wavelet.plot.R 2013-08-27 21:38:10 UTC (rev 668) @@ -1,207 +1,207 @@ -wavelet.plot <- - function(wave.list, - wavelet.levels = quantile(wave.list$Power, probs=seq(from=0, to=1, by=0.1)), - add.coi = TRUE, add.sig = TRUE, x.lab = gettext("Time"), - period.lab = gettext("Period"), crn.lab = gettext("RWI"), - key.cols = rev(rainbow(length(wavelet.levels)-1)), - key.lab = parse(text = paste0("\"", gettext("Power"), "\"^2")), - add.spline = FALSE, f = 0.5, nyrs = NULL, - crn.col = "black", crn.lwd = 1, - crn.ylim = range(wave.list$y)*1.1, side.by.side = FALSE) -{ - - ## Wavelet transform variables: - y <- wave.list$y - x <- wave.list$x - wave <- wave.list$wave - period <- wave.list$period - Signif <- wave.list$Signif - coi <- wave.list$coi - coi[coi == 0] <- 1e-12 - Power <- wave.list$Power - siglvl <- wave.list$siglvl - - if (any(diff(x) <= 0) || any(diff(period) <= 0)) { - stop("'wave.list$x' and 'wave.list$period' must be strictly ascending") - } - if (period[1] <= 0) { - stop("'wave.list$period' must be positive") - } - - ## Expand signif --> (length(wave.list$Scale))x(N) array - Signif <- t(matrix(Signif, dim(wave)[2], dim(wave)[1])) - ## Where ratio > 1, power is significant - Signif <- Power / Signif - - ## Period is in years, period2 is in powers of 2 - period2 <- log2(period) - ytick <- unique(trunc(period2)) # Unique integer powers of 2 - ytickv <- 2^(ytick) # Labels are in years - - ## coi is in years, coi2 in powers of 2 - coi2 <- log2(coi) - coi2[coi2 < 0] <- 0 - coi2.yy <- c(coi2, rep(max(period2, na.rm=TRUE), length(coi2))) - coi2.yy[is.na(coi2.yy)] <- coi[2] - yr.vec.xx <- c(x, rev(x)) - - par.orig <- par(c("mar", "las", "mfrow")) - on.exit(par(par.orig)) - nlevels <- length(wavelet.levels) - seq.level <- seq_len(nlevels - 1) - key.labs <- formatC(wavelet.levels, digits = 4, format = "f") - asp <- NA - xaxs <- "i" - yaxs <- "i" - las <- 1 - xlim <- range(x, finite=TRUE) - ylim <- range(period2, finite=TRUE) - z <- Power - ## invert to match std figs? Not sure how to do tht coi - ## parabola be easier to just fool the filled.countor internal - ## to change the plot order? - ##z <- z[,ncol(z):1] - ##Signif <-Signif[,ncol(Signif):1] - ##ytick <- rev(ytick) - - if (side.by.side) { - ## plot set up - layout(matrix(c(3, 2, 1), nrow=1, byrow=TRUE), - widths=c(1, 1, 0.2)) - ## plot 1: scale - mar <- c(3, 1, 3, 3) - par(mar=mar, tcl=0.5, mgp=c(1.5, 0.25, 0), las=las) - plot.new() - plot.window(ylim=c(1, nlevels), xlim=c(0, 1), - xaxs=xaxs, yaxs=yaxs, asp=asp) - rect(0, seq.level, 1, 2:nlevels, col = key.cols) - axis(4, at=seq_along(wavelet.levels), labels=key.labs) - ## add units - title(key.lab, cex.main=1) - ## plot 2: contour-image - mar <- c(3, 3, 3, 3) - par(mar=mar, tcl=0.5, mgp=c(1.5, 0.25, 0)) - plot.new() - - plot.window(xlim, ylim, "", xaxs=xaxs, yaxs=yaxs, asp=asp, las=las) - # note replacement of .Internal(filledcontour(as.double(x),...) - # with .filled.contour() as of R-2.15.0 - .filled.contour(as.double(x), - as.double(period2), - z, - as.double(wavelet.levels), - key.cols) - - if (add.sig) { - contour(x, period2, Signif, levels=1, labels=siglvl, - drawlabels = FALSE, axes = FALSE, - frame.plot = FALSE, add = TRUE, - lwd = 2, col="black") - } - if (add.coi) { - polygon(yr.vec.xx, coi2.yy, density=c(10, 20), - angle=c(-45, 45), col="black") - } - axis(1) - axis(3) - axis(2, at = ytick, labels = ytickv) - axis(4, at = ytick, labels = ytickv) - title(xlab = x.lab, ylab = period.lab) - box() - - ## plot 3: chron - mar <- c(3, 3, 3, 3) - par(mar = mar, las=0) - plot(x, y, type = "l", xlim, xaxs = xaxs, yaxs = yaxs, - asp = asp, xlab = "", ylab = "", axes = FALSE, col = crn.col, - lwd = crn.lwd, ylim = crn.ylim) - if (add.spline) { - spl <- y - tmp <- na.omit(spl) - if (is.null(nyrs)) { - nyrs2 <- length(tmp) * 0.33 - } else { - nyrs2 <- nyrs - } - tmp <- ffcsaps(y = tmp, x = seq_along(tmp), nyrs = nyrs2, f = f) - spl[!is.na(spl)] <- tmp - lines(x, spl, col = "red", lwd = 2) - } - axis(1) - axis(3) - axis(2) - axis(4) - title(xlab = x.lab, ylab = crn.lab) - box() - } - else { - ## plot set up - layout(matrix(c(3, 2, 1), ncol=1, byrow=TRUE), - heights=c(1, 1, 0.3)) - ## plot 1: scale - mar <- c(3, 3, 0.1, 3) - par(mar=mar, tcl=0.5, mgp=c(1.5, 0.25, 0), las=las) - plot.new() - plot.window(xlim=c(1, nlevels), ylim=c(0, 1), - xaxs=xaxs, yaxs=yaxs, asp=asp) - rect(seq.level, 0, 2:nlevels, 1, col = key.cols) - axis(1, at=seq_along(wavelet.levels), labels=key.labs) - ## add units - title(sub=key.lab, cex.sub=1, line=1.5) - ## plot 2: contour-image - par(mar=mar, tcl=0.5, mgp=c(1.5, 0.25, 0)) - plot.new() - - plot.window(xlim, ylim, "", xaxs=xaxs, yaxs=yaxs, asp=asp, las=las) - # note replacement of .Internal(filledcontour(as.double(x),...) - # with .filled.contour() as of R-2.15.0 - .filled.contour(as.double(x), - as.double(period2), - z, - as.double(wavelet.levels), - key.cols) - - if (add.sig) { - contour(x, period2, Signif, levels=1, labels=siglvl, - drawlabels = FALSE, axes = FALSE, - frame.plot = FALSE, add = TRUE, - lwd = 2, col="black") - } - if (add.coi) { - polygon(yr.vec.xx, coi2.yy, density=c(10, 20), - angle=c(-45, 45), col="black") - } - axis(1) - axis(2, at = ytick, labels = ytickv) - axis(3, labels = NA) - axis(4, at = ytick, labels = NA) - title(xlab = x.lab, ylab = period.lab) - box() - - ## plot 3: chron - mar <- c(0.1, 3, 3, 3) - par(mar = mar, las=0) - plot(x, y, type = "l", xlim, xaxs = xaxs, yaxs = yaxs, - asp = asp, xlab = "", ylab = "", axes = FALSE, col = crn.col, - lwd = crn.lwd, ylim = crn.ylim) - if (add.spline) { - spl <- y - tmp <- na.omit(spl) - if (is.null(nyrs)) { - nyrs2 <- length(tmp) * 0.33 - } else { - nyrs2 <- nyrs - } - tmp <- ffcsaps(y = tmp, x = seq_along(tmp), nyrs = nyrs2, f = f) - spl[!is.na(spl)] <- tmp - lines(x, spl, col = "red", lwd = 2) - } - axis(1, labels = NA) - axis(2, labels = NA) - axis(3) - axis(4) - mtext(crn.lab, side=4, line=1.5, cex=0.75) - box() - } - invisible() -} +wavelet.plot <- + function(wave.list, + wavelet.levels = quantile(wave.list$Power, probs=seq(from=0, to=1, by=0.1)), + add.coi = TRUE, add.sig = TRUE, x.lab = gettext("Time"), + period.lab = gettext("Period"), crn.lab = gettext("RWI"), + key.cols = rev(rainbow(length(wavelet.levels)-1)), + key.lab = parse(text = paste0("\"", gettext("Power"), "\"^2")), + add.spline = FALSE, f = 0.5, nyrs = NULL, + crn.col = "black", crn.lwd = 1,coi.col='black', + crn.ylim = range(wave.list$y)*1.1, side.by.side = FALSE) +{ + + ## Wavelet transform variables: + y <- wave.list$y + x <- wave.list$x + wave <- wave.list$wave + period <- wave.list$period + Signif <- wave.list$Signif + coi <- wave.list$coi + coi[coi == 0] <- 1e-12 + Power <- wave.list$Power + siglvl <- wave.list$siglvl + + if (any(diff(x) <= 0) || any(diff(period) <= 0)) { + stop("'wave.list$x' and 'wave.list$period' must be strictly ascending") + } + if (period[1] <= 0) { + stop("'wave.list$period' must be positive") + } + + ## Expand signif --> (length(wave.list$Scale))x(N) array + Signif <- t(matrix(Signif, dim(wave)[2], dim(wave)[1])) + ## Where ratio > 1, power is significant + Signif <- Power / Signif + + ## Period is in years, period2 is in powers of 2 + period2 <- log2(period) + ytick <- unique(trunc(period2)) # Unique integer powers of 2 + ytickv <- 2^(ytick) # Labels are in years + + ## coi is in years, coi2 in powers of 2 + coi2 <- log2(coi) + coi2[coi2 < 0] <- 0 + coi2.yy <- c(coi2, rep(max(period2, na.rm=TRUE), length(coi2))) + coi2.yy[is.na(coi2.yy)] <- coi[2] + yr.vec.xx <- c(x, rev(x)) + + par.orig <- par(c("mar", "las", "mfrow")) + on.exit(par(par.orig)) + nlevels <- length(wavelet.levels) + seq.level <- seq_len(nlevels - 1) + key.labs <- formatC(wavelet.levels, digits = 4, format = "f") + asp <- NA + xaxs <- "i" + yaxs <- "i" + las <- 1 + xlim <- range(x, finite=TRUE) + ylim <- range(period2, finite=TRUE) + z <- Power + ## invert to match std figs? Not sure how to do tht coi + ## parabola be easier to just fool the filled.countor internal + ## to change the plot order? + ##z <- z[,ncol(z):1] + ##Signif <-Signif[,ncol(Signif):1] + ##ytick <- rev(ytick) + + if (side.by.side) { + ## plot set up + layout(matrix(c(3, 2, 1), nrow=1, byrow=TRUE), + widths=c(1, 1, 0.2)) + ## plot 1: scale + mar <- c(3, 1, 3, 3) + par(mar=mar, tcl=0.5, mgp=c(1.5, 0.25, 0), las=las) + plot.new() + plot.window(ylim=c(1, nlevels), xlim=c(0, 1), + xaxs=xaxs, yaxs=yaxs, asp=asp) + rect(0, seq.level, 1, 2:nlevels, col = key.cols) + axis(4, at=seq_along(wavelet.levels), labels=key.labs) + ## add units + title(key.lab, cex.main=1) + ## plot 2: contour-image + mar <- c(3, 3, 3, 3) + par(mar=mar, tcl=0.5, mgp=c(1.5, 0.25, 0)) + plot.new() + + plot.window(xlim, ylim, "", xaxs=xaxs, yaxs=yaxs, asp=asp, las=las) + # note replacement of .Internal(filledcontour(as.double(x),...) + # with .filled.contour() as of R-2.15.0 + .filled.contour(as.double(x), + as.double(period2), + z, + as.double(wavelet.levels), + key.cols) + + if (add.sig) { + contour(x, period2, Signif, levels=1, labels=siglvl, + drawlabels = FALSE, axes = FALSE, + frame.plot = FALSE, add = TRUE, + lwd = 2, col="black") + } + if (add.coi) { + polygon(yr.vec.xx, coi2.yy, density=c(10, 20), + angle=c(-45, 45), col=coi.col) + } + axis(1) + axis(3) + axis(2, at = ytick, labels = ytickv) + axis(4, at = ytick, labels = ytickv) + title(xlab = x.lab, ylab = period.lab) + box() + + ## plot 3: chron + mar <- c(3, 3, 3, 3) + par(mar = mar, las=0) + plot(x, y, type = "l", xlim, xaxs = xaxs, yaxs = yaxs, + asp = asp, xlab = "", ylab = "", axes = FALSE, col = crn.col, + lwd = crn.lwd, ylim = crn.ylim) + if (add.spline) { + spl <- y + tmp <- na.omit(spl) + if (is.null(nyrs)) { + nyrs2 <- length(tmp) * 0.33 + } else { + nyrs2 <- nyrs + } + tmp <- ffcsaps(y = tmp, x = seq_along(tmp), nyrs = nyrs2, f = f) + spl[!is.na(spl)] <- tmp + lines(x, spl, col = "red", lwd = 2) + } + axis(1) + axis(3) + axis(2) + axis(4) + title(xlab = x.lab, ylab = crn.lab) + box() + } + else { + ## plot set up + layout(matrix(c(3, 2, 1), ncol=1, byrow=TRUE), + heights=c(1, 1, 0.3)) + ## plot 1: scale + mar <- c(3, 3, 0.1, 3) + par(mar=mar, tcl=0.5, mgp=c(1.5, 0.25, 0), las=las) + plot.new() + plot.window(xlim=c(1, nlevels), ylim=c(0, 1), + xaxs=xaxs, yaxs=yaxs, asp=asp) + rect(seq.level, 0, 2:nlevels, 1, col = key.cols) + axis(1, at=seq_along(wavelet.levels), labels=key.labs) + ## add units + title(sub=key.lab, cex.sub=1, line=1.5) + ## plot 2: contour-image + par(mar=mar, tcl=0.5, mgp=c(1.5, 0.25, 0)) + plot.new() + + plot.window(xlim, ylim, "", xaxs=xaxs, yaxs=yaxs, asp=asp, las=las) + # note replacement of .Internal(filledcontour(as.double(x),...) + # with .filled.contour() as of R-2.15.0 + .filled.contour(as.double(x), + as.double(period2), + z, + as.double(wavelet.levels), + key.cols) + + if (add.sig) { + contour(x, period2, Signif, levels=1, labels=siglvl, + drawlabels = FALSE, axes = FALSE, + frame.plot = FALSE, add = TRUE, + lwd = 2, col="black") + } + if (add.coi) { + polygon(yr.vec.xx, coi2.yy, density=c(10, 20), + angle=c(-45, 45), col=coi.col) + } + axis(1) + axis(2, at = ytick, labels = ytickv) + axis(3, labels = NA) + axis(4, at = ytick, labels = NA) + title(xlab = x.lab, ylab = period.lab) + box() + + ## plot 3: chron + mar <- c(0.1, 3, 3, 3) + par(mar = mar, las=0) + plot(x, y, type = "l", xlim, xaxs = xaxs, yaxs = yaxs, + asp = asp, xlab = "", ylab = "", axes = FALSE, col = crn.col, + lwd = crn.lwd, ylim = crn.ylim) + if (add.spline) { + spl <- y + tmp <- na.omit(spl) + if (is.null(nyrs)) { + nyrs2 <- length(tmp) * 0.33 + } else { + nyrs2 <- nyrs + } + tmp <- ffcsaps(y = tmp, x = seq_along(tmp), nyrs = nyrs2, f = f) + spl[!is.na(spl)] <- tmp + lines(x, spl, col = "red", lwd = 2) + } + axis(1, labels = NA) + axis(2, labels = NA) + axis(3) + axis(4) + mtext(crn.lab, side=4, line=1.5, cex=0.75) + box() + } + invisible() +} Modified: branches/redfit/man/wavelet.plot.Rd =================================================================== --- branches/redfit/man/wavelet.plot.Rd 2013-08-27 16:32:53 UTC (rev 667) +++ branches/redfit/man/wavelet.plot.Rd 2013-08-27 21:38:10 UTC (rev 668) @@ -1,78 +1,78 @@ -\name{wavelet.plot} -\alias{wavelet.plot} -\title{ Plot a Continuous Wavelet Transform } -\description{ - This function creates a \code{filled.contour} plot of a continuous - wavelet transform as output from \code{\link{morlet}}. -} -\usage{ -wavelet.plot(wave.list, - wavelet.levels = quantile(wave.list$Power, - probs = seq(from=0, to=1, by=0.1)), - add.coi = TRUE, add.sig = TRUE, x.lab = gettext("Time"), - period.lab = gettext("Period"), crn.lab = gettext("RWI"), - key.cols = rev(rainbow(length(wavelet.levels)-1)), - key.lab = parse(text=paste0("\"", gettext("Power"), "\"^2")), - add.spline = FALSE, f = 0.5, nyrs = NULL, - crn.col = "black", crn.lwd = 1, - crn.ylim = range(wave.list$y)*1.1, side.by.side = FALSE) -} -\arguments{ - \item{wave.list}{A \code{list}. Output from \code{\link{morlet}}.} - \item{wavelet.levels}{A \code{numeric} vector. Values for levels of - the filled contours for the wavelet plot.} - \item{add.coi}{A \code{logical} flag. Add cone of influence?} - \item{add.sig}{A \code{logical} flag. Add contour lines for significance?} - \item{x.lab}{X-axis label.} - \item{period.lab}{Y-axis label for the wavelet plot.} - \item{crn.lab}{Y-axis label for the time-series plot.} - \item{key.cols}{A vector of colors for the wavelets and the key.} - \item{key.lab}{Label for key.} - \item{add.spline}{A \code{logical} flag. Add a spline to the - time-series plot using \code{\link{ffcsaps}}?. } - \item{nyrs}{ A number giving the rigidity of the smoothing spline, defaults to - 0.33 of series length if nyrs is \code{NULL}. } - \item{f}{ A number between 0 and 1 giving the frequency response or - wavelength cutoff for the smoothing spline. Defaults to 0.5. } - \item{crn.col}{Line color for the time-series plot.} - \item{crn.lwd}{Line width for the time-series plot.} - \item{crn.ylim}{Axis limits for the time-series plot.} - \item{side.by.side}{A \code{logical} flag. Plots will be in one row if - \code{TRUE}. } -} -\details{ - This produces a plot of a continuous wavelet transform and plots the - original time series. Contours are added for significance and a cone of - influence polygon can be added as well. Anything within the cone of - influence should not be interpreted. - - The time series can be plotted with a smoothing spline as well. -} -\value{ - None. This function is invoked for its side effect, which is to produce a - plot. -} -\references{ - Torrence, C. and Compo, G. P. (1998) A practical guide to wavelet - analysis. \emph{Bulletin of the American Meteorological Society}, - 79(1):61\enc{?}{--}78. -} -\note{ The function \code{morlet} is a port of Torrence's - \acronym{IDL} code available at - \url{http://atoc.colorado.edu/research/wavelets/software.html} -} -\author{ Andy Bunn. Patched and improved by Mikko Korpela. } -\seealso{ \code{\link{morlet}}, \code{\link{ffcsaps}}} -\examples{data(ca533) -ca533.rwi <- detrend(rwl = ca533, method = "ModNegExp") -ca533.crn <- chron(ca533.rwi, prefix = "CAM", prewhiten = FALSE) -Years <- as.numeric(rownames(ca533.crn)) -CAMstd <- ca533.crn[, 1] -out.wave <- morlet(y1 = CAMstd, x1 = Years, p2 = 9, dj = 0.1, - siglvl = 0.99) -wavelet.plot(out.wave) -levs <- quantile(out.wave$Power, probs = c(0, 0.5, 0.75, 0.9, 0.99)) -wavelet.plot(out.wave, wavelet.levels = levs, add.sig = FALSE, - key.cols = c("white", "green", "blue", "red")) -} -\keyword{ hplot } +\name{wavelet.plot} +\alias{wavelet.plot} +\title{ Plot a Continuous Wavelet Transform } +\description{ + This function creates a \code{filled.contour} plot of a continuous + wavelet transform as output from \code{\link{morlet}}. +} +\usage{ +wavelet.plot(wave.list, + wavelet.levels = quantile(wave.list$Power, + probs = seq(from=0, to=1, by=0.1)), + add.coi = TRUE, add.sig = TRUE, x.lab = gettext("Time"), + period.lab = gettext("Period"), crn.lab = gettext("RWI"), + key.cols = rev(rainbow(length(wavelet.levels)-1)), + key.lab = parse(text=paste0("\"", gettext("Power"), "\"^2")), + add.spline = FALSE, f = 0.5, nyrs = NULL, + crn.col = "black", crn.lwd = 1,coi.col='black', + crn.ylim = range(wave.list$y)*1.1, side.by.side = FALSE) +} +\arguments{ + \item{wave.list}{A \code{list}. Output from \code{\link{morlet}}.} + \item{wavelet.levels}{A \code{numeric} vector. Values for levels of + the filled contours for the wavelet plot.} + \item{add.coi}{A \code{logical} flag. Add cone of influence?} + \item{add.sig}{A \code{logical} flag. Add contour lines for significance?} + \item{x.lab}{X-axis label.} + \item{period.lab}{Y-axis label for the wavelet plot.} + \item{crn.lab}{Y-axis label for the time-series plot.} + \item{key.cols}{A vector of colors for the wavelets and the key.} + \item{key.lab}{Label for key.} + \item{add.spline}{A \code{logical} flag. Add a spline to the + time-series plot using \code{\link{ffcsaps}}?. } + \item{nyrs}{ A number giving the rigidity of the smoothing spline, defaults to 0.33 of series length if nyrs is \code{NULL}. } + \item{f}{ A number between 0 and 1 giving the frequency response or + wavelength cutoff for the smoothing spline. Defaults to 0.5. } + \item{crn.col}{Line color for the time-series plot.} + \item{crn.lwd}{Line width for the time-series plot.} + \item{coi.col}{Color for the COI if \code{add.coi} is \code{TRUE}.} + \item{crn.ylim}{Axis limits for the time-series plot.} + \item{side.by.side}{A \code{logical} flag. Plots will be in one row if + \code{TRUE}. } +} +\details{ + This produces a plot of a continuous wavelet transform and plots the + original time series. Contours are added for significance and a cone of + influence polygon can be added as well. Anything within the cone of + influence should not be interpreted. + + The time series can be plotted with a smoothing spline as well. +} +\value{ + None. This function is invoked for its side effect, which is to produce a + plot. +} +\references{ + Torrence, C. and Compo, G. P. (1998) A practical guide to wavelet + analysis. \emph{Bulletin of the American Meteorological Society}, + 79(1):61\enc{?}{--}78. +} +\note{ The function \code{morlet} is a port of Torrence's + \acronym{IDL} code available at + \url{http://atoc.colorado.edu/research/wavelets/software.html} +} +\author{ Andy Bunn. Patched and improved by Mikko Korpela. } +\seealso{ \code{\link{morlet}}, \code{\link{ffcsaps}}} +\examples{data(ca533) +ca533.rwi <- detrend(rwl = ca533, method = "ModNegExp") +ca533.crn <- chron(ca533.rwi, prefix = "CAM", prewhiten = FALSE) +Years <- as.numeric(rownames(ca533.crn)) +CAMstd <- ca533.crn[, 1] +out.wave <- morlet(y1 = CAMstd, x1 = Years, p2 = 9, dj = 0.1, + siglvl = 0.99) +wavelet.plot(out.wave) +levs <- quantile(out.wave$Power, probs = c(0, 0.5, 0.75, 0.9, 0.99)) +wavelet.plot(out.wave, wavelet.levels = levs, add.sig = FALSE, + key.cols = c("white", "green", "blue", "red")) +} +\keyword{ hplot } From noreply at r-forge.r-project.org Thu Aug 29 15:52:02 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 29 Aug 2013 15:52:02 +0200 (CEST) Subject: [Dplr-commits] r669 - in branches/redfit: R src Message-ID: <20130829135202.8DE10185AD6@r-forge.r-project.org> Author: mvkorpel Date: 2013-08-29 15:52:02 +0200 (Thu, 29 Aug 2013) New Revision: 669 Modified: branches/redfit/R/redfit.R branches/redfit/src/redfit.c Log: Added some previously missing "dplR" notes to comments added in the dplR version of redfit. No "dplR" in a comment means it is essentially from the original REDFIT. Modified: branches/redfit/R/redfit.R =================================================================== --- branches/redfit/R/redfit.R 2013-08-27 21:38:10 UTC (rev 668) +++ branches/redfit/R/redfit.R 2013-08-29 13:52:02 UTC (rev 669) @@ -108,7 +108,7 @@ MIN_POINTS <- 2 WIN_NAMES <- c("rectangular", "welch i", "hanning", "triangular", "blackman-harris") - ## 21 is the lower limit of nsim where !anyDuplicated(c(idx80, + ## 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. @@ -139,7 +139,7 @@ NSIM_LIMIT, domain = "R-dplR"), domain = NA) } - ## iwin can be a number or a string. iwin2 is a number %in% 0:4 + ## 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") @@ -189,7 +189,7 @@ t <- t[idx] x <- x[idx] } - ## The rest of the function assumes that t is age, not time + ## dplR: The rest of the function assumes that t is age, not time if (tType2 == "time") { t <- -rev(t) x <- rev(x) @@ -368,7 +368,7 @@ ## 3: Parzen (Triangular) ## 4: Blackman-Harris 3-Term winbw <- function(iwin, df, ofac) { - ## NOTE: bw could be defined with greated precision + ## dplR NOTE: bw could be defined with greated precision bw <- c(1.21, 1.59, 2.00, 1.78, 2.26) df * ofac * bw[iwin + 1] } @@ -376,12 +376,12 @@ ## and n50 overlapping segments (Harris, 1978). ## dplR: Computed more precise values for c50. getdof <- function(iwin, n50) { - ## Rectangular, Welch, Hanning, Triangular, Blackman-Harris + ## 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) } - ## Automatically adds prefix (for example "# " from REDFIT) and + ## dplR: Automatically adds prefix (for example "# " from REDFIT) and ## newline (if newline = TRUE) to output. precat <- function(..., newline = TRUE, sep = "") { cat(prefix) @@ -589,7 +589,7 @@ } redfitSetdim <- function(min.nseg, t, np, ofac, hifac, n50, verbose, ...) { - ## Formula for nseg from the original Fortran version: + ## dplR: Formula for nseg from the original Fortran version: ## Integer division (or truncation, or "floor"). ## nseg <- (2 * np) %/% (n50 + 1) ## New version: rounding instead of truncation, order of operations changed. @@ -601,14 +601,14 @@ if (n50 == 1) { segskip <- 0 } else { - ## (ideal, not rounded) difference between starting indices of + ## dplR: (ideal, not rounded) difference between starting indices of ## consecutive segments segskip <- (np - nseg) / (n50 - 1) if (segskip < 1) { stop("too many segments: overlap of more than nseg - 1 points") } } - ## It seems that avgdt, fnyq, etc. were somewhat off in the + ## dplR: It seems that avgdt, fnyq, etc. were somewhat off in the ## original Fortran version because it would not use all of the ## data (t[np]) with some combinations of np and n50. avgdt <- (t[np] - t[1]) / (np - 1) # avg. sampling interval @@ -634,7 +634,7 @@ for (k in which(nzchar(argnames))) { res[[argnames[k]]] <- args[[k]] } - ## Convert integers (if any) to numeric + ## dplR: Convert integers (if any) to numeric for (k in seq_along(res)) { elem <- res[[k]] if (is.integer(elem)) { Modified: branches/redfit/src/redfit.c =================================================================== --- branches/redfit/src/redfit.c 2013-08-27 21:38:10 UTC (rev 668) +++ branches/redfit/src/redfit.c 2013-08-29 13:52:02 UTC (rev 669) @@ -35,6 +35,7 @@ double *ftrx, double *ftix); SEXP makear1(SEXP t, SEXP np, SEXP tau); +/* dplR: Find the start of a segment. */ /* Formula from the original Fortran version: * If nseg is even, the overlap is exactly 50 % every time. * If nseg is odd, an overlap of 50 % is impossible, and the actual @@ -58,7 +59,8 @@ return fmax(0.0, fmin(np - nseg, round(k * segskip))); } -/* Indices for segments of nseg points each with approximately 50 % +/* dplR: + * Indices for segments of nseg points each with approximately 50 % * overlap for consecutive values of k. segskip is the (ideal, not * rounded) difference between starting points of consecutive * segments. np (number of points) is used for a safety check, only. @@ -120,7 +122,7 @@ y_data = REAL(y); if (!mismatch) { rdualsptr = REAL(rduals); - /* Copy residuals over y */ + /* dplR: Copy residuals over y */ for (i = 0; i < n; i++) { y_data[i] = rdualsptr[i]; } From noreply at r-forge.r-project.org Thu Aug 29 18:31:57 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 29 Aug 2013 18:31:57 +0200 (CEST) Subject: [Dplr-commits] r670 - branches/redfit/man Message-ID: <20130829163157.B004A185A9C@r-forge.r-project.org> Author: mvkorpel Date: 2013-08-29 18:31:57 +0200 (Thu, 29 Aug 2013) New Revision: 670 Modified: branches/redfit/man/redfit.Rd Log: * Formatting (added spaces, double quotes for string delimiters, etc.) * FALSE instead of F (F fails R CMD check) Modified: branches/redfit/man/redfit.Rd =================================================================== --- branches/redfit/man/redfit.Rd 2013-08-29 13:52:02 UTC (rev 669) +++ branches/redfit/man/redfit.Rd 2013-08-29 16:31:57 UTC (rev 670) @@ -161,8 +161,6 @@ \item{df }{ difference between consecutive frequencies. } - \item{wz }{ difference between consecutive angular frequencies. } - \item{fnyq }{ average Nyquist frequency. } \item{n50 }{ value of the \code{\var{n50}} argument. } @@ -218,41 +216,42 @@ # an ar1 of phi, and sd of sigma phi <- 0.7 sigma <- 0.3 -sigma0 <-sqrt((1 - phi^2)*sigma^2) -x <- arima.sim(list(ar=phi),n = nyrs, sd = sigma0)+2 +sigma0 <- sqrt((1 - phi^2) * sigma^2) +x <- arima.sim(list(ar = phi), n = nyrs, sd = sigma0) + 2 # Here is a sine wave at f=0.1 to add in with an amplitude # equal to half the sd of the red noise background per <- 10 -amp <- sigma0/2 -wav <- amp * sin(2*pi*1/per*yrs) +amp <- sigma0 / 2 +wav <- amp * sin(2 * pi / per * yrs) # Add them together so we have signal and noise -x <- x+wav +x <- x + wav # Here is the redfit spec -redf.x <- redfit(x, nsim=500) +redf.x <- redfit(x, nsim = 500) op <- par(no.readonly = TRUE) # Save to reset on exit -par(tcl=0.5,mar=rep(2.2,4),mgp=c(1.1,0.1,0)) +par(tcl = 0.5, mar = rep(2.2, 4), mgp = c(1.1, 0.1, 0)) plot(redf.x[["freq"]], redf.x[["gxxc"]], - ylim=range(redf.x[["ci99"]],redf.x[["gxxc"]]), - type='n',ylab='Spectrum (dB)',xlab='Frequency (1/yr)',axes=F) + ylim = range(redf.x[["ci99"]], redf.x[["gxxc"]]), + type = "n", ylab = "Spectrum (dB)", xlab = "Frequency (1/yr)", + axes = FALSE) grid() -lines(redf.x[["freq"]], redf.x[["gxxc"]],col='#1B9E77') -lines(redf.x[["freq"]], redf.x[["ci99"]],col='#D95F02') -lines(redf.x[["freq"]], redf.x[["ci95"]],col='#7570B3') -lines(redf.x[["freq"]], redf.x[["ci90"]],col='#E7298A') +lines(redf.x[["freq"]], redf.x[["gxxc"]], col = "#1B9E77") +lines(redf.x[["freq"]], redf.x[["ci99"]], col = "#D95F02") +lines(redf.x[["freq"]], redf.x[["ci95"]], col = "#7570B3") +lines(redf.x[["freq"]], redf.x[["ci90"]], col = "#E7298A") freqs <- pretty(redf.x[["freq"]]) -pers <- round(1/freqs,2) -axis(1,at=freqs,labels=TRUE) -axis(3,at=freqs,labels=pers) -mtext(text='Period (yr)',side=3,line=1.1) -axis(2);axis(4) -legend('topright',c('x','CI99','CI95','CI90'),lwd=2, - col=c('#1B9E77','#D95F02', '#7570B3', '#E7298A'), - bg='white') +pers <- round(1 / freqs, 2) +axis(1, at = freqs, labels = TRUE) +axis(3, at = freqs, labels = pers) +mtext(text = "Period (yr)", side = 3, line = 1.1) +axis(2); axis(4) +legend("topright", c("x", "CI99", "CI95", "CI90"), lwd = 2, + col = c("#1B9E77", "#D95F02", "#7570B3", "#E7298A"), + bg = "white") box() # Second example with tree-ring data @@ -261,33 +260,35 @@ data(cana157) yrs <- as.numeric(rownames(cana157)) -x <- cana157[,1] +x <- cana157[, 1] -redf.x <- redfit(x, nsim=1000) +redf.x <- redfit(x, nsim = 1000) -plot(yrs,x,type='n',axes=F,xlab='Time',ylab='Ring Width (mm)') +plot(yrs, x, type = "n", axes = FALSE, + xlab = "Time", ylab = "Ring Width (mm)") grid() -lines(yrs,x) -axis(1);axis(2);axis(3);axis(4); +lines(yrs, x) +axis(1); axis(2); axis(3); axis(4) box() plot(redf.x[["freq"]], redf.x[["gxxc"]], - ylim=range(redf.x[["ci99"]],redf.x[["gxxc"]]), - type='n',ylab='Spectrum (dB)',xlab='Frequency (1/yr)',axes=F) + ylim = range(redf.x[["ci99"]], redf.x[["gxxc"]]), + type = "n", ylab = "Spectrum (dB)", xlab = "Frequency (1/yr)", + axes = FALSE) grid() -lines(redf.x[["freq"]], redf.x[["gxxc"]],col='#1B9E77') -lines(redf.x[["freq"]], redf.x[["ci99"]],col='#D95F02') -lines(redf.x[["freq"]], redf.x[["ci95"]],col='#7570B3') -lines(redf.x[["freq"]], redf.x[["ci90"]],col='#E7298A') +lines(redf.x[["freq"]], redf.x[["gxxc"]], col = "#1B9E77") +lines(redf.x[["freq"]], redf.x[["ci99"]], col = "#D95F02") +lines(redf.x[["freq"]], redf.x[["ci95"]], col = "#7570B3") +lines(redf.x[["freq"]], redf.x[["ci90"]], col = "#E7298A") freqs <- pretty(redf.x[["freq"]]) -pers <- round(1/freqs,2) -axis(1,at=freqs,labels=TRUE) -axis(3,at=freqs,labels=pers) -mtext(text='Period (yr)',side=3,line=1.1) -axis(2);axis(4) -legend('topright',c('x','CI99','CI95','CI90'),lwd=2, - col=c('#1B9E77','#D95F02', '#7570B3', '#E7298A'), - bg='white') +pers <- round(1 / freqs, 2) +axis(1, at = freqs, labels = TRUE) +axis(3, at = freqs, labels = pers) +mtext(text = "Period (yr)", side = 3, line = 1.1) +axis(2); axis(4) +legend("topright", c("x", "CI99", "CI95", "CI90"), lwd = 2, + col = c("#1B9E77", "#D95F02", "#7570B3", "#E7298A"), + bg = "white") box() par(op) From noreply at r-forge.r-project.org Thu Aug 29 19:07:57 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 29 Aug 2013 19:07:57 +0200 (CEST) Subject: [Dplr-commits] r671 - in branches/redfit: R src Message-ID: <20130829170757.CDDFB1851A3@r-forge.r-project.org> Author: mvkorpel Date: 2013-08-29 19:07:57 +0200 (Thu, 29 Aug 2013) New Revision: 671 Modified: branches/redfit/R/redfit.R branches/redfit/src/redfit.c Log: * Variable 'wz' (difference between successive angular frequencies) is not used anymore. Instead, angular frequencies are computed as '2 * pi * freq', where 'freq' is a frequency from the frequency vector obtained with 'seq(from = 0, to = fnyq, length.out = nfreq)': It's best to let R create a vector of evenly spaced frequencies. * The formula for 'gredth' was also simplified in the same spirit. * Instead of using 'freq[2]' with the comment 'NB: freq[2] = df', just use 'df'. Change visible to the user: the return value of redfit() no longer contains $params$wz. Modified: branches/redfit/R/redfit.R =================================================================== --- branches/redfit/R/redfit.R 2013-08-29 16:31:57 UTC (rev 670) +++ branches/redfit/R/redfit.R 2013-08-29 17:07:57 UTC (rev 671) @@ -211,20 +211,19 @@ fnyq <- params[["fnyq"]] nfreq <- params[["nfreq"]] df <- params[["df"]] - wz <- params[["wz"]] ofac <- params[["ofac"]] segskip <- params[["segskip"]] - ia <- redfitInitArrays(t, x, params) + freq <- seq(from = 0, to = fnyq, length.out = nfreq) + ia <- redfitInitArrays(t, x, freq, params) ## determine autospectrum of input data dn50 <- as.numeric(n50) cbindfun <- match.fun("cbind") lmfitfun <- tryCatch(match.fun(".lm.fit"), error = function(...) match.fun("lm.fit")) gxx <- .Call(dplR.spectr, t, x, np, ia[[1]], ia[[2]], ia[[3]], ia[[4]], - nseg, nfreq, avgdt, wz, dn50, segskip, cbindfun, lmfitfun) - freq <- seq(from = 0, by = 1, length.out = nfreq) * df + nseg, nfreq, avgdt, freq, dn50, segskip, cbindfun, lmfitfun) ## estimate data variance from autospectrum - varx <- freq[2] * sum(gxx) # NB: freq[2] = df + varx <- df * sum(gxx) ## dplR: estimate lag-1 autocorrelation coefficient unless prescribed if (is.null(rhopre) || rhopre < 0) { rho <- redfitGetrho(t, x, np, n50, nseg, avgdt, segskip) @@ -246,9 +245,9 @@ grr[, i] <- .Call(dplR.spectr, t, .Call(dplR.makear1, difft, np, tau), np, ia[[1]], ia[[2]], ia[[3]], ia[[4]], nseg, nfreq, avgdt, - wz, dn50, segskip, cbindfun, lmfitfun) + freq, dn50, segskip, cbindfun, lmfitfun) ## scale and sum red-noise spectra - varr1 <- freq[2] * sum(grr[, i]) # NB: freq[2] = df + varr1 <- df * sum(grr[, i]) grr[, i] <- varx / varr1 * grr[, i] } grrsum <- rowSums(grr) @@ -261,9 +260,9 @@ ## setup AR(1) time series and estimate its spectrum grr <- .Call(dplR.spectr, t, .Call(dplR.makear1, difft, np, tau), np, ia[[1]], ia[[2]], ia[[3]], ia[[4]], nseg, nfreq, - avgdt, wz, dn50, segskip, cbindfun, lmfitfun) + avgdt, freq, dn50, segskip, cbindfun, lmfitfun) ## scale and sum red-noise spectra - varr1 <- freq[2] * sum(grr) # NB: freq[2] = df + varr1 <- df * sum(grr) grr <- varx / varr1 * grr grrsum <- grrsum + grr } @@ -272,13 +271,14 @@ ## determine average red-noise spectrum; scale average again to ## make sure that roundoff errors do not affect the scaling grravg <- grrsum / nsim - varr2 <- freq[2] * sum(grravg) + varr2 <- df * sum(grravg) grravg <- varx / varr2 * grravg rhosq <- rho * rho ## set theoretical spectrum (e.g., Mann and Lees, 1996, Eq. 4) ## make area equal to that of the input time series - gredth <- (1 - rhosq) / (1 + rhosq - 2 * rho * cos(pi / fnyq * freq)) - varr3 <- freq[2] * sum(gredth) + gredth <- (1 - rhosq) / + (1 + rhosq - 2 * rho * cos(seq(from = 0, to = pi, length.out = nfreq))) + varr3 <- df * sum(gredth) gredth <- varx / varr3 * gredth ## determine correction factor corr <- grravg / gredth @@ -565,21 +565,20 @@ invisible(x) } -redfitInitArrays <- function(t, x, params) { +redfitInitArrays <- function(t, x, freq, params) { np <- params[["np"]] nseg <- params[["nseg"]] - nfreq <- params[["nfreq"]] + nfreqM1 <- length(freq) - 1 n50 <- params[["n50"]] iwin <- params[["iwin"]] - wz <- params[["wz"]] segskip <- params[["segskip"]] ww <- matrix(NA_real_, nseg, n50) - tsin <- array(NA_real_, c(nseg, nfreq - 1, n50)) - tcos <- array(NA_real_, c(nseg, nfreq - 1, n50)) - wtau <- matrix(NA_real_, nfreq - 1, n50) + tsin <- array(NA_real_, c(nseg, nfreqM1, n50)) + tcos <- array(NA_real_, c(nseg, nfreqM1, n50)) + wtau <- matrix(NA_real_, nfreqM1, n50) for (i in as.numeric(seq_len(n50))) { twk <- t[.Call(dplR.seg50, i, nseg, segskip, np)] - tr <- redfitTrig(twk, nseg, wz, nfreq) + tr <- redfitTrig(twk, freq) ww[, i] <- redfitWinwgt(twk, iwin) wtau[, i] <- tr[[3]] tsin[, , i] <- tr[[1]] @@ -616,7 +615,6 @@ fnyq <- hifac / (2 * avgdt) # average Nyquist freq. nfreq <- floor(hifac * ofac * nseg / 2 + 1) # f[1] == f0; f[nfreq] == fNyq df <- fnyq / (nfreq - 1) # freq. spacing - wz <- 2 * pi * fnyq / (nfreq - 1) # omega == 2*pi*f if (verbose) { cat(" N = ", np, "\n", sep="") cat(" t[1] = ", t[1], "\n", sep="") @@ -627,7 +625,7 @@ } ## dplR: ditched nout (nout == nfreq) res <- list(np = np, nseg = nseg, nfreq = nfreq, avgdt = avgdt, df = df, - wz = wz, fnyq = fnyq, n50 = n50, ofac = ofac, hifac = hifac, + fnyq = fnyq, n50 = n50, ofac = ofac, hifac = hifac, segskip = segskip) args <- list(...) argnames <- names(args) @@ -644,19 +642,21 @@ res } -redfitTrig <- function(tsamp, nn, wz, nfreq) { +redfitTrig <- function(tsamp, freq) { tol1 <- 1.0e-4 - nfreqM1 <- nfreq - 1 + nfreqM1 <- length(freq) - 1 + nn <- length(tsamp) tcos <- matrix(NA_real_, nn, nfreqM1) tsin <- matrix(NA_real_, nn, nfreqM1) wtau <- numeric(nfreqM1) + wfac <- 2 * pi # omega == 2*pi*f ## start frequency loop ## dplR: In the original Fortran code, the variables ww (not used ## in this function), wtau, tsin and tcos have unused elements ## (one extra frequency). The unused elements have now been ## dropped. for (k in seq_len(nfreqM1)) { - wrun <- k * wz + wrun <- wfac * freq[k + 1] ## calc. tau arg2 <- wrun * tsamp arg1 <- arg2 + arg2 Modified: branches/redfit/src/redfit.c =================================================================== --- branches/redfit/src/redfit.c 2013-08-29 16:31:57 UTC (rev 670) +++ branches/redfit/src/redfit.c 2013-08-29 17:07:57 UTC (rev 671) @@ -26,10 +26,10 @@ SEXP seg50(SEXP k, SEXP nseg, SEXP segskip, SEXP np); void rmtrend(SEXP x, SEXP y, SEXP lmfit); SEXP spectr(SEXP t, SEXP x, SEXP np, SEXP ww, SEXP tsin, SEXP tcos, SEXP wtau, - SEXP nseg, SEXP nfreq, SEXP avgdt, SEXP wz, SEXP n50, + SEXP nseg, SEXP nfreq, SEXP avgdt, SEXP freq, SEXP n50, SEXP segskip, SEXP cbind, SEXP lmfit); void ftfix(const double *xx, const double *tsamp, const size_t nxx, - const double wz, const size_t nfreq, const long double si, + const double *freq, const size_t nfreq, const long double si, const size_t lfreq, const double tzero, const double *tcos, const double *tsin, const double *wtau, const long double sumbysqrt, double *ftrx, double *ftix); @@ -142,16 +142,16 @@ /* dplR: Returns the spectrum of x(t), a vector of length nfreq. */ SEXP spectr(SEXP t, SEXP x, SEXP np, SEXP ww, SEXP tsin, SEXP tcos, SEXP wtau, - SEXP nseg, SEXP nfreq, SEXP avgdt, SEXP wz, SEXP n50, + SEXP nseg, SEXP nfreq, SEXP avgdt, SEXP freq, SEXP n50, SEXP segskip, SEXP cbind, SEXP lmfit) { SEXP gxx, twk, xwk, ftrx, ftix, tmp, cbindcall; - double wz_val, dnseg, sqrt_nseg, segskip_val, scal, np_val; + double dnseg, sqrt_nseg, segskip_val, scal, np_val; long double sumx; size_t i, j, nseg_val, nfreq_val, n50_val, segstart; size_t sincos_skip, wtau_skip; size_t wwidx = 0; double *t_data, *x_data, *ww_data, *tsin_data, *tcos_data, *wtau_data; - double *gxx_data, *twk_data, *xwk_data, *ftrx_data, *ftix_data; + double *gxx_data, *twk_data, *xwk_data, *ftrx_data, *ftix_data, *freq_data; const long double si = 1.0; const double tzero = 0.0; const size_t lfreq = 0; @@ -161,7 +161,6 @@ nseg_val = (size_t) dnseg; nfreq_val = (size_t) *REAL(nfreq); np_val = *REAL(np); - wz_val = *REAL(wz); n50_val = (size_t) *REAL(n50); segskip_val = *REAL(segskip); t_data = REAL(t); @@ -170,6 +169,7 @@ tsin_data = REAL(tsin); tcos_data = REAL(tcos); wtau_data = REAL(wtau); + freq_data = REAL(freq); PROTECT(gxx = allocVector(REALSXP, nfreq_val)); PROTECT_WITH_INDEX(twk = allocVector(REALSXP, nseg_val), &pidx); @@ -220,7 +220,7 @@ sumx += xwk_data[j]; } /* Lomb?Scargle Fourier transform */ - ftfix(xwk_data, twk_data, nseg_val, wz_val, nfreq_val, si, + ftfix(xwk_data, twk_data, nseg_val, freq_data, nfreq_val, si, lfreq, tzero, tcos_data, tsin_data, wtau_data, sumx / (long double) sqrt_nseg, ftrx_data, ftix_data); /* dplR: adjust tsin, tcos, wtau for next segment */ @@ -263,7 +263,7 @@ * index corresponding to nxx runs faster. */ void ftfix(const double *xx, const double *tsamp, const size_t nxx, - const double wz, const size_t nfreq, const long double si, + const double *freq, const size_t nfreq, const long double si, const size_t lfreq, const double tzero, const double *tcos, const double *tsin, const double *wtau, const long double sumbysqrt, double *ftrx, double *ftix) { @@ -284,7 +284,7 @@ ftix[0] = 0.0; /* start frequency loop */ for (ii = 1; ii < nfreq; ii++) { - wrun = (double) ii * wz; + wrun = M_2PI * freq[ii]; /* omega = 2 * pi * freq */ wtnew = wtau[ii - 1]; /* summations over the sample */ cross = 0.0; From noreply at r-forge.r-project.org Thu Aug 29 19:24:22 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 29 Aug 2013 19:24:22 +0200 (CEST) Subject: [Dplr-commits] r672 - branches/redfit/R Message-ID: <20130829172422.F3B76184DB2@r-forge.r-project.org> Author: mvkorpel Date: 2013-08-29 19:24:22 +0200 (Thu, 29 Aug 2013) New Revision: 672 Modified: branches/redfit/R/redfit.R Log: Removed internal function arguments that were not used ('avgdt') or not needed ('np'). Modified: branches/redfit/R/redfit.R =================================================================== --- branches/redfit/R/redfit.R 2013-08-29 17:07:57 UTC (rev 671) +++ branches/redfit/R/redfit.R 2013-08-29 17:24:22 UTC (rev 672) @@ -203,7 +203,7 @@ difft <- rep.int(1.0, np) } ## dplR: Setup - params <- redfitSetdim(MIN_POINTS, t, np, ofac, hifac, n50, verbose, + params <- redfitSetdim(MIN_POINTS, t, ofac, hifac, n50, verbose, iwin = iwin2, nsim = nsim, mctest = mctest, rhopre = rhopre) avgdt <- params[["avgdt"]] @@ -226,7 +226,7 @@ varx <- df * sum(gxx) ## dplR: estimate lag-1 autocorrelation coefficient unless prescribed if (is.null(rhopre) || rhopre < 0) { - rho <- redfitGetrho(t, x, np, n50, nseg, avgdt, segskip) + rho <- redfitGetrho(t, x, n50, nseg, segskip) } else { rho <- rhopre } @@ -587,7 +587,8 @@ list(ww = ww, tsin = tsin, tcos = tcos, wtau = wtau) } -redfitSetdim <- function(min.nseg, t, np, ofac, hifac, n50, verbose, ...) { +redfitSetdim <- function(min.nseg, t, ofac, hifac, n50, verbose, ...) { + np <- length(t) ## dplR: Formula for nseg from the original Fortran version: ## Integer division (or truncation, or "floor"). ## nseg <- (2 * np) %/% (n50 + 1) @@ -717,15 +718,15 @@ } ## dplR: was gettau, converted to return rho only -redfitGetrho <- function(t, x, np, n50, nseg, avgdt, segskip) { +redfitGetrho <- function(t, x, n50, nseg, segskip) { rhosum <- 0 - np2 <- as.numeric(np) + np <- as.numeric(length(x)) nseg2 <- as.numeric(nseg) segskip2 <- as.numeric(segskip) rhovec <- numeric(n50) for (i in as.numeric(seq_len(n50))) { ## copy data of (i+1)'th segment into workspace - iseg <- .Call(dplR.seg50, i, nseg2, segskip2, np2) + iseg <- .Call(dplR.seg50, i, nseg2, segskip2, np) twk <- t[iseg] xwk <- x[iseg] ## detrend data From noreply at r-forge.r-project.org Thu Aug 29 19:39:48 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 29 Aug 2013 19:39:48 +0200 (CEST) Subject: [Dplr-commits] r673 - branches/redfit/R Message-ID: <20130829173948.5F52C185879@r-forge.r-project.org> Author: mvkorpel Date: 2013-08-29 19:39:47 +0200 (Thu, 29 Aug 2013) New Revision: 673 Modified: branches/redfit/R/redfit.R Log: * do not overwrite 'ofac' in redfit() * removed unused local variables 'rhosum' and 'tp' from redfitGetrho() and redfitSetdim(), respectively * removed unused parameter 'x' from redfitInitarrays() Modified: branches/redfit/R/redfit.R =================================================================== --- branches/redfit/R/redfit.R 2013-08-29 17:24:22 UTC (rev 672) +++ branches/redfit/R/redfit.R 2013-08-29 17:39:47 UTC (rev 673) @@ -211,10 +211,9 @@ fnyq <- params[["fnyq"]] nfreq <- params[["nfreq"]] df <- params[["df"]] - ofac <- params[["ofac"]] segskip <- params[["segskip"]] freq <- seq(from = 0, to = fnyq, length.out = nfreq) - ia <- redfitInitArrays(t, x, freq, params) + ia <- redfitInitArrays(t, freq, params) ## determine autospectrum of input data dn50 <- as.numeric(n50) cbindfun <- match.fun("cbind") @@ -565,7 +564,7 @@ invisible(x) } -redfitInitArrays <- function(t, x, freq, params) { +redfitInitArrays <- function(t, freq, params) { np <- params[["np"]] nseg <- params[["nseg"]] nfreqM1 <- length(freq) - 1 @@ -612,7 +611,6 @@ ## original Fortran version because it would not use all of the ## data (t[np]) with some combinations of np and n50. avgdt <- (t[np] - t[1]) / (np - 1) # avg. sampling interval - tp <- avgdt * nseg # average period of a segment fnyq <- hifac / (2 * avgdt) # average Nyquist freq. nfreq <- floor(hifac * ofac * nseg / 2 + 1) # f[1] == f0; f[nfreq] == fNyq df <- fnyq / (nfreq - 1) # freq. spacing @@ -719,7 +717,6 @@ ## dplR: was gettau, converted to return rho only redfitGetrho <- function(t, x, n50, nseg, segskip) { - rhosum <- 0 np <- as.numeric(length(x)) nseg2 <- as.numeric(nseg) segskip2 <- as.numeric(segskip) From noreply at r-forge.r-project.org Fri Aug 30 21:04:52 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 30 Aug 2013 21:04:52 +0200 (CEST) Subject: [Dplr-commits] r674 - branches/redfit/src Message-ID: <20130830190452.1FEC6180FAF@r-forge.r-project.org> Author: mvkorpel Date: 2013-08-30 21:04:51 +0200 (Fri, 30 Aug 2013) New Revision: 674 Modified: branches/redfit/src/redfit.c Log: In makear1(), variable 'sigma' was removed. Its value is now computed as part of one statement (red_data[i] = ...). Modified: branches/redfit/src/redfit.c =================================================================== --- branches/redfit/src/redfit.c 2013-08-29 17:39:47 UTC (rev 673) +++ branches/redfit/src/redfit.c 2013-08-30 19:04:51 UTC (rev 674) @@ -85,7 +85,7 @@ return(seg); } -/* dplR: y <- lm.fit(x, y)[["residuals"]] +/* dplR: y <- lmfit(x, y)[["residuals"]] */ void rmtrend(SEXP x, SEXP y, SEXP lmfit) { SEXP tmp, lmcall, lmres, lmnames, rduals; @@ -189,7 +189,7 @@ /* dplR: twk_data points to the non-constant column; the constant * column will not be altered */ twk_data = REAL(twk) + nseg_val; - + PROTECT(xwk = allocVector(REALSXP, nseg_val)); /* dplR: unused halves of ftrx and ftix were removed */ PROTECT(ftrx = allocVector(REALSXP, nfreq_val)); @@ -276,7 +276,7 @@ double complex work; size_t i, ii, iput; size_t idx = 0; - + const2 = si * const1; const3 = (double)(const2 * sumbysqrt); /* initialize for zero frequency */ @@ -338,7 +338,7 @@ * of length 'np - 1'. */ SEXP makear1(SEXP difft, SEXP np, SEXP tau) { - double sigma, dt, tau_val, np_val; + double dt, tau_val, np_val; double *difft_data, *red_data; SEXP red; size_t i; @@ -352,8 +352,8 @@ red_data[0] = norm_rand(); for (i = 1; i < np_val; i++) { dt = difft_data[i - 1]; - sigma = sqrt(1.0 - exp(-2.0 * dt / tau_val)); - red_data[i] = exp(-dt / tau_val) * red_data[i-1] + sigma * norm_rand(); + red_data[i] = exp(-dt / tau_val) * red_data[i-1] + + sqrt(1.0 - exp(-2.0 * dt / tau_val)) * norm_rand(); } PutRNGstate(); UNPROTECT(1); From noreply at r-forge.r-project.org Fri Aug 30 22:48:32 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 30 Aug 2013 22:48:32 +0200 (CEST) Subject: [Dplr-commits] r675 - branches/redfit/src Message-ID: <20130830204832.5AEAB18513B@r-forge.r-project.org> Author: mvkorpel Date: 2013-08-30 22:48:31 +0200 (Fri, 30 Aug 2013) New Revision: 675 Modified: branches/redfit/src/redfit.c Log: Fixed or adjusted things related to precision of floating point variables and operations. Note: Unless I have missed something, the seemingly high precision (about 30 digits) of mathematical constants in Rmath.h is wasted because the definition of each constant lacks the L or l suffix required for long double literals: the compiler treats them as double precision numbers (about 15 digits of precision). Modified: branches/redfit/src/redfit.c =================================================================== --- branches/redfit/src/redfit.c 2013-08-30 19:04:51 UTC (rev 674) +++ branches/redfit/src/redfit.c 2013-08-30 20:48:31 UTC (rev 675) @@ -29,7 +29,7 @@ SEXP nseg, SEXP nfreq, SEXP avgdt, SEXP freq, SEXP n50, SEXP segskip, SEXP cbind, SEXP lmfit); void ftfix(const double *xx, const double *tsamp, const size_t nxx, - const double *freq, const size_t nfreq, const long double si, + const double *freq, const size_t nfreq, const double si, const size_t lfreq, const double tzero, const double *tcos, const double *tsin, const double *wtau, const long double sumbysqrt, double *ftrx, double *ftix); @@ -145,14 +145,14 @@ SEXP nseg, SEXP nfreq, SEXP avgdt, SEXP freq, SEXP n50, SEXP segskip, SEXP cbind, SEXP lmfit) { SEXP gxx, twk, xwk, ftrx, ftix, tmp, cbindcall; - double dnseg, sqrt_nseg, segskip_val, scal, np_val; - long double sumx; + double dnseg, segskip_val, scal, np_val; + long double sumx, sqrt_nseg; size_t i, j, nseg_val, nfreq_val, n50_val, segstart; size_t sincos_skip, wtau_skip; size_t wwidx = 0; double *t_data, *x_data, *ww_data, *tsin_data, *tcos_data, *wtau_data; double *gxx_data, *twk_data, *xwk_data, *ftrx_data, *ftix_data, *freq_data; - const long double si = 1.0; + const double si = 1.0; const double tzero = 0.0; const size_t lfreq = 0; PROTECT_INDEX pidx; @@ -198,7 +198,7 @@ xwk_data = REAL(xwk); ftrx_data = REAL(ftrx); ftix_data = REAL(ftix); - sqrt_nseg = (long double) sqrt(dnseg); + sqrt_nseg = sqrtl((long double) dnseg); wtau_skip = nfreq_val - 1; sincos_skip = wtau_skip * nseg_val; for (i = 0; i < nfreq_val; i++) { @@ -214,7 +214,7 @@ /* detrend data */ rmtrend(twk, xwk, lmfit); /* apply window to data */ - sumx = 0.0; + sumx = 0.0L; for (j = 0; j < nseg_val; j++) { xwk_data[j] *= ww_data[wwidx++]; sumx += xwk_data[j]; @@ -222,7 +222,7 @@ /* Lomb?Scargle Fourier transform */ ftfix(xwk_data, twk_data, nseg_val, freq_data, nfreq_val, si, lfreq, tzero, tcos_data, tsin_data, wtau_data, - sumx / (long double) sqrt_nseg, ftrx_data, ftix_data); + sumx / sqrt_nseg, ftrx_data, ftix_data); /* dplR: adjust tsin, tcos, wtau for next segment */ tsin_data += sincos_skip; tcos_data += sincos_skip; @@ -263,14 +263,14 @@ * index corresponding to nxx runs faster. */ void ftfix(const double *xx, const double *tsamp, const size_t nxx, - const double *freq, const size_t nfreq, const long double si, + const double *freq, const size_t nfreq, const double si, const size_t lfreq, const double tzero, const double *tcos, const double *tsin, const double *wtau, const long double sumbysqrt, double *ftrx, double *ftix) { - const double tol1 = 1.0e-4; + const double_t tol1 = 1.0e-4; const double tol2 = 1.0e-8; - const long double const1 = M_SQRT1_2; - long double const2; + const double_t const1 = M_SQRT1_2; + double_t const2; double const3, ftrd, ftid, phase, wtnew, tmpsin, tmpcos, wrun; long double cross, sumr, sumi, scos2, ssin2; double complex work; @@ -287,11 +287,11 @@ wrun = M_2PI * freq[ii]; /* omega = 2 * pi * freq */ wtnew = wtau[ii - 1]; /* summations over the sample */ - cross = 0.0; - scos2 = 0.0; - ssin2 = 0.0; - sumr = 0.0; - sumi = 0.0; + cross = 0.0L; + scos2 = 0.0L; + ssin2 = 0.0L; + sumr = 0.0L; + sumi = 0.0L; for (i = 0; i < nxx; i++) { tmpsin = tsin[idx]; tmpcos = tcos[idx]; @@ -306,7 +306,7 @@ if (ssin2 <= tol1) { ftid = (fabs((double)cross) > tol2) ? 0.0 : const3; } else { - ftid = const2 * sumi / sqrt(ssin2); + ftid = const2 * (double_t)sumi / sqrt((double)ssin2); } phase = wtnew - wrun * tzero; /* dplR: C99 complex numbers */