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); }