double dbb(int x, int n, double mu, double disp, int logp) {
double y = mu * disp;
double p = lbeta(x + y, n - x - y + disp) - lbeta(y, disp - y) + lgamma(n+1) - lgamma(x+1) -lgamma(n-x+1);
if(! logp)
p = exp(p);
return p;
}
double intrinsic_glm_shrinkage(SEXP hyperparams, int pmodel, double W, int Laplace ) {
double a, b, s, r, v, theta, n, p, u, shrinkage;
a = REAL(getListElement(hyperparams, "alpha"))[0];
b = REAL(getListElement(hyperparams, "beta"))[0];
s = REAL(getListElement(hyperparams, "s"))[0];
r = REAL(getListElement(hyperparams, "r"))[0];
n = REAL(getListElement(hyperparams, "n"))[0];
p = (double) pmodel;
v = (n + p + 1.0)/(p + 1);
theta = (n + p + 1.0)/n;
shrinkage = 1.0;
if (p >= 1.0) {
u = exp(-log(v)
+ lbeta((a + p) / 2.0 + 1.0, b / 2.0)
+ log(HyperTwo(b/2.0, r, (a +b+p)/2.0 + 1.0, (s+W)/(2.0*v), 1.0-theta))
- lbeta((a+p) / 2.0, b/2.0)
- log(HyperTwo(b/2.0, r, (a + p+ b)/2.0, (s+W)/(2.0*v), 1.0 - theta)));
shrinkage = 1.0 - u;
}
return(shrinkage);
}
double intrinsic_glm_logmarg(SEXP hyperparams, int pmodel, double W,
double loglik_mle, double logdet_Iintercept, int Laplace ) {
double a, b, s, r, v, theta,n, logmarglik, p;
a = REAL(getListElement(hyperparams, "alpha"))[0];
b = REAL(getListElement(hyperparams, "beta"))[0];
s = REAL(getListElement(hyperparams, "s"))[0];
r = REAL(getListElement(hyperparams, "r"))[0];
n = REAL(getListElement(hyperparams, "n"))[0];
p = (double) pmodel;
v = (n + p + 1.0)/(p + 1);
theta = (n + p + 1.0)/n;
logmarglik = loglik_mle + M_LN_SQRT_2PI - 0.5* logdet_Iintercept;
if (p >= 1.0) {
logmarglik += lbeta((a + p) / 2.0, b / 2.0)
+ log(HyperTwo(b/2.0, r, (a + b + p)/2.0, (s+W)/(2.0*v), 1.0 - theta))
-.5*p*log(v) -.5*W/v
- lbeta(a / 2.0, b / 2.0)
- log(HyperTwo(b/2.0, r, (a + b)/2.0, s/(2.0*v), 1.0 - theta));
}
return(logmarglik);
}
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 betaprime_glm_logmarg(SEXP hyperparams, int pmodel, double W,
double loglik_mle, double logdet_Iintercept, int Laplace ) {
double a, n, p, logmarglik;
a = REAL(getListElement(hyperparams, "alpha"))[0];
n = REAL(getListElement(hyperparams, "n"))[0];
p = (double) pmodel;
logmarglik = loglik_mle + M_LN_SQRT_2PI - 0.5* logdet_Iintercept;
if (p >= 1.0) {
logmarglik += lbeta((a + p) / 2.0, (n - p - 1.5) / 2.0)
+ loghyperg1F1((a + p)/2.0, (a + n - 1.5)/2.0, -W/2.0, Laplace)
- lbeta(a / 2.0, (n - p - 1.5)/ 2.0)
- loghyperg1F1(a/2.0, (a + n - p - 1.5)/2.0, 0.0, Laplace);
}
return(logmarglik);
}
double bprob(double p, double a, double b)
{
double q, yl ;
q = 1.0 - p ;
yl = (a-1) * log(p) + (b-1) * log (q) ;
if (!finite(yl)) fatalx("bad bprob\n") ;
yl -= lbeta(a, b) ;
if (!finite(yl)) fatalx("bad bprob\n") ;
return yl ;
}
static double lbeta_negint(int a, double b)
{
double r;
if (b == (int)b && 1 - a - b > 0) {
r = lbeta(1 - a - b, b);
return r;
}
else {
mtherr("lbeta", OVERFLOW);
return CEPHES_INFINITY;
}
}
double beta(double a, double b)
{
#ifdef NOMORE_FOR_THREADS
static double xmin, xmax = 0;/*-> typically = 171.61447887 for IEEE */
static double lnsml = 0;/*-> typically = -708.3964185 */
if (xmax == 0) {
gammalims(&xmin, &xmax);
lnsml = log(d1mach(1));
}
#else
/* For IEEE double precision DBL_EPSILON = 2^-52 = 2.220446049250313e-16 :
* xmin, xmax : see ./gammalims.c
* lnsml = log(DBL_MIN) = log(2 ^ -1022) = -1022 * log(2)
*/
# define xmin -170.5674972726612
# define xmax 171.61447887182298
# define lnsml -708.39641853226412
#endif
#ifdef IEEE_754
/* NaNs propagated correctly */
if(ISNAN(a) || ISNAN(b)) return a + b;
#endif
if (a < 0 || b < 0)
ML_ERR_return_NAN
else if (a == 0 || b == 0)
return ML_POSINF;
else if (!R_FINITE(a) || !R_FINITE(b))
return 0;
if (a + b < xmax) {/* ~= 171.61 for IEEE */
// return gammafn(a) * gammafn(b) / gammafn(a+b);
/* All the terms are positive, and all can be large for large
or small arguments. They are never much less than one.
gammafn(x) can still overflow for x ~ 1e-308,
but the result would too.
*/
return (1 / gammafn(a+b)) * gammafn(a) * gammafn(b);
} else {
double val = lbeta(a, b);
if (val < lnsml) {
/* a and/or b so big that beta underflows */
ML_ERROR(ME_UNDERFLOW, "beta");
/* return ML_UNDERFLOW; pointless giving incorrect value */
}
return exp(val);
}
}
double shrinkage_chg(double a, double b, double Q, int laplace) {
double shrinkage;
/* Beta(a/2,(b+2)/2) 1F1(a/2,(b+2)/2,(s+Q)/2 /
Beta(a/2,b/2) 1F1(a/2,b/2,(s+Q)/2
*/
/* shrinkage = exp( lbeta(a/2.0, (b+2.0)/2.0) +
log(hyperg1F1(a/2.0, b/2.0 + 1.0, Q/2.0)) -
lbeta(a/2.0, (b)/2.0) -
log(hyperg1F1(a/2.0, b/2.0, Q/2.0)));
*/
// Rprintf("shrinkage_chg: %lf\n", shrinkage);
shrinkage = exp( lbeta(a/2.0, b/2.0 + 1.0) +
loghyperg1F1(a/2.0, b/2.0 + 1.0, Q/2.0, laplace) -
lbeta(a/2.0, b/2.0) -
loghyperg1F1(a/2.0, b/2.0, Q/2.0, laplace));
//Rprintf("Laplace shrinkage_chg: %lf\n", shrinkage);
if (shrinkage > 1.0) shrinkage = 1.0;
else if (shrinkage < 0.0) shrinkage = 0.0;
return (shrinkage);
}
double CCH_glm_logmarg(SEXP hyperparams, int pmodel, double W,
double loglik_mle, double logdet_Iintercept, int Laplace ) {
double a, b, s, logmarglik, p;
a = REAL(getListElement(hyperparams, "alpha"))[0];
b = REAL(getListElement(hyperparams, "beta"))[0];
s = REAL(getListElement(hyperparams, "s"))[0];
// n = INTEGER(getListElement(hyperparams, "n"))[0];
// p = INTEGER(getListElement(hyperparams, "p"))[0];
// Rprintf("a = %lf\n", a);
// Rprintf("b = %lf\n", b);
p = (double) pmodel;
logmarglik = loglik_mle + M_LN_SQRT_2PI - 0.5* logdet_Iintercept;
if (p >= 1.0) {
logmarglik += lbeta((a + p) / 2.0, b / 2.0)
+ loghyperg1F1((a + p)/2.0, (a + b + p)/2.0, -(s+W)/2.0, Laplace)
- lbeta(a / 2.0, b / 2.0)
- loghyperg1F1(a/2.0, (a + b)/2.0, - s/2.0, Laplace);
}
return(logmarglik);
}
double tCCH_glm_shrinkage(SEXP hyperparams, int pmodel, double W, int Laplace ) {
double a, b, s, r, v, theta, p, shrinkage;
a = REAL(getListElement(hyperparams, "alpha"))[0];
b = REAL(getListElement(hyperparams, "beta"))[0];
s = REAL(getListElement(hyperparams, "s"))[0];
r = REAL(getListElement(hyperparams, "r"))[0];
v = REAL(getListElement(hyperparams, "v"))[0];
theta = REAL(getListElement(hyperparams, "theta"))[0];
p = (double) pmodel;
shrinkage = 1.0;
if (p >= 1.0) {
shrinkage -= exp( -log(v)
+ lbeta((a + p) / 2.0 + 1.0, b / 2.0)
+ log(HyperTwo(b/2.0, r, (a +b+p)/2.0 + 1.0, (s+W)/(2.0*v), 1.0-theta))
- lbeta((a+p) / 2.0, b/2.0)
- log(HyperTwo(b/2.0, r, (a + p+ b)/2.0, (s+W)/(2.0*v), 1.0 - theta)));
}
return(shrinkage);
}
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);
}
void F77_CALL(flbeta)(double *a,double *b,double *y){
*y=lbeta(*a, *b);}
double BetaLogPdf::f(double alpha, double beta, double x)
{
return (alpha - 1) * fastlog(x) + (beta - 1) * fastlog(1 - x) - lbeta(alpha, beta);
}
double attribute_hidden lfastchoose(double n, double k)
{
return -log(n + 1.) - lbeta(n - k + 1., k + 1.);
}
void inbeder(double* x_in, double* p_in, double* q_in, double* der)
{
double lbet, pa, pa1, pb, pb1, pab, pab1, err=1e-12;
double p, q, x;
int minappx=3, maxappx=200, n=0;
// falls x>p/(p+q)
if (*x_in>*p_in/(*p_in+*q_in))
{
x=1-*x_in;
p=*q_in;
q=*p_in;
}
else
{
x=*x_in;
p=*p_in;
q=*q_in;
}
// Compute Log Beta, digamma, and trigamma functions
lbet=lbeta(p,q);
pa=digamma(p);
pa1=trigamma(p);
pb=digamma(q);
pb1=trigamma(q);
pab=digamma(p+q);
pab1=trigamma(p+q);
double omx=1-x;
double logx=log(x);
double logomx=log(omx);
// Compute derivatives of K(x,p,q)=x^p(1-x)^(q-1)/[p beta(p,q)
double *c;
double c0, d;
c=Calloc(3,double);
c[0]=p*logx+(q-1)*logomx-lbet-log(p);
c0=exp(c[0]);
if (*x_in>*p_in/(*p_in+*q_in))
{
c[1]=logomx-pb+pab;
c[2]=c[1]*c[1]-pb1+pab1;
}
else
{
c[1]=logx-1/p-pa+pab;
c[2]=c[1]*c[1]+1/p/p-pa1+pab1;
}
int del=1, i=0;
double *an, *bn, *an1, *an2, *bn1, *bn2, *dr;
an=Calloc(3,double);
bn=Calloc(3,double);
an1=Calloc(3,double);
bn1=Calloc(3,double);
an2=Calloc(3,double);
bn2=Calloc(3,double);
dr=Calloc(3,double);
double *dan, *dbn, *der_old, *d1;
dan=Calloc(3,double);
dbn=Calloc(3,double);
der_old=Calloc(3,double);
d1=Calloc(3,double);
double Rn=0, pr=0;
an1[0]=1;
an2[0]=1;
bn1[0]=1;
bn2[0]=0;
der_old[0]=0;
for(i=1;i<3;i++)
{
an1[i]=0;
an2[i]=0;
bn1[i]=0;
bn2[i]=0;
der_old[i]=0;
}
while(del==1)
{
n++;
if(n==1)
{
if (*x_in>*p_in/(*p_in+*q_in))
{
incompleBeta_an1_bn1_q(&x, p, q, an, bn);
}
else
{
incompleBeta_an1_bn1_p(&x, p, q, an, bn);
}
}
else
{
if (*x_in>*p_in/(*p_in+*q_in))
{
incompleBeta_an_bn_q(&x, p, q, n, an, bn);
}
else
{
incompleBeta_an_bn_p(&x, p, q, n, an, bn);
}
}
// Use forward recurrance relations to compute An, Bn, and their derivatives
dan[0]=an[0]*an2[0]+bn[0]*an1[0];
dbn[0]=an[0]*bn2[0]+bn[0]*bn1[0];
dan[1]=an[1]*an2[0]+an[0]*an2[1]+bn[1]*an1[0]+bn[0]*an1[1];
dbn[1]=an[1]*bn2[0]+an[0]*bn2[1]+bn[1]*bn1[0]+bn[0]*bn1[1];
dan[2]=an[2]*an2[0]+2*an[1]*an2[1]+an[0]*an2[2]+bn[2]*an1[0]+2*bn[1]*an1[1]+bn[0]*an1[2];
dbn[2]=an[2]*bn2[0]+2*an[1]*bn2[1]+an[0]*bn2[2]+bn[2]*bn1[0]+2*bn[1]*bn1[1]+bn[0]*bn1[2];
// Scale derivatives to prevent overflow
Rn=dan[0];
if(fabs(dbn[0])>fabs(dan[0]))
{
Rn=dbn[0];
}
for(i=0;i<3;i++)
{
an1[i]=an1[i]/Rn;
bn1[i]=bn1[i]/Rn;
}
dan[1]=dan[1]/Rn;
dan[2]=dan[2]/Rn;
dbn[1]=dbn[1]/Rn;
dbn[2]=dbn[2]/Rn;
if(fabs(dbn[0])>fabs(dan[0]))
{
dan[0]=dan[0]/dbn[0];
dbn[0]=1;
}
else
{
dbn[0]=dbn[0]/dan[0];
dan[0]=1;
}
// Compute components of derivatives of the nth approximant
dr[0]=dan[0]/dbn[0];
Rn=dr[0];
dr[1]=(dan[1]-Rn*dbn[1])/dbn[0];
dr[2]=(-2*dan[1]*dbn[1]+2*Rn*dbn[1]*dbn[1])/dbn[0]/dbn[0]+(dan[2]-Rn*dbn[2])/dbn[0];
// Save terms corresponding to approximants n-1 and n-2
for(i=0;i<3;i++)
{
an2[i]=an1[i];
an1[i]=dan[i];
bn2[i]=bn1[i];
bn1[i]=dbn[i];
}
// Compute nth approximants
pr=0;
if(dr[0]>0)
{
pr=exp(c[0]+log(dr[0]));
}
der[0]=pr;
der[1]=pr*c[1]+c0*dr[1];
der[2]=pr*c[2]+2*c0*c[1]*dr[1]+c0*dr[2];
// Check for convergence, check for maximum and minimum iterations.
for(i=0;i<3;i++)
{
d1[i]=MAX(err,fabs(der[i]));
d1[i]=fabs(der_old[i]-der[i])/d1[i];
der_old[i]=der[i];
}
d=MAX(MAX(d1[0],d1[1]),d1[2]);
if(n< minappx)
{
d=1;
}
if(n>= maxappx)
{
d=0;
}
del=0;
if(d> err)
{
del=1;
}
}
// Adjust results if I(x,p,q) = 1- I(1-x,q,p) was used
if (*x_in>*p_in/(*p_in+*q_in))
{
der[0]=1-der[0];
der[1]=-der[1];
der[2]=-der[2];
}
Free(c);
Free(an);
Free(bn);
Free(dan);
Free(dbn);
Free(dr);
Free(an1);
Free(an2);
Free(bn1);
Free(bn2);
Free(d1);
Free(der_old);
}
//function to calculate l[P'(D|M)] for a given distribution of bases
double lPDM_mod_fn(int *z, int ind, double pstar)
{
/*'z' is a pointer to a vector of length 5, where the
first 4 elements correspond to each base (with the consensus
as the fourth element z[3]). The final element is
S-z[3]=sum(z[0:2])
'ind' denotes which model (from 0:9) is to be calculated
'pstar' is the overall mutation rate*/
double lPDM = 0.0;
/* switch(ind)*/
/* {*/
/* //Null p1=p2=p3=p3*/
/* case 0 :lPDM=z[4]*log(pstar/3.0)+z[3]*log(1.0-pstar);*/
/* break;*/
/* //Alt that one free pi is different: e.g. p1!=p2=p3 etc. but mutation rate constrained to p**/
/* case 1 :lPDM=-(z[1]+z[2])*log(2.0)+lfactorial(z[0])+lfactorial(z[1]+z[2])-lfactorial(z[4]+1)+z[4]*log(pstar)+z[3]*log(1.0-pstar);*/
/* break;*/
/* case 2 :lPDM=-(z[0]+z[2])*log(2.0)+lfactorial(z[1])+lfactorial(z[0]+z[2])-lfactorial(z[4]+1)+z[4]*log(pstar)+z[3]*log(1.0-pstar);*/
/* break;*/
/* case 3 :lPDM=-(z[0]+z[1])*log(2.0)+lfactorial(z[2])+lfactorial(z[0]+z[1])-lfactorial(z[4]+1)+z[4]*log(pstar)+z[3]*log(1.0-pstar);*/
/* break;*/
/* //Alt that all pis are different but mutation rate constrained to p**/
/* case 4 :lPDM=log(2.0)+lfactorial(z[0])+lfactorial(z[1])+lfactorial(z[2])-lfactorial(z[4]+2)+z[4]*log(pstar)+z[3]*log(1.0-pstar);*/
/* break;*/
/* //Alt that pis are uniform but not constrained to sum to p**/
/* case 5 :lPDM=-z[4]*log(3.0)+lfactorial(z[4])+lfactorial(z[3])-lfactorial(z[3]+z[4]+1);*/
/* break;*/
/* //Alt that one free pi is different: e.g. p1!=p2=p3 etc.*/
/* case 6 :lPDM=-(z[1]+z[2])*log(2.0)+lfactorial(z[1]+z[2])+lfactorial(z[0])+lfactorial(z[3])-log(z[4]+1)-lfactorial(z[4]+z[3]+1);*/
/* break;*/
/* case 7 :lPDM=-(z[0]+z[2])*log(2.0)+lfactorial(z[0]+z[2])+lfactorial(z[1])+lfactorial(z[3])-log(z[4]+1)-lfactorial(z[4]+z[3]+1);*/
/* break;*/
/* case 8 :lPDM=-(z[0]+z[1])*log(2.0)+lfactorial(z[0]+z[1])+lfactorial(z[2])+lfactorial(z[3])-log(z[4]+1)-lfactorial(z[4]+z[3]+1);*/
/* break;*/
/* //Alt that all pis are different*/
/* case 9 :lPDM=log(2.0)+lfactorial(z[0])+lfactorial(z[1])+lfactorial(z[2])+lfactorial(z[3])-log(z[4]+2)-log(z[4]+1)-lfactorial(z[4]+z[3]+1);*/
/* break;*/
/* }*/
int i;
double z1[5];
for(i=0;i<5;i++) z1[i]=(double) z[i];
switch(ind)
{
//Null p1=p2=p3=p/3 where p<=p*
case 0 :lPDM=-z1[4]*log(3.0)-log(pstar)+pbeta(pstar,z1[4]+1,z1[3]+1,1,1)+lbeta(z1[4]+1,z1[3]+1);
break;
//Alt that one free pi is different: e.g. p1!=p2=p3 etc. but mutation rate constrained to be <= p*
case 1 :lPDM=-(z[1]+z[2])*log(2.0)+lfactorial(z[0])+lfactorial(z[1]+z[2])-lfactorial(z[4]+1)-log(pstar)+pbeta(pstar,z1[4]+1,z1[3]+1,1,1)+lbeta(z1[4]+1,z1[3]+1);
break;
case 2 :lPDM=-(z[0]+z[2])*log(2.0)+lfactorial(z[1])+lfactorial(z[0]+z[2])-lfactorial(z[4]+1)-log(pstar)+pbeta(pstar,z1[4]+1,z1[3]+1,1,1)+lbeta(z1[4]+1,z1[3]+1);
break;
case 3 :lPDM=-(z[0]+z[1])*log(2.0)+lfactorial(z[2])+lfactorial(z[0]+z[1])-lfactorial(z[4]+1)-log(pstar)+pbeta(pstar,z1[4]+1,z1[3]+1,1,1)+lbeta(z1[4]+1,z1[3]+1);
break;
//Alt that all pis are different but mutation rate constrained to be <= p*
case 4 :lPDM=log(2.0)+lfactorial(z[0])+lfactorial(z[1])+lfactorial(z[2])-lfactorial(z[4]+2)-log(pstar)+pbeta(pstar,z1[4]+1,z1[3]+1,1,1)+lbeta(z1[4]+1,z1[3]+1);
break;
//Alt p1=p2=p3=p/3 where p>p*
case 5 :lPDM=-z1[4]*log(3.0)-log(1.0-pstar)+pbeta(pstar,z1[4]+1,z1[3]+1,0,1)+lbeta(z1[4]+1,z1[3]+1);
break;
//Alt that one free pi is different: e.g. p1!=p2=p3 etc. but mutation rate constrained to be > p*
case 6 :lPDM=-(z[1]+z[2])*log(2.0)+lfactorial(z[0])+lfactorial(z[1]+z[2])-lfactorial(z[4]+1)-log(1.0-pstar)+pbeta(pstar,z1[4]+1,z1[3]+1,0,1)+lbeta(z1[4]+1,z1[3]+1);
break;
case 7 :lPDM=-(z[0]+z[2])*log(2.0)+lfactorial(z[1])+lfactorial(z[0]+z[2])-lfactorial(z[4]+1)-log(1.0-pstar)+pbeta(pstar,z1[4]+1,z1[3]+1,0,1)+lbeta(z1[4]+1,z1[3]+1);
break;
case 8 :lPDM=-(z[0]+z[1])*log(2.0)+lfactorial(z[2])+lfactorial(z[0]+z[1])-lfactorial(z[4]+1)-log(1.0-pstar)+pbeta(pstar,z1[4]+1,z1[3]+1,0,1)+lbeta(z1[4]+1,z1[3]+1);
break;
//Alt that all pis are different but mutation rate constrained to be > p*
case 9 :lPDM=log(2.0)+lfactorial(z[0])+lfactorial(z[1])+lfactorial(z[2])-lfactorial(z[4]+2)-log(1.0-pstar)+pbeta(pstar,z1[4]+1,z1[3]+1,0,1)+lbeta(z1[4]+1,z1[3]+1);
break;
}
return lPDM;
}
double qbeta(double alpha, double p, double q, int lower_tail, int log_p)
{
int swap_tail, i_pb, i_inn;
double a, adj, logbeta, g, h, pp, p_, prev, qq, r, s, t, tx, w, y, yprev;
double acu;
volatile double xinbta;
/* test for admissibility of parameters */
if (isnan(p) || isnan(q) || isnan(alpha)){
return p + q + alpha;
}
if(p < 0. || q < 0.){
report_error("shape parameters for qbeta must be > 0.");
}
R_Q_P01_boundaries(alpha, 0, 1);
p_ = R_DT_qIv(alpha);/* lower_tail prob (in any case) */
if(log_p && (p_ == 0. || p_ == 1.))
return p_; /* better than NaN or infinite loop;
FIXME: suboptimal, since -Inf < alpha ! */
/* initialize */
logbeta = lbeta(p, q);
/* change tail if necessary; afterwards 0 < a <= 1/2 */
if (p_ <= 0.5) {
a = p_; pp = p; qq = q; swap_tail = 0;
} else { /* change tail, swap p <-> q :*/
a = (!lower_tail && !log_p)? alpha : 1 - p_;
pp = q; qq = p; swap_tail = 1;
}
/* calculate the initial approximation */
/* y := {fast approximation of} qnorm(1 - a) :*/
r = sqrt(-2 * log(a));
y = r - (const1 + const2 * r) / (1. + (const3 + const4 * r) * r);
if (pp > 1 && qq > 1) {
r = (y * y - 3.) / 6.;
s = 1. / (pp + pp - 1.);
t = 1. / (qq + qq - 1.);
h = 2. / (s + t);
w = y * sqrt(h + r) / h - (t - s) * (r + 5. / 6. - 2. / (3. * h));
xinbta = pp / (pp + qq * exp(w + w));
} else {
r = qq + qq;
t = 1. / (9. * qq);
t = r * pow(1. - t + y * sqrt(t), 3.0);
if (t <= 0.)
xinbta = 1. - exp((log1p(-a)+ log(qq) + logbeta) / qq);
else {
t = (4. * pp + r - 2.) / t;
if (t <= 1.)
xinbta = exp((log(a * pp) + logbeta) / pp);
else
xinbta = 1. - 2. / (t + 1.);
}
}
/* solve for x by a modified newton-raphson method, */
/* using the function pbeta_raw */
r = 1 - pp;
t = 1 - qq;
yprev = 0.;
adj = 1;
/* Sometimes the approximation is negative! */
if (xinbta < lower)
xinbta = 0.5;
else if (xinbta > upper)
xinbta = 0.5;
/* Desired accuracy should depend on (a,p)
* This is from Remark .. on AS 109, adapted.
* However, it's not clear if this is "optimal" for IEEE double prec.
* acu = std::max<double>(acu_min, pow(10., -25. - 5./(pp * pp) - 1./(a * a)));
* NEW: 'acu' accuracy NOT for squared adjustment, but simple;
* ---- i.e., "new acu" = sqrt(old acu)
*/
acu = std::max<double>(acu_min, pow(10., -13 - 2.5/(pp * pp) - 0.5/(a * a)));
tx = prev = 0.; /* keep -Wall happy */
for (i_pb=0; i_pb < 1000; i_pb++) {
y = pbeta_raw(xinbta, pp, qq, /*lower_tail = */ true, false);
if(!std::isfinite(y)){
report_error("algorithm blew up ni qbeta");
}
y = (y - a) *
exp(logbeta + r * log(xinbta) + t * log1p(-xinbta));
if (y * yprev <= 0.)
prev = std::max<double>(fabs(adj),fpu);
g = 1;
for (i_inn=0; i_inn < 1000;i_inn++) {
adj = g * y;
if (fabs(adj) < prev) {
tx = xinbta - adj; /* trial new x */
if (tx >= 0. && tx <= 1) {
if (prev <= acu) goto L_converged;
if (fabs(y) <= acu) goto L_converged;
if (tx != 0. && tx != 1)
break;
}
}
g /= 3;
}
if (fabs(tx - xinbta) < 1e-15*xinbta) goto L_converged;
xinbta = tx;
yprev = y;
}
/*-- NOT converged: Iteration count --*/
report_error("algorithm did not converge in qbeta");
L_converged:
return swap_tail ? 1 - xinbta : xinbta;
}
/***** ***************************************************************************************** *****/
void
RJMCMCcombine(int* accept, double* log_AR,
int* K, double* w, double* logw, double* mu,
double* Q, double* Li, double* Sigma, double* log_dets,
int* order, int* rank, int* r, int* mixN, int** rInv,
double* u, double* P, double* log_dens_u,
double* dwork, int* iwork, int* err,
const double* y, const int* p, const int* n,
const int* Kmax, const double* logK, const double* log_lambda, const int* priorK,
const double* logPsplit, const double* logPcombine, const double* delta,
const double* c, const double* log_c, const double* xi, const double* D_Li, const double* log_dets_D,
const double* zeta, const double* log_Wishart_const, const double* gammaInv, const double* log_sqrt_detXiInv,
const int* priormuQ, const double* pars_dens_u,
void (*ld_u)(double* log_dens_u, const double* u, const double* pars_dens_u, const int* p))
{
const char *fname = "NMix::RJMCMCcombine";
*err = 0;
*accept = 0;
*log_AR = R_NegInf;
/*** Array of two zeros to be passed to ldMVN as log_dets to compute only -1/2(x-mu)'Sigma^{-1}(x-mu) ***/
static const double ZERO_ZERO[2] = {0.0, 0.0};
/*** Some variables ***/
static int i0, i1, k, LTp, p_p, ldwork_logJacLambdaVSigma;
static int jstar, jremove, j1, j2;
static int rInvPrev;
static int rankstar;
static double sqrt_u1_ratio, one_u1, log_u1, log_one_u1, log_u1_one_minus_u1_min32, one_minus_u2sq, erand;
static double log_Jacob, log_Palloc, log_LikelihoodRatio, log_PriorRatio, log_ProposalRatio;
static double log_phi1, log_phi2, log_phistar, Prob_r1, Prob_r2, log_Prob_r1, log_Prob_r2, max_log_Prob_r12, sum_Prob_r12;
static double mu1_vstar, mu2_vstar, mustar_vstar;
/*** Some pointers ***/
static double *w1, *w2, *logw1, *logw2, *mu1, *mu2, *Sigma1, *Sigma2, *Li1, *Li2, *Q1, *Q2, *log_dets1, *log_dets2;
static int *mixN1, *mixN2, *rInv1, *rInv2;
static int **rrInv1, **rrInv2;
static double *wOldP, *logwOldP, *muOldP, *SigmaOldP, *LiOldP, *QOldP, *log_detsOldP;
static double *Listar;
static int *mixNOldP;
static int **rrInvOldP;
static const double *muNewP, *SigmaNewP, *QNewP;
static const double *mu1P, *mu2P;
static const double *yP;
static int *rInv1P, *rInv2P, *rInvP;
static int *rP;
/*** Declaration for dwork ***/
static double *mustar, *Sigmastar, *Lambdastar, *Vstar, *Lstar, *Qstar;
static double *SigmaTemp, *Lambda1, *Lambda2, *V1, *V2, *Lambda_dspev, *V_dspev, *dwork_misc;
static double *dlambdaV_dSigma, *P_im, *VPinv_re, *VPinv_im, *sqrt_Plambda_re, *sqrt_Plambda_im, *VP_re, *VP_im;
static double *mustarP, *LambdastarP, *LstarP, *Lambda1P, *Lambda2P, *VstarP, *VP_reP;
/*** Declaration for iwork ***/
static int *iwork_misc;
static int complexP[1];
/*** Declaration for auxiliary variables ***/
static double *u1, *u2, *u3;
static double *u2P, *u3P;
/*** Declaration for other mixture related variables ***/
static double wstar[1]; /** weight of the new combined component **/
static double logwstar[1]; /** log(weight) of the new combined component **/
static double log_detsstar[2]; /** Like log_dets, related to the new combined component **/
static double logJ_part3[1]; /** the third part of the log-Jacobian **/
//static double log_dlambdaV_dSigma[1]; /** logarithm of |d(Lambdastar,Vstar)/d(Sigmastar)| **/
static double logL12[2]; /** logL12[0] = sum_{i=0}^{mixN1} log(phi(y_i | mu_{r_i}, Sigma_{r_i})) + sum_{i=0}^{mixN2}... **/
/** logL12[1] = sum_{i=0}^{mixN1} log(P(r = r_i | w, K)) + sum_{i=0}^{mixN2} ... **/
/** for observations allocated to the combined components, state before reallocation **/
static double logLstar[2]; /** the same as above, state after reallocation **/
static double log_prior_mu1[1]; /** logarithm of the prior of mu1 (first splitted component) **/
static double log_prior_mu2[1]; /** logarithm of the prior of mu2 (second splitted component) **/
static double log_prior_mustar[1]; /** logarithm of the prior of mu(star) (splitted component) **/
static double log_prior_Q1[1]; /** logarithm of the prior of Q1 = Sigma1^{-1} (first splitted component) **/
static double log_prior_Q2[1]; /** logarithm of the prior of Q2 = Sigma2^{-1} (first splitted component) **/
static double log_prior_Qstar[1]; /** logarithm of the prior of Q(star) = Sigma(star)^{-1} (splitted component) **/
static int mixNstar[1]; /** numbers of allocated observations in the new combined component **/
if (*K == 1) return;
LTp = (*p * (*p + 1))/2;
p_p = *p * *p;
ldwork_logJacLambdaVSigma = *p * LTp + (4 + 2 * *p) * *p;
/*** Components of dwork ***/
mustar = dwork; /** mean vector of the new combined component **/
Sigmastar = mustar + *p; /** covariance matrix of the new combined component **/
Lambdastar = Sigmastar + LTp; /** eigenvalues of the new combined component **/
Vstar = Lambdastar + *p; /** eigenvectors of the new combined component **/
Lstar = Vstar + p_p; /** Cholesky decomposition of Sigmastar **/
Qstar = Lstar + LTp; /** inversion of Sigmastar **/
SigmaTemp = Qstar + LTp; /** Sigma1 and Sigma2 passed to dspev which overwrites it during the decomposition **/
Lambda1 = Sigmastar + LTp; /** eigenvalues of the first component to be combined **/
Lambda2 = Lambda1 + *p; /** eigenvalues of the second component to be combined **/
V1 = Lambda2 + *p; /** eigenvectors of the first component to be combined **/
V2 = V1 + p_p; /** eigenvectors of the second component to be combined **/
Lambda_dspev = V2 + p_p; /** space to store lambda's computed by dspev (in ascending order) **/
V_dspev = Lambda_dspev + *p; /** space to store V computed by dspev **/
dwork_misc = V_dspev + p_p; /** working array for LAPACK dspev (needs 3*p) **/
/** Dist::ldMVN1, Dist::ldMVN2 (needs p) **/
/** NMix::RJMCMC_logJacLambdaVSigma (needs: see above) **/
/** AK_LAPACK::sqrtGE (needs p*p) **/
/** AK_LAPACK::correctMatGE (needs p*p) **/
/** NMix::orderComp (needs at most Kmax) **/
dlambdaV_dSigma = dwork_misc + ldwork_logJacLambdaVSigma + *Kmax;
P_im = dlambdaV_dSigma + LTp * LTp; /** needed by AK_LAPACK::sqrt_GE **/
VPinv_re = P_im + p_p; /** needed by AK_LAPACK::sqrt_GE **/
VPinv_im = VPinv_re + p_p; /** needed by AK_LAPACK::sqrt_GE **/
sqrt_Plambda_re = VPinv_im + p_p; /** needed by AK_LAPACK::sqrt_GE **/
sqrt_Plambda_im = sqrt_Plambda_re + *p; /** needed by AK_LAPACK::sqrt_GE **/
VP_re = sqrt_Plambda_im + *p; /** needed by AK_LAPACK::sqrt_GE **/
VP_im = VP_re + p_p; /** needed by AK_LAPACK::sqrt_GE **/
// next = VP_im + p_p;
/*** Components of iwork ***/
iwork_misc = iwork; /** working array for NMix::RJMCMC_logJacLambdaVSigma (needs p) **/
/** Rand::RotationMatrix (needs p) **/
/** AK_LAPACK::sqrtGE (needs p) **/
/** AK_LAPACK::correctMatGE (needs p) **/
// next = iwork_misc + *p;
/***** Pointers for auxiliary vector u *****/
/***** =============================== *****/
u1 = u;
u2 = u1 + 1;
u3 = u2 + *p;
/***** Choose the components to be splitted *****/
/***** ==================================== *****/
// TEMPORAR? For p > 1, a pair is sampled from all pairs,
// for p = 1, a pair of "adjacent components" is sampled
if (*p > 1){
// ===== Code for the situation when a pair is sampled from all pairs ===== //
Rand::SamplePair(&j1, &j2, K); // generates a pair (j1, j2) where j1 < j2
}
else{
// ===== Code for the situation when j1 is sampled from K-1 components with the "smallest" mean ===== //
// ===== and j2 is the adjacent component with just a "higher" mean ===== //
// ===== For a definition of ordering see NMix::orderComp function ===== //
rankstar = (int)(floor(unif_rand() * (*K - 1)));
if (rankstar == *K - 1) jstar = *K - 2; // this row is needed with pobability 0 (unif_rand() would have to return 1)
j1 = order[rankstar];
j2 = order[rankstar + 1];
}
// ===== Code for the situation similar to the Matlab code of I. Papageorgiou ===== //
//j1 = (int)(floor(unif_rand() * (*K - 1))); // This way is used in the Matlab code of I. Papageorgiou,
//if (j1 == *K - 1) j1 = *K - 2; // i.e., j1 is sampled from Unif(0,...,K-2)
//j2 = *K - 1; // I have no idea why in this way...
/*** Pointers to chosen components ***/
w1 = w + j1;
w2 = w1 + (j2 - j1);
logw1 = logw + j1;
logw2 = logw1 + (j2 - j1);
mu1 = mu + j1 * *p;
mu2 = mu1 + (j2 - j1) * *p;
Sigma1 = Sigma + j1 * LTp;
Sigma2 = Sigma1 + (j2 - j1) * LTp;
Li1 = Li + j1 * LTp;
Li2 = Li1 + (j2 - j1) * LTp;
Q1 = Q + j1 * LTp;
Q2 = Q1 + (j2 - j1) * LTp;
log_dets1 = log_dets + j1 * 2;
log_dets2 = log_dets1 + (j2 - j1) * 2;
rrInv1 = rInv + j1;
rrInv2 = rrInv1 + (j2 - j1);
rInv1 = *rrInv1;
rInv2 = *rrInv2;
mixN1 = mixN + j1;
mixN2 = mixN1 + (j2 - j1);
/*** Pointers to the old places where a new component will be written (if accepted) ***/
/*** jstar = index of the place where a new component will be written on the place of one of old components (if accepted) ***/
/*** jremove = index of the place where an old component will be removed (and the rest will be shifted forward) ***/
/*** I will ensure jstar < jremove ***/
if (j1 < j2){
jstar = j1; // combined component will be placed on place with a lower index if combine move accepted
jremove = j2; // component with a higher index will be removed if combine move accepted
wOldP = w1; // places where a new component will be written
logwOldP = logw1;
muOldP = mu1;
SigmaOldP = Sigma1;
LiOldP = Li1;
QOldP = Q1;
log_detsOldP = log_dets1;
rrInvOldP = rrInv1;
mixNOldP = mixN1;
}
else{
jstar = j2;
jremove = j1;
wOldP = w2; // places where a new component will be written
logwOldP = logw2;
muOldP = mu2;
SigmaOldP = Sigma2;
LiOldP = Li2;
QOldP = Q2;
log_detsOldP = log_dets2;
rrInvOldP = rrInv2;
mixNOldP = mixN2;
}
/***** Compute proposed weight, mean, variance and log-Jacobian of the RJ (split) move *****/
/***** =============================================================================== *****/
/***** Proposed weight *****/
*wstar = *w1 + *w2;
*logwstar = AK_Basic::log_AK(wstar[0]);
*u1 = *w1 / *wstar;
one_u1 = 1 - *u1;
/***** Log-Jacobian, part 1 *****/
/***** Jacobian = dtheta/dtheta^*, that is corresponds to the reversal split move *****/
log_Jacob = *logwstar;
/***** Code for UNIVARIATE mixtures *****/
if (*p == 1){ /*** UNIVARIATE mixture ***/
/***** Check inequality condition which is satisfied by the reversal split move *****/
/***** This will ensure that u2 is positive *****/
// ===== The following code is needed only when (j1, j2) is sampled from a set of all pairs and hence there is no guarantee ===== //
// ===== that mu1 <= mu2 ===== //
//if (*mu1 > *mu2){ // switch labels j1, j2 such that mu1 < mu2 to get correctly u1, u2 and u3
// AK_Basic::switchValues(&j1, &j2);
// *u1 = one_u1;
// one_u1 = 1 - *u1;
// AK_Basic::switchPointers(&w1, &w2);
// AK_Basic::switchPointers(&logw1, &logw2);
// AK_Basic::switchPointers(&mu1, &mu2);
// AK_Basic::switchPointers(&Sigma1, &Sigma2);
// AK_Basic::switchPointers(&Li1, &Li2);
// AK_Basic::switchPointers(&Q1, &Q2);
// AK_Basic::switchPointers(&log_dets1, &log_dets2);
// AK_Basic::switchPointers(&rInv1, &rInv2);
// AK_Basic::switchPointers(&mixN1, &mixN2);
//}
/***** Values derived from the auxiliary number u1 corresponding to the reversal split move *****/
sqrt_u1_ratio = sqrt(*u1 / (1 - *u1));
log_u1 = AK_Basic::log_AK(*u1);
log_one_u1 = AK_Basic::log_AK(1 - *u1);
log_u1_one_minus_u1_min32 = -1.5 * (log_u1+ log_one_u1);
/***** Proposed mean: mustar = u1 * mu1 + (1 - u1) * mu2 *****/
*mustar = *u1 * *mu1 + one_u1 * *mu2;
/***** Proposed variance *****/
*Sigmastar = *u1 * (*mu1 * *mu1 + *Sigma1) + one_u1 * (*mu2 * *mu2 + *Sigma2) - *mustar * *mustar;
if (*Sigmastar <= 0) return;
/***** Cholesky decomposition of the proposed variance (standard deviation) *****/
*Lstar = sqrt(*Sigmastar);
/***** Inverted proposed variance *****/
*Qstar = 1 / *Sigmastar;
/***** Auxiliary numbers u2 and u3 correspoding to the reversal split move *****/
*u2 = ((*mustar - *mu1) / *Lstar) * sqrt_u1_ratio;
one_minus_u2sq = 1 - *u2 * *u2;
*u3 = (*u1 * *Sigma1) / (one_minus_u2sq * *Sigmastar);
/***** Log-Jacobian, part 2 *****/
log_Jacob += AK_Basic::log_AK(one_minus_u2sq * *Sigmastar * *Lstar) + log_u1_one_minus_u1_min32;
/***** log|d(Lambdastar,Vstar)/d(Sigmastar)|*****/ // NOT NEEDED AS IT IS ZERO, moreover, 25/01/2008: included in logJ_part3
//*log_dlambdaV_dSigma = 0.0;
/***** Log-Jacobian, part 3 *****/ // NOT NEEDED AS IT IS ZERO
//*logJ_part3 = 0.0;
//log_Jacob += *logJ_part3;
/***** log-dets for the proposed variance *****/
log_detsstar[0] = -AK_Basic::log_AK(*Lstar); /** log_detsstar[0] = -log(Lstar) = log|Sigmastar|^{-1/2} **/
log_detsstar[1] = log_dets1[1]; /** log_detsstar[1] = -p * log(sqrt(2*pi)) **/
}
else{ /*** MULTIVARIATE mixture ***/
/***** Values derived from the auxiliary number u1 corresponding to the reversal split move *****/
sqrt_u1_ratio = sqrt(*u1 / (1 - *u1));
log_u1 = AK_Basic::log_AK(*u1);
log_one_u1 = AK_Basic::log_AK(1 - *u1);
log_u1_one_minus_u1_min32 = -1.5 * (log_u1+ log_one_u1);
/***** Spectral decomposition of Sigma1 *****/
AK_Basic::copyArray(SigmaTemp, Sigma1, LTp);
F77_CALL(dspev)("V", "L", p, SigmaTemp, Lambda_dspev, V_dspev, p, dwork_misc, err); /** eigen values in ascending order **/
if (*err){
warning("%s: Spectral decomposition of Sigma[%d] failed.\n", fname, j1);
return;
}
//AK_LAPACK::spevAsc2spevDesc(Lambda1, V1, Lambda_dspev, V_dspev, p); /** eigen values in descending order **/
// 05/02/2008: CHANGE - eigenvalues are assumed to be in ASCENDING order
AK_LAPACK::correctMatGE(V1, dwork_misc, iwork_misc, err, p); /** be sure that det(V1) = 1 and not -1 **/
if (*err){
warning("%s: Correction of V[%d] failed.\n", fname, j1);
return;
}
/***** Spectral decomposition of Sigma2 *****/
AK_Basic::copyArray(SigmaTemp, Sigma2, LTp);
F77_CALL(dspev)("V", "L", p, SigmaTemp, Lambda_dspev, V_dspev, p, dwork_misc, err); /** eigen values in ascending order **/
if (*err){
warning("%s: Spectral decomposition of Sigma[%d] failed.\n", fname, j2);
return;
}
//AK_LAPACK::spevAsc2spevDesc(Lambda2, V2, Lambda_dspev, V_dspev, p); /** eigen values in descending order **/
// 05/02/2008: CHANGE - eigenvalues are assumed to be in ASCENDING order
AK_LAPACK::correctMatGE(V2, dwork_misc, iwork_misc, err, p); /** be sure that det(V2) = 1 and not -1 **/
if (*err){
warning("%s: Correction of V[%d] failed.\n", fname, j2);
return;
}
/***** Rotation matrix which corresponds to the reversible split move, P = (V1 %*% t(V2))^{1/2} *****/
F77_CALL(dgemm)("N", "T", p, p, p, &AK_Basic::_ONE_DOUBLE, V1, p, V2, p, &AK_Basic::_ZERO_DOUBLE, P, p); /*** P = V1 %*% t(V2) ***/
AK_LAPACK::sqrtGE(P, P_im, VPinv_re, VPinv_im, complexP, sqrt_Plambda_re, sqrt_Plambda_im, VP_re, VP_im, dwork_misc, iwork_misc, err, p);
if (*err){
warning("%s: Computation of the square root of the rotation matrix failed.\n", fname);
return;
}
/***** Proposed eigenvectors: Vstar = (1/2) * (t(P) %*% V1 + P %*% V2) *****/
F77_CALL(dgemm)("T", "N", p, p, p, &AK_Basic::_ONE_DOUBLE, P, p, V1, p, &AK_Basic::_ZERO_DOUBLE, VP_re, p); /*** VP_re = t(P) %*% V1 ***/
F77_CALL(dgemm)("N", "N", p, p, p, &AK_Basic::_ONE_DOUBLE, P, p, V2, p, &AK_Basic::_ZERO_DOUBLE, Vstar, p); /*** Vstar = P %*% V2 ***/
/***** Proposed mean: mustar = u1*mu1 + (1 - u1)*mu2 *****/
/***** Finalize computation of Vstar (sum t(P) %*% V1 and P %*% V2 and multiply it by 0.5) *****/
mu1P = mu1;
mu2P = mu2;
mustarP = mustar;
VstarP = Vstar;
VP_reP = VP_re;
for (i1 = 0; i1 < *p; i1++){
*mustarP = *u1 * *mu1P + one_u1 * *mu2P;
mu1P++;
mu2P++;
mustarP++;
for (i0 = 0; i0 < *p; i0++){
*VstarP += *VP_reP;
*VstarP *= 0.5;
VstarP++;
VP_reP++;
}
}
/***** Proposed eigenvalues *****/
/***** Auxiliary numbers u2 and u3 correspoding to the reversal split move *****/
/***** Log-Jacobian, part 2 *****/
/***** Check also the adjacency condition from the reversal split move -> u2[p-1] must be positive *****/
/****** -> if not satisfied, take abs(u2[p-1]) -> this should be equivalent to labelswitching which is then not necessary *****/
LambdastarP = Lambdastar;
u2P = u2;
u3P = u3;
Lambda1P = Lambda1;
Lambda2P = Lambda2;
VstarP = Vstar;
for (i1 = 0; i1 < *p; i1++){
mu1_vstar = 0.0;
mu2_vstar = 0.0;
mustar_vstar = 0.0;
mu1P = mu1;
mu2P = mu2;
mustarP = mustar;
for (i0 = 0; i0 < *p; i0++){
mu1_vstar += *mu1P * *VstarP;
mu2_vstar += *mu2P * *VstarP;
mustar_vstar += *mustarP * *VstarP;
mu1P++;
mu2P++;
mustarP++;
VstarP++;
}
*LambdastarP = *u1 * (mu1_vstar * mu1_vstar + *Lambda1P) + one_u1 * (mu2_vstar * mu2_vstar + *Lambda2P) - mustar_vstar * mustar_vstar;
if (*LambdastarP <= 0){
return;
}
*u2P = ((mustar_vstar - mu1_vstar) / sqrt(*LambdastarP)) * sqrt_u1_ratio;
if (i1 == *p - 1 && *u2P <= 0) *u2P *= (-1);
one_minus_u2sq = 1 - *u2P * *u2P;
*u3P = (*u1 * *Lambda1P) / (one_minus_u2sq * *LambdastarP);
log_Jacob += 1.5 * AK_Basic::log_AK(*LambdastarP) + AK_Basic::log_AK(one_minus_u2sq);
LambdastarP++;
Lambda1P++;
Lambda2P++;
u2P++;
u3P++;
}
log_Jacob += *p * log_u1_one_minus_u1_min32;
/***** Proposed variance *****/
AK_LAPACK::spevSY2SP(Sigmastar, Lambdastar, Vstar, p);
/***** Cholesky decomposition of the proposed variance *****/
AK_Basic::copyArray(Lstar, Sigmastar, LTp);
F77_CALL(dpptrf)("L", p, Lstar, err);
if (*err){
warning("%s: Cholesky decomposition of proposed Sigmastar failed.\n", fname);
return;
}
/***** Inverted proposed variance *****/
AK_Basic::copyArray(Qstar, Lstar, LTp);
F77_CALL(dpptri)("L", p, Qstar, err);
if (*err){
warning("%s: Inversion of proposed Sigmastar failed.\n", fname);
return;
}
/***** log-dets for the proposed variance *****/
log_detsstar[0] = 0.0;
LstarP = Lstar;
for (i0 = *p; i0 > 0; i0--){ /** log_detsstar[0] = -sum(log(Lstar[i,i])) **/
log_detsstar[0] -= AK_Basic::log_AK(*LstarP);
LstarP += i0;
}
log_detsstar[1] = log_dets1[1]; /** log_detsstar[1] = -p * log(sqrt(2*pi)) **/
/***** log|d(Lambdastar,Vstar)/d(Sigmastar)|*****/ // 25/01/2008: this part included in NMix::RJMCMC_logJac_part3
//NMix::RJMCMC_logJacLambdaVSigma(log_dlambdaV_dSigma, dlambdaV_dSigma, dwork_misc, iwork_misc, err,
// Lambdastar, Vstar, Sigmastar, p, &AK_Basic::_ZERO_INT);
//if (*err){
// warning("%s: RJMCMC_logJacLambdaVSigma failed.\n", fname);
// return;
//}
/***** Log-Jacobian, part 3 *****/
NMix::RJMCMC_logJac_part3(logJ_part3, Lambdastar, Vstar, P, p);
log_Jacob += *logJ_part3;
} /*** end of the code for a MULTIVARIATE mixture ***/
/***** Log-density of the auxiliary vector *****/
/***** =================================== *****/
ld_u(log_dens_u, u, pars_dens_u, p);
/***** Propose new allocations *****/
/***** Compute logarithm of reversal Palloc *****/
/***** ==================================== *****/
log_Palloc = 0.0; /** to compute sum[i: r[i]=j1] log P(r[i]=j1|...) + sum[i: r[i]=j2] log P(r[i]=j2|...) **/
logL12[0] = 0.0; /** to sum up log_phi for observations in the original two components **/
logLstar[0] = 0.0; /** to sum up log_phi for observations belonging to the new combined component **/
*mixNstar = *mixN1 + *mixN2;
/*** Loop for component j1 ***/
yP = y; /** all observations **/
rInv1P = rInv1;
rInvPrev = 0;
for (i0 = 0; i0 < *mixN1; i0++){
yP += (*rInv1P - rInvPrev) * *p;
/*** log(phi(y | mu1, Sigma1)), log(phi(y | mu2, Sigma2)), log(phi(y | mustar, Sigmastar)) ***/
Dist::ldMVN1(&log_phi1, dwork_misc, yP, mu1, Li1, log_dets1, p);
Dist::ldMVN1(&log_phi2, dwork_misc, yP, mu2, Li2, log_dets2, p);
Dist::ldMVN2(&log_phistar, dwork_misc, yP, mustar, Lstar, log_detsstar, p);
/*** Probabilities of the full conditional of r (to compute log_Palloc of the reversal split move) ***/
log_Prob_r1 = log_phi1 + *logw1;
log_Prob_r2 = log_phi2 + *logw2;
max_log_Prob_r12 = (log_Prob_r1 > log_Prob_r2 ? log_Prob_r1 : log_Prob_r2);
log_Prob_r1 -= max_log_Prob_r12;
log_Prob_r2 -= max_log_Prob_r12;
Prob_r1 = AK_Basic::exp_AK(log_Prob_r1);
Prob_r2 = AK_Basic::exp_AK(log_Prob_r2);
sum_Prob_r12 = Prob_r1 + Prob_r2;
log_Palloc += log_Prob_r1 - AK_Basic::log_AK(sum_Prob_r12);
logL12[0] += log_phi1;
logLstar[0] += log_phistar;
rInvPrev = *rInv1P;
rInv1P++;
}
/*** Loop for component j2 ***/
yP = y; /** all observations **/
rInv2P = rInv2;
rInvPrev = 0;
for (i0 = 0; i0 < *mixN2; i0++){
yP += (*rInv2P - rInvPrev) * *p;
/*** log(phi(y | mu1, Sigma1)), log(phi(y | mu2, Sigma2)), log(phi(y | mustar, Sigmastar)) ***/
Dist::ldMVN1(&log_phi1, dwork_misc, yP, mu1, Li1, log_dets1, p);
Dist::ldMVN1(&log_phi2, dwork_misc, yP, mu2, Li2, log_dets2, p);
Dist::ldMVN2(&log_phistar, dwork_misc, yP, mustar, Lstar, log_detsstar, p);
/*** Probabilities of the full conditional of r (to compute log_Palloc of the reversal split move) ***/
log_Prob_r1 = log_phi1 + *logw1;
log_Prob_r2 = log_phi2 + *logw2;
max_log_Prob_r12 = (log_Prob_r1 > log_Prob_r2 ? log_Prob_r1 : log_Prob_r2);
log_Prob_r1 -= max_log_Prob_r12;
log_Prob_r2 -= max_log_Prob_r12;
Prob_r1 = AK_Basic::exp_AK(log_Prob_r1);
Prob_r2 = AK_Basic::exp_AK(log_Prob_r2);
sum_Prob_r12 = Prob_r1 + Prob_r2;
log_Palloc += log_Prob_r2 - AK_Basic::log_AK(sum_Prob_r12);
logL12[0] += log_phi2;
logLstar[0] += log_phistar;
rInvPrev = *rInv2P;
rInv2P++;
}
logL12[1] = *mixN1 * *logw1 + *mixN2 * *logw2;
logLstar[1] = *mixNstar * *logwstar;
/***** Logarithm of the likelihood ratio (of the reversal split move) *****/
/***** ============================================================== *****/
log_LikelihoodRatio = logL12[0] + logL12[1] - logLstar[0] - logLstar[1];
/***** Logarithm of the prior ratio (of the reversal split move) *****/
/***** ========================================================= *****/
/***** log-ratio of priors on mixture weights *****/
log_PriorRatio = (*delta - 1) * (*logw1 + *logw2 - *logwstar) - lbeta(*delta, *K * *delta);
/***** log-ratio of priors on K (+ factor comming from the equivalent ways that the components can produce the same likelihood) *****/
switch (*priorK){
case NMix::K_FIXED:
case NMix::K_UNIF: /*** K * (p(K)/p(K-1)) = K ***/
log_PriorRatio += logK[*K - 1];
break;
case NMix::K_TPOISS: /*** K * (p(K)/p(K-1)) = K * (lambda/K) = lambda ***/
log_PriorRatio += *log_lambda;
break;
}
/***** log-ratio of priors on mixture means *****/
switch (*priormuQ){
case NMix::MUQ_NC:
Dist::ldMVN1(log_prior_mu1, dwork_misc, mu1, xi + j1 * *p, Li1, ZERO_ZERO, p);
*log_prior_mu1 *= c[j1];
*log_prior_mu1 += log_dets1[0] + log_dets1[1] + (*p * log_c[j1]) / 2;
Dist::ldMVN1(log_prior_mu2, dwork_misc, mu2, xi + j2 * *p, Li2, ZERO_ZERO, p);
*log_prior_mu2 *= c[j2];
*log_prior_mu2 += log_dets2[0] + log_dets2[1] + (*p * log_c[j2]) / 2;
Dist::ldMVN2(log_prior_mustar, dwork_misc, mustar, xi + jstar * *p, Lstar, ZERO_ZERO, p);
*log_prior_mustar *= c[jstar];
*log_prior_mustar += log_detsstar[0] + log_detsstar[1] + (*p * log_c[jstar]) / 2;
break;
case NMix::MUQ_IC:
Dist::ldMVN1(log_prior_mu1, dwork_misc, mu1, xi + j1 * *p, D_Li + j1 * LTp, log_dets_D + j1 * 2, p);
Dist::ldMVN1(log_prior_mu2, dwork_misc, mu2, xi + j2 * *p, D_Li + j2 * LTp, log_dets_D + j2 * 2, p);
Dist::ldMVN1(log_prior_mustar, dwork_misc, mustar, xi + jstar * *p, D_Li + jstar * LTp, log_dets_D + jstar * 2, p);
break;
}
log_PriorRatio += *log_prior_mu1 + *log_prior_mu2 - *log_prior_mustar;
/***** log-ratio of priors on mixture (inverse) variances *****/
Dist::ldWishart_diagS(log_prior_Q1, Q1, log_dets1, log_Wishart_const, zeta, gammaInv, log_sqrt_detXiInv, p);
Dist::ldWishart_diagS(log_prior_Q2, Q2, log_dets2, log_Wishart_const, zeta, gammaInv, log_sqrt_detXiInv, p);
Dist::ldWishart_diagS(log_prior_Qstar, Qstar, log_detsstar, log_Wishart_const, zeta, gammaInv, log_sqrt_detXiInv, p);
log_PriorRatio += *log_prior_Q1 + *log_prior_Q2 - *log_prior_Qstar;
/***** Logarithm of the proposal ratio (of the reversal split move) *****/
/***** ============================================================ *****/
log_ProposalRatio = logPcombine[*K - 1] - logPsplit[*K - 2] - log_Palloc - *log_dens_u;
/***** Accept/reject *****/
/***** ============= *****/
*log_AR = -(log_LikelihoodRatio + log_PriorRatio + log_ProposalRatio + log_Jacob);
if (*log_AR >= 0) *accept = 1;
else{ /** decide by sampling from the exponential distribution **/
erand = exp_rand();
*accept = (erand > -(*log_AR) ? 1 : 0);
}
/***** Update mixture values if proposal accepted *****/
/***** ========================================== *****/
// Remember that jstar < jremove (irrespective of values j1 and j2)
//
if (*accept){
/*** r: loop for component j1 ***/
rP = r; /** all observations **/
rInv1P = rInv1; /** observations from component j1 **/
rInvPrev = 0;
for (i0 = 0; i0 < *mixN1; i0++){
rP += (*rInv1P - rInvPrev);
*rP = jstar;
rInvPrev = *rInv1P;
rInv1P++;
}
/*** r: loop for component j2 ***/
rP = r; /** all observations **/
rInv2P = rInv2; /** observations from component j2 **/
rInvPrev = 0;
for (i0 = 0; i0 < *mixN2; i0++){
rP += (*rInv2P - rInvPrev);
*rP = jstar;
rInvPrev = *rInv2P;
rInv2P++;
}
/*** w: weights ***/
*wOldP = *wstar;
wOldP += (jremove - jstar); /** jump to the point from which everything must be shifted **/
/*** logw: log-weights ***/
*logwOldP = *logwstar;
logwOldP += (jremove - jstar); /** jump to the point from which everything must be shifted **/
/*** mu: means ***/
/*** Q: inverse variances ***/
/*** Sigma: variances ***/
/*** Li: Cholesky decomposition of inverse variances, must be computed ***/
muNewP = mustar;
QNewP = Qstar;
SigmaNewP = Sigmastar;
Listar = LiOldP;
for (i1 = 0; i1 < *p; i1++){
*muOldP = *muNewP;
muOldP++;
muNewP++;
for (i0 = i1; i0 < *p; i0++){
*QOldP = *QNewP;
*LiOldP = *QNewP; /* preparing to calculate Cholesky decomposition */
QOldP++;
LiOldP++;
QNewP++;
*SigmaOldP = *SigmaNewP;
SigmaOldP++;
SigmaNewP++;
}
}
F77_CALL(dpptrf)("L", p, Listar, err);
if (*err){
error("%s: Cholesky decomposition of proposed Q(star) failed.\n", fname); // this should never happen
}
muOldP += *p * (jremove - jstar - 1); /** jump to the point from which everything must be shifted **/
QOldP += LTp * (jremove - jstar - 1); /** jump to the point from which everything must be shifted **/
SigmaOldP += LTp * (jremove - jstar - 1); /** jump to the point from which everything must be shifted **/
LiOldP += LTp * (jremove - jstar - 1); /** jump to the point from which everything must be shifted **/
/*** log_dets ***/
log_detsOldP[0] = log_detsstar[0];
log_detsOldP++;
log_detsOldP += 2 * (jremove - jstar - 1); /** jump to the point from which everything must be shifted **/
/*** mixN ***/
*mixNOldP = *mixNstar;
mixNOldP += (jremove - jstar); /** jump to the point from which everything must be shifted **/
/*** rInv ***/
rInvP = *rrInvOldP;
rP = r;
for (i0 = 0; i0 < *n; i0++){
if (*rP == jstar){
*rInvP = i0;
rInvP++;
}
rP++;
}
rrInvOldP += (jremove - jstar); /** jump to the point from which everything must be shifted **/
/*** Shift forward components after the removed one ***/
for (k = jremove; k < *K-1; k++){
*wOldP = *(wOldP + 1);
wOldP++;
*logwOldP = *(logwOldP + 1);
logwOldP++;
for (i1 = 0; i1 < *p; i1++){
*muOldP = *(muOldP + *p);
muOldP++;
for (i0 = i1; i0 < *p; i0++){
*QOldP = *(QOldP + LTp);
QOldP++;
*SigmaOldP = *(SigmaOldP + LTp);
SigmaOldP++;
*LiOldP = *(LiOldP + LTp);
LiOldP++;
}
}
log_detsOldP[0] = log_detsOldP[2];
log_detsOldP += 2;
*mixNOldP = *(mixNOldP + 1);
AK_Basic::copyArray(*rrInvOldP, *(rrInvOldP + 1), *mixNOldP);
mixNOldP++;
rrInvOldP++;
}
/*** K ***/
*K -= 1;
/*** order, rank ***/
NMix::orderComp(order, rank, dwork_misc, &AK_Basic::_ZERO_INT, K, mu, p);
} /*** end of if (*accept) ***/
return;
}
double F77_SUB(lbetaf)(double *a, double *b)
{
return lbeta(*a, *b);
}
// Returns both qbeta() and its "mirror" 1-qbeta(). Useful notably when qbeta() ~= 1
attribute_hidden void
qbeta_raw(double alpha, double p, double q, int lower_tail, int log_p,
int swap_01, // {TRUE, NA, FALSE}: if NA, algorithm decides swap_tail
double log_q_cut, /* if == Inf: return log(qbeta(..));
otherwise, if finite: the bound for
switching to log(x)-scale; see use_log_x */
int n_N, // number of "unconstrained" Newton steps before switching to constrained
double *qb) // = qb[0:1] = { qbeta(), 1 - qbeta() }
{
Rboolean
swap_choose = (swap_01 == MLOGICAL_NA),
swap_tail,
log_, give_log_q = (log_q_cut == ML_POSINF),
use_log_x = give_log_q, // or u < log_q_cut below
warned = FALSE, add_N_step = TRUE;
int i_pb, i_inn;
double a, la, logbeta, g, h, pp, p_, qq, r, s, t, w, y = -1.;
volatile double u, xinbta;
// Assuming p >= 0, q >= 0 here ...
// Deal with boundary cases here:
if(alpha == R_DT_0) {
#define return_q_0 \
if(give_log_q) { qb[0] = ML_NEGINF; qb[1] = 0; } \
else { qb[0] = 0; qb[1] = 1; } \
return
return_q_0;
}
if(alpha == R_DT_1) {
#define return_q_1 \
if(give_log_q) { qb[0] = 0; qb[1] = ML_NEGINF; } \
else { qb[0] = 1; qb[1] = 0; } \
return
return_q_1;
}
// check alpha {*before* transformation which may all accuracy}:
if((log_p && alpha > 0) ||
(!log_p && (alpha < 0 || alpha > 1))) { // alpha is outside
R_ifDEBUG_printf("qbeta(alpha=%g, %g, %g, .., log_p=%d): %s%s\n",
alpha, p,q, log_p, "alpha not in ",
log_p ? "[-Inf, 0]" : "[0,1]");
// ML_ERR_return_NAN :
ML_ERROR(ME_DOMAIN, "");
qb[0] = qb[1] = ML_NAN; return;
}
// p==0, q==0, p = Inf, q = Inf <==> treat as one- or two-point mass
if(p == 0 || q == 0 || !R_FINITE(p) || !R_FINITE(q)) {
// We know 0 < T(alpha) < 1 : pbeta() is constant and trivial in {0, 1/2, 1}
R_ifDEBUG_printf(
"qbeta(%g, %g, %g, lower_t=%d, log_p=%d): (p,q)-boundary: trivial\n",
alpha, p,q, lower_tail, log_p);
if(p == 0 && q == 0) { // point mass 1/2 at each of {0,1} :
if(alpha < R_D_half) { return_q_0; }
if(alpha > R_D_half) { return_q_1; }
// else: alpha == "1/2"
#define return_q_half \
if(give_log_q) qb[0] = qb[1] = -M_LN2; \
else qb[0] = qb[1] = 0.5; \
return
return_q_half;
} else if (p == 0 || p/q == 0) { // point mass 1 at 0 - "flipped around"
return_q_0;
} else if (q == 0 || q/p == 0) { // point mass 1 at 0 - "flipped around"
return_q_1;
}
// else: p = q = Inf : point mass 1 at 1/2
return_q_half;
}
/* initialize */
p_ = R_DT_qIv(alpha);/* lower_tail prob (in any case) */
// Conceptually, 0 < p_ < 1 (but can be 0 or 1 because of cancellation!)
logbeta = lbeta(p, q);
swap_tail = (swap_choose) ? (p_ > 0.5) : swap_01;
// change tail; default (swap_01 = NA): afterwards 0 < a <= 1/2
if(swap_tail) { /* change tail, swap p <-> q :*/
a = R_DT_CIv(alpha); // = 1 - p_ < 1/2
/* la := log(a), but without numerical cancellation: */
la = R_DT_Clog(alpha);
pp = q; qq = p;
}
else {
a = p_;
la = R_DT_log(alpha);
pp = p; qq = q;
}
/* calculate the initial approximation */
/* Desired accuracy for Newton iterations (below) should depend on (a,p)
* This is from Remark .. on AS 109, adapted.
* However, it's not clear if this is "optimal" for IEEE double prec.
* acu = fmax2(acu_min, pow(10., -25. - 5./(pp * pp) - 1./(a * a)));
* NEW: 'acu' accuracy NOT for squared adjustment, but simple;
* ---- i.e., "new acu" = sqrt(old acu)
*/
double acu = fmax2(acu_min, pow(10., -13. - 2.5/(pp * pp) - 0.5/(a * a)));
// try to catch "extreme left tail" early
double tx, u0 = (la + log(pp) + logbeta) / pp; // = log(x_0)
static const double
log_eps_c = M_LN2 * (1. - DBL_MANT_DIG);// = log(DBL_EPSILON) = -36.04..
r = pp*(1.-qq)/(pp+1.);
t = 0.2;
// FIXME: Factor 0.2 is a bit arbitrary; '1' is clearly much too much.
R_ifDEBUG_printf(
"qbeta(%g, %g, %g, lower_t=%d, log_p=%d):%s\n"
" swap_tail=%d, la=%g, u0=%g (bnd: %g (%g)) ",
alpha, p,q, lower_tail, log_p,
(log_p && (p_ == 0. || p_ == 1.)) ? (p_==0.?" p_=0":" p_=1") : "",
swap_tail, la, u0,
(t*log_eps_c - log(fabs(pp*(1.-qq)*(2.-qq)/(2.*(pp+2.)))))/2.,
t*log_eps_c - log(fabs(r))
);
if(M_LN2 * DBL_MIN_EXP < u0 && // cannot allow exp(u0) = 0 ==> exp(u1) = exp(u0) = 0
u0 < -0.01 && // (must: u0 < 0, but too close to 0 <==> x = exp(u0) = 0.99..)
// qq <= 2 && // <--- "arbitrary"
// u0 < t*log_eps_c - log(fabs(r)) &&
u0 < (t*log_eps_c - log(fabs(pp*(1.-qq)*(2.-qq)/(2.*(pp+2.)))))/2.)
{
// TODO: maybe jump here from below, when initial u "fails" ?
// L_tail_u:
// MM's one-step correction (cheaper than 1 Newton!)
r = r*exp(u0);// = r*x0
if(r > -1.) {
u = u0 - log1p(r)/pp;
R_ifDEBUG_printf("u1-u0=%9.3g --> choosing u = u1\n", u-u0);
} else {
u = u0;
R_ifDEBUG_printf("cannot cheaply improve u0\n");
}
tx = xinbta = exp(u);
use_log_x = TRUE; // or (u < log_q_cut) ??
goto L_Newton;
}
// y := y_\alpha in AS 64 := Hastings(1955) approximation of qnorm(1 - a) :
r = sqrt(-2 * la);
y = r - (const1 + const2 * r) / (1. + (const3 + const4 * r) * r);
if (pp > 1 && qq > 1) { // use Carter(1947), see AS 109, remark '5.'
r = (y * y - 3.) / 6.;
s = 1. / (pp + pp - 1.);
t = 1. / (qq + qq - 1.);
h = 2. / (s + t);
w = y * sqrt(h + r) / h - (t - s) * (r + 5. / 6. - 2. / (3. * h));
R_ifDEBUG_printf("p,q > 1 => w=%g", w);
if(w > 300) { // exp(w+w) is huge or overflows
t = w+w + log(qq) - log(pp); // = argument of log1pexp(.)
u = // log(xinbta) = - log1p(qq/pp * exp(w+w)) = -log(1 + exp(t))
(t <= 18) ? -log1p(exp(t)) : -t - exp(-t);
xinbta = exp(u);
} else {
xinbta = pp / (pp + qq * exp(w + w));
u = // log(xinbta)
- log1p(qq/pp * exp(w+w));
}
} else { // use the original AS 64 proposal, Scheffé-Tukey (1944) and Wilson-Hilferty
r = qq + qq;
/* A slightly more stable version of t := \chi^2_{alpha} of AS 64
* t = 1. / (9. * qq); t = r * R_pow_di(1. - t + y * sqrt(t), 3); */
t = 1. / (3. * sqrt(qq));
t = r * R_pow_di(1. + t*(-t + y), 3);// = \chi^2_{alpha} of AS 64
s = 4. * pp + r - 2.;// 4p + 2q - 2 = numerator of new t = (...) / chi^2
R_ifDEBUG_printf("min(p,q) <= 1: t=%g", t);
if (t == 0 || (t < 0. && s >= t)) { // cannot use chisq approx
// x0 = 1 - { (1-a)*q*B(p,q) } ^{1/q} {AS 65}
// xinbta = 1. - exp((log(1-a)+ log(qq) + logbeta) / qq);
double l1ma;/* := log(1-a), directly from alpha (as 'la' above):
* FIXME: not worth it? log1p(-a) always the same ?? */
if(swap_tail)
l1ma = R_DT_log(alpha);
else
l1ma = R_DT_Clog(alpha);
R_ifDEBUG_printf(" t <= 0 : log1p(-a)=%.15g, better l1ma=%.15g\n", log1p(-a), l1ma);
double xx = (l1ma + log(qq) + logbeta) / qq;
if(xx <= 0.) {
xinbta = -expm1(xx);
u = R_Log1_Exp (xx);// = log(xinbta) = log(1 - exp(...A...))
} else { // xx > 0 ==> 1 - e^xx < 0 .. is nonsense
R_ifDEBUG_printf(" xx=%g > 0: xinbta:= 1-e^xx < 0\n", xx);
xinbta = 0; u = ML_NEGINF; /// FIXME can do better?
}
} else {
t = s / t;
R_ifDEBUG_printf(" t > 0 or s < t < 0: new t = %g ( > 1 ?)\n", t);
if (t <= 1.) { // cannot use chisq, either
u = (la + log(pp) + logbeta) / pp;
xinbta = exp(u);
} else { // (1+x0)/(1-x0) = t, solved for x0 :
xinbta = 1. - 2. / (t + 1.);
u = log1p(-2. / (t + 1.));
}
}
}
// Problem: If initial u is completely wrong, we make a wrong decision here
if(swap_choose &&
(( swap_tail && u >= -exp( log_q_cut)) || // ==> "swap back"
(!swap_tail && u >= -exp(4*log_q_cut) && pp / qq < 1000.))) { // ==> "swap now" (much less easily)
// "revert swap" -- and use_log_x
swap_tail = !swap_tail;
R_ifDEBUG_printf(" u = %g (e^u = xinbta = %.16g) ==> ", u, xinbta);
if(swap_tail) {
a = R_DT_CIv(alpha); // needed ?
la = R_DT_Clog(alpha);
pp = q; qq = p;
}
else {
a = p_;
la = R_DT_log(alpha);
pp = p; qq = q;
}
R_ifDEBUG_printf("\"%s\"; la = %g\n",
(swap_tail ? "swap now" : "swap back"), la);
// we could redo computations above, but this should be stable
u = R_Log1_Exp(u);
xinbta = exp(u);
/* Careful: "swap now" should not fail if
1) the above initial xinbta is "completely wrong"
2) The correction step can go outside (u_n > 0 ==> e^u > 1 is illegal)
e.g., for
qbeta(0.2066, 0.143891, 0.05)
*/
}
if(!use_log_x)
use_log_x = (u < log_q_cut);//(per default) <==> xinbta = e^u < 4.54e-5
Rboolean
bad_u = !R_FINITE(u),
bad_init = bad_u || xinbta > p_hi;
R_ifDEBUG_printf(" -> u = %g, e^u = xinbta = %.16g, (Newton acu=%g%s)\n",
u, xinbta, acu,
(bad_u ? ", ** bad u **" :
(use_log_x ? ", on u = log(x) scale" : "")));
double u_n = 1.; // -Wall
tx = xinbta; // keeping "original initial x" (for now)
if(bad_u || u < log_q_cut) { /* e.g.
qbeta(0.21, .001, 0.05)
try "left border" quickly, i.e.,
try at smallest positive number: */
w = pbeta_raw(DBL_very_MIN, pp, qq, TRUE, log_p);
if(w > (log_p ? la : a)) {
R_ifDEBUG_printf(" quantile is left of smallest positive number; \"convergence\"\n");
if(log_p || fabs(w - a) < fabs(0 - a)) { // DBL_very_MIN is better than 0
tx = DBL_very_MIN;
u_n = DBL_log_v_MIN;// = log(DBL_very_MIN)
} else {
tx = 0.;
u_n = ML_NEGINF;
}
use_log_x = log_p; add_N_step = FALSE; goto L_return;
}
else {
R_ifDEBUG_printf(" pbeta(smallest pos.) = %g <= %g --> continuing\n",
w, (log_p ? la : a));
if(u < DBL_log_v_MIN) {
u = DBL_log_v_MIN;// = log(DBL_very_MIN)
xinbta = DBL_very_MIN;
}
}
}
/* Sometimes the approximation is negative (and == 0 is also not "ok") */
if (bad_init && !(use_log_x && tx > 0)) {
if(u == ML_NEGINF) {
R_ifDEBUG_printf(" u = -Inf;");
u = M_LN2 * DBL_MIN_EXP;
xinbta = DBL_MIN;
} else {
R_ifDEBUG_printf(" bad_init: u=%g, xinbta=%g;", u,xinbta);
xinbta = (xinbta > 1.1) // i.e. "way off"
? 0.5 // otherwise, keep the respective boundary:
: ((xinbta < p_lo) ? exp(u) : p_hi);
if(bad_u)
u = log(xinbta);
// otherwise: not changing "potentially better" u than the above
}
R_ifDEBUG_printf(" -> (partly)new u=%g, xinbta=%g\n", u,xinbta);
}
L_Newton:
/* --------------------------------------------------------------------
* Solve for x by a modified Newton-Raphson method, using pbeta_raw()
*/
r = 1 - pp;
t = 1 - qq;
double wprev = 0., prev = 1., adj = 1.; // -Wall
if(use_log_x) { // find log(xinbta) -- work in u := log(x) scale
// if(bad_init && tx > 0) xinbta = tx;// may have been better
for (i_pb=0; i_pb < 1000; i_pb++) {
// using log_p == TRUE unconditionally here
// FIXME: if exp(u) = xinbta underflows to 0, like different formula pbeta_log(u, *)
y = pbeta_raw(xinbta, pp, qq, /*lower_tail = */ TRUE, TRUE);
/* w := Newton step size for L(u) = log F(e^u) =!= 0; u := log(x)
* = (L(.) - la) / L'(.); L'(u)= (F'(e^u) * e^u ) / F(e^u)
* = (L(.) - la)*F(.) / {F'(e^u) * e^u } =
* = (L(.) - la) * e^L(.) * e^{-log F'(e^u) - u}
* = ( y - la) * e^{ y - u -log F'(e^u)}
and -log F'(x)= -log f(x) = + logbeta + (1-p) log(x) + (1-q) log(1-x)
= logbeta + (1-p) u + (1-q) log(1-e^u)
*/
w = (y == ML_NEGINF) // y = -Inf well possible: we are on log scale!
? 0. : (y - la) * exp(y - u + logbeta + r * u + t * R_Log1_Exp(u));
if(!R_FINITE(w))
break;
if (i_pb >= n_N && w * wprev <= 0.)
prev = fmax2(fabs(adj),fpu);
R_ifDEBUG_printf("N(i=%2d): u=%#20.16g, pb(e^u)=%#12.6g, w=%#15.9g, %s prev=%11g,",
i_pb, u, y, w, (w * wprev <= 0.) ? "new" : "old", prev);
g = 1;
for (i_inn=0; i_inn < 1000; i_inn++) {
adj = g * w;
// take full Newton steps at the beginning; only then safe guard:
if (i_pb < n_N || fabs(adj) < prev) {
u_n = u - adj; // u_{n+1} = u_n - g*w
if (u_n <= 0.) { // <==> 0 < xinbta := e^u <= 1
if (prev <= acu || fabs(w) <= acu) {
/* R_ifDEBUG_printf(" -adj=%g, %s <= acu ==> convergence\n", */
/* -adj, (prev <= acu) ? "prev" : "|w|"); */
R_ifDEBUG_printf(" it{in}=%d, -adj=%g, %s <= acu ==> convergence\n",
i_inn, -adj, (prev <= acu) ? "prev" : "|w|");
goto L_converged;
}
// if (u_n != ML_NEGINF && u_n != 1)
break;
}
}
g /= 3;
}
// (cancellation in (u_n -u) => may differ from adj:
double D = fmin2(fabs(adj), fabs(u_n - u));
/* R_ifDEBUG_printf(" delta(u)=%g\n", u_n - u); */
R_ifDEBUG_printf(" it{in}=%d, delta(u)=%9.3g, D/|.|=%.3g\n",
i_inn, u_n - u, D/fabs(u_n + u));
if (D <= 4e-16 * fabs(u_n + u))
goto L_converged;
u = u_n;
xinbta = exp(u);
wprev = w;
} // for(i )
} else
for (i_pb=0; i_pb < 1000; i_pb++) {
y = pbeta_raw(xinbta, pp, qq, /*lower_tail = */ TRUE, log_p);
// delta{y} : d_y = y - (log_p ? la : a);
#ifdef IEEE_754
if(!R_FINITE(y) && !(log_p && y == ML_NEGINF))// y = -Inf is ok if(log_p)
#else
if (errno)
#endif
{ // ML_ERR_return_NAN :
ML_ERROR(ME_DOMAIN, "");
qb[0] = qb[1] = ML_NAN; return;
}
/* w := Newton step size (F(.) - a) / F'(.) or,
* -- log: (lF - la) / (F' / F) = exp(lF) * (lF - la) / F'
*/
w = log_p
? (y - la) * exp(y + logbeta + r * log(xinbta) + t * log1p(-xinbta))
: (y - a) * exp( logbeta + r * log(xinbta) + t * log1p(-xinbta));
if (i_pb >= n_N && w * wprev <= 0.)
prev = fmax2(fabs(adj),fpu);
R_ifDEBUG_printf("N(i=%2d): x0=%#17.15g, pb(x0)=%#17.15g, w=%#17.15g, %s prev=%g,",
i_pb, xinbta, y, w, (w * wprev <= 0.) ? "new" : "old", prev);
g = 1;
for (i_inn=0; i_inn < 1000;i_inn++) {
adj = g * w;
// take full Newton steps at the beginning; only then safe guard:
if (i_pb < n_N || fabs(adj) < prev) {
tx = xinbta - adj; // x_{n+1} = x_n - g*w
if (0. <= tx && tx <= 1.) {
if (prev <= acu || fabs(w) <= acu) {
R_ifDEBUG_printf(" it{in}=%d, delta(x)=%g, %s <= acu ==> convergence\n",
i_inn, -adj, (prev <= acu) ? "prev" : "|w|");
goto L_converged;
}
if (tx != 0. && tx != 1)
break;
}
}
g /= 3;
}
R_ifDEBUG_printf(" it{in}=%d, delta(x)=%g\n", i_inn, tx - xinbta);
if (fabs(tx - xinbta) <= 4e-16 * (tx + xinbta)) // "<=" : (.) == 0
goto L_converged;
xinbta = tx;
if(tx == 0) // "we have lost"
break;
wprev = w;
}
/*-- NOT converged: Iteration count --*/
warned = TRUE;
ML_ERROR(ME_PRECISION, "qbeta");
L_converged:
log_ = log_p || use_log_x; // only for printing
R_ifDEBUG_printf(" %s: Final delta(y) = %g%s\n",
warned ? "_NO_ convergence" : "converged",
y - (log_ ? la : a), (log_ ? " (log_)" : ""));
if((log_ && y == ML_NEGINF) || (!log_ && y == 0)) {
// stuck at left, try if smallest positive number is "better"
w = pbeta_raw(DBL_very_MIN, pp, qq, TRUE, log_);
if(log_ || fabs(w - a) <= fabs(y - a)) {
tx = DBL_very_MIN;
u_n = DBL_log_v_MIN;// = log(DBL_very_MIN)
}
add_N_step = FALSE; // not trying to do better anymore
}
else if(!warned && (log_ ? fabs(y - la) > 3 : fabs(y - a) > 1e-4)) {
if(!(log_ && y == ML_NEGINF &&
// e.g. qbeta(-1e-10, .2, .03, log=TRUE) cannot get accurate ==> do NOT warn
pbeta_raw(DBL_1__eps, // = 1 - eps
pp, qq, TRUE, TRUE) > la + 2))
MATHLIB_WARNING2( // low accuracy for more platform independent output:
"qbeta(a, *) =: x0 with |pbeta(x0,*%s) - alpha| = %.5g is not accurate",
(log_ ? ", log_" : ""), fabs(y - (log_ ? la : a)));
}
L_return:
if(give_log_q) { // ==> use_log_x , too
if(!use_log_x) // (see if claim above is true)
MATHLIB_WARNING(
"qbeta() L_return, u_n=%g; give_log_q=TRUE but use_log_x=FALSE -- please report!",
u_n);
double r = R_Log1_Exp(u_n);
if(swap_tail) {
qb[0] = r; qb[1] = u_n;
} else {
qb[0] = u_n; qb[1] = r;
}
} else {
if(use_log_x) {
if(add_N_step) {
/* add one last Newton step on original x scale, e.g., for
qbeta(2^-98, 0.125, 2^-96) */
xinbta = exp(u_n);
y = pbeta_raw(xinbta, pp, qq, /*lower_tail = */ TRUE, log_p);
w = log_p
? (y - la) * exp(y + logbeta + r * log(xinbta) + t * log1p(-xinbta))
: (y - a) * exp( logbeta + r * log(xinbta) + t * log1p(-xinbta));
tx = xinbta - w;
R_ifDEBUG_printf(
"Final Newton correction(non-log scale): xinbta=%.16g, y=%g, w=%g. => new tx=%.16g\n",
xinbta, y, w, tx);
} else {
if(swap_tail) {
qb[0] = -expm1(u_n); qb[1] = exp (u_n);
} else {
qb[0] = exp (u_n); qb[1] = -expm1(u_n);
}
return;
}
}
if(swap_tail) {
qb[0] = 1 - tx; qb[1] = tx;
} else {
qb[0] = tx; qb[1] = 1 - tx;
}
}
return;
}
/***** ***************************************************************************************** *****/
void
RJMCMCdeath(int* accept, double* log_AR,
int* K, double* w, double* logw, double* mu,
double* Q, double* Li, double* Sigma, double* log_dets,
int* order, int* rank, int* mixN,
int* jempty, int* err,
const int* p, const int* n,
const int* Kmax, const double* logK, const double* log_lambda, const int* priorK,
const double* logPbirth, const double* logPdeath, const double* delta)
{
//const char *fname = "NMix::RJMCMCdeath";
*err = 0;
*accept = 0;
/*** Some variables ***/
static int j, i1, i0, jstar, LTp;
static int Nempty;
static double one_wstar, log_one_wstar, erand;
/*** Some pointers ***/
static double *wstar, *logwstar;
static int *mixNP, *jemptyP;
static double *wP, *logwP, *muP, *QP, *LiP, *SigmaP, *log_detsP;
static const double *muPnext, *QPnext, *LiPnext, *SigmaPnext;
if (*K == 1){
*log_AR = R_NegInf;
return;
}
LTp = (*p * (*p + 1))/2;
/***** Compute the number of empty components and store their indeces *****/
/***** ============================================================== *****/
Nempty = 0;
jemptyP = jempty;
mixNP = mixN;
for (j = 0; j < *K; j++){
if (*mixNP == 0){
Nempty++;
*jemptyP = j;
jemptyP++;
}
mixNP++;
}
/***** Directly reject the death move if there are no empty components *****/
/***** =============================================================== *****/
if (Nempty == 0){
*log_AR = R_NegInf;
return;
}
/***** Choose at random one of empty components *****/
/***** ======================================== *****/
j = (int)(floor(unif_rand() * Nempty));
if (j == Nempty) j = Nempty - 1; // this row is needed with theoretical probability 0 (in cases when unif_rand() returns 1)
jstar = jempty[j];
/***** Log-acceptance ratio *****/
/***** ==================== *****/
wstar = w + jstar;
logwstar = logw + jstar;
one_wstar = 1 - *wstar;
log_one_wstar = AK_Basic::log_AK(one_wstar);
// *log_AR = -(logPdeath[*K - 1] - logPbirth[*K - 2] - AK_Basic::log_AK((double)(Nempty)) + lbeta(1, *K - 1) - lbeta(*delta, (*K - 1) * *delta)
// + (*delta - 1) * *logwstar + (*n + (*K - 1) * (*delta - 1) + 1) * log_one_wstar); // this is according to the original paper Richardson and Green (1997)
*log_AR = -(logPdeath[*K - 1] - logPbirth[*K - 2] - AK_Basic::log_AK((double)(Nempty)) + lbeta(1, *K - 1) - lbeta(*delta, (*K - 1) * *delta)
+ (*delta - 1) * *logwstar + (*n + (*K - 1) * (*delta - 1)) * log_one_wstar); // this is according to Corrigendum in JRSS, B (1998), p. 661
/***** log-ratio of priors on K (+ factor comming from the equivalent ways that the components can produce the same likelihood) *****/
switch (*priorK){
case NMix::K_FIXED:
case NMix::K_UNIF: /*** K * (p(K)/p(K-1)) = K ***/
*log_AR -= logK[*K - 1];
break;
case NMix::K_TPOISS: /*** K * (p(K)/p(K-1)) = K * (lambda/K) = lambda ***/
*log_AR -= *log_lambda;
break;
}
/***** Accept/reject *****/
/***** ============= *****/
if (*log_AR >= 0) *accept = 1;
else{ /** decide by sampling from the exponential distribution **/
erand = exp_rand();
*accept = (erand > -(*log_AR) ? 1 : 0);
}
/***** Update mixture values if proposal accepted *****/
/***** ========================================== *****/
if (*accept){
/***** Adjustment of the weights and their shift, new log-weights *****/
wP = w;
logwP = logw;
j = 0;
while (j < jstar){
*logwP -= log_one_wstar;
*wP = AK_Basic::exp_AK(*logwP);
wP++;
logwP++;
j++;
}
while (j < *K - 1){
*logwP = *(logwP + 1) - log_one_wstar;
*wP = AK_Basic::exp_AK(*logwP);
wP++;
logwP++;
j++;
}
/***** Mixture means, inverse variances, their Cholesky decompositions, variances, log_dets -> must be shifted *****/
/***** mixN -> must be shifted *****/
mixNP = mixN + jstar;
muP = mu + jstar * *p;
QP = Q + jstar * LTp;
LiP = Li + jstar * LTp;
SigmaP = Sigma + jstar * LTp;
log_detsP = log_dets + jstar * 2;
muPnext = muP + *p;
QPnext = QP + LTp;
LiPnext = LiP + LTp;
SigmaPnext = SigmaP + LTp;
for (j = jstar; j < *K - 1; j++){
*mixNP = *(mixNP + 1);
mixNP++;
*log_detsP = *(log_detsP + 2);
log_detsP += 2;
for (i1 = 0; i1 < *p; i1++){
*muP = *muPnext;
muP++;
muPnext++;
for (i0 = i1; i0 < *p; i0++){
*QP = *QPnext;
QP++;
QPnext++;
*LiP = *LiPnext;
LiP++;
LiPnext++;
*SigmaP = *SigmaPnext;
SigmaP++;
SigmaPnext++;
}
}
}
/***** order, rank *****/
NMix::orderComp_remove(order, rank, &jstar, K);
/***** K *****/
*K -= 1;
}
return;
}
double lfastchoose(double n, double k)
{
return -log(n + 1.) - lbeta(n - k + 1., k + 1.);
}
