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