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 betaprime_glm_shrinkage(SEXP hyperparams, int pmodel, double W, int Laplace ) {
double a, n,p, b, shrinkage = 1.0;
a = REAL(getListElement(hyperparams, "alpha"))[0];
n = REAL(getListElement(hyperparams, "n"))[0];
p = (double) pmodel;
b = n - p - 1.5;
// Rprintf("a = %lf\n", a);
// Rprintf("b = %lf\n", b);
// Rprintf("s = %lf\n", s);
shrinkage = 1.0;
if (p >= 1.0)
if (p >= 1.0)
// shrinkage = shrinkage_chg(a + p, a + b + p, -(s+W), Laplace);
shrinkage = 1.0 - exp(log(a + p) -log(a + b + p)
+loghyperg1F1((a+p+2.0)/2.0, (a+p+b +2.0)/2.0, -W/2.0, Laplace)
-loghyperg1F1((a+p)/2,(a+p+b)/2.0, -W/2.0, Laplace)
);
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 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);
}
void hypergeometric1F1(double *a, double *b, double *x, double *y, int *npara, int *Method)
{
int k;
for (k = 0; k < *npara; k++) {
// if (x[k] <0) {
/* Since Linex system tends to report error for negative x, we
use the following fomular to convert it to positive value
1F1(a, b, x) = 1F1(b - a, b, -x) * exp(x) */
/* a[k] = b[k] - a[k];
y[k] = hyperg(a[k], b[k], -x[k])*exp(x[k]);
}
else {
y[k] = hyperg(a[k], b[k], x[k]);
}*/
y[k] = loghyperg1F1(a[k], b[k], x[k], Method[k]);
}
}
