double pnbinom_mu(double x, double size, double mu, int lower_tail, int log_p)
{
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(size) || ISNAN(mu))
return x + size + mu;
if(!R_FINITE(mu)) ML_ERR_return_NAN;
#endif
if (size < 0 || mu < 0) ML_ERR_return_NAN;
/* limiting case: point mass at zero */
if (size == 0)
return (x >= 0) ? R_DT_1 : R_DT_0;
if (x < 0) return R_DT_0;
if (!R_FINITE(x)) return R_DT_1;
if (!R_FINITE(size)) // limit case: Poisson
return(ppois(x, mu, lower_tail, log_p));
x = 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;
double w, wc;
bratio(size, x+1, size/(size+mu), mu/(size+mu), &w, &wc, &ierr, log_p);
if(ierr)
MATHLIB_WARNING(_("pnbinom_mu() -> bratio() gave error code %d"), ierr);
return lower_tail ? w : wc;
}
}
double qpois(double p, double lambda, int lower_tail, int log_p)
{
double mu, sigma, gamma, z, y;
#ifdef IEEE_754
if (ISNAN(p) || ISNAN(lambda))
return p + lambda;
#endif
if(!R_FINITE(lambda))
ML_ERR_return_NAN;
if(lambda < 0) ML_ERR_return_NAN;
R_Q_P01_check(p);
if(lambda == 0) return 0;
if(p == R_DT_0) return 0;
if(p == R_DT_1) return ML_POSINF;
mu = lambda;
sigma = sqrt(lambda);
/* gamma = sigma; PR#8058 should be kurtosis which is mu^-0.5 */
gamma = 1.0/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!): */
if (p == 0.) return 0;
if (p == 1.) return ML_POSINF;
}
/* temporary hack --- FIXME --- */
if (p + 1.01*DBL_EPSILON >= 1.) return ML_POSINF;
/* y := approx.value (Cornish-Fisher expansion) : */
z = qnorm(p, 0., 1., /*lower_tail*/TRUE, /*log_p*/FALSE);
#ifdef HAVE_NEARBYINT
y = nearbyint(mu + sigma * (z + gamma * (z*z - 1) / 6));
#else
y = round(mu + sigma * (z + gamma * (z*z - 1) / 6));
#endif
z = ppois(y, lambda, /*lower_tail*/TRUE, /*log_p*/FALSE);
/* fuzz to ensure left continuity; 1 - 1e-7 may lose too much : */
p *= 1 - 64*DBL_EPSILON;
/* If the mean is not too large a simple search is OK */
if(lambda < 1e5) return do_search(y, &z, p, lambda, 1);
/* Otherwise be a bit cleverer in the search */
{
double incr = floor(y * 0.001), oldincr;
do {
oldincr = incr;
y = do_search(y, &z, p, lambda, incr);
incr = fmax2(1, floor(incr/100));
} while(oldincr > 1 && incr > lambda*1e-15);
return y;
}
}
static double
do_search(double y, double *z, double p, double lambda, double incr)
{
if(*z >= p) {
/* search to the left */
for(;;) {
if(y == 0 ||
(*z = ppois(y - incr, lambda, /*l._t.*/TRUE, /*log_p*/FALSE)) < p)
return y;
y = fmax2(0, y - incr);
}
}
else { /* search to the right */
for(;;) {
y = y + incr;
if((*z = ppois(y, lambda, /*l._t.*/TRUE, /*log_p*/FALSE)) >= p)
return y;
}
}
}
void poisMstat(int *x, int *nx, double *stat)
{
/* computes the Poisson mean distance statistic */
int i, j, k, n=(*nx);
double eps=1.0e-10;
double cvm, d, lambda, m, q;
double Mcdf1, Mcdf0, Mpdf1, cdf1, cdf0;
lambda = 0;
for (i=0; i<n; i++)
lambda += x[i];
lambda /= ((double) n);
q = qpois(1.0-eps, lambda, TRUE, FALSE) + 1;
m = 0.0;
for (j=0; j<n; j++) m += abs(x[j] - 1);
m /= ((double) n); /* est of m_1 = E|1 - X| */
Mcdf0 = (m + 1.0 - lambda) / 2.0; /* M-est of F(0) */
cdf0 = exp(-lambda); /* MLE of F(0) */
d = Mcdf0 - cdf0;
cvm = d * d * cdf0; /* von Mises type of distance */
for (i=1; i<q; i++) {
m = 0;
k = i + 1;
for (j=0; j<n; j++) m += abs(x[j]-k);
m /= ((double) n); /* est of m_{i+1} = E|i+1 - X| */
/* compute M-estimate of f(i) and F(i) */
Mpdf1 = (m-(k-lambda)*(2.0*Mcdf0-1.0))/((double) 2.0*k);
if (Mpdf1 < 0.0) Mpdf1 = 0.0;
Mcdf1 = Mcdf0 + Mpdf1;
if (Mcdf1 > 1) Mcdf1 = 1.0;
cdf1 = ppois(i, lambda, TRUE, FALSE); /* MLE of F(i) */
d = Mcdf1 - cdf1;
cvm += d * d * (cdf1 - cdf0);
cdf0 = cdf1;
Mcdf0 = Mcdf1;
}
cvm *= n;
*stat = cvm;
}
double F77_SUB(cdfpoiss)(double *x, double *lambda, int *lower_tail, int *log_p)
{
return ppois(*x, *lambda, *lower_tail, *log_p);
}
