double pgamma(double x, double alph, double scale, int lower_tail, int log_p)
{
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(alph) || ISNAN(scale))
return x + alph + scale;
#endif
if(alph < 0. || scale <= 0.)
ML_ERR_return_NAN;
x /= scale;
#ifdef IEEE_754
if (ISNAN(x)) /* eg. original x = scale = +Inf */
return x;
#endif
if(alph == 0.) /* limit case; useful e.g. in pnchisq() */
return (x <= 0) ? R_DT_0: R_DT_1; /* <= assert pgamma(0,0) ==> 0 */
return pgamma_raw (x, alph, 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;
}
