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