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 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);
}
double qt(double p, double ndf, int lower_tail, int log_p)
{
const static double eps = 1.e-12;
double P, q;
Rboolean neg;
#ifdef IEEE_754
if (ISNAN(p) || ISNAN(ndf))
return p + ndf;
#endif
R_Q_P01_boundaries(p, ML_NEGINF, ML_POSINF);
if (ndf <= 0) ML_ERR_return_NAN;
if (ndf < 1) { /* based on qnt */
const static double accu = 1e-13;
const static double Eps = 1e-11; /* must be > accu */
double ux, lx, nx, pp;
int iter = 0;
p = R_DT_qIv(p);
/* Invert pt(.) :
* 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 = 1.; ux < DBL_MAX && pt(ux, ndf, TRUE, FALSE) < pp; ux *= 2);
pp = p * (1 - Eps);
for(lx =-1.; lx > -DBL_MAX && pt(lx, ndf, TRUE, FALSE) > pp; lx *= 2);
/* 2. interval (lx,ux) halving
regula falsi failed on qt(0.1, 0.1)
*/
do {
nx = 0.5 * (lx + ux);
if (pt(nx, ndf, TRUE, FALSE) > p) ux = nx; else lx = nx;
} while ((ux - lx) / fabs(nx) > accu && ++iter < 1000);
if(iter >= 1000) ML_ERROR(ME_PRECISION, "qt");
return 0.5 * (lx + ux);
}
/* Old comment:
* FIXME: "This test should depend on ndf AND p !!
* ----- and in fact should be replaced by
* something like Abramowitz & Stegun 26.7.5 (p.949)"
*
* That would say that if the qnorm value is x then
* the result is about x + (x^3+x)/4df + (5x^5+16x^3+3x)/96df^2
* The differences are tiny even if x ~ 1e5, and qnorm is not
* that accurate in the extreme tails.
*/
if (ndf > 1e20) return qnorm(p, 0., 1., lower_tail, log_p);
P = R_D_qIv(p); /* if exp(p) underflows, we fix below */
neg = (!lower_tail || P < 0.5) && (lower_tail || P > 0.5);
if(neg)
P = 2 * (log_p ? (lower_tail ? P : -expm1(p)) : R_D_Lval(p));
else
P = 2 * (log_p ? (lower_tail ? -expm1(p) : P) : R_D_Cval(p));
/* 0 <= P <= 1 ; P = 2*min(P', 1 - P') in all cases */
/* Use this if(log_p) only : */
#define P_is_exp_2p (lower_tail == neg) /* both TRUE or FALSE == !xor */
if (fabs(ndf - 2) < eps) { /* df ~= 2 */
if(P > DBL_MIN) {
if(3* P < DBL_EPSILON) /* P ~= 0 */
q = 1 / sqrt(P);
else if (P > 0.9) /* P ~= 1 */
q = (1 - P) * sqrt(2 /(P * (2 - P)));
else /* eps/3 <= P <= 0.9 */
q = sqrt(2 / (P * (2 - P)) - 2);
}
else { /* P << 1, q = 1/sqrt(P) = ... */
if(log_p)
q = P_is_exp_2p ? exp(- p/2) / M_SQRT2 : 1/sqrt(-expm1(p));
else
q = ML_POSINF;
}
}
else if (ndf < 1 + eps) { /* df ~= 1 (df < 1 excluded above): Cauchy */
if(P > 0)
q = 1/tan(P * M_PI_2);/* == - tan((P+1) * M_PI_2) -- suffers for P ~= 0 */
else { /* P = 0, but maybe = 2*exp(p) ! */
if(log_p) /* 1/tan(e) ~ 1/e */
q = P_is_exp_2p ? M_1_PI * exp(-p) : -1./(M_PI * expm1(p));
else
q = ML_POSINF;
}
}
else { /*-- usual case; including, e.g., df = 1.1 */
double x = 0., y, log_P2 = 0./* -Wall */,
a = 1 / (ndf - 0.5),
b = 48 / (a * a),
c = ((20700 * a / b - 98) * a - 16) * a + 96.36,
d = ((94.5 / (b + c) - 3) / b + 1) * sqrt(a * M_PI_2) * ndf;
Rboolean P_ok1 = P > DBL_MIN || !log_p, P_ok = P_ok1;
if(P_ok1) {
y = pow(d * P, 2 / ndf);
P_ok = (y >= DBL_EPSILON);
}
if(!P_ok) { /* log_p && P very small */
log_P2 = P_is_exp_2p ? p : R_Log1_Exp(p); /* == log(P / 2) */
x = (log(d) + M_LN2 + log_P2) / ndf;
y = exp(2 * x);
}
if ((ndf < 2.1 && P > 0.5) || y > 0.05 + a) { /* P > P0(df) */
/* Asymptotic inverse expansion about normal */
if(P_ok)
x = qnorm(0.5 * P, 0., 1., /*lower_tail*/TRUE, /*log_p*/FALSE);
else /* log_p && P underflowed */
x = qnorm(log_P2, 0., 1., lower_tail, /*log_p*/ TRUE);
y = x * x;
if (ndf < 5)
c += 0.3 * (ndf - 4.5) * (x + 0.6);
c = (((0.05 * d * x - 5) * x - 7) * x - 2) * x + b + c;
y = (((((0.4 * y + 6.3) * y + 36) * y + 94.5) / c
- y - 3) / b + 1) * x;
y = expm1(a * y * y);
q = sqrt(ndf * y);
} else { /* re-use 'y' from above */
if(!P_ok && x < - M_LN2 * DBL_MANT_DIG) {/* 0.5* log(DBL_EPSILON) */
/* y above might have underflown */
q = sqrt(ndf) * exp(-x);
}
else {
y = ((1 / (((ndf + 6) / (ndf * y) - 0.089 * d - 0.822)
* (ndf + 2) * 3) + 0.5 / (ndf + 4))
* y - 1) * (ndf + 1) / (ndf + 2) + 1 / y;
q = sqrt(ndf * y);
}
}
/* Now apply 2-term Taylor expansion improvement (1-term = Newton):
* as by Hill (1981) [ref.above] */
/* FIXME: This can be far from optimal when log_p = TRUE
* but is still needed, e.g. for qt(-2, df=1.01, log=TRUE).
* Probably also improvable when lower_tail = FALSE */
if(P_ok1) {
int it=0;
while(it++ < 10 && (y = dt(q, ndf, FALSE)) > 0 &&
R_FINITE(x = (pt(q, ndf, FALSE, FALSE) - P/2) / y) &&
fabs(x) > 1e-14*fabs(q))
/* Newton (=Taylor 1 term):
* q += x;
* Taylor 2-term : */
q += x * (1. + x * q * (ndf + 1) / (2 * (q * q + ndf)));
}
}
if(neg) q = -q;
return q;
}
