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