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 BM::Logp(double x, double &d1, double &d2, uint nd) const{
if(x<0 || x>1) return BOOM::negative_infinity();
double inf = BOOM::infinity();
double a = this->a();
double b = this->b();
if(a==inf || b==inf) return Logp_degenerate(x,d1,d2,nd);
double ans = dbeta(x,a,b, true);
double A = a-1;
double B = b-1;
double y = 1-x;
if(nd>0){
d1 = A/x - B/(y);
if(nd>1) d2 = -A/(x*x) - B/(y*y);
}
return ans;
}
/*
Given prob, x, a and b, this function returns the corresponding
noncentrality parameter of the noncentral beta distribution.
I.e. the following equation
I_x(a, b, lambda) = prob
is solved for lambda with Newton iteration.
This function works just fine when supplied with meaningful input
data (and from practically meaningful range) but may easily crash
if not. Please be nice.
*/
double ncbeta(double prob, double x, double a, double b) {
double ql;
double qu;
double c;
double d;
double p;
double lambda;
double lambda_new;
double k;
double f;
double g;
double mu;
double eps;
double eps2;
int itr_cnt;
lambda_new = guess(prob, x, 2.0*a, 2.0*b);
/* FIXME: are these tolerances OK ? */
eps = 1.0e-7;
eps2 = 1.0e-6;
itr_cnt = 0;
do {
lambda = lambda_new;
mu = lambda/2.0;
ql = qpois(eps, mu, 1, 0);
qu = qpois(eps, mu, 0, 0);
k = qu;
c = pbeta(x, a+k, b, 1, 0);
d = x*(1.0-x)/(a+k-1.0)*dbeta(x, a+k-1, b, 0);
p = dpois(k, mu, 0);
f=p*c;
p = k/mu*p;
g = p*d;
for (k = qu-1; k >= ql; --k) {
c=c+d;
d=(a+k)/(x*(a+k+b-1))*d;
f=f+p*c;
p=k/mu*p;
g=g+p*d;
}
/* Newton step */
lambda_new = lambda+2.0*(f-prob)/g;
++itr_cnt;
}
while ((fabs(lambda_new-lambda) > eps2*lambda_new)&&(itr_cnt<=10));
/* FIXME: how this error is handled properly in R ? */
if (itr_cnt == 11) {
fprintf( stderr, "Newton iteration failed in ncbeta()!\n");
exit(127);
}
return lambda_new;
}
void binom_bayes(int *x,
int *n,
double *a,
double *b,
double *alpha,
double *lcl,
double* ucl,
int *len,
int *maxit,
double *tol,
int *error) {
int i, j, first, down;
double lcl_x, ucl_x, lcl_y, ucl_y;
double y1, y2, y3;
double px1, px2, sig;
double mode, xx;
double x1, x2;
double lx1, lx2, ux1, ux2;
double p[3];
for(j = 0; j < len[0]; j++) {
lcl_x = lcl[j];
ucl_x = ucl[j];
lcl_y = dbeta(lcl_x, a[j], b[j], NCP);
ucl_y = dbeta(ucl_x, a[j], b[j], NCP);
y3 = fmax(lcl_y, ucl_y);
y1 = 0;
mode = (a[j] - 1)/(a[j] + b[j] - 2);
first = (lcl_y < ucl_y ? 0 : 1);
x1 = first ? mode : 0;
x2 = first ? 1 : mode;
p[0] = y3;
p[1] = a[j];
p[2] = b[j];
xx = zeroin(dbeta_shift, x1, x2, p, tol[0], maxit[0]);
if(first) {
ucl_x = xx;
} else {
lcl_x = xx;
}
px1 = pbeta(lcl_x, a[j], b[j], LOWER_TAIL, LOG_P);
px2 = pbeta(ucl_x, a[j], b[j], UPPER_TAIL, LOG_P);
sig = px1 + px2;
down = 0;
i = 0;
while(fabs(sig - 2 * alpha[j]) > tol[0] && i < maxit[0]) {
y2 = (y1 + y3) * 0.5;
if(down) {
if(dbeta(lcl_x, a[j], b[j], 0) < y2)
lcl_x = mode;
lx1 = 0;
lx2 = lcl_x;
if(dbeta(ucl_x, a[j], b[j], 0) < y2)
ucl_x = mode;
ux1 = ucl_x;
ux2 = 1;
} else {
if(dbeta(lcl_x, a[j], b[j], 0) > y2)
lcl_x = 0;
lx1 = lcl_x;
lx2 = mode;
if(dbeta(ucl_x, a[j], b[j], 0) > y2)
ucl_x = 1;
ux1 = mode;
ux2 = ucl_x;
}
p[0] = y2;
lcl_x = zeroin(dbeta_shift, lx1, lx2, p, tol[0], maxit[0]);
ucl_x = zeroin(dbeta_shift, ux1, ux2, p, tol[0], maxit[0]);
px1 = pbeta(lcl_x, a[j], b[j], LOWER_TAIL, LOG_P);
px2 = pbeta(ucl_x, a[j], b[j], UPPER_TAIL, LOG_P);
sig = px1 + px2;
if(sig > 2 * alpha[j]) {
down = 0;
y3 = y2;
} else {
down = 1;
y1 = y2;
}
i++;
}
error[j] = (i >= maxit[0] ? 1 : 0);
lcl[j] = lcl_x;
ucl[j] = ucl_x;
}
}
double dbeta_shift(double x, double *p) {
double y = p[0];
double a = p[1];
double b = p[2];
return dbeta(x, a, b, NCP) - y;
}
Type objective_function<Type>::operator() ()
{
DATA_STRING(distr);
DATA_INTEGER(n);
Type ans = 0;
if (distr == "norm") {
PARAMETER(mu);
PARAMETER(sd);
vector<Type> x = rnorm(n, mu, sd);
ans -= dnorm(x, mu, sd, true).sum();
}
else if (distr == "gamma") {
PARAMETER(shape);
PARAMETER(scale);
vector<Type> x = rgamma(n, shape, scale);
ans -= dgamma(x, shape, scale, true).sum();
}
else if (distr == "pois") {
PARAMETER(lambda);
vector<Type> x = rpois(n, lambda);
ans -= dpois(x, lambda, true).sum();
}
else if (distr == "compois") {
PARAMETER(mode);
PARAMETER(nu);
vector<Type> x = rcompois(n, mode, nu);
ans -= dcompois(x, mode, nu, true).sum();
}
else if (distr == "compois2") {
PARAMETER(mean);
PARAMETER(nu);
vector<Type> x = rcompois2(n, mean, nu);
ans -= dcompois2(x, mean, nu, true).sum();
}
else if (distr == "nbinom") {
PARAMETER(size);
PARAMETER(prob);
vector<Type> x = rnbinom(n, size, prob);
ans -= dnbinom(x, size, prob, true).sum();
}
else if (distr == "nbinom2") {
PARAMETER(mu);
PARAMETER(var);
vector<Type> x = rnbinom2(n, mu, var);
ans -= dnbinom2(x, mu, var, true).sum();
}
else if (distr == "exp") {
PARAMETER(rate);
vector<Type> x = rexp(n, rate);
ans -= dexp(x, rate, true).sum();
}
else if (distr == "beta") {
PARAMETER(shape1);
PARAMETER(shape2);
vector<Type> x = rbeta(n, shape1, shape2);
ans -= dbeta(x, shape1, shape2, true).sum();
}
else if (distr == "f") {
PARAMETER(df1);
PARAMETER(df2);
vector<Type> x = rf(n, df1, df2);
ans -= df(x, df1, df2, true).sum();
}
else if (distr == "logis") {
PARAMETER(location);
PARAMETER(scale);
vector<Type> x = rlogis(n, location, scale);
ans -= dlogis(x, location, scale, true).sum();
}
else if (distr == "t") {
PARAMETER(df);
vector<Type> x = rt(n, df);
ans -= dt(x, df, true).sum();
}
else if (distr == "weibull") {
PARAMETER(shape);
PARAMETER(scale);
vector<Type> x = rweibull(n, shape, scale);
ans -= dweibull(x, shape, scale, true).sum();
}
else if (distr == "AR1") {
PARAMETER(phi);
vector<Type> x(n);
density::AR1(phi).simulate(x);
ans += density::AR1(phi)(x);
}
else if (distr == "ARk") {
PARAMETER_VECTOR(phi);
vector<Type> x(n);
density::ARk(phi).simulate(x);
ans += density::ARk(phi)(x);
}
else if (distr == "MVNORM") {
PARAMETER(phi);
matrix<Type> Sigma(5,5);
for(int i=0; i<Sigma.rows(); i++)
for(int j=0; j<Sigma.rows(); j++)
Sigma(i,j) = exp( -phi * abs(i - j) );
density::MVNORM_t<Type> nldens = density::MVNORM(Sigma);
for(int i = 0; i<n; i++) {
vector<Type> x = nldens.simulate();
ans += nldens(x);
}
}
else if (distr == "SEPARABLE") {
PARAMETER(phi1);
PARAMETER_VECTOR(phi2);
array<Type> x(100, 200);
SEPARABLE( density::ARk(phi2), density::AR1(phi1) ).simulate(x);
ans += SEPARABLE( density::ARk(phi2), density::AR1(phi1) )(x);
}
else if (distr == "GMRF") {
PARAMETER(delta);
matrix<Type> Q0(5, 5);
Q0 <<
1,-1, 0, 0, 0,
-1, 2,-1, 0, 0,
0,-1, 2,-1, 0,
0, 0,-1, 2,-1,
0, 0, 0,-1, 1;
Q0.diagonal().array() += delta;
Eigen::SparseMatrix<Type> Q = asSparseMatrix(Q0);
vector<Type> x(5);
for(int i = 0; i<n; i++) {
density::GMRF(Q).simulate(x);
ans += density::GMRF(Q)(x);
}
}
else if (distr == "SEPARABLE_NESTED") {
PARAMETER(phi1);
PARAMETER(phi2);
PARAMETER(delta);
matrix<Type> Q0(5, 5);
Q0 <<
1,-1, 0, 0, 0,
-1, 2,-1, 0, 0,
0,-1, 2,-1, 0,
0, 0,-1, 2,-1,
0, 0, 0,-1, 1;
Q0.diagonal().array() += delta;
Eigen::SparseMatrix<Type> Q = asSparseMatrix(Q0);
array<Type> x(5, 6, 7);
for(int i = 0; i<n; i++) {
SEPARABLE(density::AR1(phi2),
SEPARABLE(density::AR1(phi1),
density::GMRF(Q) ) ).simulate(x);
ans += SEPARABLE(density::AR1(phi2),
SEPARABLE(density::AR1(phi1),
density::GMRF(Q) ) )(x);
}
}
else error( ("Invalid distribution '" + distr + "'").c_str() );
return ans;
}
double F77_SUB(dbet)(double *x, double *a, double *b, int *give_log)
{
return dbeta(*x, *a, *b, *give_log);
}
