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 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_D_forceint(n);
x = R_D_forceint(x);
return dbinom_raw(x, n, p, 1-p, give_log);
}
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) );
}
/* FIXME: The old phyper() code was basically used in ./qhyper.c as well
* ----- We need to sync this again!
*/
double phyper (double x, double NR, double NB, double n,
int lower_tail, int log_p)
{
/* Sample of n balls from NR red and NB black ones; x are red */
double d, pd;
#ifdef IEEE_754
if(ISNAN(x) || ISNAN(NR) || ISNAN(NB) || ISNAN(n))
return x + NR + NB + n;
#endif
x = floor (x + 1e-7);
NR = R_D_forceint(NR);
NB = R_D_forceint(NB);
n = R_D_forceint(n);
if (NR < 0 || NB < 0 || !R_FINITE(NR + NB) || n < 0 || n > NR + NB)
ML_ERR_return_NAN;
if (x * (NR + NB) > n * NR) {
/* Swap tails. */
double oldNB = NB;
NB = NR;
NR = oldNB;
x = n - x - 1;
lower_tail = !lower_tail;
}
if (x < 0)
return R_DT_0;
d = dhyper (x, NR, NB, n, log_p);
pd = pdhyper(x, NR, NB, n, log_p);
return log_p ? R_DT_Log(d + pd) : R_D_Lval(d * pd);
}
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 pbinom(double x, double n, double p, int lower_tail, int log_p)
{
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(n) || ISNAN(p))
return x + n + p;
if (!R_FINITE(n) || !R_FINITE(p)) ML_ERR_return_NAN;
#endif
if(R_D_nonint(n)) ML_ERR_return_NAN;
n = R_D_forceint(n);
if(n <= 0 || p < 0 || p > 1) ML_ERR_return_NAN;
x = floor(x + 1e-7);
if (x < 0.0) return R_DT_0;
if (n <= x) return R_DT_1;
return pbeta(p, x + 1, n - x, !lower_tail, log_p);
}
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_D_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 */
double ans, p;
#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_D_forceint(x);
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 */
return R_D_exp(x * log(size*mu / (size+mu)) - 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
*/
ans = dbinom_raw(size, x+size, size/(size+mu), mu/(size+mu), give_log);
p = ((double)size)/(size+x);
return((give_log) ? log(p) + ans : p * ans);
}
