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);
}
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);
}
}
double qnchisq(double p, double n, double lambda, int lower_tail, int log_p)
{
const double acu = 1e-12;
const double Eps = 1e-6; /* must be > acu */
double ux, lx, nx;
#ifdef IEEE_754
if (ISNAN(p) || ISNAN(n) || ISNAN(lambda))
return p + n + lambda;
#endif
if (!R_FINITE(n)) ML_ERR_return_NAN;
n = FLOOR(n + 0.5);
if (n < 1 || lambda < 0) ML_ERR_return_NAN;
R_Q_P01_check(p);
if (p == R_DT_0)
return 0;
/* Invert pnchisq(.) finding an upper and lower bound;
then interval halfing : */
p = R_D_qIv(p);
if(lower_tail) {
for(ux = 1.; pnchisq_raw(ux, n, lambda, Eps, 128) < p * (1 + Eps);
ux *= 2){}
for(lx = ux; pnchisq_raw(lx, n, lambda, Eps, 128) > p * (1 - Eps);
lx *= 0.5){}
}
else {
for(ux = 1.; pnchisq_raw(ux, n, lambda, Eps, 128) + p < 1 + Eps;
ux *= 2){}
for(lx = ux; pnchisq_raw(lx, n, lambda, Eps, 128) + p > 1 - Eps;
lx *= 0.5){}
}
p = R_D_Lval(p);
do {
nx = 0.5 * (lx + ux);
if (pnchisq_raw(nx, n, lambda, acu, 1000) > p)
ux = nx;
else
lx = nx;
}
while ((ux - lx) / nx > acu);
return 0.5 * (ux + lx);
}
double pnchisq(double x, double f, double theta, int lower_tail, int log_p)
{
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(f) || ISNAN(theta))
return x + f + theta;
if (!R_FINITE(f) || !R_FINITE(theta))
ML_ERR_return_NAN;
#endif
if (f < 0. || theta < 0.) ML_ERR_return_NAN;
return (R_DT_val(pnchisq_raw(x, f, theta, 1e-12, 8*DBL_EPSILON, 1000000)));
}
double qnchisq(double p, double df, double ncp, int lower_tail, int log_p)
{
const static double accu = 1e-13;
const static double racc = 4*DBL_EPSILON;
/* these two are for the "search" loops, can have less accuracy: */
const static double Eps = 1e-11; /* must be > accu */
const static double rEps= 1e-10; /* relative tolerance ... */
double ux, lx, ux0, 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 || ncp < 0) ML_ERR_return_NAN;
R_Q_P01_boundaries(p, 0, ML_POSINF);
/* Invert pnchisq(.) :
* 1. finding an upper and lower bound */
{
/* This is Pearson's (1959) approximation,
which is usually good to 4 figs or so. */
double b, c, ff;
b = (ncp*ncp)/(df + 3*ncp);
c = (df + 3*ncp)/(df + 2*ncp);
ff = (df + 2 * ncp)/(c*c);
ux = b + c * qchisq(p, ff, lower_tail, log_p);
if(ux < 0) ux = 1;
ux0 = ux;
}
p = R_D_qIv(p);
if(!lower_tail && ncp >= 80) {
/* pnchisq is only for lower.tail = TRUE */
if(p < 1e-10) ML_ERROR(ME_PRECISION, "qnchisq");
p = 1. - p;
lower_tail = TRUE;
}
if(lower_tail) {
if(p > 1 - DBL_EPSILON) return ML_POSINF;
pp = fmin2(1 - DBL_EPSILON, p * (1 + Eps));
for(; ux < DBL_MAX &&
pnchisq_raw(ux, df, ncp, Eps, rEps, 10000, TRUE) < pp;
ux *= 2);
pp = p * (1 - Eps);
for(lx = fmin2(ux0, DBL_MAX);
lx > DBL_MIN &&
pnchisq_raw(lx, df, ncp, Eps, rEps, 10000, TRUE) > pp;
lx *= 0.5);
}
else {
if(p > 1 - DBL_EPSILON) return 0.0;
pp = fmin2(1 - DBL_EPSILON, p * (1 + Eps));
for(; ux < DBL_MAX &&
pnchisq_raw(ux, df, ncp, Eps, rEps, 10000, FALSE) > pp;
ux *= 2);
pp = p * (1 - Eps);
for(lx = fmin2(ux0, DBL_MAX);
lx > DBL_MIN &&
pnchisq_raw(lx, df, ncp, Eps, rEps, 10000, FALSE) < pp;
lx *= 0.5);
}
/* 2. interval (lx,ux) halving : */
if(lower_tail) {
do {
nx = 0.5 * (lx + ux);
if (pnchisq_raw(nx, df, ncp, accu, racc, 100000, TRUE) > p)
ux = nx;
else
lx = nx;
}
while ((ux - lx) / nx > accu);
} else {
do {
nx = 0.5 * (lx + ux);
if (pnchisq_raw(nx, df, ncp, accu, racc, 100000, FALSE) < p)
ux = nx;
else
lx = nx;
}
while ((ux - lx) / nx > accu);
}
return 0.5 * (ux + lx);
}
