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);
}
double punif(double x, double a, double b, int lower_tail, int log_p)
{
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(a) || ISNAN(b))
return x + a + b;
#endif
if (b < a) ML_ERR_return_NAN;
if (!R_FINITE(a) || !R_FINITE(b)) ML_ERR_return_NAN;
if (x >= b)
return R_DT_1;
if (x <= a)
return R_DT_0;
if (lower_tail) return R_D_val((x - a) / (b - a));
else return R_D_val((b - x) / (b - a));
}
double dnchisq(double x, double df, double lambda, int give_log)
{
const double eps = 5e-15;
double i, lambda2, term, sum, q, mid, dfmid, imax, errorbound;
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(df) || ISNAN(lambda))
return x + df + lambda;
#endif
if (lambda < 0 || df <= 0) ML_ERR_return_NAN;
if (!R_FINITE(df) || !R_FINITE(lambda))
ML_ERR_return_NAN;
if(x < 0) return R_D__0;
if(x == 0 && df < 2.)
return ML_POSINF;
if(lambda == 0)
return dchisq(x, df, give_log);
lambda2 = 0.5 * lambda;
/* find max element of sum */
imax = ceil((-(2+df) +sqrt((2-df) * (2-df) + 4 * lambda * x))/4);
if (imax < 0) imax = 0;
dfmid = df + 2 * imax;
mid = dpois_raw(imax, lambda2, FALSE) * dchisq(x, dfmid, FALSE);
sum = mid;
/* upper tail */
term = mid;
i = imax;
df = dfmid;
do {
i++;
q = x * lambda2 / i / df;
df += 2;
term = q * term;
sum += term;
errorbound = term * q / (1-q);
} while (errorbound > eps || q >= 1);
/* lower tail */
term = mid;
df = dfmid;
i = imax;
while ( i ){
df -= 2;
q = i * df / x / lambda2;
i--;
term = q * term;
sum += term;
errorbound = term * q / (1-q);
if (errorbound <= eps && q < 1) break;
}
return R_D_val(sum);
}
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 dnbeta(double x, double a, double b, double lambda, int give_log)
{
const double eps = 1.e-14;
const int maxiter = 200;
double k, lambda2, psum, sum, term, weight;
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(a) || ISNAN(b) || ISNAN(lambda))
return x + a + b + lambda;
#endif
if (lambda < 0 || a <= 0 || b <= 0)
ML_ERR_return_NAN;
if (!R_FINITE(a) || !R_FINITE(b) || !R_FINITE(lambda))
ML_ERR_return_NAN;
if(x <= 0) return R_D__0;
if(lambda == 0)
return dbeta(x, a, b, give_log);
term = dbeta(x, a, b, /* log = */ false);
lambda2 = 0.5 * lambda;
weight = exp(- lambda2);
sum = weight * term;
psum = weight;
for(k = 1; k <= maxiter; k++) {
weight *= (lambda2 / k);
term *= x * (a + b) / a;
sum += weight * term;
psum += weight;
a += 1;
if(1 - psum < eps) break;
}
if(1 - psum >= eps) { /* not converged */
ML_ERROR(ME_PRECISION);
}
return R_D_val(sum);
}
double dnchisq(double x, double df, double ncp, int give_log)
{
const static double eps = 5e-15;
double i, ncp2, q, mid, dfmid, imax;
LDOUBLE sum, term;
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(df) || ISNAN(ncp))
return x + df + ncp;
#endif
if (!R_FINITE(df) || !R_FINITE(ncp) || ncp < 0 || df < 0)
ML_ERR_return_NAN;
if(x < 0) return R_D__0;
if(x == 0 && df < 2.)
return ML_POSINF;
if(ncp == 0)
return (df > 0) ? dchisq(x, df, give_log) : R_D__0;
if(x == ML_POSINF) return R_D__0;
ncp2 = 0.5 * ncp;
/* find max element of sum */
imax = ceil((-(2+df) +sqrt((2-df) * (2-df) + 4 * ncp * x))/4);
if (imax < 0) imax = 0;
if(R_FINITE(imax)) {
dfmid = df + 2 * imax;
mid = dpois_raw(imax, ncp2, FALSE) * dchisq(x, dfmid, FALSE);
} else /* imax = Inf */
mid = 0;
if(mid == 0) {
/* underflow to 0 -- maybe numerically correct; maybe can be more accurate,
* particularly when give_log = TRUE */
/* Use central-chisq approximation formula when appropriate;
* ((FIXME: the optimal cutoff also depends on (x,df); use always here? )) */
if(give_log || ncp > 1000.) {
double nl = df + ncp, ic = nl/(nl + ncp);/* = "1/(1+b)" Abramowitz & St.*/
return dchisq(x*ic, nl*ic, give_log);
} else
return R_D__0;
}
sum = mid;
/* errorbound := term * q / (1-q) now subsumed in while() / if() below: */
/* upper tail */
term = mid; df = dfmid; i = imax;
double x2 = x * ncp2;
do {
i++;
q = x2 / i / df;
df += 2;
term *= q;
sum += term;
} while (q >= 1 || term * q > (1-q)*eps || term > 1e-10*sum);
/* lower tail */
term = mid; df = dfmid; i = imax;
while (i != 0) {
df -= 2;
q = i * df / x2;
i--;
term *= q;
sum += term;
if (q < 1 && term * q <= (1-q)*eps) break;
}
return R_D_val((double) sum);
}
