/* produces standard Frechet margins */
void rbvalog_shi(int *n, double *alpha, double *asy, double *sim)
{
double v1_1,v2_2,v1_12,v2_12,u,z;
int i;
RANDIN;
if(*alpha == 1)
for(i=0;i<2*(*n);i++) sim[i] = 1/EXP;
else {
for(i=0;i<*n;i++)
{
v1_1 = (1-asy[0]) / EXP;
v2_2 = (1-asy[1]) / EXP;
u = UNIF;
if(UNIF < *alpha) z = EXP+EXP;
else z = EXP;
v1_12 = asy[0] / (z * R_pow(u,*alpha));
v2_12 = asy[1] / (z * R_pow(1-u,*alpha));
sim[2*i] = fmax2(v1_1,v1_12);
sim[2*i+1] = fmax2(v2_2,v2_12);
}
}
RANDOUT;
}
double pnchisq(double x, double df, double ncp, int lower_tail, int log_p)
{
double ans;
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(df) || ISNAN(ncp))
return x + df + ncp;
if (!R_FINITE(df) || !R_FINITE(ncp))
ML_ERR_return_NAN;
#endif
if (df < 0. || ncp < 0.) ML_ERR_return_NAN;
ans = pnchisq_raw(x, df, ncp, 1e-12, 8*DBL_EPSILON, 1000000, lower_tail, log_p);
if(ncp >= 80) {
if(lower_tail) {
ans = fmin2(ans, R_D__1); /* e.g., pchisq(555, 1.01, ncp = 80) */
} else { /* !lower_tail */
/* since we computed the other tail cancellation is likely */
if(ans < (log_p ? (-10. * M_LN10) : 1e-10)) ML_ERROR(ME_PRECISION, "pnchisq");
if(!log_p) ans = fmax2(ans, 0.0); /* Precaution PR#7099 */
}
}
if (!log_p || ans < -1e-8)
return ans;
else { // log_p && ans > -1e-8
// prob. = exp(ans) is near one: we can do better using the other tail
#ifdef DEBUG_pnch
REprintf(" pnchisq_raw(*, log_p): ans=%g => 2nd call, other tail\n", ans);
#endif
// FIXME: (sum,sum2) will be the same (=> return them as well and reuse here ?)
ans = pnchisq_raw(x, df, ncp, 1e-12, 8*DBL_EPSILON, 1000000, !lower_tail, FALSE);
return log1p(-ans);
}
}
static void update_batch_params(void)
{
int longest_run, flawed_measurements;
if( current_synchronization == SYNC_REAL ) {
longest_run = get_longest_run();
flawed_measurements = get_number_flawed_measurements();
if( flawed_measurements > max_counter/4 ) {
interval = fmax2(2.0*interval,
(global_stop_batch-start_batch)/(max_counter+1)*1.5);
}
if( first_measurement_run ) {
first_measurement_run = False;
max_counter = min_repetitions;
} else if( longest_run > max_counter/2 ) {
/* more than half of the measurements are late in a row */
max_counter = imax2(max_counter/2, First_max_counter);
}
logging(DBG_SYNC, "flawed_m = %d longest_run = %d max_counter = %d interval = %9.1f\n",
flawed_measurements, longest_run, max_counter, interval*1.0e6);
} else {
max_counter = imax2(4, min_repetitions);
/* @@ how can we predict how many measurements we'll need to get a
specific standard error ? */
}
}
double pnchisq(double x, double df, double ncp, int lower_tail, int log_p)
{
double ans;
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(df) || ISNAN(ncp))
return x + df + ncp;
if (!R_FINITE(df) || !R_FINITE(ncp))
ML_ERR_return_NAN;
#endif
if (df < 0. || ncp < 0.) ML_ERR_return_NAN;
ans = pnchisq_raw(x, df, ncp, 1e-12, 8*DBL_EPSILON, 1000000, lower_tail);
if(ncp >= 80) {
if(lower_tail) {
ans = fmin2(ans, 1.0); /* e.g., pchisq(555, 1.01, ncp = 80) */
} else { /* !lower_tail */
/* since we computed the other tail cancellation is likely */
if(ans < 1e-10) ML_ERROR(ME_PRECISION, "pnchisq");
ans = fmax2(ans, 0.0); /* Precaution PR#7099 */
}
}
if (!log_p) return ans;
/* if ans is near one, we can do better using the other tail */
if (ncp >= 80 || ans < 1 - 1e-8) return log(ans);
ans = pnchisq_raw(x, df, ncp, 1e-12, 8*DBL_EPSILON, 1000000, !lower_tail);
return log1p(-ans);
}
static double
do_search(double y, double *z, double p, double n, double pr, double incr)
{
if(*z >= p) {
/* search to the left */
#ifdef DEBUG_qbinom
REprintf("\tnew z=%7g >= p = %7g --> search to left (y--) ..\n", z,p);
#endif
for(;;) {
double newz;
if(y == 0 ||
(newz = pbinom(y - incr, n, pr, /*l._t.*/TRUE, /*log_p*/FALSE)) < p)
return y;
y = fmax2(0, y - incr);
*z = newz;
}
}
else { /* search to the right */
#ifdef DEBUG_qbinom
REprintf("\tnew z=%7g < p = %7g --> search to right (y++) ..\n", z,p);
#endif
for(;;) {
y = fmin2(y + incr, n);
if(y == n ||
(*z = pbinom(y, n, pr, /*l._t.*/TRUE, /*log_p*/FALSE)) >= p)
return y;
}
}
}
Float tweedie_logW(Float y, Float phi, Float p){
bool ok = (0 < y) && (0 < phi) && (1 < p) && (p < 2);
if (!ok) return NAN;
Float p1 = p - 1.0, p2 = 2.0 - p;
Float a = - p2 / p1, a1 = 1.0 / p1;
Float cc, w, sum_ww = 0.0, ww_max ;
double j;
/* only need the lower bound and the # terms to be stored */
int jh, jl, jd;
double jmax = 0;
Float logz = 0;
/* compute jmax for the given y > 0*/
cc = a * log(p1) - log(p2);
jmax = asDouble( fmax2(1.0, pow(y, p2) / (phi * p2)) );
logz = - a * log(y) - a1 * log(phi) + cc;
/* find bounds in the summation */
/* locate upper bound */
cc = logz + a1 + a * log(-a);
j = jmax ;
w = a1 * j ;
while (1) {
j += TWEEDIE_INCRE ;
if (j * (cc - a1 * log(j)) < (w - TWEEDIE_DROP))
break ;
}
jh = ceil(j);
/* locate lower bound */
j = jmax;
while (1) {
j -= TWEEDIE_INCRE ;
if (j < 1 || j * (cc - a1 * log(j)) < w - TWEEDIE_DROP)
break ;
}
jl = imax2(1, floor(j)) ;
jd = jh - jl + 1;
/* set limit for # terms in the sum */
int nterms = imin2(imax(&jd, 1), TWEEDIE_NTERM), iterm ;
Float *ww = Calloc(nterms, Float) ;
/* evaluate series using the finite sum*/
/* y > 0 */
sum_ww = 0.0 ;
iterm = imin2(jd, nterms) ;
for (int k = 0; k < iterm; k++) {
j = k + jl ;
ww[k] = j * logz - lgamma(1 + j) - lgamma(-a * j);
}
ww_max = dmax(ww, iterm) ;
for (int k = 0; k < iterm; k++)
sum_ww += exp(ww[k] - ww_max);
Float ans = log(sum_ww) + ww_max ;
Free(ww);
return ans;
}
void pplik(double *data, int *n, double *loc, double *scale,
double *shape, double *thresh, double *noy, double *dns)
{
int i;
double *dvec, preg;
dvec = (double *)R_alloc(*n, sizeof(double));
if(*scale <= 0) {
*dns = -1e6;
return;
}
preg = (*thresh - *loc) / *scale;
if (*shape == 0)
preg = - *noy * exp(-preg);
else {
preg = 1 + *shape * preg;
if ((preg <= 0) && (*shape > 0)){
*dns = -1e6;
return;
}
else {
preg = fmax2(preg, 0);
preg = - *noy * R_pow(preg, -1 / *shape);
}
}
for(i=0;i<*n;i++) {
data[i] = (data[i] - *loc) / *scale;
if(*shape == 0)
dvec[i] = log(1 / *scale) - data[i];
else {
data[i] = 1 + *shape * data[i];
if(data[i] <= 0) {
*dns = -1e6;
return;
}
dvec[i] = log(1 / *scale) - (1 / *shape + 1) * log(data[i]);
}
}
for(i=0;i<*n;i++)
*dns = *dns + dvec[i];
*dns = *dns + preg;
}
void R_max_col(double *matrix, int *nr, int *nc, int *maxes, int *ties_meth)
{
int r, c, m, n_r = *nr;
double a, b, large;
Rboolean isna,
used_random = FALSE,
do_rand = *ties_meth == 1;
for (r = 0; r < n_r; r++) {
/* first check row for any NAs and find the largest abs(entry) */
large = 0.0;
isna = FALSE;
for (c = 0; c < *nc; c++) {
a = matrix[r + c * n_r];
if (ISNAN(a)) { isna = TRUE; break; }
if (!R_FINITE(a)) continue;
if (do_rand) large = fmax2(large, fabs(a));
}
if (isna) { maxes[r] = NA_INTEGER; continue; }
m = 0;
a = matrix[r];
if (do_rand) {
double tol = RELTOL * large;
int ntie = 1;
for (c = 1; c < *nc; c++) {
b = matrix[r + c * n_r];
if (b > a + tol) { /* tol could be zero */
a = b; m = c;
ntie = 1;
} else if (b >= a - tol) { /* b ~= current max. a */
ntie++;
if (!used_random) { GetRNGstate(); used_random = TRUE; }
if (ntie * unif_rand() < 1.) m = c;
}
}
} else {
if(*ties_meth == 2) /* return the *first* max if there are ties */
for (c = 1; c < *nc; c++) {
b = matrix[r + c * n_r];
if (a < b) {
a = b; m = c;
}
}
else if(*ties_meth == 3) /* return the *last* max ... */
for (c = 1; c < *nc; c++) {
b = matrix[r + c * n_r];
if (a <= b) {
a = b; m = c;
}
}
else error("invalid 'ties_meth' {should not happen}");
}
maxes[r] = m + 1;
}
if(used_random) PutRNGstate();
}
double qpois(double p, double lambda, int lower_tail, int log_p)
{
double mu, sigma, gamma, z, y;
#ifdef IEEE_754
if (ISNAN(p) || ISNAN(lambda))
return p + lambda;
#endif
if(!R_FINITE(lambda))
ML_ERR_return_NAN;
if(lambda < 0) ML_ERR_return_NAN;
R_Q_P01_check(p);
if(lambda == 0) return 0;
if(p == R_DT_0) return 0;
if(p == R_DT_1) return ML_POSINF;
mu = lambda;
sigma = sqrt(lambda);
/* gamma = sigma; PR#8058 should be kurtosis which is mu^-0.5 */
gamma = 1.0/sigma;
/* Note : "same" code in qpois.c, qbinom.c, qnbinom.c --
* FIXME: This is far from optimal [cancellation for p ~= 1, etc]: */
if(!lower_tail || log_p) {
p = R_DT_qIv(p); /* need check again (cancellation!): */
if (p == 0.) return 0;
if (p == 1.) return ML_POSINF;
}
/* temporary hack --- FIXME --- */
if (p + 1.01*DBL_EPSILON >= 1.) return ML_POSINF;
/* y := approx.value (Cornish-Fisher expansion) : */
z = qnorm(p, 0., 1., /*lower_tail*/TRUE, /*log_p*/FALSE);
#ifdef HAVE_NEARBYINT
y = nearbyint(mu + sigma * (z + gamma * (z*z - 1) / 6));
#else
y = round(mu + sigma * (z + gamma * (z*z - 1) / 6));
#endif
z = ppois(y, lambda, /*lower_tail*/TRUE, /*log_p*/FALSE);
/* fuzz to ensure left continuity; 1 - 1e-7 may lose too much : */
p *= 1 - 64*DBL_EPSILON;
/* If the mean is not too large a simple search is OK */
if(lambda < 1e5) return do_search(y, &z, p, lambda, 1);
/* Otherwise be a bit cleverer in the search */
{
double incr = floor(y * 0.001), oldincr;
do {
oldincr = incr;
y = do_search(y, &z, p, lambda, incr);
incr = fmax2(1, floor(incr/100));
} while(oldincr > 1 && incr > lambda*1e-15);
return y;
}
}
/* Do two lines intersect ?
* Algorithm from Paul Bourke
* (http://www.swin.edu.au/astronomy/pbourke/geometry/lineline2d/index.html)
*/
int linesIntersect(double x1, double x2, double x3, double x4,
double y1, double y2, double y3, double y4)
{
double result = 0;
double denom = (y4 - y3)*(x2 - x1) - (x4 - x3)*(y2 - y1);
double ua = ((x4 - x3)*(y1 - y3) - (y4 - y3)*(x1 - x3));
/* If the lines are parallel ...
*/
if (denom == 0) {
/* If the lines are coincident ...
*/
if (ua == 0) {
/* If the lines are vertical ...
*/
if (x1 == x2) {
/* Compare y-values
*/
if (!((y1 < y3 && fmax2(y1, y2) < fmin2(y3, y4)) ||
(y3 < y1 && fmax2(y3, y4) < fmin2(y1, y2))))
result = 1;
} else {
/* Compare x-values
*/
if (!((x1 < x3 && fmax2(x1, x2) < fmin2(x3, x4)) ||
(x3 < x1 && fmax2(x3, x4) < fmin2(x1, x2))))
result = 1;
}
}
}
/* ... otherwise, calculate where the lines intersect ...
*/
else {
double ub = ((x2 - x1)*(y1 - y3) - (y2 - y1)*(x1 - x3));
ua = ua/denom;
ub = ub/denom;
/* Check for overlap
*/
if ((ua > 0 && ua < 1) && (ub > 0 && ub < 1))
result = 1;
}
return (int) result;
}
/**
* update the proposal standard deviations
*
* @param p the number of parameters to be tuned
* @param acc pointer to the acceptance rate in the M-H update
* @param mh_sd pointer to the vector of proposal standard deviations
* @param mark pointer to the vector of marks
*
*/
static R_INLINE void tune_var(int p, double *acc, double *mh_sd, int *mark) {
double acc_bd;
for (int j = 0; j < p; j++){
acc_bd = fmin2(fmax2(acc[j], 0.01), 0.99); /* bound the empirical acceptance */
if (acc[j] < (MH_ACC_TAR - MH_ACC_TOL))
mh_sd[j] /= 2 - acc_bd/MH_ACC_TAR;
else if (acc[j] > (MH_ACC_TAR - MH_ACC_TOL))
mh_sd[j] *= 2 - (1 - acc_bd)/(1 - MH_ACC_TAR);
else mark[j]++;
}
}
SEXP F21DaR(SEXP A, SEXP B, SEXP C, SEXP Z, SEXP Minit, SEXP Maxit) {
int n = LENGTH(Z);
double maxit = REAL(Maxit)[0];
double minit = REAL(Minit)[0];
double f, maxsum;
double a = REAL(A)[0];
Rcomplex b = COMPLEX(AS_COMPLEX(B))[0];
Rcomplex c = COMPLEX(AS_COMPLEX(C))[0];
Rcomplex *z = COMPLEX(Z);
double curra;
Rcomplex currc,currb,currsum,tres;
SEXP LRes, LNames, Res, Rel;
PROTECT (LRes = allocVector(VECSXP, 2));
PROTECT (LNames = allocVector(STRSXP, 2));
PROTECT (Res = allocVector(CPLXSXP, n));
PROTECT (Rel = allocVector(REALSXP, n));
Rcomplex *res = COMPLEX(Res);
double *rel = REAL(Rel);
for (int i=0; i<n; i++) {
curra = a; currb = b; currc = c; currsum.r = 1.; currsum.i = 0.;
tres = currsum; maxsum = 1.;
for (f = 1.; (f<minit)||((f<maxit)&&(StopCritD(currsum,tres)>DOUBLE_EPS)); f=f+1.) {
R_CheckUserInterrupt();
currsum = CMultR(currsum,curra);
currsum = CMult(currsum,currb);
currsum = CDiv(currsum,currc);
currsum = CMult(currsum,z[i]);
currsum = CDivR(currsum,f);
tres = CAdd(tres,currsum);
curra = curra+1.;
currb = CAdd1(currb);
currc = CAdd1(currc);
// Rprintf("%f: %g + %g i\n",f,currsum.r,currsum.i);
maxsum = fmax2(maxsum,Cabs2(currsum));
}
if (f>=maxit) {
// Rprintf("D:Appr: %f - Z: %f + %f i, Currsum; %f + %f i, Rel: %g\n",f,z[i].r,z[i].i,currsum.r,currsum.i,StopCritD(currsum,tres));
warning("approximation of hypergeometric function inexact");
}
res[i] = tres;
rel[i] = sqrt(Cabs2(res[i])/maxsum);
// Rprintf("Iterations: %f, Result: %g+%g i\n",f,res[i].r,res[i].i);
}
SET_VECTOR_ELT(LRes, 0, Res);
SET_STRING_ELT(LNames, 0, mkChar("value"));
SET_VECTOR_ELT(LRes, 1, Rel);
SET_STRING_ELT(LNames, 1, mkChar("rel"));
setAttrib(LRes, R_NamesSymbol, LNames);
UNPROTECT(4);
return(LRes);
}
double qnbinom(double p, double size, double prob, int lower_tail, int log_p)
{
double P, Q, mu, sigma, gamma, z, y;
#ifdef IEEE_754
if (ISNAN(p) || ISNAN(size) || ISNAN(prob))
return p + size + prob;
#endif
if (prob <= 0 || prob > 1 || size <= 0) ML_ERR_return_NAN;
/* FIXME: size = 0 is well defined ! */
if (prob == 1) return 0;
R_Q_P01_boundaries(p, 0, ML_POSINF);
Q = 1.0 / prob;
P = (1.0 - prob) * Q;
mu = size * P;
sigma = sqrt(size * P * Q);
gamma = (Q + P)/sigma;
/* Note : "same" code in qpois.c, qbinom.c, qnbinom.c --
* FIXME: This is far from optimal [cancellation for p ~= 1, etc]: */
if(!lower_tail || log_p) {
p = R_DT_qIv(p); /* need check again (cancellation!): */
if (p == R_DT_0) return 0;
if (p == R_DT_1) return ML_POSINF;
}
/* temporary hack --- FIXME --- */
if (p + 1.01*DBL_EPSILON >= 1.) return ML_POSINF;
/* y := approx.value (Cornish-Fisher expansion) : */
z = qnorm(p, 0., 1., /*lower_tail*/TRUE, /*log_p*/FALSE);
y = floor(mu + sigma * (z + gamma * (z*z - 1) / 6) + 0.5);
z = pnbinom(y, size, prob, /*lower_tail*/TRUE, /*log_p*/FALSE);
/* fuzz to ensure left continuity: */
p *= 1 - 64*DBL_EPSILON;
/* If the C-F value is not too large a simple search is OK */
if(y < 1e5) return do_search(y, &z, p, size, prob, 1);
/* Otherwise be a bit cleverer in the search */
{
double incr = floor(y * 0.001), oldincr;
do {
oldincr = incr;
y = do_search(y, &z, p, size, prob, incr);
incr = fmax2(1, floor(incr/100));
} while(oldincr > 1 && incr > y*1e-15);
return y;
}
}
bool Tree::calculateTotalCosts(int method, double alpha, int sumWeights, double populationMSE){
// calculates tree quality
if(method == 1){
this->performance = 2.0*(((double) sumWeights)-this->calculateTotalMC(0)) + alpha*(this->nNodes+1.0)*log(((double)sumWeights));
}else{
double SMSE = fmax2(this->calculateTotalSE(0)/(populationMSE), 0.001);
this->performance = (
((double) sumWeights)*log(SMSE)+alpha*4.0*log(((double) sumWeights))*((double)this->nNodes+2.0)
+ ((double) sumWeights)*7.0 // constant such that formula is alway positive
);
}
return true;
} // end calculateTotalCosts
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 dtweedielogwsmallp(double *y, double *phi, double *power, double *logw) {
double p,a,a1,r,drop=37,logz,jmax,j,cc,wmax,estlogw,oldestlogw;
int hij,lowj;
if (*power < 1) error("Error - power<1!");
if (*power > 2) error("Error - power>2!");
if (*phi <= 0) error("Error - phi<=0!");
if (*y <= 0) error("Error - y<=0!");
p = *power;
a = (2 - p)/(1 - p);
a1 = 1 - a;
r = -a * log(*y) + a * log(p - 1) - a1 * log(*phi) - log(2 - p);
logz = r;
jmax = (pow(*y,(2 - p)))/(*phi * (2 - p));
j = fmax2(1, jmax);
cc = logz + a1 + a * log(-a);
wmax = a1 * jmax;
estlogw = wmax;
while (estlogw > (wmax - drop)) {
j = j + 2;
estlogw = j * (cc - a1 * log(j));
}
hij = (int)ceil(j);
logz = r;
jmax = pow(*y,(2 - *power))/(*phi * (2 - *power));
j = fmax2(1, jmax);
wmax = a1 * jmax;
estlogw = wmax;
while ((estlogw > (wmax - drop)) && (j >= 2)) {
j = fmax2(1, j - 2);
oldestlogw = estlogw;
estlogw = j * (cc - a1 * log(j));
}
lowj = (int)fmax2(1, floor(j));
double newj[hij-lowj+1];
int k;
for(k=0;k<(hij-lowj+1);k++) newj[k] = lowj+k;
double g[hij-lowj+1];
for(k=0;k<hij-lowj+1;k++) g[k] = lgamma(newj[k]+1)+lgamma(-a*newj[k]);
double A[hij-lowj+1];
for(k=0;k<hij-lowj+1;k++) A[k] = r*(double)newj[k]-g[k];
double m=fmax2(A[0],hij-lowj+1);
for(k=0;k<(hij-lowj+1);k++) m = fmax2(A[k],hij-lowj+1);
double we[hij-lowj+1];
for(k=0;k<hij-lowj+1;k++) we[k] = exp(A[k]-m);
double sumwe=0;
for(k=0;k<hij-lowj+1;k++) sumwe+=we[k];
*logw=log(sumwe)+m;
}
double qgeom(double p, double prob, int lower_tail, int log_p)
{
if (prob <= 0 || prob > 1) ML_ERR_return_NAN;
R_Q_P01_boundaries(p, 0, ML_POSINF);
#ifdef IEEE_754
if (ISNAN(p) || ISNAN(prob))
return p + prob;
#endif
if (prob == 1) return(0);
/* add a fuzz to ensure left continuity, but value must be >= 0 */
return fmax2(0, ceil(R_DT_Clog(p) / log1p(- prob) - 1 - 1e-12));
}
/// Temporary array J
void J_m(int n, int p, const int b[], const double U[], const int R[],
double *J)
{
int m=0;
for (int k=0; k < p; k++)
for (int l=0; l < n; l++)
for (int i=0; i < n; i++)
{
J[m] = 1.0;
for (int j= b[k]; j < b[k+1]; j++)
J[m] *= 1.0 - fmax2(U[n * j + R[n * k + i]],
U[n * j + R[n * k + l]]);
m++;
}
}
/*===============================================================*/
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;
}
SEXP pvaluecombine( SEXP RpVec, SEXP Rmethod ) {
int k = length(RpVec);
const char * method = CHAR(STRING_ELT(Rmethod, 0));
SEXP Rcmbdpvalue = PROTECT(allocVector(REALSXP, 1));
memset(REAL(Rcmbdpvalue), 0.0, sizeof(double));
double * cmbdpvalue = REAL(Rcmbdpvalue);
if (!strcmp(method, "fisher")) {
for (int i=0; i<k; i++) {
*cmbdpvalue += log(REAL(RpVec)[i]);
}
*cmbdpvalue = 1 - pchisq(-2 * *cmbdpvalue, 2*k, 1, 0);
} else if (!strcmp(method, "normal") || !strcmp(method, "stouffer")) {
for (int i=0; i<k; i++) {
*cmbdpvalue += qnorm(REAL(RpVec)[i], 0.0, 1.0, 1, 0);
}
*cmbdpvalue = *cmbdpvalue / sqrt(k);
*cmbdpvalue = pnorm(*cmbdpvalue, 0.0, 1.0, 1, 0);
} else if (!strcmp(method, "min") || !strcmp(method, "tippett")) {
*cmbdpvalue = REAL(RpVec)[0];
for (int i=1; i<k; i++) {
*cmbdpvalue = fmin2(*cmbdpvalue, REAL(RpVec)[i]);
}
*cmbdpvalue = 1 - pow(1-*cmbdpvalue, k);
} else if (!strcmp(method, "max")) {
*cmbdpvalue = REAL(RpVec)[0];
for (int i=1; i<k; i++) {
*cmbdpvalue = fmax2(*cmbdpvalue, REAL(RpVec)[i]);
}
*cmbdpvalue = pow(*cmbdpvalue, k);
} else if (!strcmp(method, "sum")) {
for (int i=0; i<k; i++) {
*cmbdpvalue += REAL(RpVec)[i];
}
if (k <= 30) {
*cmbdpvalue = pConvolveUniform(*cmbdpvalue, (double)k);
} else {
*cmbdpvalue = pnorm(*cmbdpvalue, (double)k/2.0, sqrt((double)k/12.0), 1, 0);
}
} else {
*cmbdpvalue = 3.1415926;
}
// return
UNPROTECT(1);
return(Rcmbdpvalue);
}
double qnt(double p, double df, double ncp, int lower_tail, int log_p)
{
const static double accu = 1e-13;
const static double Eps = 1e-11; /* must be > accu */
double ux, lx, nx, pp;
#ifdef IEEE_754
if (ISNAN(p) || ISNAN(df) || ISNAN(ncp))
return p + df + ncp;
#endif
if (!R_FINITE(df)) ML_ERR_return_NAN;
/* Was
* df = floor(df + 0.5);
* if (df < 1 || ncp < 0) ML_ERR_return_NAN;
*/
if (df <= 0.0) ML_ERR_return_NAN;
if(ncp == 0.0 && df >= 1.0) return qt(p, df, lower_tail, log_p);
R_Q_P01_boundaries(p, ML_NEGINF, ML_POSINF);
p = R_DT_qIv(p);
/* Invert pnt(.) :
* 1. finding an upper and lower bound */
if(p > 1 - DBL_EPSILON) return ML_POSINF;
pp = fmin2(1 - DBL_EPSILON, p * (1 + Eps));
for(ux = fmax2(1., ncp);
ux < DBL_MAX && pnt(ux, df, ncp, TRUE, FALSE) < pp;
ux *= 2);
pp = p * (1 - Eps);
for(lx = fmin2(-1., -ncp);
lx > -DBL_MAX && pnt(lx, df, ncp, TRUE, FALSE) > pp;
lx *= 2);
/* 2. interval (lx,ux) halving : */
do {
nx = 0.5 * (lx + ux);
if (pnt(nx, df, ncp, TRUE, FALSE) > p) ux = nx; else lx = nx;
}
while ((ux - lx) / fabs(nx) > accu);
return 0.5 * (lx + ux);
}
// used in GScale(), but also grDevices/src/axis_scales.c :
// (usr, log, n_inp) |--> (axp, n_out) :
void GAxisPars(double *min, double *max, int *n, Rboolean log, int axis)
{
#define EPS_FAC_2 100
Rboolean swap = CXXRCONSTRUCT(Rboolean, *min > *max);
double t_, min_o, max_o;
if(swap) { /* Feature: in R, something like xlim = c(100,0) just works */
t_ = *min; *min = *max; *max = t_;
}
/* save only for the extreme case (EPS_FAC_2): */
min_o = *min; max_o = *max;
if(log) {
/* Avoid infinities */
if(*max > 308) *max = 308;
if(*min < -307) *min = -307;
*min = Rexp10(*min);
*max = Rexp10(*max);
GLPretty(min, max, n);
}
else GEPretty(min, max, n);
double tmp2 = EPS_FAC_2 * DBL_EPSILON;/* << prevent overflow in product below */
if(fabs(*max - *min) < (t_ = fmax2(fabs(*max), fabs(*min)))* tmp2) {
/* Treat this case somewhat similar to the (min ~= max) case above */
/* Too much accuracy here just shows machine differences */
warning(_("relative range of values =%4.0f * EPS, is small (axis %d)")
/*"to compute accurately"*/,
fabs(*max - *min) / (t_*DBL_EPSILON), axis);
/* No pretty()ing anymore */
*min = min_o;
*max = max_o;
double eps = .005 * fabs(*max - *min);/* .005: not to go to DBL_MIN/MAX */
*min += eps;
*max -= eps;
if(log) {
*min = Rexp10(*min);
*max = Rexp10(*max);
}
*n = 1;
}
if(swap) {
t_ = *min; *min = *max; *max = t_;
}
}
static void update_std_error(int a, int n)
{
int i, p;
for( i = a; i < n; i++) {
max_results[i] = 0.0;
for( p = 0; p < get_measurement_size(); p++ )
max_results[i] = fmax2( max_results[i], all_results[p * max_rep_hard_limit + i]);
sum_of_results += max_results[i];
sum_of_squares += fsqr( max_results[i] );
}
mean_value = sum_of_results / n;
std_error = sqrt( fabs( sum_of_squares - (fsqr(sum_of_results)/n)) /
(n*(n-1)) );
logging(DBG_MEAS, "new std_error = %9.1f\n", std_error*1.0e6);
}
void rtruncn(double *a, double *b, double *x) {
double A, B;
double maxA, maxB, maxR, r2, r, th, u, v, accept=0.0;
A = atan(*a);
B = atan(*b);
maxA = exp(-pow(*a,2)/4)/cos(A);
maxB = exp(-pow(*b,2)/4)/cos(B);
maxR = fmax2(maxA, maxB);
if((*a<1) && (*b>-1)) maxR = exp(-0.25)*sqrt(2.0);
while (accept==0) {
r2 = runif(0.0,1.0);
r = sqrt(r2)*maxR;
th = runif(A,B);
u = r*cos(th);
*x = tan(th);
accept = ((pow(*x,2)) < (log(u)*-4));
}
}
//the max and min of the diagonal elements of a p by p matrix v
void absrng_(double * v, int* p, double * vmin, double * vmax)
{
int m = *p,i;
double tmp;
tmp= fabs(v[0]);
vmin[0] = tmp;
vmax[0] = tmp;
if(m==1) return;
for(i=1;i< m;i++)
{
tmp = fabs(v[i*m+i]);
vmin[0] = fmin2(tmp,vmin[0]);
vmax[0] = fmax2(tmp,vmax[0]);
}
return;
}
static double
do_search(double y, double *z, double p, double n, double pr, double incr)
{
if(*z >= p) {
/* search to the left */
for(;;) {
if(y == 0 ||
(*z = pnbinom(y - incr, n, pr, /*l._t.*/TRUE, /*log_p*/FALSE)) < p)
return y;
y = fmax2(0, y - incr);
}
}
else { /* search to the right */
for(;;) {
y = y + incr;
if((*z = pnbinom(y, n, pr, /*l._t.*/TRUE, /*log_p*/FALSE)) >= p)
return y;
}
}
}
void drawwi(double *w, double *mu, double *sigmai,int *p, int *y)
{
/* function to draw w_i by Gibbing's thru p vector */
int i,j,above;
double bound;
double mean, csig;
for (i=0; i < *p; ++i)
{
bound=0.0;
for (j=0; j < *p ; ++j)
{ if (j != i) {bound=fmax2(bound,w[j]); }}
if (*y == i+1)
above = 0;
else
above = 1;
condmom(w,mu,sigmai,*p,(i+1),&mean,&csig);
w[i]=rtrun(mean,csig,bound,above);
}
}
void R_max_col(double *matrix, int *nr, int *nc, int *maxes)
{
int r, c, m, ntie, n_r = *nr;
double a, b, tol, large;
Rboolean isna, used_random=FALSE;
for (r = 0; r < n_r; r++) {
/* first check row for any NAs and find the largest entry */
large = 0.0;
isna = FALSE;
for (c = 0; c < *nc; c++) {
a = matrix[r + c * n_r];
if (ISNAN(a)) { isna = TRUE; break; }
large = fmax2(large, fabs(a));
}
if (isna) { maxes[r] = NA_INTEGER; continue; }
tol = RELTOL * large;
m = 0;
ntie = 1;
a = matrix[r];
for (c = 1; c < *nc; c++) {
b = matrix[r + c * n_r];
if (b >= a + tol) {
ntie = 1;
a = b;
m = c;
} else if (b >= a - tol) {
ntie++;
if (!used_random) { GetRNGstate(); used_random = TRUE; }
if (ntie * unif_rand() < 1.) m = c;
}
}
maxes[r] = m + 1;
}
if(used_random) PutRNGstate();
}
double hypot(double a, double b)
{
double p, r, s, t, tmp, u;
if(ISNAN(a) || ISNAN(b)) /* propagate Na(N)s: */
return
#ifdef IEEE_754
a + b;
#else
ML_NAN;
#endif
if (!R_FINITE(a) || !R_FINITE(b)) {
return ML_POSINF;
}
p = fmax2(fabs(a), fabs(b));
if (p != 0.0) {
/* r = (min(|a|,|b|) / p) ^2 */
tmp = fmin2(fabs(a), fabs(b))/p;
r = tmp * tmp;
for(;;) {
t = 4.0 + r;
/* This was a test of 4.0 + r == 4.0, but optimizing
compilers nowadays infinite loop on that. */
if(fabs(r) < 2*DBL_EPSILON) break;
s = r / t;
u = 1. + 2. * s;
p *= u ;
/* r = (s / u)^2 * r */
tmp = s / u;
r *= tmp * tmp;
}
}
return p;
}
double gammafn(double x)
{
const static double gamcs[42] = {
+.8571195590989331421920062399942e-2,
+.4415381324841006757191315771652e-2,
+.5685043681599363378632664588789e-1,
-.4219835396418560501012500186624e-2,
+.1326808181212460220584006796352e-2,
-.1893024529798880432523947023886e-3,
+.3606925327441245256578082217225e-4,
-.6056761904460864218485548290365e-5,
+.1055829546302283344731823509093e-5,
-.1811967365542384048291855891166e-6,
+.3117724964715322277790254593169e-7,
-.5354219639019687140874081024347e-8,
+.9193275519859588946887786825940e-9,
-.1577941280288339761767423273953e-9,
+.2707980622934954543266540433089e-10,
-.4646818653825730144081661058933e-11,
+.7973350192007419656460767175359e-12,
-.1368078209830916025799499172309e-12,
+.2347319486563800657233471771688e-13,
-.4027432614949066932766570534699e-14,
+.6910051747372100912138336975257e-15,
-.1185584500221992907052387126192e-15,
+.2034148542496373955201026051932e-16,
-.3490054341717405849274012949108e-17,
+.5987993856485305567135051066026e-18,
-.1027378057872228074490069778431e-18,
+.1762702816060529824942759660748e-19,
-.3024320653735306260958772112042e-20,
+.5188914660218397839717833550506e-21,
-.8902770842456576692449251601066e-22,
+.1527474068493342602274596891306e-22,
-.2620731256187362900257328332799e-23,
+.4496464047830538670331046570666e-24,
-.7714712731336877911703901525333e-25,
+.1323635453126044036486572714666e-25,
-.2270999412942928816702313813333e-26,
+.3896418998003991449320816639999e-27,
-.6685198115125953327792127999999e-28,
+.1146998663140024384347613866666e-28,
-.1967938586345134677295103999999e-29,
+.3376448816585338090334890666666e-30,
-.5793070335782135784625493333333e-31
};
int i, n;
double y;
double sinpiy, value;
#ifdef NOMORE_FOR_THREADS
static int ngam = 0;
static double xmin = 0, xmax = 0., xsml = 0., dxrel = 0.;
/* Initialize machine dependent constants, the first time gamma() is called.
FIXME for threads ! */
if (ngam == 0) {
ngam = chebyshev_init(gamcs, 42, DBL_EPSILON/20);/*was .1*d1mach(3)*/
gammalims(&xmin, &xmax);/*-> ./gammalims.c */
xsml = exp(fmax2(log(DBL_MIN), -log(DBL_MAX)) + 0.01);
/* = exp(.01)*DBL_MIN = 2.247e-308 for IEEE */
dxrel = sqrt(DBL_EPSILON);/*was sqrt(d1mach(4)) */
}
#else
/* For IEEE double precision DBL_EPSILON = 2^-52 = 2.220446049250313e-16 :
* (xmin, xmax) are non-trivial, see ./gammalims.c
* xsml = exp(.01)*DBL_MIN
* dxrel = sqrt(DBL_EPSILON) = 2 ^ -26
*/
# define ngam 22
# define xmin -170.5674972726612
# define xmax 171.61447887182298
# define xsml 2.2474362225598545e-308
# define dxrel 1.490116119384765696e-8
#endif
if(ISNAN(x)) return x;
/* If the argument is exactly zero or a negative integer
* then return NaN. */
if (x == 0 || (x < 0 && x == (long)x)) {
ML_ERROR(ME_DOMAIN, "gammafn");
return ML_NAN;
}
y = fabs(x);
if (y <= 10) {
/* Compute gamma(x) for -10 <= x <= 10
* Reduce the interval and find gamma(1 + y) for 0 <= y < 1
* first of all. */
n = (int) x;
if(x < 0) --n;
y = x - n;/* n = floor(x) ==> y in [ 0, 1 ) */
--n;
value = chebyshev_eval(y * 2 - 1, gamcs, ngam) + .9375;
if (n == 0)
return value;/* x = 1.dddd = 1+y */
if (n < 0) {
/* compute gamma(x) for -10 <= x < 1 */
/* exact 0 or "-n" checked already above */
/* The answer is less than half precision */
/* because x too near a negative integer. */
if (x < -0.5 && fabs(x - (int)(x - 0.5) / x) < dxrel) {
ML_ERROR(ME_PRECISION, "gammafn");
}
/* The argument is so close to 0 that the result would overflow. */
if (y < xsml) {
ML_ERROR(ME_RANGE, "gammafn");
if(x > 0) return ML_POSINF;
else return ML_NEGINF;
}
n = -n;
for (i = 0; i < n; i++) {
value /= (x + i);
}
return value;
}
else {
/* gamma(x) for 2 <= x <= 10 */
for (i = 1; i <= n; i++) {
value *= (y + i);
}
return value;
}
}
else {
/* gamma(x) for y = |x| > 10. */
if (x > xmax) { /* Overflow */
ML_ERROR(ME_RANGE, "gammafn");
return ML_POSINF;
}
if (x < xmin) { /* Underflow */
ML_ERROR(ME_UNDERFLOW, "gammafn");
return 0.;
}
if(y <= 50 && y == (int)y) { /* compute (n - 1)! */
value = 1.;
for (i = 2; i < y; i++) value *= i;
}
else { /* normal case */
value = exp((y - 0.5) * log(y) - y + M_LN_SQRT_2PI +
((2*y == (int)2*y)? stirlerr(y) : lgammacor(y)));
}
if (x > 0)
return value;
if (fabs((x - (int)(x - 0.5))/x) < dxrel){
/* The answer is less than half precision because */
/* the argument is too near a negative integer. */
ML_ERROR(ME_PRECISION, "gammafn");
}
sinpiy = sin(M_PI * y);
if (sinpiy == 0) { /* Negative integer arg - overflow */
ML_ERROR(ME_RANGE, "gammafn");
return ML_POSINF;
}
return -M_PI / (y * sinpiy * value);
}
}