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);
}
/*--------------------------------------------------------------------------
HyperTwo
Function for Phi1(a,b,c,x,y)
Assumes: 0<a<c, 0<b, y<1
Use rule T5 if y<0. Then use rule T1 if x>=0 or rule T2 if x<0.
--------------------------------------------------------------------------*/
double HyperTwo(double a, double b, double c, double x, double y) {
int m=0;
double F, zf=1.0, zfg;
if (y<0)
F=exp(x)*pow(1-y,-b)*HyperTwo(c-a,b,c,-x,y/(y-1));
else {
zfg=hyperg2F1(b,a,c,y);
F=zfg;
if (x<0) {
while ((zfg/F)>FACCURACY) {
m++;
zf*=((c-a+m-1)/(c+m-1))*(-x/m);
zfg=zf*hyperg2F1(b,a,c+m,y);
F+=zfg;
}
F*=exp(x);
}
else {
while ((zfg/F)>FACCURACY) {
m++;
zf*=((a+m-1)/(c+m-1))*(x/m);
zfg=zf*hyperg2F1(b,a+m,c+m,y);
F+=zfg;
}
}
}
return(F);
}
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);
}
void phi1(double *a, double *b, double *c, double *x, double *y, double *phi, int *npara)
{
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]);
}*/
phi[k] = HyperTwo(a[k], b[k], c[k], x[k], y[k]);
}
}
