void fbst_loginorm(gsl_rng *r,
gsl_vector_uint *x,
gsl_vector_uint *sums,
double alpha,
double beta,
double *_ev,double *_err,
FBSTConfig *config) {
size_t i,j;
double mean;
double var;
double a,b;
assert(x->size == sums->size);
gsl_vector *means=gsl_vector_alloc(x->size);
gsl_vector *sd=gsl_vector_alloc(x->size);
for(i=0;i<x->size;i++) {
a=ELT(x,i)+alpha;
b=ELT(sums,i)+beta-a;
mean=gsl_sf_psi(a)-gsl_sf_psi(b);
var=gsl_sf_psi_1(a)+gsl_sf_psi_1(b);
printf("x%i=N(%lg %lg)\n",i,mean,var);
gsl_vector_set(means,i,mean);
gsl_vector_set(sd,i,var);
}
fbst_normal(r,means,sd,_ev,_err,config);
gsl_vector_free(means);
gsl_vector_free(sd);
}
void binom_transform (const double* rs, const double* fq, double* out)
{
double r=rs[0]; double s=rs[1];
double f=fq[0]; double q=fq[1];
double E = gsl_sf_psi(r) - gsl_sf_psi(s);
double V = gsl_sf_psi_1(r) + gsl_sf_psi_1(s);
out[0] = E - f;
out[1] = V - q;
// Rprintf("r=%g, s=%g, f=%g, q=%g, out=%g, %g\n", r, s, f, q, out[0], out[1]);
}
static void hessian(gsl_matrix* ptHessian, const double* adLambda,
const struct data_t *data)
{
const int S = data->S, N = data->N, *aanX = data->aanX;
const double *adPi = data->adPi;
int i = 0, j = 0;
double adAlpha[S], adAJK[S], adCJK[S], adAJK0[S], adCJK0[S];
double dCK0 = 0.0, dAK0;
double dCSum, dAlphaSum = 0.0, dW = 0.0, dCK = 0.0, dAK;
for (j = 0; j < S; j++) {
adAlpha[j] = exp(adLambda[j]);
dAlphaSum += adAlpha[j];
adAJK0[j] = adAJK[j] = adCJK0[j] = adCJK[j] = 0.0;
const double dPsiAlpha = gsl_sf_psi(adAlpha[j]);
const double dPsi1Alpha = gsl_sf_psi_1(adAlpha[j]);
for (i = 0; i < N; i++) {
const int n = aanX[j * N + i];
adCJK0[j] += adPi[i] * n ? gsl_sf_psi(adAlpha[j] + n) : dPsiAlpha;
adAJK0[j] += adPi[i] * dPsiAlpha;
adCJK[j] += adPi[i] * n ? gsl_sf_psi_1(adAlpha[j] + n): dPsi1Alpha;
adAJK[j] += adPi[i] * dPsi1Alpha;
}
}
for (i = 0; i < N; i++) {
dW += adPi[i];
dCSum = 0.0;
for (j = 0; j < S; j++)
dCSum += adAlpha[j] + aanX[j * N + i];
dCK += adPi[i]*gsl_sf_psi_1(dCSum);
dCK0 += adPi[i]*gsl_sf_psi(dCSum);
}
dAK = dW * gsl_sf_psi_1(dAlphaSum);
dAK0 = dW * gsl_sf_psi(dAlphaSum);
for (i = 0; i < S; i++)
for (j = 0; j < S; j++) {
double dVal = 0.0;
if (i == j) {
double dG1 = -adAlpha[i] *
(dAK0 - dCK0 + adCJK0[i] - adAJK0[i]);
double dG2 = -adAlpha[i] *
adAlpha[i]*(dAK - dCK + adCJK[i] - adAJK[i]);
double dG3 = adAlpha[i]*GAMMA_NU;
dVal = dG1 + dG2 + dG3;
} else
dVal = -adAlpha[i] * adAlpha[j] * (dAK - dCK);
gsl_matrix_set(ptHessian, i, j, dVal);
}
}
double NBinGlm::getfAfAdash(double k0, unsigned int id, unsigned int limit)
{
unsigned int i, it=0;
double sum=1, num=0, k;
double y, m, dl, ddl, tol;
double phi, dl_dphi, d2l_dphi2, del_phi;
if (k0==0) {
for (i=0; i<nRows; i++) {
y = gsl_matrix_get(Yref, i, id);
m = gsl_matrix_get(Mu, i, id);
if (m>0) {
sum = sum+(y/m-1)*(y/m-1);
num = num+1;
}
}
k = num/sum;
if (num==0) printf("num=0\n");
}
else k=k0;
k = MAX(k, mintol);
phi = 1/k;
while ( it<limit ) {
it++;
dl=nRows*(1+log(k)-gsl_sf_psi(k));
ddl=nRows*(gsl_sf_psi_1(k)-1/k);
for ( i=0; i<nRows; i++ ) {
y = gsl_matrix_get(Yref, i, id);
m = gsl_matrix_get(Mu, i, id);
dl = dl + gsl_sf_psi(y+k)-log(m+k)-(y+k)/(m+k);
ddl = ddl - gsl_sf_psi_1(y+k)+2/(m+k)-(y+k)/((m+k)*(m+k));
}
dl_dphi = - exp(2*log(k))*dl;
d2l_dphi2 = 2*exp(3*log(k))*dl + exp(4*log(k))*ddl;
if (ABS(ddl) < mintol) ddl = GSL_SIGN(ddl)*mintol;
del_phi = dl_dphi/ABS(d2l_dphi2);
tol = ABS(del_phi*dl_dphi);
if (tol<eps) break;
phi = phi + del_phi;
if (phi<0) {k=0; break;}
k = 1/MAX(ABS(phi),mintol);
if (k>maxth) break;
}
return k;
}
double NBinGlm::thetaML(double k0, unsigned int id, unsigned int limit)
{
// equivalent to theta.ml() in MASS
// Note that theta here is the dispersion parameter
// So phi = 1/theta;
unsigned int i, it=0;
double del=1, sum=1, num=0, k;
double y, m, dl, ddl, tol;
if (k0==0) {
for (i=0; i<nRows; i++) {
y = gsl_matrix_get(Yref, i, id);
m = gsl_matrix_get(Mu, i, id);
if (m>0) {
sum = sum+(y/m-1)*(y/m-1);
num = num+1;
}
}
k = num/sum;
}
else k=k0;
k = MAX(k, mintol);
while ( it<=limit ) {
it++;
k = ABS(k);
dl=nRows*(1+log(k)-gsl_sf_psi(k));
ddl=nRows*(gsl_sf_psi_1(k)-1/k);
for ( i=0; i<nRows; i++ ) {
y = gsl_matrix_get(Yref, i, id);
m = gsl_matrix_get(Mu, i, id);
dl = dl + gsl_sf_psi(y+k)-log(m+k)-(y+k)/(m+k);
ddl = ddl - gsl_sf_psi_1(y+k)+2/(m+k)-(y+k)/((m+k)*(m+k));
}
if (ABS(ddl) < mintol) ddl = GSL_SIGN(ddl)*mintol;
del = dl/ABS(ddl);
tol = ABS(del*dl);
if (tol<eps) break;
k = k+del; // Normal Newton use - instead of + for -ddl
if (k>maxth) break;
if (k<0) { k = 0; break; }
}
// if (k<0) k=0;
return k;
}
int binom_transform_df(const gsl_vector* x, void* p, gsl_matrix* J)
{
double r = gsl_vector_get(x, 0);
double s = gsl_vector_get(x, 1);
double df00 = gsl_sf_psi_1(r);
double df01 = -1.0 * gsl_sf_psi_1(s);
double df10 = gsl_sf_psi_n(2, r);
double df11 = gsl_sf_psi_n(2, s);
gsl_matrix_set(J, 0, 0, df00);
gsl_matrix_set(J, 0, 1, df01);
gsl_matrix_set(J, 1, 0, df10);
gsl_matrix_set(J, 1, 1, df11);
return GSL_SUCCESS;
}
void gr_KL_V_nu_g (const gsl_vector *v_V_nu_g, void *null, gsl_vector *df)
{
int i = *params->i; //, j, d = *params->d;
int g, G = *params->G;
double tmpsum = 0.0, tmp;
int N = *params->N;
double KL;
double V_nu_g = gsl_vector_get(v_V_nu_g, 0);
tmp = 0.0;
for (g = 0; g < G; g++)
if (g!=*params->g)
tmp += params->V_nu[g];
for (i = 0; i < SUBSET; i++)
tmpsum =
tmpsum + params->V_lambda[*params->g * N + i] * (gsl_sf_psi_1 (V_nu_g) -
gsl_sf_psi_1 (tmp+V_nu_g));
KL =
tmpsum - gsl_sf_psi (tmp+V_nu_g) - gsl_sf_psi (params->nu[*params->g]) -
V_nu_g * gsl_sf_psi_1 (V_nu_g) +
params->nu[*params->g] * gsl_sf_psi_1 (V_nu_g);
gsl_vector_set(df, 0, -KL);
return;
}
void gr_KL_V_alpha_g (const gsl_vector *v_V_alpha_g, void *null, gsl_vector *df)
{
int i = *params->i;
int g = *params->g;
double tmpsum = 0.0, tmp;
int N = *params->N;
int d;
double KL;
double V_alpha_g = gsl_vector_get(v_V_alpha_g, 0);
for (i = 0; i < SUBSET; i++)
{
tmp = 0.0;
for (d=0; d<*params->D; d++)
tmp += pow(params->V_z[i * *params->D + d] - params->V_eta[g * *params->D + d], 2.0);
tmpsum +=
params->V_lambda[*params->g * N + i] *
(*params->D* *params->inv_sigma02* gsl_sf_psi_1(0.5* *params->inv_sigma02*V_alpha_g)-
0.5* *params->inv_sigma02*(params->V_sigma2[i]+params->V_omega2[g]+tmp));
}
KL = tmpsum + (0.5*(V_alpha_g-params->alpha[*params->g])* gsl_sf_psi_1(0.5*V_alpha_g));// -
//gsl_sf_psi(0.5*V_alpha_g)) + gsl_sf_psi(0.5*V_alpha_g)/lgamma(0.5*V_alpha_g);
gsl_vector_set(df, 0, -KL);
return;
}
//------------------------------------------------------------------------------
/// Trigamma function \f$ \psi^{(1)}(x) \f$
inline double psi1(const double x)
{
return gsl_sf_psi_1(x);
}
double trigamma(double x){
return gsl_sf_psi_1(x);
}
