static R_INLINE void hankelize_fft(double *F, const double *U, const double *V, const hankel_matrix *h) { R_len_t N = h->length, L = h->window; R_len_t K = N - L + 1; R_len_t i; int maxf, maxp, *iwork; double *work; complex double *iU, *iV; /* Estimate the best plans for given input length */ fft_factor(N, &maxf, &maxp); if (maxf == 0) error("fft factorization error"); /* Allocate needed memory */ iU = Calloc(N, complex double); iV = Calloc(N, complex double); work = Calloc(4 * maxf, double); iwork = Calloc(maxp, int); /* Fill in buffers */ for (i = 0; i < L; ++i) iU[i] = U[i]; for (i = 0; i < K; ++i) iV[i] = V[i]; /* Compute the FFTs */ fft_factor(N, &maxf, &maxp); fft_work((double*)iU, ((double*)iU)+1, 1, N, 1, -2, work, iwork); fft_factor(N, &maxf, &maxp); fft_work((double*)iV, ((double*)iV)+1, 1, N, 1, -2, work, iwork); /* Dot-multiply */ for (i = 0; i < N; ++i) iU[i] = iU[i] * iV[i]; /* Compute the inverse FFT */ fft_factor(N, &maxf, &maxp); fft_work((double*)iU, ((double*)iU)+1, 1, N, 1, +2, work, iwork); /* Form the result */ for (i = 0; i < N; ++i) { R_len_t leftu, rightu, l; if (i < L) leftu = i; else leftu = L - 1; if (i < K) rightu = 0; else rightu = i - K + 1; l = (leftu - rightu + 1); F[i] = creal(iU[i]) / l / N; } Free(iU); Free(iV); Free(work); Free(iwork); }
static void hankel_tmatmul(double* out, const double* v, const void* matrix) { const hankel_matrix *h = matrix; R_len_t N = h->length, L = h->window; R_len_t K = N - L + 1, i; double *work; complex double *circ; int *iwork, maxf, maxp; /* Estimate the best plans for given input length */ fft_factor(N, &maxf, &maxp); if (maxf == 0) error("fft factorization error"); /* Allocate needed memory */ circ = Calloc(N, complex double); work = Calloc(4 * maxf, double); iwork = Calloc(maxp, int); /* Fill the arrays */ for (i = 0; i < L; ++i) circ[i + K - 1] = v[L - i - 1]; /* Compute the FFT of the reversed vector v */ fft_work((double*)circ, ((double*)circ)+1, 1, N, 1, -2, work, iwork); /* Dot-multiply with pre-computed FFT of toeplitz circulant */ for (i = 0; i < N; ++i) circ[i] = circ[i] * h->circ_freq[i]; /* Compute the reverse transform to obtain result */ fft_factor(N, &maxf, &maxp); fft_work((double*)circ, ((double*)circ)+1, 1, N, 1, +2, work, iwork); /* Cleanup and return */ for (i = 0; i < K; ++i) out[i] = creal(circ[i + L - 1]) / N; Free(circ); Free(work); Free(iwork); }
SEXP attribute_hidden do_mvfft(SEXP call, SEXP op, SEXP args, SEXP env) { SEXP z, d; int i, inv, maxf, maxp, n, p; double *work; int *iwork; checkArity(op, args); z = CAR(args); d = getAttrib(z, R_DimSymbol); if (d == R_NilValue || length(d) > 2) error(_("vector-valued (multivariate) series required")); n = INTEGER(d)[0]; p = INTEGER(d)[1]; switch(TYPEOF(z)) { case INTSXP: case LGLSXP: case REALSXP: z = coerceVector(z, CPLXSXP); break; case CPLXSXP: if (NAMED(z)) z = duplicate(z); break; default: error(_("non-numeric argument")); } PROTECT(z); /* -2 for forward transform, complex values */ /* +2 for backward transform, complex values */ inv = asLogical(CADR(args)); if (inv == NA_INTEGER || inv == 0) inv = -2; else inv = 2; if (n > 1) { fft_factor(n, &maxf, &maxp); if (maxf == 0) error(_("fft factorization error")); work = (double*)R_alloc(4 * maxf, sizeof(double)); iwork = (int*)R_alloc(maxp, sizeof(int)); for (i = 0; i < p; i++) { fft_factor(n, &maxf, &maxp); fft_work(&(COMPLEX(z)[i*n].r), &(COMPLEX(z)[i*n].i), 1, n, 1, inv, work, iwork); } } UNPROTECT(1); return z; }
static void initialize_circulant(hankel_matrix *h, const double *F, R_len_t N, R_len_t L) { R_len_t K = N - L + 1, i; int *iwork, maxf, maxp; double *work; complex double * circ; /* Allocate needed memory */ circ = Calloc(N, complex double); /* Estimate the best plans for given input length */ fft_factor(N, &maxf, &maxp); if (maxf == 0) error("fft factorization error"); work = Calloc(4 * maxf, double); iwork = Calloc(maxp, int); /* Fill input buffer */ for (i = K-1; i < N; ++i) circ[i - K + 1] = F[i]; for (i = 0; i < K-1; ++i) { circ[L + i] = F[i]; } /* Run the FFT on input data */ fft_work((double*)circ, ((double*)circ)+1, 1, N, 1, -2, work, iwork); /* Cleanup and return */ Free(work); Free(iwork); h->circ_freq = circ; h->window = L; h->length = N; }
SEXP attribute_hidden do_fft(SEXP call, SEXP op, SEXP args, SEXP env) { SEXP z, d; int i, inv, maxf, maxmaxf, maxmaxp, maxp, n, ndims, nseg, nspn; double *work; int *iwork; checkArity(op, args); z = CAR(args); switch (TYPEOF(z)) { case INTSXP: case LGLSXP: case REALSXP: z = coerceVector(z, CPLXSXP); break; case CPLXSXP: if (NAMED(z)) z = duplicate(z); break; default: error(_("non-numeric argument")); } PROTECT(z); /* -2 for forward transform, complex values */ /* +2 for backward transform, complex values */ inv = asLogical(CADR(args)); if (inv == NA_INTEGER || inv == 0) inv = -2; else inv = 2; if (LENGTH(z) > 1) { if (isNull(d = getAttrib(z, R_DimSymbol))) { /* temporal transform */ n = length(z); fft_factor(n, &maxf, &maxp); if (maxf == 0) error(_("fft factorization error")); work = (double*)R_alloc(4 * maxf, sizeof(double)); iwork = (int*)R_alloc(maxp, sizeof(int)); fft_work(&(COMPLEX(z)[0].r), &(COMPLEX(z)[0].i), 1, n, 1, inv, work, iwork); } else { /* spatial transform */ maxmaxf = 1; maxmaxp = 1; ndims = LENGTH(d); /* do whole loop just for error checking and maxmax[fp] .. */ for (i = 0; i < ndims; i++) { if (INTEGER(d)[i] > 1) { fft_factor(INTEGER(d)[i], &maxf, &maxp); if (maxf == 0) error(_("fft factorization error")); if (maxf > maxmaxf) maxmaxf = maxf; if (maxp > maxmaxp) maxmaxp = maxp; } } work = (double*)R_alloc(4 * maxmaxf, sizeof(double)); iwork = (int*)R_alloc(maxmaxp, sizeof(int)); nseg = LENGTH(z); n = 1; nspn = 1; for (i = 0; i < ndims; i++) { if (INTEGER(d)[i] > 1) { nspn *= n; n = INTEGER(d)[i]; nseg /= n; fft_factor(n, &maxf, &maxp); fft_work(&(COMPLEX(z)[0].r), &(COMPLEX(z)[0].i), nseg, n, nspn, inv, work, iwork); } } } } UNPROTECT(1); return z; }
void rextremaltcirc(int *nObs, int *ngrid, double *steps, int *dim, int *covmod, double *nugget, double *range, double *smooth, double *DoF, double *uBound, double *ans){ /* This function generates random fields from the Schlather model nObs: the number of observations to be generated ngrid: the number of locations along one axis dim: the random field is generated in R^dim covmod: the covariance model nugget: the nugget parameter range: the range parameter smooth: the smooth parameter DoF: the degree of freedom blockSize: see rextremalttbm ans: the generated random field */ int i, j, k = -1, nbar = R_pow_di(*ngrid, *dim), r, m; const double zero = 0; double *rho, *irho, sill = 1 - *nugget; //Below is a table of highly composite numbers int HCN[39] = {1, 2, 4, 6, 12, 24, 36, 48, 60, 120, 180, 240, 360, 720, 840, 1260, 1680, 2520, 5040, 7560, 10080, 15120, 20160, 25200, 27720, 45360, 50400, 55440, 83160, 110880, 166320, 221760, 277200, 332640, 498960, 554400, 665280, 720720, 1081080}; /* Find the smallest size m for the circulant embedding matrix */ { int dummy = 2 * (*ngrid - 1); do { k++; m = HCN[k]; } while (m < dummy); } /* ---------- beginning of the embedding stage ---------- */ int mbar = m * m, halfM = m / 2, notPosDef = 0; do { double *dist = (double *)R_alloc(mbar, sizeof(double)); notPosDef = 0; //Computation of the distance for (r=mbar;r--;){ i = r % m; j = r / m; if (i > halfM) i -= m; if (j > halfM) j -= m; dist[r] = hypot(steps[0] * i, steps[1] * j); } //Computations of the covariances rho = (double *)R_alloc(mbar, sizeof(double)); irho = (double *)R_alloc(mbar, sizeof(double)); for (i=mbar;i--;) irho[i] = 0; switch (*covmod){ case 1: whittleMatern(dist, mbar, zero, sill, *range, *smooth, rho); break; case 2: cauchy(dist, mbar, zero, sill, *range, *smooth, rho); break; case 3: powerExp(dist, mbar, zero, sill, *range, *smooth, rho); break; case 4: bessel(dist, mbar, *dim, zero, sill, *range, *smooth, rho); break; } /* Compute the eigen values to check if the circulant embbeding matrix is positive definite */ /* Note : The next lines is only valid for 2d random fields. I need to change if there are m_1 \neq m_2 as I suppose that m_1 = m_2 = m */ int maxf, maxp, *iwork; double *work; fft_factor(m, &maxf, &maxp); work = (double *)R_alloc(4 * maxf, sizeof(double)); iwork = (int *)R_alloc(maxp, sizeof(int)); fft_work(rho, irho, m, m, 1, -1, work, iwork); fft_factor(m, &maxf, &maxp); work = (double *)R_alloc(4 * maxf, sizeof(double)); iwork = (int *)R_alloc(maxp, sizeof(int)); fft_work(rho, irho, 1, m, m, -1, work, iwork); //Check if the eigenvalues are all positive for (i=mbar;i--;){ notPosDef |= (rho[i] <= 0) || (fabs(irho[i]) > 0.001); } if (notPosDef){ k++; m = HCN[k]; halfM = m / 2; mbar = m * m; } if (k > 30) error("Impossible to embbed the covariance matrix"); } while (notPosDef); /* --------- end of the embedding stage --------- */ /* Computation of the square root of the eigenvalues */ for (i=mbar;i--;){ rho[i] = sqrt(rho[i]); irho[i] = 0;//No imaginary part } int mdag = m / 2 + 1, mdagbar = mdag * mdag; double isqrtMbar = 1 / sqrt(mbar); double *a = malloc(mbar * sizeof(double)), *ia = malloc(mbar * sizeof(double)), *gp = malloc(nbar * sizeof(double)); GetRNGstate(); for (int i=*nObs;i--;){ int nKO = nbar; double poisson = 0; while (nKO){ poisson += exp_rand(); double ipoisson = 1 / poisson, thresh = *uBound * ipoisson; /* We simulate one realisation of a gaussian random field with the required covariance function */ circcore(rho, a, ia, m, halfM, mdag, mdagbar, *ngrid, nbar, isqrtMbar, *nugget, gp); nKO = nbar; for (int j=nbar;j--;){ double dummy = R_pow(fmax2(gp[j], 0), *DoF) * ipoisson; ans[j + i * nbar] = fmax2(dummy, ans[j + i * nbar]); nKO -= (thresh <= ans[j + i * nbar]); } } } PutRNGstate(); //Lastly we multiply by the normalizing constant const double imean = M_SQRT_PI * R_pow(2, -0.5 * (*DoF - 2)) / gammafn(0.5 * (*DoF + 1)); for (i=(nbar * *nObs);i--;) ans[i] *= imean; free(a); free(ia); free(gp); return; }
void circemb(int *nsim, int *ngrid, double *steps, int *dim, int *covmod, double *nugget, double *sill, double *range, double *smooth, double *ans){ int i, j, k = -1, r, nbar = *ngrid * *ngrid, m; //irho is the imaginary part of the covariance -> 0 double *rho, *irho; const double zero = 0; //Below is a table of highly composite numbers int HCN[39] = {1, 2, 4, 6, 12, 24, 36, 48, 60, 120, 180, 240, 360, 720, 840, 1260, 1680, 2520, 5040, 7560, 10080, 15120, 20160, 25200, 27720, 45360, 50400, 55440, 83160, 110880, 166320, 221760, 277200, 332640, 498960, 554400, 665280, 720720, 1081080}; /* Find the smallest size m for the circulant embedding matrix */ { int dummy = 2 * (*ngrid - 1); do { k++; m = HCN[k]; } while (m < dummy); } /* ---------- beginning of the embedding stage ---------- */ int mbar = m * m, halfM = m / 2, notPosDef = 0; do { double *dist = malloc(mbar * sizeof(double)); notPosDef = 0; //Computation of the distance for (r=mbar;r--;){ i = r % m; j = r / m; if (i > halfM) i -= m; if (j > halfM) j -= m; dist[r] = hypot(steps[0] * i, steps[1] * j); } //Computations of the covariances rho = (double *)R_alloc(mbar, sizeof(double)); irho = (double *)R_alloc(mbar, sizeof(double)); for (i=mbar;i--;) irho[i] = 0; switch (*covmod){ case 1: whittleMatern(dist, mbar, zero, *sill, *range, *smooth, rho); break; case 2: cauchy(dist, mbar, zero, *sill, *range, *smooth, rho); break; case 3: powerExp(dist, mbar, zero, *sill, *range, *smooth, rho); break; case 4: bessel(dist, mbar, *dim, zero, *sill, *range, *smooth, rho); break; } /* Compute the eigen values to check if the circulant embbeding matrix is positive definite */ /* Note : The next lines is only valid for 2d random fields. I need to change if there are m_1 \neq m_2 as I suppose that m_1 = m_2 = m */ int maxf, maxp, *iwork; double *work; fft_factor(m, &maxf, &maxp); work = (double *)R_alloc(4 * maxf, sizeof(double)); iwork = (int *)R_alloc(maxp, sizeof(int)); fft_work(rho, irho, m, m, 1, -1, work, iwork); fft_factor(m, &maxf, &maxp); work = (double *)R_alloc(4 * maxf, sizeof(double)); iwork = (int *)R_alloc(maxp, sizeof(int)); fft_work(rho, irho, 1, m, m, -1, work, iwork); //Check if the eigenvalues are all positive for (i=mbar;i--;){ notPosDef |= (rho[i] < 0) || (fabs(irho[i]) > 0.001); } if (notPosDef){ k++; m = HCN[k]; halfM = m / 2; mbar = m * m; } if (k > 30) error("Impossible to embbed the covariance matrix"); free(dist); } while (notPosDef); /* --------- end of the embedding stage --------- */ /* Computation of the square root of the eigenvalues */ for (i=mbar;i--;){ rho[i] = sqrt(rho[i]); irho[i] = 0;//No imaginary part } int mdag = m / 2 + 1, mdagbar = mdag * mdag; double isqrtMbar = 1 / sqrt(mbar); double *a = malloc(mbar * sizeof(double)), *ia = malloc(mbar * sizeof(double)); GetRNGstate(); for (k=*nsim;k--;){ /* ---------- Simulation from \Lambda^1/2 Q* Z ------------ */ for (r=mdagbar;r--;){ /* Below is the procedure 5.2.4 in Wood and Chan */ //Computation of the cardinality of A(j) int j1, j2,i = r % mdag, j = r / mdag; double u, v; int card = (i != 0) * (i != halfM) + 2 * (j != 0) * (j != halfM); switch (card){ case 3: //B(1) = {1}, B^c(1) = {2} j1 = (m - i) + m * j; j2 = i + m * (m - j); u = norm_rand(); v = norm_rand(); a[j1] = ia[j1] = M_SQRT1_2 * rho[j1]; a[j1] *= u; ia[j1] *= v; a[j2] = ia[j2] = M_SQRT1_2 * rho[j2]; a[j2] *= u; ia[j2] *= -v; //B(2) = {1,2}, B^c(2) = {0} j1 = (m - i) + m * (m - j); j2 = i + m * j; u = norm_rand(); v = norm_rand(); a[j1] = ia[j1] = M_SQRT1_2 * rho[j1]; a[j1]*= u; ia[j1] *= v; a[j2] = ia[j2] = M_SQRT1_2 * rho[j2]; a[j2]*= u; ia[j2] *= -v; break; case 1: //B(1) = 0, B^c(1) = {1} j1 = i + m * j; j2 = m - i + m * j; u = norm_rand(); v = norm_rand(); a[j1] = ia[j1] = M_SQRT1_2 * rho[j1]; a[j1] *= u; ia[j1] *= v; a[j2] = ia[j2] = M_SQRT1_2 * rho[j2]; a[j2] *= u; ia[j2] *= -v; break; case 2: //B(1) = 0, B^c(1) = {2} j1 = i + m * j; j2 = i + m * (m - j); u = norm_rand(); v = norm_rand(); a[j1] = ia[j1] = M_SQRT1_2 * rho[j1]; a[j1] *= u; ia[j1] *= v; a[j2] = ia[j2] = M_SQRT1_2 * rho[j2]; a[j2] *= u; ia[j2] *= -v; break; case 0: j1 = i + m * j; a[j1] = rho[j1] * norm_rand(); ia[j1] = 0; break; } } /* ---------- Computation of Q \Lambda^1/2 Q* Z ------------ */ int maxf, maxp, *iwork; double *work; /* The next lines is only valid for 2d random fields. I need to change if m_1 \neq m_2 as here I suppose that m_1 = m_2 = m */ fft_factor(m, &maxf, &maxp); work = (double *)R_alloc(4 * maxf, sizeof(double)); iwork = (int *)R_alloc(maxp, sizeof(int)); fft_work(a, ia, m, m, 1, -1, work, iwork); fft_factor(m, &maxf, &maxp); work = (double *)R_alloc(4 * maxf, sizeof(double)); iwork = (int *)R_alloc(maxp, sizeof(int)); fft_work(a, ia, 1, m, m, -1, work, iwork); for (i=nbar;i--;) ans[i + k * nbar] = isqrtMbar * a[i % *ngrid + m * (i / *ngrid)]; } PutRNGstate(); if (*nugget > 0){ int dummy = *nsim * nbar; double sqrtNugget = sqrt(*nugget); GetRNGstate(); for (i=dummy;i--;) ans[i] += sqrtNugget * norm_rand(); PutRNGstate(); } free(a); free(ia); return; }
void rgeomcirc(int *nObs, int *ngrid, double *steps, int *dim, int *covmod, double *sigma2, double *nugget, double *range, double *smooth, double *uBound, double *ans){ /* This function generates random fields from the geometric model nObs: the number of observations to be generated ngrid: the number of locations along one axis dim: the random field is generated in R^dim covmod: the covariance model nugget: the nugget parameter range: the range parameter smooth: the smooth parameter uBound: the uniform upper bound for the stoch. proc. ans: the generated random field */ int i, j, k = -1, nbar = R_pow_di(*ngrid, *dim), r, m; const double loguBound = log(*uBound), halfSigma2 = 0.5 * *sigma2, zero = 0; double sigma = sqrt(*sigma2), sill = 1 - *nugget, *rho, *irho, *dist; //Below is a table of highly composite numbers int HCN[39] = {1, 2, 4, 6, 12, 24, 36, 48, 60, 120, 180, 240, 360, 720, 840, 1260, 1680, 2520, 5040, 7560, 10080, 15120, 20160, 25200, 27720, 45360, 50400, 55440, 83160, 110880, 166320, 221760, 277200, 332640, 498960, 554400, 665280, 720720, 1081080}; /* Find the smallest size m for the circulant embedding matrix */ { int dummy = 2 * (*ngrid - 1); do { k++; m = HCN[k]; } while (m < dummy); } /* ---------- beginning of the embedding stage ---------- */ int mbar = m * m, halfM = m / 2, notPosDef = 0; do { dist = (double *)R_alloc(mbar, sizeof(double)); notPosDef = 0; //Computation of the distance for (r=mbar;r--;){ i = r % m; j = r / m; if (i > halfM) i -= m; if (j > halfM) j -= m; dist[r] = hypot(steps[0] * i, steps[1] * j); } //Computations of the covariances rho = (double *)R_alloc(mbar, sizeof(double)); irho = (double *)R_alloc(mbar, sizeof(double)); for (i=mbar;i--;) irho[i] = 0; switch (*covmod){ case 1: whittleMatern(dist, mbar, zero, sill, *range, *smooth, rho); break; case 2: cauchy(dist, mbar, zero, sill, *range, *smooth, rho); break; case 3: powerExp(dist, mbar, zero, sill, *range, *smooth, rho); break; case 4: bessel(dist, mbar, *dim, zero, sill, *range, *smooth, rho); break; } /* Compute the eigen values to check if the circulant embbeding matrix is positive definite */ /* Note : The next lines is only valid for 2d random fields. I need to change if there are m_1 \neq m_2 as I suppose that m_1 = m_2 = m */ int maxf, maxp; fft_factor(m, &maxf, &maxp); double *work = (double *)R_alloc(4 * maxf, sizeof(double)); int *iwork = (int *)R_alloc(maxp, sizeof(int)); fft_work(rho, irho, m, m, 1, -1, work, iwork); fft_factor(m, &maxf, &maxp); work = (double *)R_alloc(4 * maxf, sizeof(double)); iwork = (int *)R_alloc(maxp, sizeof(int)); fft_work(rho, irho, 1, m, m, -1, work, iwork); //Check if the eigenvalues are all positive for (i=mbar;i--;){ notPosDef |= (rho[i] <= 0) || (fabs(irho[i]) > 0.001); } if (notPosDef){ k++; m = HCN[k]; halfM = m / 2; mbar = m * m; } if (k > 30) error("Impossible to embbed the covariance matrix"); } while (notPosDef); /* --------- end of the embedding stage --------- */ /* Computation of the square root of the eigenvalues */ for (i=mbar;i--;){ rho[i] = sqrt(rho[i]); irho[i] = 0;//No imaginary part } int mdag = m / 2 + 1, mdagbar = mdag * mdag; double isqrtMbar = 1 / sqrt(mbar); double *a = (double *)R_alloc(mbar, sizeof(double)); double *ia = (double *)R_alloc(mbar, sizeof(double)); GetRNGstate(); for (i=*nObs;i--;){ int nKO = nbar; double poisson = 0; while (nKO) { /* The stopping rule is reached when nKO = 0 i.e. when each site satisfies the condition in Eq. (8) of Schlather (2002) */ int j; double *gp = (double *)R_alloc(nbar, sizeof(double)); poisson += exp_rand(); double ipoisson = -log(poisson), thresh = loguBound + ipoisson; /* We simulate one realisation of a gaussian random field with the required covariance function */ circcore(rho, a, ia, m, halfM, mdag, mdagbar, *ngrid, nbar, isqrtMbar, *nugget, gp); nKO = nbar; double ipoissonMinusHalfSigma2 = ipoisson - halfSigma2; for (j=nbar;j--;){ ans[j + i * nbar] = fmax2(sigma * gp[j] + ipoissonMinusHalfSigma2, ans[j + i * nbar]); nKO -= (thresh <= ans[j + i * nbar]); } } } PutRNGstate(); /* So fare we generate a max-stable process with standard Gumbel margins. Switch to unit Frechet ones */ for (i=*nObs * nbar;i--;) ans[i] = exp(ans[i]); return; }