From noreply at r-forge.r-project.org Tue Sep 3 13:45:50 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 3 Sep 2013 13:45:50 +0200 (CEST) Subject: [Dplr-commits] r676 - in branches/redfit: R src Message-ID: <20130903114550.E3239185C0A@r-forge.r-project.org> Author: mvkorpel Date: 2013-09-03 13:45:50 +0200 (Tue, 03 Sep 2013) New Revision: 676 Modified: branches/redfit/R/redfit.R branches/redfit/src/redfit.c Log: * Removed parameter 'cbind' from C function spectr(): lookup now done in C code * In C function rmtrend(), use R version of length(): theoretical support for long vectors while not requiring R >= 3.0.0 Modified: branches/redfit/R/redfit.R =================================================================== --- branches/redfit/R/redfit.R 2013-08-30 20:48:31 UTC (rev 675) +++ branches/redfit/R/redfit.R 2013-09-03 11:45:50 UTC (rev 676) @@ -216,11 +216,10 @@ ia <- redfitInitArrays(t, 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, freq, dn50, segskip, cbindfun, lmfitfun) + nseg, nfreq, avgdt, freq, dn50, segskip, lmfitfun) ## estimate data variance from autospectrum varx <- df * sum(gxx) ## dplR: estimate lag-1 autocorrelation coefficient unless prescribed @@ -244,7 +243,7 @@ grr[, i] <- .Call(dplR.spectr, t, .Call(dplR.makear1, difft, np, tau), np, ia[[1]], ia[[2]], ia[[3]], ia[[4]], nseg, nfreq, avgdt, - freq, dn50, segskip, cbindfun, lmfitfun) + freq, dn50, segskip, lmfitfun) ## scale and sum red-noise spectra varr1 <- df * sum(grr[, i]) grr[, i] <- varx / varr1 * grr[, i] @@ -259,7 +258,7 @@ ## 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, freq, dn50, segskip, cbindfun, lmfitfun) + avgdt, freq, dn50, segskip, lmfitfun) ## scale and sum red-noise spectra varr1 <- df * sum(grr) grr <- varx / varr1 * grr Modified: branches/redfit/src/redfit.c =================================================================== --- branches/redfit/src/redfit.c 2013-08-30 20:48:31 UTC (rev 675) +++ branches/redfit/src/redfit.c 2013-09-03 11:45:50 UTC (rev 676) @@ -24,10 +24,10 @@ #include SEXP seg50(SEXP k, SEXP nseg, SEXP segskip, SEXP np); -void rmtrend(SEXP x, SEXP y, SEXP lmfit); +void rmtrend(SEXP x, SEXP y, SEXP lengthfun, 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 freq, SEXP n50, - SEXP segskip, SEXP cbind, SEXP lmfit); + SEXP segskip, SEXP lmfit); void ftfix(const double *xx, const double *tsamp, const size_t nxx, const double *freq, const size_t nfreq, const double si, const size_t lfreq, const double tzero, const double *tcos, @@ -87,11 +87,13 @@ /* dplR: y <- lmfit(x, y)[["residuals"]] */ -void rmtrend(SEXP x, SEXP y, SEXP lmfit) { +void rmtrend(SEXP x, SEXP y, SEXP lengthfun, SEXP lmfit) { SEXP tmp, lmcall, lmres, lmnames, rduals; + SEXP sn, ncall; + PROTECT_INDEX ipx; double *rdualsptr, *y_data; - int i, nameslength; - int n = 0; + size_t i, nameslength; + size_t n = 0; Rboolean found = FALSE; Rboolean mismatch = TRUE; @@ -105,7 +107,14 @@ /* dplR: get residuals from the list given by lm.fit(x, y) */ lmnames = getAttrib(lmres, R_NamesSymbol); - nameslength = length(lmnames); + PROTECT(tmp = ncall = allocList(2)); + SET_TYPEOF(ncall, LANGSXP); + SETCAR(tmp, lengthfun); tmp = CDR(tmp); + SETCAR(tmp, lmnames); + PROTECT_WITH_INDEX(sn = eval(ncall, R_GlobalEnv), &ipx); + REPROTECT(sn = coerceVector(sn, REALSXP), ipx); + nameslength = (size_t) *REAL(sn); + UNPROTECT(2); for (i = 0; i < nameslength; i++) { if (strcmp(CHAR(STRING_ELT(lmnames, i)), "residuals") == 0) { rduals = VECTOR_ELT(lmres, i); @@ -115,10 +124,24 @@ } } + /* dplR: compare length of y with length of residuals */ + PROTECT(tmp = ncall = allocList(2)); + SET_TYPEOF(ncall, LANGSXP); + SETCAR(tmp, lengthfun); tmp = CDR(tmp); + SETCAR(tmp, y); + PROTECT_WITH_INDEX(sn = eval(ncall, R_GlobalEnv), &ipx); + REPROTECT(sn = coerceVector(sn, REALSXP), ipx); + n = (size_t) *REAL(sn); + UNPROTECT(1); if (found) { - n = length(rduals); - mismatch = n != length(y); + SETCAR(tmp, rduals); + PROTECT_WITH_INDEX(sn = eval(ncall, R_GlobalEnv), &ipx); + REPROTECT(sn = coerceVector(sn, REALSXP), ipx); + mismatch = n != (size_t) *REAL(sn); + UNPROTECT(1); } + UNPROTECT(1); + y_data = REAL(y); if (!mismatch) { rdualsptr = REAL(rduals); @@ -127,7 +150,6 @@ y_data[i] = rdualsptr[i]; } } else { - n = length(y); for (i = 0; i < n; i++) { y_data[i] = NA_REAL; } @@ -143,8 +165,8 @@ */ SEXP spectr(SEXP t, SEXP x, SEXP np, SEXP ww, SEXP tsin, SEXP tcos, SEXP wtau, SEXP nseg, SEXP nfreq, SEXP avgdt, SEXP freq, SEXP n50, - SEXP segskip, SEXP cbind, SEXP lmfit) { - SEXP gxx, twk, xwk, ftrx, ftix, tmp, cbindcall; + SEXP segskip, SEXP lmfit) { + SEXP gxx, twk, xwk, ftrx, ftix, tmp, cbindcall, lengthfun; double dnseg, segskip_val, scal, np_val; long double sumx, sqrt_nseg; size_t i, j, nseg_val, nfreq_val, n50_val, segstart; @@ -182,7 +204,7 @@ * though.*/ PROTECT(tmp = cbindcall = allocList(3)); SET_TYPEOF(cbindcall, LANGSXP); - SETCAR(tmp, cbind); tmp = CDR(tmp); + SETCAR(tmp, install("cbind")); tmp = CDR(tmp); SETCAR(tmp, ScalarReal(1.0)); tmp = CDR(tmp); SETCAR(tmp, twk); REPROTECT(twk = eval(cbindcall, R_GlobalEnv), pidx); @@ -204,6 +226,7 @@ for (i = 0; i < nfreq_val; i++) { gxx_data[i] = 0.0; } + lengthfun = install("length"); for (i = 0; i < n50_val; i++) { /* copy data of i'th segment into workspace */ segstart = (size_t) segfirst((double) i, segskip_val, np_val, dnseg); @@ -212,7 +235,7 @@ xwk_data[j] = x_data[segstart + j]; } /* detrend data */ - rmtrend(twk, xwk, lmfit); + rmtrend(twk, xwk, lengthfun, lmfit); /* apply window to data */ sumx = 0.0L; for (j = 0; j < nseg_val; j++) { From noreply at r-forge.r-project.org Tue Sep 3 15:01:10 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 3 Sep 2013 15:01:10 +0200 (CEST) Subject: [Dplr-commits] r677 - branches/redfit/src Message-ID: <20130903130110.EB6781806EB@r-forge.r-project.org> Author: mvkorpel Date: 2013-09-03 15:01:10 +0200 (Tue, 03 Sep 2013) New Revision: 677 Modified: branches/redfit/src/redfit.c Log: Use memcpy for copying Modified: branches/redfit/src/redfit.c =================================================================== --- branches/redfit/src/redfit.c 2013-09-03 11:45:50 UTC (rev 676) +++ branches/redfit/src/redfit.c 2013-09-03 13:01:10 UTC (rev 677) @@ -22,6 +22,7 @@ #include #include #include +#include SEXP seg50(SEXP k, SEXP nseg, SEXP segskip, SEXP np); void rmtrend(SEXP x, SEXP y, SEXP lengthfun, SEXP lmfit); @@ -91,7 +92,7 @@ SEXP tmp, lmcall, lmres, lmnames, rduals; SEXP sn, ncall; PROTECT_INDEX ipx; - double *rdualsptr, *y_data; + double *y_data; size_t i, nameslength; size_t n = 0; Rboolean found = FALSE; @@ -144,11 +145,8 @@ y_data = REAL(y); if (!mismatch) { - rdualsptr = REAL(rduals); /* dplR: Copy residuals over y */ - for (i = 0; i < n; i++) { - y_data[i] = rdualsptr[i]; - } + memcpy(y_data, REAL(rduals), n * sizeof(double)); } else { for (i = 0; i < n; i++) { y_data[i] = NA_REAL; @@ -169,7 +167,7 @@ SEXP gxx, twk, xwk, ftrx, ftix, tmp, cbindcall, lengthfun; 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 i, j, nseg_val, nfreq_val, n50_val, segstart, ncopy; size_t sincos_skip, wtau_skip; size_t wwidx = 0; double *t_data, *x_data, *ww_data, *tsin_data, *tcos_data, *wtau_data; @@ -227,13 +225,12 @@ gxx_data[i] = 0.0; } lengthfun = install("length"); + ncopy = nseg_val * sizeof(double); for (i = 0; i < n50_val; i++) { /* copy data of i'th segment into workspace */ segstart = (size_t) segfirst((double) i, segskip_val, np_val, dnseg); - for (j = 0; j < nseg_val; j++) { - twk_data[j] = t_data[segstart + j]; - xwk_data[j] = x_data[segstart + j]; - } + memcpy(twk_data, t_data + segstart, ncopy); + memcpy(xwk_data, x_data + segstart, ncopy); /* detrend data */ rmtrend(twk, xwk, lengthfun, lmfit); /* apply window to data */ From noreply at r-forge.r-project.org Tue Sep 3 17:13:49 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 3 Sep 2013 17:13:49 +0200 (CEST) Subject: [Dplr-commits] r678 - branches/redfit/R Message-ID: <20130903151349.2562D1855D5@r-forge.r-project.org> Author: mvkorpel Date: 2013-09-03 17:13:48 +0200 (Tue, 03 Sep 2013) New Revision: 678 Modified: branches/redfit/R/redfit.R Log: Small optimizations: * reorganization of array initialization, * lm.fit() or .lm.fit() in redfitGetrho() Modified: branches/redfit/R/redfit.R =================================================================== --- branches/redfit/R/redfit.R 2013-09-03 13:01:10 UTC (rev 677) +++ branches/redfit/R/redfit.R 2013-09-03 15:13:48 UTC (rev 678) @@ -212,19 +212,24 @@ nfreq <- params[["nfreq"]] df <- params[["df"]] segskip <- params[["segskip"]] + dn50 <- params[["n50"]] freq <- seq(from = 0, to = fnyq, length.out = nfreq) - ia <- redfitInitArrays(t, freq, params) + tr <- redfitTrig(t, freq, nseg, dn50, segskip) + ww <- matrix(NA_real_, nseg, dn50) + for (i in as.numeric(seq_len(dn50))) { + twk <- t[.Call(dplR.seg50, i, nseg, segskip, np)] + ww[, i] <- redfitWinwgt(twk, iwin2) + } ## determine autospectrum of input data - dn50 <- as.numeric(n50) 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]], + gxx <- .Call(dplR.spectr, t, x, np, ww, tr[[1]], tr[[2]], tr[[3]], nseg, nfreq, avgdt, freq, dn50, segskip, lmfitfun) ## estimate data variance from autospectrum varx <- df * sum(gxx) ## dplR: estimate lag-1 autocorrelation coefficient unless prescribed if (is.null(rhopre) || rhopre < 0) { - rho <- redfitGetrho(t, x, n50, nseg, segskip) + rho <- redfitGetrho(t, x, dn50, nseg, segskip, lmfitfun) } else { rho <- rhopre } @@ -242,7 +247,7 @@ ## 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, + ww, tr[[1]], tr[[2]], tr[[3]], nseg, nfreq, avgdt, freq, dn50, segskip, lmfitfun) ## scale and sum red-noise spectra varr1 <- df * sum(grr[, i]) @@ -257,7 +262,7 @@ } ## 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, + np, ww, tr[[1]], tr[[2]], tr[[3]], nseg, nfreq, avgdt, freq, dn50, segskip, lmfitfun) ## scale and sum red-noise spectra varr1 <- df * sum(grr) @@ -563,28 +568,6 @@ invisible(x) } -redfitInitArrays <- function(t, freq, params) { - np <- params[["np"]] - nseg <- params[["nseg"]] - nfreqM1 <- length(freq) - 1 - n50 <- params[["n50"]] - iwin <- params[["iwin"]] - segskip <- params[["segskip"]] - ww <- matrix(NA_real_, nseg, 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, freq) - 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, ofac, hifac, n50, verbose, ...) { np <- length(t) ## dplR: Formula for nseg from the original Fortran version: @@ -640,41 +623,46 @@ res } -redfitTrig <- function(tsamp, freq) { +redfitTrig <- function(t, freq, nseg, n50, segskip) { + np <- as.numeric(length(t)) tol1 <- 1.0e-4 nfreqM1 <- length(freq) - 1 - nn <- length(tsamp) - tcos <- matrix(NA_real_, nn, nfreqM1) - tsin <- matrix(NA_real_, nn, nfreqM1) - wtau <- numeric(nfreqM1) + tsin <- array(NA_real_, c(nseg, nfreqM1, n50)) + tcos <- array(NA_real_, c(nseg, nfreqM1, n50)) + wtau <- matrix(NA_real_, nfreqM1, n50) 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 <- wfac * freq[k + 1] - ## 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) + ## start segment loop + for (j in as.numeric(seq_len(n50))) { + tsamp <- t[.Call(dplR.seg50, j, nseg, segskip, np)] + ## 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 <- wfac * freq[k + 1] + ## 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, j] <- wtnew + ## summations over the sample + ## dplR: Summations can be found above, but these are not... + arg2 <- arg2 - wtnew + tcos[, k, j] <- cos(arg2) + tsin[, k, j] <- sin(arg2) + } } list(tsin = tsin, tcos = tcos, wtau = wtau) } @@ -715,23 +703,24 @@ } ## dplR: was gettau, converted to return rho only -redfitGetrho <- function(t, x, n50, nseg, segskip) { +redfitGetrho <- function(t, x, n50, nseg, segskip, lmfitfun) { np <- as.numeric(length(x)) nseg2 <- as.numeric(nseg) segskip2 <- as.numeric(segskip) rhovec <- numeric(n50) + twkM <- matrix(1, nseg2, 2) for (i in as.numeric(seq_len(n50))) { ## copy data of (i+1)'th segment into workspace iseg <- .Call(dplR.seg50, i, nseg2, segskip2, np) twk <- t[iseg] + twkM[, 2] <- twk xwk <- x[iseg] ## detrend data - xwk <- as.vector(residuals(lm(xwk ~ twk))) + xwk <- do.call(lmfitfun, list(twkM, xwk))[["residuals"]] ## estimate and sum rho for each segment rho <- redfitTauest(twk, xwk) ## bias correction for rho (Kendall & Stuart, 1967; Vol. 3)) - rho <- (rho * (nseg2 - 1) + 1) / (nseg2 - 4) - rhovec[i] <- rho + rhovec[i] <- (rho * (nseg2 - 1) + 1) / (nseg2 - 4) } ## average rho mean(rhovec) From noreply at r-forge.r-project.org Wed Sep 4 10:00:54 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 4 Sep 2013 10:00:54 +0200 (CEST) Subject: [Dplr-commits] r679 - in branches/redfit: R man Message-ID: <20130904080054.DBA66185C53@r-forge.r-project.org> Author: mvkorpel Date: 2013-09-04 10:00:54 +0200 (Wed, 04 Sep 2013) New Revision: 679 Modified: branches/redfit/R/redfit.R branches/redfit/man/redfit.Rd Log: In redfit.R: * rcritlo and rcrithi are returned by redfit(), not computed in print.redfit(). * rcnt is not computed if the conditions of the statistical test are not met. * small optimizations in print.redfit() In redfit.Rd: * Added reference, Bendat & Piersol: Random Data. Still need to find the book and check facts. * Documented rcritlo, rcrithi and rhopre. Modified: branches/redfit/R/redfit.R =================================================================== --- branches/redfit/R/redfit.R 2013-09-03 15:13:48 UTC (rev 678) +++ branches/redfit/R/redfit.R 2013-09-04 08:00:54 UTC (rev 679) @@ -311,16 +311,34 @@ 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) + ## 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. + if (iwin2 == 0 && ofac == 1 && dn50 == 1) { + rcnt <- 1 + sum(diff(sign(gxxc - gredth)) != 0) + ## 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) + } else { + rcnt <- NULL + rcritlo <- NULL + rcrithi <- NULL + } ## 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 + ## rcritlo critical low value for rcnt + ## rcrithi critical high value for rcnt ## freq frequency vector ## gxx autospectrum of input data ## gxxc corrected autospectrum of input data @@ -331,10 +349,10 @@ ## 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) + ## call how the function was called + ## 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) dplrNS <- tryCatch(getNamespace("dplR"), error = function(...) NULL) if (!is.null(dplrNS) && exists("redfit", dplrNS) && identical(match.fun(as.list(cl)[[1]]), get("redfit", dplrNS))) { @@ -343,6 +361,7 @@ vers <- NULL } res <- list(varx = varx, rho = rho, tau = tau, rcnt = rcnt, + rcritlo = rcritlo, rcrithi = rcrithi, freq = freq, gxx = gxx, gxxc = gxxc, grravg = grravg, gredth = gredth, corr = corr, ci80 = ci80, ci90 = ci90, ci95 = ci95, ci99 = ci99, @@ -396,11 +415,7 @@ 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 @@ -413,27 +428,6 @@ 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, @@ -449,6 +443,16 @@ } if (!csv.out) { ## dplR: print miscellaneous information AND if (do.table) print(dframe) + nseg <- params[["nseg"]] + ofac <- params[["ofac"]] + rhopre <- params[["rhopre"]] + + ## 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 + precat("redfit()", newline = FALSE) vers <- x[["vers"]] if (!is.null(vers)) { @@ -513,13 +517,16 @@ domain = "R-dplR") precat(gtxt) precat(rep.int("-", nchar(gtxt))) - if (iwin == 0 && ofac == 1 && n50 == 1) { + rcnt <- x[["rcnt"]] + if (!is.null(rcnt)) { gtxt <- gettext("5-% acceptance region:", domain = "R-dplR") precat(gtxt, newline = FALSE) - cat(" rcritlo = ", format(rcritlo, digits = digits), "\n", sep = "") + cat(" rcritlo = ", format(x[["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)) + cat(" rcrithi = ", format(x[["rcrithi"]], digits = digits), "\n", + sep = "") + precat("r_test = ", format(rcnt, digits = digits)) } else { if (iwin != 0) { precat(gettext("Test requires iwin = 0", domain = "R-dplR")) Modified: branches/redfit/man/redfit.Rd =================================================================== --- branches/redfit/man/redfit.Rd 2013-09-03 15:13:48 UTC (rev 678) +++ branches/redfit/man/redfit.Rd 2013-09-04 08:00:54 UTC (rev 679) @@ -110,8 +110,22 @@ \item{rcnt }{ a \code{numeric} value giving the number of runs in a statistical test studying the difference between a theoretical AR1 - spectrum and the bias-corrected spectrum estimated from the data. } + spectrum and the bias-corrected spectrum estimated from the data. + Requires that \code{\var{iwin} == 0} (\code{"rectangular"}), + \code{\var{ofac} == 1} and \code{\var{n50} == 1}. Otherwise the + test is not performed and \var{rcnt} is \code{NULL}. See Bendat and + Piersol, p. 95. } + \item{rcritlo }{ a \code{numeric} critical low value for + \code{\var{rcnt}}. Approximately 2.5 percent of the null + distribution lies below this value (TO BE CHECKED). Is \code{NULL} + when \code{\var{rcnt}} is \code{NULL}. } + + \item{rcritlo }{ a \code{numeric} critical high value for + \code{\var{rcnt}}. Approximately 2.5 percent of the null + distribution lies above this value (TO BE CHECKED). Is \code{NULL} + when \code{\var{rcnt}} is \code{NULL}.} + \item{freq }{ the frequencies used. A \code{numeric} vector. The other numeric vectors have the same length, i.e. one value for each frequency studied. } @@ -179,6 +193,8 @@ \item{nsim }{ value of the \code{\var{nsim}} argument. } \item{mctest }{ value of the \code{\var{mctest}} argument. } + + \item{rhopre }{ value of the \code{\var{rhopre}} argument. } } } @@ -194,10 +210,13 @@ \href{http://www.ncdc.noaa.gov/paleo/softlib/redfit/redfit.html}{REDFIT}, which is in the public domain. + Bendat, J. S. and Piersol, A. G. (1986) \emph{Random Data: Analysis + and Measurement Procedures.} Wiley. \acronym{ISBN}: 0-471-04000-2. + Schulz, M. and Mudelsee, M. (2002) REDFIT: estimating red-noise spectra directly from unevenly spaced paleoclimatic time series. \emph{Computers & Geosciences}, 28(3):421\enc{?}{--}426. - + } \author{ Mikko Korpela From noreply at r-forge.r-project.org Wed Sep 4 10:20:05 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 4 Sep 2013 10:20:05 +0200 (CEST) Subject: [Dplr-commits] r680 - branches/redfit/R Message-ID: <20130904082005.BC525185730@r-forge.r-project.org> Author: mvkorpel Date: 2013-09-04 10:20:05 +0200 (Wed, 04 Sep 2013) New Revision: 680 Modified: branches/redfit/R/pointer.R Log: Removed unused variable 'nseries' Modified: branches/redfit/R/pointer.R =================================================================== --- branches/redfit/R/pointer.R 2013-09-04 08:00:54 UTC (rev 679) +++ branches/redfit/R/pointer.R 2013-09-04 08:20:05 UTC (rev 680) @@ -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", From noreply at r-forge.r-project.org Wed Sep 4 11:15:24 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 4 Sep 2013 11:15:24 +0200 (CEST) Subject: [Dplr-commits] r681 - branches/redfit/R Message-ID: <20130904091524.2C77D1810EC@r-forge.r-project.org> Author: mvkorpel Date: 2013-09-04 11:15:23 +0200 (Wed, 04 Sep 2013) New Revision: 681 Modified: branches/redfit/R/detrend.series.R Log: Check arguments 'make.plot' and 'pos.slope': must be TRUE or FALSE Modified: branches/redfit/R/detrend.series.R =================================================================== --- branches/redfit/R/detrend.series.R 2013-09-04 08:20:05 UTC (rev 680) +++ branches/redfit/R/detrend.series.R 2013-09-04 09:15:23 UTC (rev 681) @@ -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, From noreply at r-forge.r-project.org Wed Sep 4 11:21:05 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 4 Sep 2013 11:21:05 +0200 (CEST) Subject: [Dplr-commits] r682 - branches/redfit/R Message-ID: <20130904092105.8787D1810EC@r-forge.r-project.org> Author: mvkorpel Date: 2013-09-04 11:21:05 +0200 (Wed, 04 Sep 2013) New Revision: 682 Modified: branches/redfit/R/powt.R Log: Use lm.fit() instead of lm(). Avoids codetools nag about possibly unused variable. Modified: branches/redfit/R/powt.R =================================================================== --- branches/redfit/R/powt.R 2013-09-04 09:15:23 UTC (rev 681) +++ branches/redfit/R/powt.R 2013-09-04 09:21:05 UTC (rev 682) @@ -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) { From noreply at r-forge.r-project.org Wed Sep 4 12:09:48 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 4 Sep 2013 12:09:48 +0200 (CEST) Subject: [Dplr-commits] r683 - branches/redfit/R Message-ID: <20130904100948.ABEF81802F0@r-forge.r-project.org> Author: mvkorpel Date: 2013-09-04 12:09:48 +0200 (Wed, 04 Sep 2013) New Revision: 683 Modified: branches/redfit/R/detrend.series.R Log: Use lm.fit() instead of lm(). Avoids codetools nag about possibly unused variable. Modified: branches/redfit/R/detrend.series.R =================================================================== --- branches/redfit/R/detrend.series.R 2013-09-04 09:21:05 UTC (rev 682) +++ branches/redfit/R/detrend.series.R 2013-09-04 10:09:48 UTC (rev 683) @@ -39,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 From noreply at r-forge.r-project.org Wed Sep 4 14:08:26 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 4 Sep 2013 14:08:26 +0200 (CEST) Subject: [Dplr-commits] r684 - branches/redfit/R Message-ID: <20130904120826.83113185D1B@r-forge.r-project.org> Author: mvkorpel Date: 2013-09-04 14:08:26 +0200 (Wed, 04 Sep 2013) New Revision: 684 Modified: branches/redfit/R/detrend.R branches/redfit/R/rwi.stats.running.R Log: Functions (operators) from Suggested packages "foreach" and "iterators" are called using the `::` operator. The packages are loaded with requireNamespace() instead of require(). Consequences: * no names from "foreach" or "iterators" will be added to the user's workspace * eliminates possibility of name space conflicts * avoids nag from codetools::checkUsagePackage("dplR") Modified: branches/redfit/R/detrend.R =================================================================== --- branches/redfit/R/detrend.R 2013-09-04 10:09:48 UTC (rev 683) +++ branches/redfit/R/detrend.R 2013-09-04 12:08:26 UTC (rev 684) @@ -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: branches/redfit/R/rwi.stats.running.R =================================================================== --- branches/redfit/R/rwi.stats.running.R 2013-09-04 10:09:48 UTC (rev 683) +++ branches/redfit/R/rwi.stats.running.R 2013-09-04 12:08:26 UTC (rev 684) @@ -328,14 +328,15 @@ ## Iterate over all windows if (running.window && !inherits(try(suppressWarnings(req.fe <- - require(foreach, quietly=TRUE)), + requireNamespace("foreach", + quietly=TRUE)), silent = TRUE), "try-error") && req.fe) { compos.stats <- - foreach(s.idx=window.start, .combine="rbind", - .packages="dplR") %dopar% { - loop.body(s.idx) - } + foreach::"%dopar%"(foreach::foreach(s.idx=window.start, + .combine="rbind", + .packages="dplR"), + loop.body(s.idx)) } else { compos.stats <- NULL for (s.idx in window.start) { From noreply at r-forge.r-project.org Wed Sep 4 15:41:35 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 4 Sep 2013 15:41:35 +0200 (CEST) Subject: [Dplr-commits] r685 - in branches/redfit: . man Message-ID: <20130904134135.445C31858F4@r-forge.r-project.org> Author: mvkorpel Date: 2013-09-04 15:41:34 +0200 (Wed, 04 Sep 2013) New Revision: 685 Modified: branches/redfit/DESCRIPTION branches/redfit/man/bai.in.Rd branches/redfit/man/bai.out.Rd branches/redfit/man/cms.Rd branches/redfit/man/detrend.Rd branches/redfit/man/detrend.series.Rd branches/redfit/man/ffcsaps.Rd branches/redfit/man/fill.internal.NA.Rd branches/redfit/man/hanning.Rd branches/redfit/man/redfit.Rd branches/redfit/man/rwi.stats.running.Rd branches/redfit/man/sea.Rd branches/redfit/man/series.rwl.plot.Rd branches/redfit/man/skel.plot.Rd Log: Load necessary packages in Examples. The packages ("graphics", "grDevices", "stats", "utils") should already be loaded, but that might not always be the case. Modified: branches/redfit/DESCRIPTION =================================================================== --- branches/redfit/DESCRIPTION 2013-09-04 12:08:26 UTC (rev 684) +++ branches/redfit/DESCRIPTION 2013-09-04 13:41:34 UTC (rev 685) @@ -3,7 +3,7 @@ Type: Package Title: Dendrochronology Program Library in R Version: 1.5.7 -Date: 2013-08-19 +Date: 2013-09-04 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 = "aut"), person("Franco", "Biondi", Modified: branches/redfit/man/bai.in.Rd =================================================================== --- branches/redfit/man/bai.in.Rd 2013-09-04 12:08:26 UTC (rev 684) +++ branches/redfit/man/bai.in.Rd 2013-09-04 13:41:34 UTC (rev 685) @@ -27,6 +27,7 @@ Nevada Reno, \acronym{USA}. Patched and improved by Mikko Korpela. } \seealso{ \code{\link{bai.out}} } \examples{ +library(graphics) ## Toy n <- 100 ## Make three fake tree-ring series to show that these funcs work on rwl objects Modified: branches/redfit/man/bai.out.Rd =================================================================== --- branches/redfit/man/bai.out.Rd 2013-09-04 12:08:26 UTC (rev 684) +++ branches/redfit/man/bai.out.Rd 2013-09-04 13:41:34 UTC (rev 685) @@ -29,6 +29,7 @@ \seealso{ \code{\link{bai.in}} } \examples{ \dontrun{ +library(graphics) ## Toy n <- 100 ## Make three fake tree-ring series to show that these funcs work on rwl objects Modified: branches/redfit/man/cms.Rd =================================================================== --- branches/redfit/man/cms.Rd 2013-09-04 12:08:26 UTC (rev 684) +++ branches/redfit/man/cms.Rd 2013-09-04 13:41:34 UTC (rev 685) @@ -37,7 +37,8 @@ dplR by Andy Bunn. Patched and improved by Mikko Korpela. } \seealso{ \code{\link{detrend}}, \code{\link{chron}}, \code{\link{rcs}} } -\examples{data(gp.rwl) +\examples{library(graphics) +data(gp.rwl) data(gp.po) gp.rwi <- cms(rwl = gp.rwl, po = gp.po) gp.crn <- chron(gp.rwi) Modified: branches/redfit/man/detrend.Rd =================================================================== --- branches/redfit/man/detrend.Rd 2013-09-04 12:08:26 UTC (rev 684) +++ branches/redfit/man/detrend.Rd 2013-09-04 13:41:34 UTC (rev 685) @@ -65,6 +65,7 @@ ca533.rwi <- detrend(rwl = ca533, method = "ModNegExp") \dontrun{ +library(grDevices) ## Detrend using all methods. Returns a list ca533.rwi <- detrend(rwl = ca533) ## Save a pdf of all series Modified: branches/redfit/man/detrend.series.Rd =================================================================== --- branches/redfit/man/detrend.series.Rd 2013-09-04 12:08:26 UTC (rev 684) +++ branches/redfit/man/detrend.series.Rd 2013-09-04 13:41:34 UTC (rev 685) @@ -88,7 +88,7 @@ } \author{ Andy Bunn. Patched and improved by Mikko Korpela. } \seealso{ \code{\link{detrend}} } -\examples{ +\examples{library(stats) ## Using a plausible representation of a tree-ring series gt <- 0.5 * exp (-0.05 * 1:200) + 0.2 noise <- c(arima.sim(model = list(ar = 0.7), n = 200, mean = 1, sd = 0.5)) Modified: branches/redfit/man/ffcsaps.Rd =================================================================== --- branches/redfit/man/ffcsaps.Rd 2013-09-04 12:08:26 UTC (rev 684) +++ branches/redfit/man/ffcsaps.Rd 2013-09-04 13:41:34 UTC (rev 685) @@ -49,6 +49,7 @@ \examples{ \dontrun{ +library(graphics) ## Use series CAM011 from the Campito dataset data(ca533) series <- ca533[, "CAM011"] Modified: branches/redfit/man/fill.internal.NA.Rd =================================================================== --- branches/redfit/man/fill.internal.NA.Rd 2013-09-04 12:08:26 UTC (rev 684) +++ branches/redfit/man/fill.internal.NA.Rd 2013-09-04 13:41:34 UTC (rev 685) @@ -52,6 +52,7 @@ \seealso{ \code{\link{spline}}, \code{\link{approx}} } \examples{ +library(graphics) foo <- data.frame(x1=c(rnorm(5), NA, NA, rnorm(3)), x2=c(rnorm(10)), x3=c(NA, NA, rnorm(3), NA, rnorm(4)), Modified: branches/redfit/man/hanning.Rd =================================================================== --- branches/redfit/man/hanning.Rd 2013-09-04 12:08:26 UTC (rev 684) +++ branches/redfit/man/hanning.Rd 2013-09-04 13:41:34 UTC (rev 685) @@ -26,7 +26,8 @@ \author{ Andy Bunn. Patched and improved by Mikko Korpela. } \seealso{ \code{\link[stats]{filter} } } -\examples{data(ca533) +\examples{library(graphics) +data(ca533) yrs <- as.numeric(rownames(ca533)) y <- ca533[, 1] not.na <- !is.na(y) Modified: branches/redfit/man/redfit.Rd =================================================================== --- branches/redfit/man/redfit.Rd 2013-09-04 12:08:26 UTC (rev 684) +++ branches/redfit/man/redfit.Rd 2013-09-04 13:41:34 UTC (rev 685) @@ -227,6 +227,8 @@ \examples{ # Create a simulated tree-ring width series that has a red-noise # background and an embedded signal. +library(graphics) +library(stats) set.seed(123) nyrs <- 500 yrs <- 1:nyrs Modified: branches/redfit/man/rwi.stats.running.Rd =================================================================== --- branches/redfit/man/rwi.stats.running.Rd 2013-09-04 12:08:26 UTC (rev 684) +++ branches/redfit/man/rwi.stats.running.Rd 2013-09-04 13:41:34 UTC (rev 685) @@ -203,6 +203,7 @@ rwi.stats(ca533.rwi, ca533.ids) # i.e. running.window = FALSE rwi.stats.legacy(ca533.rwi, ca533.ids) # rwi.stats prior to dplR 1.5.3 \dontrun{ +library(graphics) ## Plot the chronology showing a potential cutoff year based on eps ca533.rwi <- detrend(rwl = ca533, method = "Spline") # detrend again ca533.crn <- chron(ca533.rwi) Modified: branches/redfit/man/sea.Rd =================================================================== --- branches/redfit/man/sea.Rd 2013-09-04 12:08:26 UTC (rev 684) +++ branches/redfit/man/sea.Rd 2013-09-04 13:41:34 UTC (rev 685) @@ -58,7 +58,8 @@ } -\examples{data(cana157) +\examples{library(graphics) +data(cana157) event.years <- c(1631, 1742, 1845) cana157.sea <- sea(cana157, event.years) foo <- cana157.sea$se.unscaled Modified: branches/redfit/man/series.rwl.plot.Rd =================================================================== --- branches/redfit/man/series.rwl.plot.Rd 2013-09-04 12:08:26 UTC (rev 684) +++ branches/redfit/man/series.rwl.plot.Rd 2013-09-04 13:41:34 UTC (rev 685) @@ -65,7 +65,8 @@ \code{\link{corr.rwl.seg}}, \code{\link{corr.series.seg}}, \code{\link{ccf.series.rwl}} } -\examples{data(co021) +\examples{library(utils) +data(co021) dat <- co021 flagged <- dat$"646244" names(flagged) <- rownames(dat) Modified: branches/redfit/man/skel.plot.Rd =================================================================== --- branches/redfit/man/skel.plot.Rd 2013-09-04 12:08:26 UTC (rev 684) +++ branches/redfit/man/skel.plot.Rd 2013-09-04 13:41:34 UTC (rev 685) @@ -74,7 +74,8 @@ \author{ Andy Bunn. Patched and improved by Mikko Korpela. } \seealso{ \code{\link{Devices}}, \code{\link{hanning}} } -\examples{data(co021) +\examples{library(grDevices) +data(co021) x <- co021[,33] x.yrs <- as.numeric(rownames(co021)) x.name <- colnames(co021)[33] From noreply at r-forge.r-project.org Wed Sep 4 16:56:00 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 4 Sep 2013 16:56:00 +0200 (CEST) Subject: [Dplr-commits] r686 - branches/redfit/R Message-ID: <20130904145600.471FF1857FA@r-forge.r-project.org> Author: mvkorpel Date: 2013-09-04 16:55:59 +0200 (Wed, 04 Sep 2013) New Revision: 686 Modified: branches/redfit/R/redfit.R Log: * Better type check for 't' and 'x' (no unnecessary conversions). * Avoid checkUsagePackage("dplR", all = TRUE) nag about changing 't' and 'x'. Modified: branches/redfit/R/redfit.R =================================================================== --- branches/redfit/R/redfit.R 2013-09-04 13:41:34 UTC (rev 685) +++ branches/redfit/R/redfit.R 2013-09-04 14:55:59 UTC (rev 686) @@ -153,27 +153,35 @@ } else { stop("'iwin' must be numeric or character") } - x <- as.numeric(x) - np <- as.numeric(length(x)) + if (is.double(x)) { + x2 <- x + } else { + x2 <- as.numeric(x) + } + np <- as.numeric(length(x2)) tGiven <- !missing(t) if (tGiven) { - t <- as.numeric(t) - if (length(t) != np) { + if (is.double(t)) { + t2 <- t + } else { + t2 <- as.numeric(t) + } + if (length(t2) != np) { stop("lengths of 't' and 'x' must match") } } else { - t <- as.numeric(seq_len(np)) + t2 <- as.numeric(seq_len(np)) } - naidx <- is.na(x) + naidx <- is.na(x2) if (tGiven) { - naidx <- naidx | is.na(t) + naidx <- naidx | is.na(t2) } if (any(naidx)) { goodidx <- which(!naidx) - t <- t[goodidx] - x <- x[goodidx] + t2 <- t2[goodidx] + x2 <- x2[goodidx] nporig <- np - np <- as.numeric(length(x)) + np <- as.numeric(length(x2)) nna <- nporig - np warning(sprintf(ngettext(nna, "%.0f NA value removed", @@ -185,17 +193,17 @@ np, MIN_POINTS, domain = "R-dplR"), domain = NA) } if (tGiven && !txOrdered) { - idx <- order(t) - t <- t[idx] - x <- x[idx] + idx <- order(t2) + t2 <- t2[idx] + x2 <- x2[idx] } - ## dplR: The rest of the function assumes that t is age, not time + ## dplR: The rest of the function assumes that t2 is age, not time if (tType2 == "time") { - t <- -rev(t) - x <- rev(x) + t2 <- -rev(t2) + x2 <- rev(x2) } if (tGiven) { - difft <- diff(t) + difft <- diff(t2) if (!txOrdered && any(difft == 0)) { stop("duplicated values in 't'") } @@ -203,7 +211,7 @@ difft <- rep.int(1.0, np) } ## dplR: Setup - params <- redfitSetdim(MIN_POINTS, t, ofac, hifac, n50, verbose, + params <- redfitSetdim(MIN_POINTS, t2, ofac, hifac, n50, verbose, iwin = iwin2, nsim = nsim, mctest = mctest, rhopre = rhopre) avgdt <- params[["avgdt"]] @@ -214,22 +222,22 @@ segskip <- params[["segskip"]] dn50 <- params[["n50"]] freq <- seq(from = 0, to = fnyq, length.out = nfreq) - tr <- redfitTrig(t, freq, nseg, dn50, segskip) + tr <- redfitTrig(t2, freq, nseg, dn50, segskip) ww <- matrix(NA_real_, nseg, dn50) for (i in as.numeric(seq_len(dn50))) { - twk <- t[.Call(dplR.seg50, i, nseg, segskip, np)] + twk <- t2[.Call(dplR.seg50, i, nseg, segskip, np)] ww[, i] <- redfitWinwgt(twk, iwin2) } ## determine autospectrum of input data lmfitfun <- tryCatch(match.fun(".lm.fit"), error = function(...) match.fun("lm.fit")) - gxx <- .Call(dplR.spectr, t, x, np, ww, tr[[1]], tr[[2]], tr[[3]], + gxx <- .Call(dplR.spectr, t2, x2, np, ww, tr[[1]], tr[[2]], tr[[3]], nseg, nfreq, avgdt, freq, dn50, segskip, lmfitfun) ## estimate data variance from autospectrum varx <- df * sum(gxx) ## dplR: estimate lag-1 autocorrelation coefficient unless prescribed if (is.null(rhopre) || rhopre < 0) { - rho <- redfitGetrho(t, x, dn50, nseg, segskip, lmfitfun) + rho <- redfitGetrho(t2, x2, dn50, nseg, segskip, lmfitfun) } else { rho <- rhopre } @@ -246,7 +254,7 @@ } ## setup AR(1) time series and estimate its spectrum grr[, i] <- - .Call(dplR.spectr, t, .Call(dplR.makear1, difft, np, tau), np, + .Call(dplR.spectr, t2, .Call(dplR.makear1, difft, np, tau), np, ww, tr[[1]], tr[[2]], tr[[3]], nseg, nfreq, avgdt, freq, dn50, segskip, lmfitfun) ## scale and sum red-noise spectra @@ -261,7 +269,7 @@ 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), + grr <- .Call(dplR.spectr, t2, .Call(dplR.makear1, difft, np, tau), np, ww, tr[[1]], tr[[2]], tr[[3]], nseg, nfreq, avgdt, freq, dn50, segskip, lmfitfun) ## scale and sum red-noise spectra From noreply at r-forge.r-project.org Fri Sep 6 21:43:00 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 6 Sep 2013 21:43:00 +0200 (CEST) Subject: [Dplr-commits] r687 - branches/redfit/man Message-ID: <20130906194301.005211849F3@r-forge.r-project.org> Author: andybunn Date: 2013-09-06 21:43:00 +0200 (Fri, 06 Sep 2013) New Revision: 687 Modified: branches/redfit/man/redfit.Rd Log: small change to redfit example Modified: branches/redfit/man/redfit.Rd =================================================================== --- branches/redfit/man/redfit.Rd 2013-09-04 14:55:59 UTC (rev 686) +++ branches/redfit/man/redfit.Rd 2013-09-06 19:43:00 UTC (rev 687) @@ -282,16 +282,8 @@ data(cana157) yrs <- as.numeric(rownames(cana157)) x <- cana157[, 1] - redf.x <- redfit(x, nsim = 1000) -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) -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)", From noreply at r-forge.r-project.org Thu Sep 12 18:37:03 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 12 Sep 2013 18:37:03 +0200 (CEST) Subject: [Dplr-commits] r688 - branches/redfit/R Message-ID: <20130912163703.E1BAA1855CA@r-forge.r-project.org> Author: mvkorpel Date: 2013-09-12 18:37:03 +0200 (Thu, 12 Sep 2013) New Revision: 688 Modified: branches/redfit/R/redfit.R Log: Edited a comment Modified: branches/redfit/R/redfit.R =================================================================== --- branches/redfit/R/redfit.R 2013-09-06 19:43:00 UTC (rev 687) +++ branches/redfit/R/redfit.R 2013-09-12 16:37:03 UTC (rev 688) @@ -229,7 +229,7 @@ ww[, i] <- redfitWinwgt(twk, iwin2) } ## determine autospectrum of input data - lmfitfun <- tryCatch(match.fun(".lm.fit"), + lmfitfun <- tryCatch(match.fun("lm.fit"), error = function(...) match.fun("lm.fit")) gxx <- .Call(dplR.spectr, t2, x2, np, ww, tr[[1]], tr[[2]], tr[[3]], nseg, nfreq, avgdt, freq, dn50, segskip, lmfitfun) @@ -330,8 +330,8 @@ ## 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? + ## dplR: NOTE! Is round() the right function to use? Maybe ceiling + ## for the lower limit and floor for the higher limit? rcritlo <- round((-0.79557086 + 1.0088719 * sqrtHalfNfreq)^2) rcrithi <- round(( 0.75751462 + 0.9955133 * sqrtHalfNfreq)^2) } else { From noreply at r-forge.r-project.org Thu Sep 12 18:46:54 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 12 Sep 2013 18:46:54 +0200 (CEST) Subject: [Dplr-commits] r689 - branches/redfit/R Message-ID: <20130912164654.46E32185A6D@r-forge.r-project.org> Author: mvkorpel Date: 2013-09-12 18:46:53 +0200 (Thu, 12 Sep 2013) New Revision: 689 Modified: branches/redfit/R/redfit.R Log: Reverted accidental change in previous commit Modified: branches/redfit/R/redfit.R =================================================================== --- branches/redfit/R/redfit.R 2013-09-12 16:37:03 UTC (rev 688) +++ branches/redfit/R/redfit.R 2013-09-12 16:46:53 UTC (rev 689) @@ -229,7 +229,7 @@ ww[, i] <- redfitWinwgt(twk, iwin2) } ## determine autospectrum of input data - lmfitfun <- tryCatch(match.fun("lm.fit"), + lmfitfun <- tryCatch(match.fun(".lm.fit"), error = function(...) match.fun("lm.fit")) gxx <- .Call(dplR.spectr, t2, x2, np, ww, tr[[1]], tr[[2]], tr[[3]], nseg, nfreq, avgdt, freq, dn50, segskip, lmfitfun) From noreply at r-forge.r-project.org Thu Sep 12 19:46:02 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 12 Sep 2013 19:46:02 +0200 (CEST) Subject: [Dplr-commits] r690 - branches/redfit/R Message-ID: <20130912174602.CF8CE185618@r-forge.r-project.org> Author: mvkorpel Date: 2013-09-12 19:46:02 +0200 (Thu, 12 Sep 2013) New Revision: 690 Modified: branches/redfit/R/redfit.R Log: Stop if tau estimation fails. Modified: branches/redfit/R/redfit.R =================================================================== --- branches/redfit/R/redfit.R 2013-09-12 16:46:53 UTC (rev 689) +++ branches/redfit/R/redfit.R 2013-09-12 17:46:02 UTC (rev 690) @@ -806,7 +806,8 @@ ## determine rho, corresponding to tau exp(-dt / tau) } else { - NaN + ## dplR: fail early + stop("error in tau estimation") } } From noreply at r-forge.r-project.org Mon Sep 16 11:53:52 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 16 Sep 2013 11:53:52 +0200 (CEST) Subject: [Dplr-commits] r691 - in branches/redfit: . R Message-ID: <20130916095352.6FC62184671@r-forge.r-project.org> Author: mvkorpel Date: 2013-09-16 11:53:52 +0200 (Mon, 16 Sep 2013) New Revision: 691 Modified: branches/redfit/ChangeLog branches/redfit/R/common.interval.R Log: In 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 Modified: branches/redfit/ChangeLog =================================================================== --- branches/redfit/ChangeLog 2013-09-12 17:46:02 UTC (rev 690) +++ branches/redfit/ChangeLog 2013-09-16 09:53:52 UTC (rev 691) @@ -6,6 +6,14 @@ - 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 -------------------- Modified: branches/redfit/R/common.interval.R =================================================================== --- branches/redfit/R/common.interval.R 2013-09-12 17:46:02 UTC (rev 690) +++ branches/redfit/R/common.interval.R 2013-09-16 09:53:52 UTC (rev 691) @@ -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 + } } From noreply at r-forge.r-project.org Tue Sep 17 18:30:12 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 17 Sep 2013 18:30:12 +0200 (CEST) Subject: [Dplr-commits] r692 - branches/redfit/R Message-ID: <20130917163013.145511850D9@r-forge.r-project.org> Author: mvkorpel Date: 2013-09-17 18:30:12 +0200 (Tue, 17 Sep 2013) New Revision: 692 Modified: branches/redfit/R/redfit.R Log: Fixed sign comparison of runs test to match that of the original Fortran REDFIT (and literature). Modified: branches/redfit/R/redfit.R =================================================================== --- branches/redfit/R/redfit.R 2013-09-16 09:53:52 UTC (rev 691) +++ branches/redfit/R/redfit.R 2013-09-17 16:30:12 UTC (rev 692) @@ -324,7 +324,9 @@ ## equations for calculating critical values for 5-% significance ## were derived from the tabulated critical values in B&P. if (iwin2 == 0 && ofac == 1 && dn50 == 1) { - rcnt <- 1 + sum(diff(sign(gxxc - gredth)) != 0) + spectrcomp <- rep.int(0, nfreq) + spectrcomp[gxxc - gredth >= 0] <- 1 + rcnt <- 1 + sum(diff(spectrcomp) != 0) ## 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. From noreply at r-forge.r-project.org Tue Sep 24 12:38:31 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 24 Sep 2013 12:38:31 +0200 (CEST) Subject: [Dplr-commits] r693 - in branches/redfit: R man Message-ID: <20130924103831.7113918417D@r-forge.r-project.org> Author: mvkorpel Date: 2013-09-24 12:38:31 +0200 (Tue, 24 Sep 2013) New Revision: 693 Modified: branches/redfit/R/redfit.R branches/redfit/man/redfit.Rd Log: New formulas for rcritlo and rcrithi (limits of acceptance region of runs test). Uses a normal approximation, fixed to exact values for nfreq <= 16000. Modified: branches/redfit/R/redfit.R =================================================================== --- branches/redfit/R/redfit.R 2013-09-17 16:30:12 UTC (rev 692) +++ branches/redfit/R/redfit.R 2013-09-24 10:38:31 UTC (rev 693) @@ -319,23 +319,227 @@ ci99 <- NULL } - ## 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. if (iwin2 == 0 && ofac == 1 && dn50 == 1) { spectrcomp <- rep.int(0, nfreq) spectrcomp[gxxc - gredth >= 0] <- 1 rcnt <- 1 + sum(diff(spectrcomp) != 0) - ## 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 ceiling - ## for the lower limit and floor for the higher limit? - rcritlo <- round((-0.79557086 + 1.0088719 * sqrtHalfNfreq)^2) - rcrithi <- round(( 0.75751462 + 0.9955133 * sqrtHalfNfreq)^2) + + ## dplR: Old formulas for rcritlo, rcrithi (REDFIT). + ## ## 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) + + ## 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 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). + ## + ## 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 + ## by 1 going from nfreq to nfreq + 1, rcrithi does not + ## change, and the change in the width is -1. + ## + ## 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 + } } else { rcnt <- NULL rcritlo <- NULL Modified: branches/redfit/man/redfit.Rd =================================================================== --- branches/redfit/man/redfit.Rd 2013-09-17 16:30:12 UTC (rev 692) +++ branches/redfit/man/redfit.Rd 2013-09-24 10:38:31 UTC (rev 693) @@ -87,9 +87,12 @@ between \code{redfit} and REDFIT with respect to the number of points per segment and the overlap of consecutive segments. - \item The critical values of the runs test may differ between - \code{redfit} and REDFIT due to a different interpretation of the - related equations. + \item The critical values of the runs test differ between + \code{redfit} and REDFIT. The equations in REDFIT are flawed, + particularly when the number of frequencies is large. For example, + the lower limit of the acceptance region exceeds the upper limit + when the number of frequencies exceeds a threshold, which is clearly + wrong. } } @@ -111,20 +114,25 @@ \item{rcnt }{ a \code{numeric} value giving the number of runs in a statistical test studying the difference between a theoretical AR1 spectrum and the bias-corrected spectrum estimated from the data. - Requires that \code{\var{iwin} == 0} (\code{"rectangular"}), + Null hypothesis: the two spectra \dQuote{agree}, i.e. the + probability of either being larger than the other is 0.5 at every + point. Requires that \code{\var{iwin} == 0} (\code{"rectangular"}), \code{\var{ofac} == 1} and \code{\var{n50} == 1}. Otherwise the - test is not performed and \var{rcnt} is \code{NULL}. See Bendat and - Piersol, p. 95. } + test is not performed and \var{rcnt} is \code{NULL}. See Bradley, + p. 253\enc{?}{--}254, 259\enc{?}{--}263 (probability \var{p} equals + 0.5). } \item{rcritlo }{ a \code{numeric} critical low value for - \code{\var{rcnt}}. Approximately 2.5 percent of the null - distribution lies below this value (TO BE CHECKED). Is \code{NULL} - when \code{\var{rcnt}} is \code{NULL}. } + \code{\var{rcnt}}, i.e. the lowest value for accepting the null + hyphothesis. Approximately 2.5 percent of the null distribution + lies below this value. Is \code{NULL} when \code{\var{rcnt}} is + \code{NULL}. } - \item{rcritlo }{ a \code{numeric} critical high value for - \code{\var{rcnt}}. Approximately 2.5 percent of the null - distribution lies above this value (TO BE CHECKED). Is \code{NULL} - when \code{\var{rcnt}} is \code{NULL}.} + \item{rcrithi }{ a \code{numeric} critical high value for + \code{\var{rcnt}}, i.e. the highest value for accepting the null + hyphothesis. Approximately 2.5 percent of the null distribution + lies above this value. Is \code{NULL} when \code{\var{rcnt}} is + \code{NULL}.} \item{freq }{ the frequencies used. A \code{numeric} vector. The other numeric vectors have the same length, i.e. one value for each @@ -210,8 +218,8 @@ \href{http://www.ncdc.noaa.gov/paleo/softlib/redfit/redfit.html}{REDFIT}, which is in the public domain. - Bendat, J. S. and Piersol, A. G. (1986) \emph{Random Data: Analysis - and Measurement Procedures.} Wiley. \acronym{ISBN}: 0-471-04000-2. + Bradley, J. V. (1968) \emph{Distribution-Free Statistical + Tests}. Prentice-Hall. Schulz, M. and Mudelsee, M. (2002) REDFIT: estimating red-noise spectra directly from unevenly spaced paleoclimatic time series. From noreply at r-forge.r-project.org Tue Sep 24 15:42:56 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 24 Sep 2013 15:42:56 +0200 (CEST) Subject: [Dplr-commits] r694 - branches/redfit/man Message-ID: <20130924134256.410A4185E97@r-forge.r-project.org> Author: mvkorpel Date: 2013-09-24 15:42:55 +0200 (Tue, 24 Sep 2013) New Revision: 694 Modified: branches/redfit/man/redfit.Rd Log: Added "Examples by Andy Bunn" to Author(s) Modified: branches/redfit/man/redfit.Rd =================================================================== --- branches/redfit/man/redfit.Rd 2013-09-24 10:38:31 UTC (rev 693) +++ branches/redfit/man/redfit.Rd 2013-09-24 13:42:55 UTC (rev 694) @@ -227,7 +227,7 @@ } \author{ - Mikko Korpela + Mikko Korpela. Examples by Andy Bunn. } \seealso{ \code{\link{print.redfit}} From noreply at r-forge.r-project.org Tue Sep 24 15:46:43 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 24 Sep 2013 15:46:43 +0200 (CEST) Subject: [Dplr-commits] r695 - in branches/redfit: . man Message-ID: <20130924134643.C51A8185E5C@r-forge.r-project.org> Author: mvkorpel Date: 2013-09-24 15:46:43 +0200 (Tue, 24 Sep 2013) New Revision: 695 Modified: branches/redfit/DESCRIPTION branches/redfit/man/dplR-package.Rd Log: * Added authors of REDFIT to the list of authors (not copyright holders). * Added "trl" as a role for myself: redfit() is an improved translation of REDFIT. Modified: branches/redfit/DESCRIPTION =================================================================== --- branches/redfit/DESCRIPTION 2013-09-24 13:42:55 UTC (rev 694) +++ branches/redfit/DESCRIPTION 2013-09-24 13:46:43 UTC (rev 695) @@ -3,15 +3,17 @@ Type: Package Title: Dendrochronology Program Library in R Version: 1.5.7 -Date: 2013-09-04 +Date: 2013-09-24 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 = "aut"), 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], 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) Modified: branches/redfit/man/dplR-package.Rd =================================================================== --- branches/redfit/man/dplR-package.Rd 2013-09-24 13:42:55 UTC (rev 694) +++ branches/redfit/man/dplR-package.Rd 2013-09-24 13:46:43 UTC (rev 695) @@ -26,7 +26,10 @@ \author{ Andy Bunn \email{andy.bunn at wwu.edu} with major additions from Mikko Korpela and other significant contributions from Franco Biondi, Filipe - Campelo, Pierre \enc{M?rian}{Merian}, Fares Qeadan and Christian Zang + Campelo, Pierre \enc{M?rian}{Merian}, Fares Qeadan and Christian + Zang. Function \code{\link{redfit}} is an improved translation of + program REDFIT which is original work of Manfred Mudelsee and Michael + Schulz. } \references{ Cook, E. R. and Kairiukstis, L. A. (1990) \emph{Methods of