attribute_hidden
double pbeta_raw(double x, double a, double b, int lower_tail, int log_p)
{
// treat limit cases correctly here:
if(a == 0 || b == 0 || !R_FINITE(a) || !R_FINITE(b)) {
// NB: 0 < x < 1 :
if(a == 0 && b == 0) // point mass 1/2 at each of {0,1} :
return (log_p ? -M_LN2 : 0.5);
if (a == 0 || a/b == 0) // point mass 1 at 0 ==> P(X <= x) = 1, all x > 0
return R_DT_1;
if (b == 0 || b/a == 0) // point mass 1 at 1 ==> P(X <= x) = 0, all x < 1
return R_DT_0;
// else, remaining case: a = b = Inf : point mass 1 at 1/2
if (x < 0.5) return R_DT_0; else return R_DT_1;
}
// Now: 0 < a < Inf; 0 < b < Inf
double x1 = 0.5 - x + 0.5, w, wc;
int ierr;
//====
bratio(a, b, x, x1, &w, &wc, &ierr, log_p); /* -> ./toms708.c */
//====
// ierr in {10,14} <==> bgrat() error code ierr-10 in 1:4; for 1 and 4, warned *there*
if(ierr && ierr != 11 && ierr != 14)
MATHLIB_WARNING4(_("pbeta_raw(%g, a=%g, b=%g, ..) -> bratio() gave error code %d"),
x, a,b, ierr);
return lower_tail ? w : wc;
} /* pbeta_raw() */
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;
}
}
LDOUBLE attribute_hidden
pnbeta_raw(double x, double o_x, double a, double b, double ncp)
{
/* o_x == 1 - x but maybe more accurate */
/* change errmax and itrmax if desired;
* original (AS 226, R84) had (errmax; itrmax) = (1e-6; 100) */
const static double errmax = 1.0e-9;
const int itrmax = 10000; /* 100 is not enough for pf(ncp=200)
see PR#11277 */
double a0, lbeta, c, errbd, x0, temp, tmp_c;
int j, ierr;
LDOUBLE ans, ax, gx, q, sumq;
if (ncp < 0. || a <= 0. || b <= 0.) ML_ERR_return_NAN;
if(x < 0. || o_x > 1. || (x == 0. && o_x == 1.)) return 0.;
if(x > 1. || o_x < 0. || (x == 1. && o_x == 0.)) return 1.;
c = ncp / 2.;
/* initialize the series */
x0 = floor(fmax2(c - 7. * sqrt(c), 0.));
a0 = a + x0;
lbeta = lgammafn(a0) + lgammafn(b) - lgammafn(a0 + b);
/* temp = pbeta_raw(x, a0, b, TRUE, FALSE), but using (x, o_x): */
bratio(a0, b, x, o_x, &temp, &tmp_c, &ierr, FALSE);
gx = exp(a0 * log(x) + b * (x < .5 ? log1p(-x) : log(o_x))
- lbeta - log(a0));
if (a0 > a)
q = exp(-c + x0 * log(c) - lgammafn(x0 + 1.));
else
q = exp(-c);
sumq = 1. - q;
ans = ax = q * temp;
/* recurse over subsequent terms until convergence is achieved */
j = (int) x0;
do {
j++;
temp -= (double) gx;
gx *= x * (a + b + j - 1.) / (a + j);
q *= c / j;
sumq -= q;
ax = temp * q;
ans += ax;
errbd = (double)((temp - gx) * sumq);
}
while (errbd > errmax && j < itrmax + x0);
if (errbd > errmax)
ML_ERROR(ME_PRECISION, "pnbeta");
if (j >= itrmax + x0)
ML_ERROR(ME_NOCONV, "pnbeta");
return ans;
}
void cumfnc(double *f,double *dfn,double *dfd,double *pnonc,
double *cum,double *ccum)
/*
**********************************************************************
F -NON- -C-ENTRAL F DISTRIBUTION
Function
COMPUTES NONCENTRAL F DISTRIBUTION WITH DFN AND DFD
DEGREES OF FREEDOM AND NONCENTRALITY PARAMETER PNONC
Arguments
X --> UPPER LIMIT OF INTEGRATION OF NONCENTRAL F IN EQUATION
DFN --> DEGREES OF FREEDOM OF NUMERATOR
DFD --> DEGREES OF FREEDOM OF DENOMINATOR
PNONC --> NONCENTRALITY PARAMETER.
CUM <-- CUMULATIVE NONCENTRAL F DISTRIBUTION
CCUM <-- COMPLIMENT OF CUMMULATIVE
Method
USES FORMULA 26.6.20 OF REFERENCE FOR INFINITE SERIES.
SERIES IS CALCULATED BACKWARD AND FORWARD FROM J = LAMBDA/2
(THIS IS THE TERM WITH THE LARGEST POISSON WEIGHT) UNTIL
THE CONVERGENCE CRITERION IS MET.
FOR SPEED, THE INCOMPLETE BETA FUNCTIONS ARE EVALUATED
BY FORMULA 26.5.16.
REFERENCE
HANDBOOD OF MATHEMATICAL FUNCTIONS
EDITED BY MILTON ABRAMOWITZ AND IRENE A. STEGUN
NATIONAL BUREAU OF STANDARDS APPLIED MATEMATICS SERIES - 55
MARCH 1965
P 947, EQUATIONS 26.6.17, 26.6.18
Note
THE SUM CONTINUES UNTIL A SUCCEEDING TERM IS LESS THAN EPS
TIMES THE SUM (OR THE SUM IS LESS THAN 1.0E-20). EPS IS
SET TO 1.0E-4 IN A DATA STATEMENT WHICH CAN BE CHANGED.
**********************************************************************
*/
{
#define qsmall(x) (int)(sum < 1.0e-20 || (x) < eps*sum)
#define half 0.5e0
#define done 1.0e0
static double eps = 1.0e-4;
static double dsum,dummy,prod,xx,yy,adn,aup,b,betdn,betup,centwt,dnterm,sum,
upterm,xmult,xnonc;
static int i,icent,ierr;
static double T1,T2,T3,T4,T5,T6;
/*
..
.. Executable Statements ..
*/
if(!(*f <= 0.0e0)) goto S10;
*cum = 0.0e0;
*ccum = 1.0e0;
return;
S10:
if(!(*pnonc < 1.0e-10)) goto S20;
/*
Handle case in which the non-centrality parameter is
(essentially) zero.
*/
cumf(f,dfn,dfd,cum,ccum);
return;
S20:
xnonc = *pnonc/2.0e0;
/*
Calculate the central term of the poisson weighting factor.
*/
icent = (long)(xnonc);
if(icent == 0) icent = 1;
/*
Compute central weight term
*/
T1 = (double)(icent+1);
centwt = exp(-xnonc+(double)icent*log(xnonc)-alngam(&T1));
/*
Compute central incomplete beta term
Assure that minimum of arg to beta and 1 - arg is computed
accurately.
*/
prod = *dfn**f;
dsum = *dfd+prod;
yy = *dfd/dsum;
if(yy > half) {
xx = prod/dsum;
yy = done-xx;
}
else xx = done-yy;
T2 = *dfn*half+(double)icent;
T3 = *dfd*half;
bratio(&T2,&T3,&xx,&yy,&betdn,&dummy,&ierr);
adn = *dfn/2.0e0+(double)icent;
aup = adn;
b = *dfd/2.0e0;
betup = betdn;
sum = centwt*betdn;
/*
Now sum terms backward from icent until convergence or all done
*/
xmult = centwt;
i = icent;
T4 = adn+b;
T5 = adn+1.0e0;
dnterm = exp(alngam(&T4)-alngam(&T5)-alngam(&b)+adn*log(xx)+b*log(yy));
S30:
if(qsmall(xmult*betdn) || i <= 0) goto S40;
xmult *= ((double)i/xnonc);
i -= 1;
adn -= 1.0;
dnterm = (adn+1.0)/((adn+b)*xx)*dnterm;
betdn += dnterm;
sum += (xmult*betdn);
goto S30;
S40:
i = icent+1;
/*
Now sum forwards until convergence
*/
xmult = centwt;
if(aup-1.0+b == 0) upterm = exp(-alngam(&aup)-alngam(&b)+(aup-1.0)*log(xx)+
b*log(yy));
else {
T6 = aup-1.0+b;
upterm = exp(alngam(&T6)-alngam(&aup)-alngam(&b)+(aup-1.0)*log(xx)+b*
log(yy));
}
goto S60;
S50:
if(qsmall(xmult*betup)) goto S70;
S60:
xmult *= (xnonc/(double)i);
i += 1;
aup += 1.0;
upterm = (aup+b-2.0e0)*xx/(aup-1.0)*upterm;
betup -= upterm;
sum += (xmult*betup);
goto S50;
S70:
*cum = sum;
*ccum = 0.5e0+(0.5e0-*cum);
return;
#undef qsmall
#undef half
#undef done
}
