public static double dnbinom_mu(double x, double size, double mu, boolean give_log) {
/* originally, just set prob := size / (size + mu) and called dbinom_raw(),
* but that suffers from cancellation when mu << size */
double ans, p;
if (DoubleVector.isNaN(x) || DoubleVector.isNaN(size) || DoubleVector.isNaN(mu)) {
return x + size + mu;
}
if (mu < 0 || size < 0) {
return DoubleVector.NaN;
}
// R_D_nonint_check(x);
if (SignRank.R_D_nonint(x, true, give_log)) {
// MATHLIB_WARNING("non-integer x = %f", x);
// How to warn??
return SignRank.R_D__0(true, give_log);
}
if (x < 0 || !DoubleVector.isFinite(x)) {
return SignRank.R_D__0(true, give_log);
}
x = SignRank.R_D_forceint(x);
if (x == 0) /* be accerate, both for n << mu, and n >> mu :*/ {
return SignRank.R_D_exp(
size * (size < mu ? Math.log(size / (size + mu)) : Math.log1p(-mu / (size + mu))),
true,
give_log);
}
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 SignRank.R_D_exp(
x * Math.log(size * mu / (size + mu))
- mu
- org.apache.commons.math.special.Gamma.logGamma(x + 1)
+ Math.log1p(x * (x - 1) / (2 * size)),
true,
give_log);
}
/* 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) ? Math.log(p) + ans : p * ans);
}
public static double qnbeta(
double p, double a, double b, double ncp, boolean lower_tail, boolean log_p) {
final double accu = 1e-15;
final double Eps = 1e-14; /* must be > accu */
double ux, lx, nx, pp;
if (DoubleVector.isNaN(p)
|| DoubleVector.isNaN(a)
|| DoubleVector.isNaN(b)
|| DoubleVector.isNaN(ncp)) {
return p + a + b + ncp;
}
if (!DoubleVector.isFinite(a)) {
return DoubleVector.NaN;
}
if (ncp < 0. || a <= 0. || b <= 0.) {
return DoubleVector.NaN;
}
// R_Q_P01_boundaries(p, 0, 1);
if ((log_p && p > 0) || (!log_p && (p < 0 || p > 1))) {
return DoubleVector.NaN;
}
if (p == SignRank.R_DT_0(lower_tail, log_p)) {
return 0.0;
}
if (p == SignRank.R_DT_1(lower_tail, log_p)) {
return 1.0;
}
// end of R_Q_P01_boundaries
p = Normal.R_DT_qIv(p, log_p ? 1.0 : 0.0, lower_tail ? 1.0 : 0.0);
/* Invert pnbeta(.) :
* 1. finding an upper and lower bound */
if (p > 1 - SignRank.DBL_EPSILON) {
return 1.0;
}
pp = Math.min(1 - SignRank.DBL_EPSILON, p * (1 + Eps));
for (ux = 0.5;
ux < 1 - SignRank.DBL_EPSILON && pnbeta(ux, a, b, ncp, true, false) < pp;
ux = 0.5 * (1 + ux)) ;
pp = p * (1 - Eps);
for (lx = 0.5; lx > Double.MIN_VALUE && pnbeta(lx, a, b, ncp, true, false) > pp; lx *= 0.5) ;
/* 2. interval (lx,ux) halving : */
do {
nx = 0.5 * (lx + ux);
if (pnbeta(nx, a, b, ncp, true, false) > p) {
ux = nx;
} else {
lx = nx;
}
} while ((ux - lx) / nx > accu);
return 0.5 * (ux + lx);
}
public static double pnbeta(
double x, double a, double b, double ncp, boolean lower_tail, boolean log_p) {
if (DoubleVector.isNaN(x)
|| DoubleVector.isNaN(a)
|| DoubleVector.isNaN(b)
|| DoubleVector.isNaN(ncp)) {
return x + a + b + ncp;
}
// R_P_bounds_01(x, 0., 1.);
if (x <= 0.0) {
return SignRank.R_DT_0(lower_tail, log_p);
}
if (x >= 1.0) {
return SignRank.R_DT_1(lower_tail, log_p);
}
return pnbeta2(x, 1 - x, a, b, ncp, lower_tail, log_p);
}
public static double pnbinom_mu(
double x, double size, double mu, boolean lower_tail, boolean log_p) {
if (DoubleVector.isNaN(x) || DoubleVector.isNaN(size) || DoubleVector.isNaN(mu)) {
return x + size + mu;
}
if (!DoubleVector.isFinite(size) || !DoubleVector.isFinite(mu)) {
return DoubleVector.NaN;
}
if (size <= 0 || mu < 0) {
return DoubleVector.NaN;
}
if (x < 0) {
SignRank.R_DT_0(lower_tail, log_p);
}
if (!DoubleVector.isFinite(x)) {
return SignRank.R_DT_1(lower_tail, log_p);
}
x = Math.floor(x + 1e-7);
/* return
* pbeta(pr, size, x + 1, lower_tail, log_p); pr = size/(size + mu), 1-pr = mu/(size+mu)
*
*= pbeta_raw(pr, size, x + 1, lower_tail, log_p)
* x. pin qin
*= bratio (pin, qin, x., 1-x., &w, &wc, &ierr, log_p), and return w or wc ..
*= bratio (size, x+1, pr, 1-pr, &w, &wc, &ierr, log_p) */
{
int[] ierr = new int[1];
double[] w = new double[1];
double[] wc = new double[1];
Utils.bratio(size, x + 1, size / (size + mu), mu / (size + mu), w, wc, ierr, log_p);
return lower_tail ? w[0] : wc[0];
}
}
public static double dbinom_raw(double x, double n, double p, double q, boolean give_log) {
double lf, lc;
if (p == 0) {
return ((x == 0) ? SignRank.R_D__1(true, give_log) : SignRank.R_D__0(true, give_log));
}
if (q == 0) {
return ((x == n) ? SignRank.R_D__1(true, give_log) : SignRank.R_D__0(true, give_log));
}
if (x == 0) {
if (n == 0) {
return SignRank.R_D__1(true, give_log);
}
lc = (p < 0.1) ? -bd0(n, n * q) - n * p : n * Math.log(q);
return (SignRank.R_D_exp(lc, true, give_log));
}
if (x == n) {
lc = (q < 0.1) ? -bd0(n, n * p) - n * q : n * Math.log(p);
return (SignRank.R_D_exp(lc, true, give_log));
}
if (x < 0 || x > n) {
return (SignRank.R_D__0(true, give_log));
}
/* 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 = Math.log(2.0 * Math.PI) + Math.log(x) + Math.log1p(-x / n);
return SignRank.R_D_exp(lc - 0.5 * lf, true, give_log);
}
public static double qnbinom(
double p, double size, double prob, boolean lower_tail, boolean log_p) {
double P, Q, mu, sigma, gamma, y;
double[] z = new double[1];
if (DoubleVector.isNaN(p) || DoubleVector.isNaN(size) || DoubleVector.isNaN(prob)) {
return p + size + prob;
}
if (prob <= 0 || prob > 1 || size <= 0) {
return DoubleVector.NaN;
}
/* FIXME: size = 0 is well defined ! */
if (prob == 1) {
return 0;
}
// R_Q_P01_boundaries(p, 0, ML_POSINF);
// #define R_Q_P01_boundaries(p, _LEFT_, _RIGHT_)
// This macro is defined in /src/nmath/dpq.h
if (log_p) {
if (p > 0) {
return DoubleVector.NaN;
}
if (p == 0) {
/* upper bound*/
return lower_tail ? Double.POSITIVE_INFINITY : 0;
}
if (p == Double.NEGATIVE_INFINITY) {
return lower_tail ? 0 : Double.POSITIVE_INFINITY;
}
} else {
/* !log_p */
if (p < 0 || p > 1) {
return DoubleVector.NaN;
}
if (p == 0) {
return lower_tail ? 0 : Double.POSITIVE_INFINITY;
}
if (p == 1) {
return lower_tail ? Double.POSITIVE_INFINITY : 0;
}
}
Q = 1.0 / prob;
P = (1.0 - prob) * Q;
mu = size * P;
sigma = Math.sqrt(size * P * Q);
gamma = (Q + P) / sigma;
/* Note : "same" code in qpois.c, qbinom.c, qnbinom.c --
* FIXME: This is far from optimal [cancellation for p ~= 1, etc]: */
if (!lower_tail || log_p) {
// p = R_DT_qIv(p); /* need check again (cancellation!): */
p = Normal.R_DT_qIv(p, lower_tail ? 1.0 : 0.0, log_p ? 1.0 : 0.0);
if (p == SignRank.R_DT_0(lower_tail, log_p)) {
return 0;
}
if (p == SignRank.R_DT_1(lower_tail, log_p)) {
return Double.POSITIVE_INFINITY;
}
}
/* temporary hack --- FIXME --- */
if (p + 1.01 * SignRank.DBL_EPSILON >= 1.) {
return Double.POSITIVE_INFINITY;
}
/* y := approx.value (Cornish-Fisher expansion) : */
z[0] = Distributions.qnorm(p, 0., 1., /*lower_tail*/ true, /*log_p*/ false);
y = Math.floor(mu + sigma * (z[0] + gamma * (z[0] * z[0] - 1) / 6) + 0.5);
z[0] = Distributions.pnbinom(y, (int) size, prob, /*lower_tail*/ true, /*log_p*/ false);
/* fuzz to ensure left continuity: */
p *= 1 - 64 * SignRank.DBL_EPSILON;
/* If the C-F value is not too large a simple search is OK */
if (y < 1e5) {
return do_search(y, z, p, size, prob, 1);
}
/* Otherwise be a bit cleverer in the search */
{
double incr = Math.floor(y * 0.001), oldincr;
do {
oldincr = incr;
y = do_search(y, z, p, size, prob, incr);
incr = Math.max(1, Math.floor(incr / 100));
} while (oldincr > 1 && incr > y * 1e-15);
return y;
}
}
public static double dnbeta(double x, double a, double b, double ncp, boolean give_log) {
final double eps = 1.e-15;
int kMax;
double k, ncp2, dx2, d, D;
double sum, term, p_k, q; /* They were LDOUBLE */
if (DoubleVector.isNaN(x)
|| DoubleVector.isNaN(a)
|| DoubleVector.isNaN(b)
|| DoubleVector.isNaN(ncp)) {
return x + a + b + ncp;
}
if (ncp < 0 || a <= 0 || b <= 0) {
return DoubleVector.NaN;
}
if (!DoubleVector.isFinite(a) || !DoubleVector.isFinite(b) || !DoubleVector.isFinite(ncp)) {
return DoubleVector.NaN;
}
if (x < 0 || x > 1) {
return (SignRank.R_D__0(true, give_log));
}
if (ncp == 0) {
return Distributions.dbeta(x, a, b, give_log);
}
/* New algorithm, starting with *largest* term : */
ncp2 = 0.5 * ncp;
dx2 = ncp2 * x;
d = (dx2 - a - 1) / 2;
D = d * d + dx2 * (a + b) - a;
if (D <= 0) {
kMax = 0;
} else {
D = Math.ceil(d + Math.sqrt(D));
kMax = (D > 0) ? (int) D : 0;
}
/* The starting "middle term" --- first look at it's log scale: */
term = Distributions.dbeta(x, a + kMax, b, /* log = */ true);
p_k = Poisson.dpois_raw(kMax, ncp2, true);
if (x == 0.
|| !DoubleVector.isFinite(term)
|| !DoubleVector.isFinite(p_k)) /* if term = +Inf */ {
return SignRank.R_D_exp(p_k + term, true, give_log);
}
/* Now if s_k := p_k * t_k {here = exp(p_k + term)} would underflow,
* we should rather scale everything and re-scale at the end:*/
p_k += term; /* = log(p_k) + log(t_k) == log(s_k) -- used at end to rescale */
/* mid = 1 = the rescaled value, instead of mid = exp(p_k); */
/* Now sum from the inside out */
sum = term = 1. /* = mid term */;
/* middle to the left */
k = kMax;
while (k > 0 && term > sum * eps) {
k--;
q = /* 1 / r_k = */ (k + 1) * (k + a) / (k + a + b) / dx2;
term *= q;
sum += term;
}
/* middle to the right */
term = 1.;
k = kMax;
do {
q = /* r_{old k} = */ dx2 * (k + a + b) / (k + a) / (k + 1);
k++;
term *= q;
sum += term;
} while (term > sum * eps);
return SignRank.R_D_exp(p_k + Math.log(sum), true, give_log);
}
