double pf(double x, double df1, double df2, int lower_tail, int log_p) { #ifdef IEEE_754 if (ISNAN(x) || ISNAN(df1) || ISNAN(df2)) return x + df2 + df1; #endif if (df1 <= 0. || df2 <= 0.) ML_ERR_return_NAN; R_P_bounds_01(x, 0., ML_POSINF); /* move to pchisq for very large values - was 'df1 > 4e5' in 2.0.x, now only needed for df1 = Inf or df2 = Inf {since pbeta(0,*)=0} : */ if (df2 == ML_POSINF) { if (df1 == ML_POSINF) { if(x < 1.) return R_DT_0; if(x == 1.) return (log_p ? -M_LN2 : 0.5); if(x > 1.) return R_DT_1; } return pchisq(x * df1, df1, lower_tail, log_p); } if (df1 == ML_POSINF)/* was "fudge" 'df1 > 4e5' in 2.0.x */ return pchisq(df2 / x , df2, !lower_tail, log_p); /* Avoid squeezing pbeta's first parameter against 1 : */ if (df1 * x > df2) x = pbeta(df2 / (df2 + df1 * x), df2 / 2., df1 / 2., !lower_tail, log_p); else x = pbeta(df1 * x / (df2 + df1 * x), df1 / 2., df2 / 2., lower_tail, log_p); return ML_VALID(x) ? x : ML_NAN; }
double pnbeta(double x, double a, double b, double ncp, int lower_tail, int log_p) { #ifdef IEEE_754 if (ISNAN(x) || ISNAN(a) || ISNAN(b) || ISNAN(ncp)) return x + a + b + ncp; #endif R_P_bounds_01(x, 0., 1.); return pnbeta2(x, 1-x, a, b, ncp, lower_tail, log_p); }
double pgamma_raw (double x, double alph, int lower_tail, int log_p) { /* Here, assume that (x,alph) are not NA & alph > 0 . */ double res; #ifdef DEBUG_p REprintf("pgamma_raw(x=%.14g, alph=%.14g, low=%d, log=%d)\n", x, alph, lower_tail, log_p); #endif R_P_bounds_01(x, 0., ML_POSINF); if (x < 1) { res = pgamma_smallx (x, alph, lower_tail, log_p); } else if (x <= alph - 1 && x < 0.8 * (alph + 50)) { /* incl. large alph compared to x */ double sum = pd_upper_series (x, alph, log_p);/* = x/alph + o(x/alph) */ double d = dpois_wrap (alph, x, log_p); #ifdef DEBUG_p REprintf(" alph 'large': sum=pd_upper*()= %.12g, d=dpois_w(*)= %.12g\n", sum, d); #endif if (!lower_tail) res = log_p ? R_Log1_Exp (d + sum) : 1 - d * sum; else res = log_p ? sum + d : sum * d; } else if (alph - 1 < x && alph < 0.8 * (x + 50)) { /* incl. large x compared to alph */ double sum; double d = dpois_wrap (alph, x, log_p); #ifdef DEBUG_p REprintf(" x 'large': d=dpois_w(*)= %.14g ", d); #endif if (alph < 1) { if (x * DBL_EPSILON > 1 - alph) sum = R_D__1; else { double f = pd_lower_cf (alph, x - (alph - 1)) * x / alph; /* = [alph/(x - alph+1) + o(alph/(x-alph+1))] * x/alph = 1 + o(1) */ sum = log_p ? log (f) : f; } } else { sum = pd_lower_series (x, alph - 1);/* = (alph-1)/x + o((alph-1)/x) */ sum = log_p ? log1p (sum) : 1 + sum; } #ifdef DEBUG_p REprintf(", sum= %.14g\n", sum); #endif if (!lower_tail) res = log_p ? sum + d : sum * d; else res = log_p ? R_Log1_Exp (d + sum) : 1 - d * sum; } else { /* x >= 1 and x fairly near alph. */ #ifdef DEBUG_p REprintf(" using ppois_asymp()\n"); #endif res = ppois_asymp (alph - 1, x, !lower_tail, log_p); } /* * We lose a fair amount of accuracy to underflow in the cases * where the final result is very close to DBL_MIN. In those * cases, simply redo via log space. */ if (!log_p && res < DBL_MIN / DBL_EPSILON) { /* with(.Machine, double.xmin / double.eps) #|-> 1.002084e-292 */ #ifdef DEBUG_p REprintf(" very small res=%.14g; -> recompute via log\n", res); #endif return exp (pgamma_raw (x, alph, lower_tail, 1)); } else return res; }