double
dhyper (double x, double r, double b, double n, int give_log)
{
double p, q, p1, p2, p3;
if (isnan (x) || isnan (r) || isnan (b) || isnan (n))
return x + r + b + n;
if (R_D_negInonint (r) || R_D_negInonint (b) || R_D_negInonint (n)
|| n > r + b)
return(NAN);
if (x < 0)
return (R_D__0);
R_D_nonint_check (x); // incl warning
x = round (x);
r = round (r);
b = round (b);
n = round (n);
if (n < x || r < x || n - x > b)
return (R_D__0);
if (n == 0)
return ((x == 0) ? R_D__1 : R_D__0);
p = ((double) n) / ((double) (r + b));
q = ((double) (r + b - n)) / ((double) (r + b));
p1 = dbinom_raw (x, r, p, q, give_log);
p2 = dbinom_raw (n - x, b, p, q, give_log);
p3 = dbinom_raw (n, r + b, p, q, give_log);
return ((give_log) ? p1 + p2 - p3 : p1 * p2 / p3);
}
double df(double x, double m, double n, int give_log)
{
double p, q, f, dens;
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(m) || ISNAN(n))
return x + m + n;
#endif
if (m <= 0 || n <= 0) ML_ERR_return_NAN;
if (x <= 0.) return(R_D__0);
if (!R_FINITE(m) && !R_FINITE(n)) { /* both +Inf */
if(x == 1.) return ML_POSINF;
/* else */ return R_D__0;
}
if (!R_FINITE(n)) /* must be +Inf by now */
return(dgamma(x, m/2, 2./m, give_log));
if (m > 1e14) {/* includes +Inf: code below is inaccurate there */
dens = dgamma(1./x, n/2, 2./n, give_log);
return give_log ? dens - 2*log(x): dens/(x*x);
}
f = 1./(n+x*m);
q = n*f;
p = x*m*f;
if (m >= 2) {
f = m*q/2;
dens = dbinom_raw((m-2)/2, (m+n-2)/2, p, q, give_log);
}
else {
f = m*m*q / (2*p*(m+n));
dens = dbinom_raw(m/2, (m+n)/2, p, q, give_log);
}
return(give_log ? log(f)+dens : f*dens);
}
double dhyper(double x, double r, double b, double n, int give_log)
{
double p, q, p1, p2, p3;
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(r) || ISNAN(b) || ISNAN(n))
return x + r + b + n;
#endif
if (R_D_negInonint(r) || R_D_negInonint(b) || R_D_negInonint(n) || n > r+b)
ML_ERR_return_NAN;
if (R_D_negInonint(x))
return(R_D__0);
x = R_D_forceint(x);
r = R_D_forceint(r);
b = R_D_forceint(b);
n = R_D_forceint(n);
if (n < x || r < x || n - x > b) return(R_D__0);
if (n == 0) return((x == 0) ? R_D__1 : R_D__0);
p = ((double)n)/((double)(r+b));
q = ((double)(r+b-n))/((double)(r+b));
p1 = dbinom_raw(x, r, p,q,give_log);
p2 = dbinom_raw(n-x,b, p,q,give_log);
p3 = dbinom_raw(n,r+b, p,q,give_log);
return( (give_log) ? p1 + p2 - p3 : p1*p2/p3 );
}
double dbeta(double x, double a, double b, int give_log)
{
double lval;
#ifdef IEEE_754
/* NaNs propagated correctly */
if (ISNAN(x) || ISNAN(a) || ISNAN(b)) return x + a + b;
#endif
if (a <= 0 || b <= 0) ML_ERR_return_NAN;
if (x < 0 || x > 1) return(R_D__0);
if (x == 0) {
if(a > 1) return(R_D__0);
if(a < 1) return(ML_POSINF);
/* a == 1 : */ return(R_D_val(b));
}
if (x == 1) {
if(b > 1) return(R_D__0);
if(b < 1) return(ML_POSINF);
/* b == 1 : */ return(R_D_val(a));
}
if (a <= 2 || b <= 2)
lval = (a-1)*log(x) + (b-1)*log1p(-x) - lbeta(a, b);
else
lval = log(a+b-1) + dbinom_raw(a-1, a+b-2, x, 1-x, TRUE);
return R_D_exp(lval);
}
static lua_Number dhyper_raw (lua_Number x, lua_Number r, lua_Number b,
lua_Number n) {
lua_Number p, q, p1, p2, p3;
if (x < 0) return 0;
x = FORCE_INT(x);
r = FORCE_INT(r);
b = FORCE_INT(b);
n = FORCE_INT(n);
if (n == 0) return (x == 0) ? 1 : 0;
p = n / (r + b);
q = (r + b - n) / (r + b);
p1 = dbinom_raw(x, r, p, q);
p2 = dbinom_raw(n - x, b, p, q);
p3 = dbinom_raw(n, r + b, p, q);
return p1 * p2 / p3;
}
double qztbinom(double x, double size, double prob, int lower_tail, int log_p)
{
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(size) || ISNAN(prob))
return x + size + prob;
#endif
if (prob < 0 || prob > 1 || size < 1) return R_NaN;
/* limiting cases as size -> 1 or prob -> 0 are point mass at one */
if (size == 1 || prob == 0)
{
/* simplified ACT_Q_P01_boundaries macro */
if (log_p)
{
if (x > 0)
return R_NaN;
return 1.0;
}
else /* !log_p */
{
if (x < 0 || x > 1)
return R_NaN;
return 1.0;
}
}
ACT_Q_P01_boundaries(x, 1, size);
x = ACT_DT_qIv(x);
double p0 = dbinom_raw(0, size, prob, 1 - prob, /*give_log*/0);
return qbinom(p0 + (1 - p0) * x, size, prob, /*l._t.*/1, /*log_p*/0);
}
double rztbinom(double size, double prob)
{
if (!R_FINITE(prob) || prob < 0 || prob > 1 || size < 0) return R_NaN;
/* limiting cases as size -> 1 or prob -> 0 are point mass at one */
if (size == 1 || prob == 0) return 1.0;
double p0 = dbinom_raw(0, size, prob, 1 - prob, /*give_log*/0);
return qbinom(runif(p0, 1), size, prob, /*l._t.*/1, /*log_p*/0);
}
static int stat_dbinom (lua_State *L) {
/* stack should contain s, xn, pr */
lua_Number s = luaL_checknumber(L, 1);
lua_Number xn = luaL_checknumber(L, 2);
lua_Number pr = luaL_checknumber(L, 3);
check_binom(L, 1, s, xn, pr);
s = FORCE_INT(s);
xn = FORCE_INT(xn);
lua_pushnumber(L, dbinom_raw(s, xn, pr, 1 - pr));
return 1;
}
double dbinom(double x, double n, double p, int give_log)
{
#ifdef IEEE_754
/* NaNs propagated correctly */
if (ISNAN(x) || ISNAN(n) || ISNAN(p)) return x + n + p;
#endif
if (p < 0 || p > 1 || R_D_negInonint(n))
ML_ERR_return_NAN;
R_D_nonint_check(x);
if (x < 0 || !R_FINITE(x)) return R_D__0;
n = R_forceint(n);
x = R_forceint(x);
return dbinom_raw(x, n, p, 1-p, give_log);
}
double pztbinom(double x, double size, double prob, int lower_tail, int log_p)
{
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(size) || ISNAN(prob))
return x + size + prob;
#endif
if (prob < 0 || prob > 1 || size < 1) return R_NaN;
if (x < 1) return ACT_DT_0;
if (!R_FINITE(x)) return ACT_DT_1;
/* limiting cases as size -> 1 or prob -> 0 are point mass at one */
if (size == 1 || prob == 0) return (x >= 1) ? ACT_DT_1 : ACT_DT_0;
double lp0 = dbinom_raw(0, size, prob, 1 - prob, /*give_log*/1);
return ACT_DT_Cval(pbinom(x, size, prob, /*l._t.*/0, /*log_p*/0)/(-expm1(lp0)));
}
double dbeta(double x, double a, double b, int give_log)
{
#ifdef IEEE_754
/* NaNs propagated correctly */
if (ISNAN(x) || ISNAN(a) || ISNAN(b)) return x + a + b;
#endif
if (a < 0 || b < 0) ML_ERR_return_NAN;
if (x < 0 || x > 1) return(R_D__0);
// limit cases for (a,b), leading to point masses
if(a == 0 || b == 0 || !R_FINITE(a) || !R_FINITE(b)) {
if(a == 0 && b == 0) { // point mass 1/2 at each of {0,1} :
if (x == 0 || x == 1) return(ML_POSINF); /* else */ return(R_D__0);
}
if (a == 0 || a/b == 0) { // point mass 1 at 0
if (x == 0) return(ML_POSINF); /* else */ return(R_D__0);
}
if (b == 0 || b/a == 0) { // point mass 1 at 1
if (x == 1) return(ML_POSINF); /* else */ return(R_D__0);
}
// else, remaining case: a = b = Inf : point mass 1 at 1/2
if (x == 0.5) return(ML_POSINF); /* else */ return(R_D__0);
}
if (x == 0) {
if(a > 1) return(R_D__0);
if(a < 1) return(ML_POSINF);
/* a == 1 : */ return(R_D_val(b));
}
if (x == 1) {
if(b > 1) return(R_D__0);
if(b < 1) return(ML_POSINF);
/* b == 1 : */ return(R_D_val(a));
}
double lval;
if (a <= 2 || b <= 2)
lval = (a-1)*log(x) + (b-1)*log1p(-x) - lbeta(a, b);
else
lval = log(a+b-1) + dbinom_raw(a-1, a+b-2, x, 1-x, TRUE);
return R_D_exp(lval);
}
double dgeom(double x, double p, int give_log)
{
double prob;
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(p)) return x + p;
#endif
if (p < 0 || p > 1) ML_ERR_return_NAN;
R_D_nonint_check(x);
if (x < 0 || !R_FINITE(x) || p == 0) return R_D__0;
x = R_D_forceint(x);
/* prob = (1-p)^x, stable for small p */
prob = dbinom_raw(0.,x, p,1-p, give_log);
return((give_log) ? log(p) + prob : p*prob);
}
double dnbinom(double x, double size, double prob, int give_log)
{
double ans, p;
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(size) || ISNAN(prob))
return x + size + prob;
#endif
if (prob <= 0 || prob > 1 || 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 */
if (x == 0 && size==0) return R_D__1;
x = R_forceint(x);
ans = dbinom_raw(size, x+size, prob, 1-prob, give_log);
p = ((double)size)/(size+x);
return((give_log) ? log(p) + ans : p * ans);
}
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 dztbinom(double x, double size, double prob, int give_log)
{
/* We compute Pr[X = 0] with dbinom_raw() [as would eventually
* dbinom()] to take advantage of all the optimizations for
* small/large values of 'prob' and 'size' (and also to skip some
* validity tests).
*/
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(size) || ISNAN(prob))
return x + size + prob;
#endif
if (prob < 0 || prob > 1 || size < 1) return R_NaN;
if (x < 1 || !R_FINITE(x)) return ACT_D__0;
/* limiting cases as size -> 1 or prob -> 0 are point mass at one */
if (size == 1 || prob == 0) return (x == 1) ? ACT_D__1 : ACT_D__0;
double lp0 = dbinom_raw(0, size, prob, 1 - prob, /*give_log*/1);
return ACT_D_val(dbinom(x, size, prob, /*give_log*/0)/(-expm1(lp0)));
}
