double dbinom_raw(double x, double n, double p, double q, int give_log)
{
double lf, lc;
if (p == 0) return((x == 0) ? R_D__1 : R_D__0);
if (q == 0) return((x == n) ? R_D__1 : R_D__0);
if (x == 0) {
if(n == 0) return R_D__1;
lc = (p < 0.1) ? -bd0(n,n*q) - n*p : n*log(q);
return( R_D_exp(lc) );
}
if (x == n) {
lc = (q < 0.1) ? -bd0(n,n*p) - n*q : n*log(p);
return( R_D_exp(lc) );
}
if (x < 0 || x > n) return( R_D__0 );
/* n*p or n*q can underflow to zero if n and p or q are small. This
used to occur in dbeta, and gives NaN as from R 2.3.0. */
lc = stirlerr(n) - stirlerr(x) - stirlerr(n-x) - bd0(x,n*p) - bd0(n-x,n*q);
/* f = (M_2PI*x*(n-x))/n; could overflow or underflow */
/* Upto R 2.7.1:
* lf = log(M_2PI) + log(x) + log(n-x) - log(n);
* -- following is much better for x << n : */
lf = M_LN_2PI + log(x) + log1p(- x/n);
return R_D_exp(lc - 0.5*lf);
}
double dbinom(int x, int n, double p)
{
assert((p>=0) && (p<=1));
assert(n>=0);
assert((x>=0) && (x<=n));
if (p==0.0) return x==0 ? 1.0 : 0.0;
if (p==1.0) return x==n ? 1.0 : 0.0;
if (x==0) return exp(n*log(1-p));
if (x==n) return exp(n*log(p));
double lc = stirlerr(n) - stirlerr(x) - stirlerr(n-x) - bd0(x, n*p) - bd0(n-x, n*(1-p));
return exp(lc)*sqrt(n/(PI2*x*(n-x)));
}
static lua_Number dbinom_raw (lua_Number x, lua_Number n, lua_Number p,
lua_Number q) {
lua_Number f, lc;
if (p == 0) return (x == 0) ? 1 : 0;
if (q == 0) return (x == n) ? 1 : 0;
if (x == 0)
return exp((p < 0.1) ? -bd0(n, n * q) - n * p : n * log(q));
if (x == n)
return exp((q < 0.1) ? -bd0(n, n * p) - n * q : n * log(p));
if ((x < 0) || (x > n)) return 0;
lc = stirlerr(n) - stirlerr(x) - stirlerr(n - x)
- bd0(x, n * p) - bd0(n - x, n * q);
f = (2 * M_PI * x * (n - x)) / n;
return exp(lc) / sqrt(f);
}
double dt(double x, double n, int give_log)
{
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(n))
return x + n;
#endif
if (n <= 0) ML_ERR_return_NAN;
if(!R_FINITE(x))
return R_D__0;
if(!R_FINITE(n))
return dnorm(x, 0., 1., give_log);
double u, ax, t = -bd0(n/2.,(n+1)/2.) + stirlerr((n+1)/2.) - stirlerr(n/2.),
x2n = x*x/n, // in [0, Inf]
l_x2n; // := log(sqrt(1 + x2n)) = log(1 + x2n)/2
Rboolean lrg_x2n = (x2n > 1./DBL_EPSILON);
if (lrg_x2n) { // large x^2/n :
ax = fabs(x);
l_x2n = log(ax) - log(n)/2.; // = log(x2n)/2 = 1/2 * log(x^2 / n)
u = // log(1 + x2n) * n/2 = n * log(1 + x2n)/2 =
n * l_x2n;
}
else if (x2n > 0.2) {
l_x2n = log(1 + x2n)/2.;
u = n * l_x2n;
} else {
l_x2n = log1p(x2n)/2.;
u = -bd0(n/2.,(n+x*x)/2.) + x*x/2.;
}
//old: return R_D_fexp(M_2PI*(1+x2n), t-u);
// R_D_fexp(f,x) := (give_log ? -0.5*log(f)+(x) : exp(x)/sqrt(f))
// f = 2pi*(1+x2n)
// ==> 0.5*log(f) = log(2pi)/2 + log(1+x2n)/2 = log(2pi)/2 + l_x2n
// 1/sqrt(f) = 1/sqrt(2pi * (1+ x^2 / n))
// = 1/sqrt(2pi)/(|x|/sqrt(n)*sqrt(1+1/x2n))
// = M_1_SQRT_2PI * sqrt(n)/ (|x|*sqrt(1+1/x2n))
if(give_log)
return t-u - (M_LN_SQRT_2PI + l_x2n);
// else : if(lrg_x2n) : sqrt(1 + 1/x2n) ='= sqrt(1) = 1
double I_sqrt_ = (lrg_x2n ? sqrt(n)/ax : exp(-l_x2n));
return exp(t-u) * M_1_SQRT_2PI * I_sqrt_;
}
double dpois_raw(NMATH_STATE *state, double x, double lambda, int give_log)
{
/* x >= 0 ; integer for dpois(), but not e.g. for pgamma()!
lambda >= 0
*/
if (lambda == 0) return( (x == 0) ? R_D__1 : R_D__0 );
if (!isfinite(lambda)) return R_D__0;
if (x < 0) return( R_D__0 );
if (x <= lambda * DBL_MIN) return(R_D_exp(-lambda) );
if (lambda < x * DBL_MIN) return(R_D_exp(-lambda + x*log(lambda) -lgammafn(state, x+1)));
return(R_D_fexp( M_PI*2.0*x, -stirlerr(state,x)-bd0(x,lambda) ));
}
double attribute_hidden dpois_raw(double x, double lambda, int give_log)
{
/* x >= 0 ; integer for dpois(), but not e.g. for pgamma()!
lambda >= 0
*/
if (lambda == 0) return( (x == 0) ? R_D__1 : R_D__0 );
if (!R_FINITE(lambda)) return R_D__0;
if (x < 0) return( R_D__0 );
if (x <= lambda * DBL_MIN) return(R_D_exp(-lambda) );
if (lambda < x * DBL_MIN) return(R_D_exp(-lambda + x*log(lambda) -lgammafn(x+1)));
return(R_D_fexp( M_2PI*x, -stirlerr(x)-bd0(x,lambda) ));
}
double dpois(int x, double lb)
{
if (lb==0.0) return x==0 ? 1.0 : 0.0;
if (x==0) return exp(-lb);
return exp(-stirlerr(x)-bd0(x,lb))/sqrt(PI2*x);
}
