double qf(double p, double df1, double df2, int lower_tail, int log_p) { #ifdef IEEE_754 if (ISNAN(p) || ISNAN(df1) || ISNAN(df2)) return p + df1 + df2; #endif if (df1 <= 0. || df2 <= 0.) ML_ERR_return_NAN; R_Q_P01_boundaries(p, 0, ML_POSINF); /* fudge the extreme DF cases -- qbeta doesn't do this well. But we still need to fudge the infinite ones. */ if (df1 <= df2 && df2 > 4e5) { if(!R_FINITE(df1)) /* df1 == df2 == Inf : */ return 1.; /* else */ return qchisq(p, df1, lower_tail, log_p) / df1; } if (df1 > 4e5) { /* and so df2 < df1 */ return df2 / qchisq(p, df2, !lower_tail, log_p); } p = (1. / qbeta(p, df2/2, df1/2, !lower_tail, log_p) - 1.) * (df2 / df1); return ML_VALID(p) ? p : ML_NAN; }
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 F77_SUB(sqrtqchisqint)(int *n, double *p) { return(sqrt(qchisq(p[0], (double) n[0], 0, 0))); }
double F77_SUB(invcdfchisq)(double *p, double *df, int *lower_tail, int *log_p) { return qchisq(*p, *df, *lower_tail, *log_p); }