void spectrum_wrapper(control *c, timeseries *ts, double *xdata, double *ydata, double *frequency, double *power) { /* wrapper func - to calculate periodgram for given time-series also has the options to remove trends from the data and apply a window. */ int i, j, istart; double intercept = 0., abdev = 0., slope = 0.; double *ftrx = NULL, *ftix = NULL, *xwk = NULL, *ywk = NULL, scal; ftrx = allocate_memory_double(ts->lfreq+1, __LINE__); ftix = allocate_memory_double(ts->lfreq+1, __LINE__); xwk = allocate_memory_double(ts->nseg+1, __LINE__); /* periodgram power */ ywk = allocate_memory_double(ts->nseg+1, __LINE__); /* corresponding frequencies */ /* scale autospectrum and setup frequency axis */ scal = 2.0 / ((double)ts->n50 * (double)ts->nseg * ts->df * ts->ofac); ts->factor = scal; /* store for coherency code */ for (i = 1; i <= ts->n50; i++) { /* copy data of i'th segment into workspace */ istart = (int)((i - 1) * (double)ts->nseg / 2.); for (j = 1; j <= ts->nseg; j++) { xwk[j] = xdata[istart + j]; ywk[j] = ydata[istart + j]; } /* detrend the data */ if (c->DETREND == TRUE) { rmtrend(c, ts, ywk, xwk); } else if (c->ROBUSTDETREND == TRUE) { /* fitting method that is more sensitive to outliers in the time-series, I guess the way to go? */ medfit(ts->nseg, ywk, xwk, &intercept, &slope, &abdev); /* Subtract the fitted line from the time-series to obtain a linear detrend */ for (j = 1; j <= ts->nseg; j++) { ywk[j] -= (slope * xwk[j]) + intercept; } } /* apply window to data */ if (c->WINDOW_TYPE != NO_WINDOW) { if (c->WINDOW_TYPE == COSINE_TAPER) { taper_timeseries(c, ts, ywk); /* leads to some bizarre results if used in coherency */ } else { window(c, ts, ywk, xwk); } } /* calculate periodgram - there are two options the original implementation in Scargle paper or the Press et al method. They give identical results. */ if (c->PERIODOGRAM_TYPE == SCARGLE) { ft_uneven_data(xwk, ywk, ftrx, ftix, ts->nfreq, ts->nseg, ts->lfreq, ts->wz); /* sum raw spectra */ for (j = 1; j <= ts->nout; j++) { power[j] += ftrx[j] * ftrx[j] + ftix[j] * ftix[j]; } } else if (c->PERIODOGRAM_TYPE == PRESS) { period(xwk, ywk, ftrx, ftix, ts->nseg, ts->df, ts->nout); /* sum raw spectra */ for (j = 1; j <= ts->nout; j++) { power[j] += ftrx[j] * ftrx[j] + ftix[j] * ftix[j]; } } for (j = 1; j <= ts->nseg; j++) { xwk[j] = 0.0; ywk[j] = 0.0; } } /* rescale periodogram */ if (c->PERIODOGRAM_TYPE == SCARGLE) { for (i = 1; i <= ts->nout; i++) { power[i] *= scal; frequency[i] = (i - 1) * ts->df; } } else if (c->PERIODOGRAM_TYPE == PRESS) { for (i = 1; i <= ts->nout; i++) { power[i] *= scal; /* press algorithm starts at df, rather than 0.0 */ frequency[i] = i * ts->df; } } /* tidy up */ free_array_double(xwk); free_array_double(ywk); free_array_double(ftrx); free_array_double(ftix); return; }
/* 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 freq, SEXP n50, 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, ncopy; 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 double si = 1.0; const double tzero = 0.0; const size_t lfreq = 0; PROTECT_INDEX pidx; dnseg = *REAL(nseg); nseg_val = (size_t) dnseg; nfreq_val = (size_t) *REAL(nfreq); np_val = *REAL(np); n50_val = (size_t) *REAL(n50); segskip_val = *REAL(segskip); t_data = REAL(t); x_data = REAL(x); ww_data = REAL(ww); 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); /* dplR: cbind(1, twk) needed for lm.fit() in rmtrend(). Another * approach would be to use 1. allocMatrix() or to assign * dim=c(nseg, 2) on a vector and 2. fill the first column with * ones. The cbind() approach should be compatible with array * dimensions greater than 2^31 - 1 if that is allowed in future * versions of R. I don't see that limit becoming a problem, * though.*/ PROTECT(tmp = cbindcall = allocList(3)); SET_TYPEOF(cbindcall, LANGSXP); SETCAR(tmp, install("cbind")); tmp = CDR(tmp); SETCAR(tmp, ScalarReal(1.0)); tmp = CDR(tmp); SETCAR(tmp, twk); REPROTECT(twk = eval(cbindcall, R_BaseEnv), pidx); /* 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)); PROTECT(ftix = allocVector(REALSXP, nfreq_val)); gxx_data = REAL(gxx); xwk_data = REAL(xwk); ftrx_data = REAL(ftrx); ftix_data = REAL(ftix); sqrt_nseg = sqrtl((long double) dnseg); wtau_skip = nfreq_val - 1; sincos_skip = wtau_skip * nseg_val; for (i = 0; i < nfreq_val; i++) { 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); 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 */ sumx = 0.0L; for (j = 0; j < nseg_val; j++) { xwk_data[j] *= ww_data[wwidx++]; sumx += xwk_data[j]; } /* 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 / sqrt_nseg, ftrx_data, ftix_data); /* dplR: adjust tsin, tcos, wtau for next segment */ tsin_data += sincos_skip; tcos_data += sincos_skip; wtau_data += wtau_skip; /* sum raw spectra */ for (j = 0; j < nfreq_val; j++) { gxx_data[j] += ftrx_data[j] * ftrx_data[j] + ftix_data[j] * ftix_data[j]; } } /* scale autospectrum */ scal = 2.0 * *REAL(avgdt) / n50_val; for (j = 0; j < nfreq_val; j++) { gxx_data[j] *= scal; } UNPROTECT(6); return(gxx); }