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);
}
