void fx(double *x, int n, void *ex) {
int i;
double * p;
double poly[maxvertices * 2];
double a;
double b;
double epsabs = 0.0001;
double epsrel = 0.0001;
double result = 0;
double abserr = 0;
int neval = 0;
int ier = 0;
int limit = 100;
int lenw = 400;
int last = 0;
int iwork[100];
double work[400];
int kk;
p = (double*) ex;
kk = round(p[9]);
for (i=0; i<kk; i++) {
poly[i] = p[i+10];
poly[i+kk] = p[i+kk+10];
}
for (i=0; i<n; i++) {
yab(x, &i, &kk, poly, &a, &b); /* refine limits here */
p[6] = x[i]; /* pass forward the value of x; consider &ex etc. */
Rdqags(fy, ex, &a, &b, &epsabs, &epsrel, &result, &abserr, &neval, &ier,
&limit, &lenw, &last, iwork, work);
x[i] = result;
}
}
double integral1D
(int fn, int m, int c, double gsbval[], int cc, double traps[],
double mask[], int n1, int n2, int kk, int mm, double ex[])
{
double ax=0;
double bx=0;
double epsabs = 0.0001;
double epsrel = 0.0001;
double result = 0;
double abserr = 0;
int neval = 0;
int ier = 0;
int limit = 100;
int lenw = 400;
int last = 0;
int iwork[100];
double work[400];
int k;
int ns;
ns = n2-n1+1;
/* 2011-06-21 uniform treated separately */
if (fn == 4) {
for (k=n1+1; k<=n2; k++) { /* upper bound is length of this transect */
bx += SegCircle2(
traps[k-1], traps[k-1+kk],
traps[k], traps[k+kk],
mask[m], mask[m+mm],
gsbval[cc + c]);
}
return (bx);
}
for (k=n1+1; k<=n2; k++) { /* upper bound is length of this transect */
bx += sqrt( (traps[k] - traps[k-1]) * (traps[k] - traps[k-1]) +
(traps[k+kk] - traps[k-1+kk]) * (traps[k+kk] - traps[k-1+kk]) );
}
/* pass parameters etc. through pointer */
ex[0] = gsbval[c];
ex[1] = gsbval[cc + c];
ex[2] = gsbval[2*cc + c];
ex[3] = fn;
ex[4] = mask[m];
ex[5] = mask[m+mm];
ex[6] = 0;
ex[7] = 0;
ex[8] = 0;
ex[9] = ns;
for (k=0; k<ns; k++) { /* pass transect vertices */
ex[k+10] = traps[k+n1]; /* x */
ex[k+ns+10] = traps[k+n1+kk]; /* y */
}
Rdqags(fx1, ex, &ax, &bx, &epsabs, &epsrel, &result, &abserr, &neval, &ier,
&limit, &lenw, &last, iwork, work);
if (ier != 0) Rprintf("ier error code in integral1D %5d\n", ier);
return (result);
}
/* n'th order derivative of (scaled) incomplete gamma wrt. shape parameter */
double D_incpl_gamma_shape(double x, double shape, double n, double logc){
if(n<.5){
return exp(logc + Rf_lgammafn(shape)) * Rf_pgamma(x, shape, 1.0, 1, 0);
}
double epsabs=1e-10;
double epsrel=1e-10;
double result1=0;
double result2=0;
double abserr=10000;
int neval=10000;
int ier=0;
int limit=100;
int lenw = 4 * limit;
int last=0;
int* iwork = (int*)malloc(limit * sizeof(int));
double* work = (double*)malloc(lenw * sizeof(double));
double ex[3];
ex[0] = shape;
ex[1] = n;
ex[2] = logc; /* Scale integrand with exp(logc) */
double bound; /* For indefinite integration */
int inf=-1; /* corresponds to (-Inf, bound) */
bound = log(Rf_fmin2(x,shape));
/* integrate -Inf...min(log(x),log(shape)) */
Rdqagi(integrand_D_incpl_gamma_shape, ex, &bound, &inf,
&epsabs, &epsrel,
&result1, &abserr, &neval, &ier,
&limit, &lenw, &last, iwork, work);
if(ier!=0){
#ifndef _OPENMP
warning("incpl_gamma (indef) integrate unreliable: x=%f shape=%f n=%f ier=%i", x, shape, n, ier);
#endif
}
/* integrate min(log(x),log(shape))...log(x) */
if(x>shape){
ier = 0;
double a = bound;
double b = log(x);
Rdqags(integrand_D_incpl_gamma_shape, ex, &a, &b,
&epsabs, &epsrel,
&result2, &abserr, &neval, &ier,
&limit, &lenw, &last, iwork, work);
if(ier!=0){
#ifndef _OPENMP
warning("incpl_gamma (def) integrate unreliable: x=%f shape=%f n=%f ier=%i", x, shape, n, ier);
#endif
}
}
free(iwork);
free(work);
return result1 + result2;
}
SEXP anclikR(SEXP s_dst, SEXP s_vst, SEXP s_s2_pr_alpha, SEXP s_s2_pr_beta){
// s_dst: list of vectors with differences between transformed observed and modelled prevalences
// s_vst: list of vectors with clinic level variances (transformed) for each site
// s_s2_pr_alpha: parameter for inverse-gamma prior on variance of clinic-level effects
// s_s2_pr_beta: parameter for inverse-gamma prior on variance of clinic-level effects
size_t numsites = length(s_dst);
size_t *nobs_site = (size_t*) R_alloc(numsites, sizeof(size_t));
size_t maxobs = 0;
double **dst = (double**) R_alloc(numsites, sizeof(double*));
double **vst = (double**) R_alloc(numsites, sizeof(double*));
for(size_t site = 0; site < numsites; site++){
nobs_site[site] = length(VECTOR_ELT(s_dst, site));
dst[site] = REAL(VECTOR_ELT(s_dst, site));
vst[site] = REAL(VECTOR_ELT(s_vst, site));
if(maxobs < nobs_site[site])
maxobs = nobs_site[site];
}
double *x = (double*) R_alloc(maxobs, sizeof(double));
double *mean = (double*) R_alloc(maxobs, sizeof(double));
double *sigma = (double*) R_alloc(maxobs*maxobs, sizeof(double));
for(size_t i=0; i < maxobs; i++)
mean[i] = 0.0;
struct anclik_integrand_param param = {numsites, nobs_site, dst, vst, x, mean, sigma, *REAL(s_s2_pr_alpha), *REAL(s_s2_pr_beta)};
// create R object for return and call anclik
SEXP s_val;
PROTECT(s_val = allocVector(REALSXP, 1));
// numerical integration
// Note: integration limits and parameters taken from Leontine's R implementation.
double a=1.0e-15, b=0.3, epsabs=0.0001220703, epsrel=0.0001220703, err;
int neval, ier, last;
int limit = 1000;
int lenw = 4 * limit;
int *iwork = (int *) R_alloc(limit, sizeof(int));
double *work = (double *) R_alloc(lenw, sizeof(double));
Rdqags(anclik_integrand, ¶m, &a, &b, &epsabs, &epsrel,
REAL(s_val), &err, &neval, &ier, &limit, &lenw, &last, iwork, work);
UNPROTECT(1);
return s_val;
}
double integral2D (int fn, int m, int c, double gsbval[], int cc, double traps[],
double mask[], int n1, int n2, int kk, int mm, double ex[]) {
double ax=1e20;
double bx=-1e20;
double epsabs = 0.0001;
double epsrel = 0.0001;
double result = 0;
double abserr = 0;
int neval = 0;
int ier = 0;
int limit = 100;
int lenw = 400;
int last = 0;
int iwork[100];
double work[400];
int k;
int ns;
int reportier = 0;
/* limits from bounding box of this polygon */
ns = n2-n1+1;
for (k=0; k<ns; k++) {
ax = fmin2(ax, traps[k+n1]);
bx = fmax2(bx, traps[k+n1]);
}
/* pass parameters etc. through pointer */
ex[0] = gsbval[c];
ex[1] = gsbval[cc + c];
ex[2] = gsbval[2*cc + c];
ex[3] = fn;
ex[4] = mask[m];
ex[5] = mask[m+mm];
ex[6] = 0;
ex[7] = 0;
ex[8] = 0;
ex[9] = ns;
/* also pass polygon vertices */
for (k=0; k<ns; k++) {
ex[k+10] = traps[k+n1]; /* x */
ex[k+ns+10] = traps[k+n1+kk]; /* y */
}
Rdqags(fx, ex, &ax, &bx, &epsabs, &epsrel, &result, &abserr, &neval, &ier,
&limit, &lenw, &last, iwork, work);
if ((ier != 0) & (reportier))
Rprintf("ier error code in integral2D %5d\n", ier);
return (result);
}
/*===============================================================*/
void integral2Dtest
(int *fn, int *m, int *c, double *gsbval, int *cc, double *traps,
double *mask, int *n1, int *n2, int *kk, int *mm, double *result)
{
double *ex;
double ax=1e20;
double bx=-1e20;
double res;
double epsabs = 0.0001;
double epsrel = 0.0001;
double abserr = 0;
int neval = 0;
int ier = 0;
int limit = 100;
int lenw = 400;
int last = 0;
int iwork[100];
double work[400];
int k;
int ns;
/* limits from bounding box of this polygon */
ns = *n2 - *n1 + 1;
for (k=0; k<ns; k++) {
ax = fmin2(ax, traps[k+ns]);
bx = fmax2(bx, traps[k+ns]);
}
ex = (double *) R_alloc(10 + 2 * *kk, sizeof(double));
ex[0] = gsbval[*c]; /* 1.0? */
ex[1] = gsbval[*cc + *c];
ex[2] = gsbval[2* *cc + *c];
ex[3] = *fn;
ex[4] = mask[*m];
ex[5] = mask[*m+ *mm];
ex[6] = 0;
ex[7] = 0;
ex[8] = 0;
ex[9] = ns;
for (k=0; k<ns; k++) {
ex[k+10] = traps[k+ *n1];
ex[k+ns+10] = traps[k+ *n1 + *kk];
}
Rdqags(fx, ex, &ax, &bx, &epsabs, &epsrel, &res, &abserr, &neval, &ier,
&limit, &lenw, &last, iwork, work);
*result = res;
}
double levinvpareto(double limit, double shape, double scale, double order,
int give_log)
{
double u;
double ex[3], lower, upper, epsabs, epsrel, result, abserr, *work;
int neval, ier, subdiv, lenw, last, *iwork;
if (!R_FINITE(shape) ||
!R_FINITE(scale) ||
!R_FINITE(order) ||
shape <= 0.0 ||
scale <= 0.0)
return R_NaN;
if (order <= -shape)
return R_PosInf;
if (limit <= 0.0)
return 0.0;
/* Parameters for the integral are pretty much fixed here */
ex[0] = shape; ex[1] = scale; ex[2] = order;
lower = 0.0; upper = limit / (limit + scale);
subdiv = 100;
epsabs = R_pow(DOUBLE_EPS, 0.25);
epsrel = epsabs;
lenw = 4 * subdiv; /* as instructed in WRE */
iwork = (int *) R_alloc(subdiv, sizeof(int)); /* idem */
work = (double *) R_alloc(lenw, sizeof(double)); /* idem */
Rdqags(fn, (void *) &ex,
&lower, &upper, &epsabs, &epsrel, &result,
&abserr, &neval, &ier, &subdiv, &lenw, &last, iwork, work);
if (ier == 0)
{
u = exp(-log1pexp(log(scale) - log(limit)));
return R_pow(scale, order) * shape * result
+ ACT_DLIM__0(limit, order) * (0.5 - R_pow(u, shape) + 0.5);
}
else
error(_("integration failed"));
}
double Clmbr::sl_geo2(double * err)
// calculate significance level for changepoint = (theta0,alpha0) by CLR
// using Knowles, Siegmund, Zhang's geometric-expectation formula
// assume th0 and y values already set
{
double sL;
if (variance_unknown) { if (th0ex) sL =2*F(m,-c); else sL =2*F(m-1,-c); }
else sL = 2 * Rf_pnorm5(-lambda*c ,0,1,1,0);
// 'Rdqag' parameters
// here it integrates another numerical integral, so adds its average error-estimate
int neval =0, ier =0, limit =100, lenw = 4*limit, last =0;
int* iwork= Calloc( limit, int );
double lower = -c, upper = c, epsabs = tol_sl_abs/2, epsrel = tol_sl_rel/2,
result =0, abserr =0;
double * work= Calloc( lenw, double );
if (!variance_unknown) epsabs /= lambda;
int ne = 0;
double er =0;
void * ex[3] = { this, &er, &ne };
Rdqags( igeo2, ex, &lower, &upper, &epsabs, &epsrel, &result, &abserr, &neval,
&ier, &limit, &lenw, &last, iwork, work );
Free( iwork ); Free( work );
double integral= result, error= abserr + er/ne;
if (!variance_unknown) integral *=lambda , error *=lambda;
sL += integral;
if( err != 0 ) *err = error;
return min( sL, 1. );
}
