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