double dgamma(double x, double shape, double scale, int give_log)
{
double pr;
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(shape) || ISNAN(scale))
return x + shape + scale;
#endif
if (shape <= 0 || scale <= 0) ML_ERR_return_NAN;
if (x < 0)
return R_D__0;
if (x == 0) {
if (shape < 1) return ML_POSINF;
if (shape > 1) return R_D__0;
/* else */
return give_log ? -log(scale) : 1 / scale;
}
if (shape < 1) {
pr = dpois_raw(shape, x/scale, give_log);
return give_log ? pr + log(shape/x) : pr*shape/x;
}
/* else shape >= 1 */
pr = dpois_raw(shape-1, x/scale, give_log);
return give_log ? pr - log(scale) : pr/scale;
}
double dnchisq(double x, double df, double lambda, int give_log)
{
const double eps = 5e-15;
double i, lambda2, term, sum, q, mid, dfmid, imax, errorbound;
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(df) || ISNAN(lambda))
return x + df + lambda;
#endif
if (lambda < 0 || df <= 0) ML_ERR_return_NAN;
if (!R_FINITE(df) || !R_FINITE(lambda))
ML_ERR_return_NAN;
if(x < 0) return R_D__0;
if(x == 0 && df < 2.)
return ML_POSINF;
if(lambda == 0)
return dchisq(x, df, give_log);
lambda2 = 0.5 * lambda;
/* find max element of sum */
imax = ceil((-(2+df) +sqrt((2-df) * (2-df) + 4 * lambda * x))/4);
if (imax < 0) imax = 0;
dfmid = df + 2 * imax;
mid = dpois_raw(imax, lambda2, FALSE) * dchisq(x, dfmid, FALSE);
sum = mid;
/* upper tail */
term = mid;
i = imax;
df = dfmid;
do {
i++;
q = x * lambda2 / i / df;
df += 2;
term = q * term;
sum += term;
errorbound = term * q / (1-q);
} while (errorbound > eps || q >= 1);
/* lower tail */
term = mid;
df = dfmid;
i = imax;
while ( i ){
df -= 2;
q = i * df / x / lambda2;
i--;
term = q * term;
sum += term;
errorbound = term * q / (1-q);
if (errorbound <= eps && q < 1) break;
}
return R_D_val(sum);
}
/*
* Abramowitz and Stegun 6.5.29 [right]
*/
static double
pgamma_smallx (double x, double alph, int lower_tail, int log_p)
{
double sum = 0, c = alph, n = 0, term;
#ifdef DEBUG_p
REprintf (" pg_smallx(x=%.12g, alph=%.12g): ", x, alph);
#endif
/*
* Relative to 6.5.29 all terms have been multiplied by alph
* and the first, thus being 1, is omitted.
*/
do {
n++;
c *= -x / n;
term = c / (alph + n);
sum += term;
} while (fabs (term) > DBL_EPSILON * fabs (sum));
#ifdef DEBUG_p
REprintf ("%5.0f terms --> conv.sum=%g;", n, sum);
#endif
if (lower_tail) {
double f1 = log_p ? log1p (sum) : 1 + sum;
double f2;
if (alph > 1) {
f2 = dpois_raw (alph, x, log_p);
f2 = log_p ? f2 + x : f2 * exp (x);
} else if (log_p)
f2 = alph * log (x) - lgamma1p (alph);
else
f2 = pow (x, alph) / exp (lgamma1p (alph));
#ifdef DEBUG_p
REprintf (" (f1,f2)= (%g,%g)\n", f1,f2);
#endif
return log_p ? f1 + f2 : f1 * f2;
} else {
double lf2 = alph * log (x) - lgamma1p (alph);
#ifdef DEBUG_p
REprintf (" 1:%.14g 2:%.14g\n", alph * log (x), lgamma1p (alph));
REprintf (" sum=%.14g log(1+sum)=%.14g lf2=%.14g\n",
sum, log1p (sum), lf2);
#endif
if (log_p)
return R_Log1_Exp (log1p (sum) + lf2);
else {
double f1m1 = sum;
double f2m1 = expm1 (lf2);
return -(f1m1 + f2m1 + f1m1 * f2m1);
}
}
} /* pgamma_smallx() */
double dgamma(double x, double shape, double scale, int give_log)
{
#ifndef D_non_pois
double pr;
#endif
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(shape) || ISNAN(scale))
return x + shape + scale;
#endif
if (shape <= 0 || scale <= 0) ML_ERR_return_NAN;
if (x < 0)
return R_D__0;
if (x == 0) {
// if (shape < 1) ML_ERR_return_NAN;
if(shape < 1) return BOOM::infinity();
if(shape > 1) return R_D__0;
/* else */
return give_log ? -log(scale) : 1 / scale;
}
#ifdef D_non_pois
x /= scale;
return give_log ?
((shape - 1) * log(x) - lgammafn(shape) - x) - log(scale) :
exp((shape - 1) * log(x) - lgammafn(shape) - x) / scale;
#else /* new dpois() based code */
if (shape < 1) {
pr = dpois_raw(shape, x/scale, give_log);
return give_log ? pr + log(shape/x) : pr*shape/x;
}
/* else shape >= 1 */
pr = dpois_raw(shape-1, x/scale, give_log);
return give_log ? pr - log(scale) : pr/scale;
#endif
}
/* dpois_wrap (x_P_1, lambda, g_log) ==
* dpois (x_P_1 - 1, lambda, g_log) := exp(-L) L^k / gamma(k+1) , k := x_P_1 - 1
*/
static double
dpois_wrap (double x_plus_1, double lambda, int give_log)
{
#ifdef DEBUG_p
REprintf (" dpois_wrap(x+1=%.14g, lambda=%.14g, log=%d)\n",
x_plus_1, lambda, give_log);
#endif
if (!R_FINITE(lambda))
return R_D__0;
if (x_plus_1 > 1)
return dpois_raw (x_plus_1 - 1, lambda, give_log);
if (lambda > fabs(x_plus_1 - 1) * M_cutoff)
return R_D_exp(-lambda - lgammafn(x_plus_1));
else {
double d = dpois_raw (x_plus_1, lambda, give_log);
#ifdef DEBUG_p
REprintf (" -> d=dpois_raw(..)=%.14g\n", d);
#endif
return give_log
? d + log (x_plus_1 / lambda)
: d * (x_plus_1 / lambda);
}
}
double dpois(NMATH_STATE *state, double x, double lambda, int give_log)
{
if(isnan(x) || isnan(lambda))
return x + lambda;
if (lambda < 0) return NAN;
R_D_nonint_check(x);
if (x < 0 || !isfinite(x))
return R_D__0;
x = R_D_forceint(x);
return( dpois_raw(state, x,lambda,give_log) );
}
double dpois(double x, double lambda, int give_log)
{
#ifdef IEEE_754
if(ISNAN(x) || ISNAN(lambda))
return x + lambda;
#endif
if (lambda < 0) ML_ERR_return_NAN;
R_D_nonint_check(x);
if (x < 0 || !R_FINITE(x))
return R_D__0;
x = R_D_forceint(x);
return( dpois_raw(x,lambda,give_log) );
}
double dnbinom_mu(double x, double size, double mu, int give_log)
{
/* originally, just set prob := size / (size + mu) and called dbinom_raw(),
* but that suffers from cancellation when mu << size */
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(size) || ISNAN(mu))
return x + size + mu;
#endif
if (mu < 0 || size < 0) ML_ERR_return_NAN;
R_D_nonint_check(x);
if (x < 0 || !R_FINITE(x)) return R_D__0;
/* limiting case as size approaches zero is point mass at zero,
* even if mu is kept constant. limit distribution does not
* have mean mu, though.
*/
if (x == 0 && size == 0) return R_D__1;
x = R_forceint(x);
if(!R_FINITE(size)) // limit case: Poisson
return(dpois_raw(x, mu, give_log));
if(x == 0)/* be accurate, both for n << mu, and n >> mu :*/
return R_D_exp(size * (size < mu ? log(size/(size+mu)) : log1p(- mu/(size+mu))));
if(x < 1e-10 * size) { /* don't use dbinom_raw() but MM's formula: */
/* FIXME --- 1e-8 shows problem; rather use algdiv() from ./toms708.c */
double p = (size < mu ? log(size/(1 + size/mu)) : log(mu / (1 + mu/size)));
return R_D_exp(x * p - mu - lgamma(x+1) +
log1p(x*(x-1)/(2*size)));
} else {
/* no unnecessary cancellation inside dbinom_raw, when
* x_ = size and n_ = x+size are so close that n_ - x_ loses accuracy */
double p = ((double)size)/(size+x),
ans = dbinom_raw(size, x+size, size/(size+mu), mu/(size+mu), give_log);
return((give_log) ? log(p) + ans : p * ans);
}
}
double dnchisq(double x, double df, double ncp, int give_log)
{
const static double eps = 5e-15;
double i, ncp2, q, mid, dfmid, imax;
LDOUBLE sum, term;
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(df) || ISNAN(ncp))
return x + df + ncp;
#endif
if (!R_FINITE(df) || !R_FINITE(ncp) || ncp < 0 || df < 0)
ML_ERR_return_NAN;
if(x < 0) return R_D__0;
if(x == 0 && df < 2.)
return ML_POSINF;
if(ncp == 0)
return (df > 0) ? dchisq(x, df, give_log) : R_D__0;
if(x == ML_POSINF) return R_D__0;
ncp2 = 0.5 * ncp;
/* find max element of sum */
imax = ceil((-(2+df) +sqrt((2-df) * (2-df) + 4 * ncp * x))/4);
if (imax < 0) imax = 0;
if(R_FINITE(imax)) {
dfmid = df + 2 * imax;
mid = dpois_raw(imax, ncp2, FALSE) * dchisq(x, dfmid, FALSE);
} else /* imax = Inf */
mid = 0;
if(mid == 0) {
/* underflow to 0 -- maybe numerically correct; maybe can be more accurate,
* particularly when give_log = TRUE */
/* Use central-chisq approximation formula when appropriate;
* ((FIXME: the optimal cutoff also depends on (x,df); use always here? )) */
if(give_log || ncp > 1000.) {
double nl = df + ncp, ic = nl/(nl + ncp);/* = "1/(1+b)" Abramowitz & St.*/
return dchisq(x*ic, nl*ic, give_log);
} else
return R_D__0;
}
sum = mid;
/* errorbound := term * q / (1-q) now subsumed in while() / if() below: */
/* upper tail */
term = mid; df = dfmid; i = imax;
double x2 = x * ncp2;
do {
i++;
q = x2 / i / df;
df += 2;
term *= q;
sum += term;
} while (q >= 1 || term * q > (1-q)*eps || term > 1e-10*sum);
/* lower tail */
term = mid; df = dfmid; i = imax;
while (i != 0) {
df -= 2;
q = i * df / x2;
i--;
term *= q;
sum += term;
if (q < 1 && term * q <= (1-q)*eps) break;
}
return R_D_val((double) sum);
}
