int mcmclib_cholesky_inverse(gsl_matrix* A) {
int status = mcmclib_cholesky_decomp(A);
if(status)
return status;
gsl_linalg_cholesky_invert(A);
return GSL_SUCCESS;
}
void chol_inverse_cov_matrix(optstruct* options, gsl_matrix* temp_matrix, gsl_matrix* result_matrix, double* final_determinant_c){
int cholesky_test, i;
double determinant_c = 0.0;
gsl_error_handler_t *temp_handler; // disable the default handler
// do a cholesky decomp of the cov matrix, LU is not stable for ill conditioned matrices
temp_handler = gsl_set_error_handler_off();
cholesky_test = gsl_linalg_cholesky_decomp(temp_matrix);
if(cholesky_test == GSL_EDOM){
fprintf(stderr, "trying to cholesky a non postive def matrix, in emulate-fns.c sorry...\n");
exit(1);
}
gsl_set_error_handler(temp_handler);
// find the determinant and then invert
// the determinant is just the trace squared
determinant_c = 1.0;
for(i = 0; i < options->nmodel_points; i++)
determinant_c *= gsl_matrix_get(temp_matrix, i, i);
determinant_c = determinant_c * determinant_c;
//printf("det CHOL:%g\n", determinant_c);
gsl_linalg_cholesky_invert(temp_matrix);
gsl_matrix_memcpy(result_matrix, temp_matrix);
*final_determinant_c = determinant_c;
}
// Inverse Wishart distribution random number generator
int ran_invwishart(const gsl_rng *r, const double nu,
const gsl_matrix *V, gsl_matrix *X)
{
const int k = V->size1;
gsl_matrix *Vinv = gsl_matrix_alloc(k, k);
gsl_matrix_memcpy(Vinv, V);
gsl_linalg_cholesky_decomp(Vinv);
gsl_linalg_cholesky_invert(Vinv);
ran_wishart(r, nu, Vinv, X);
gsl_linalg_cholesky_decomp(X);
gsl_linalg_cholesky_invert(X);
gsl_matrix_free(Vinv);
return 0;
}
/* Update parameters using an implicit solver for
* equation (17) of Girolami and Calderhead (2011).
* Arguments:
* state: a pointer to internal working storage for RMHMC.
* model: a pointer to the rmhmc_model structure with pointers to user defined functions.
* N: number of parameters.
* stepSize: integration step-size.
* Result:
* The method directly updates the new_x array in the state structure.
* returns 0 for success or non-zero for failure.
*/
static int parametersNewtonUpdate(rmhmc_params* state, rmhmc_model* model, int N , double stepSize){
gsl_vector_view new_x_v = gsl_vector_view_array(state->new_x, N);
gsl_vector_view new_p_v = gsl_vector_view_array(state->new_momentum, N);
gsl_matrix_view new_cholM_v = gsl_matrix_view_array(state->new_cholMx, N, N);
/* temp copy of parameters */
gsl_vector_view x0_v = gsl_vector_view_array(state->btmp, N);
gsl_vector_memcpy(&x0_v.vector, &new_x_v.vector);
/* temp copy of inverse Metric */
gsl_matrix_view new_invM_v = gsl_matrix_view_array(state->new_invMx, N, N);
gsl_matrix_view invM0_v = gsl_matrix_view_array(state->tmpM, N, N);
gsl_matrix_memcpy(&invM0_v.matrix, &new_invM_v.matrix);
gsl_vector_view a_v = gsl_vector_view_array(state->atmp, N);
/* a = invM0*pNew */
/* TODO: replace gsl_blas_dgemv with gsl_blas_dsymv since invM0_v.matrix is symetric */
gsl_blas_dgemv(CblasNoTrans, 1.0, &invM0_v.matrix, &new_p_v.vector, 0.0, &a_v.vector);
int iterations = state->fIt;
int flag = 0;
int i;
for (i = 0; i < iterations; i++) {
/* new_x = invM_new*p_new */
/* TODO: replace gsl_blas_dgemv with gsl_blas_dsymv since inew_invM_v.matrix is symetric */
gsl_blas_dgemv(CblasNoTrans, 1.0, &new_invM_v.matrix, &new_p_v.vector, 0.0, &new_x_v.vector);
/* Calculates new_x_v = x0 + 0.5*stepSize*(invM_0*newP + newInvM*newP) */
gsl_vector_add(&new_x_v.vector, &a_v.vector);
gsl_vector_scale(&new_x_v.vector, 0.5*stepSize);
gsl_vector_add(&new_x_v.vector, &x0_v.vector);
/* calculate metric at the current position or update everything if this is the last iteration */
if ( (i == iterations-1) )
/* call user defined function for updating all quantities */
model->PosteriorAll(state->new_x, model->m_params, &state->new_fx, state->new_dfx, state->new_cholMx, state->new_dMx);
else
/* call user defined function for updating only the metric ternsor */
model->Metric(state->new_x, model->m_params, state->new_cholMx);
/* calculate cholesky factor for current metric */
gsl_error_handler_t* old_handle = gsl_set_error_handler_off();
flag = gsl_linalg_cholesky_decomp( &new_cholM_v.matrix );
if (flag != 0){
fprintf(stderr,"RMHMC: matrix not positive definite in parametersNewtonUpdate.\n");
return flag;
}
gsl_set_error_handler(old_handle);
/* calculate inverse for current metric */
gsl_matrix_memcpy(&new_invM_v.matrix, &new_cholM_v.matrix );
gsl_linalg_cholesky_invert(&new_invM_v.matrix);
}
return flag;
}
double ran_invwishart_pdf(const gsl_matrix *X, const double nu, const gsl_matrix *V)
{
const int k = X->size1;
double den;
gsl_matrix *Xinv = gsl_matrix_alloc(k, k);
gsl_matrix *Vinv = gsl_matrix_alloc(k, k);
gsl_matrix_memcpy(Xinv, X);
gsl_matrix_memcpy(Vinv, V);
gsl_linalg_cholesky_decomp(Xinv);
gsl_linalg_cholesky_invert(Xinv);
gsl_linalg_cholesky_decomp(Vinv);
gsl_linalg_cholesky_invert(Vinv);
den = ran_wishart_pdf(Xinv, nu, Vinv);
gsl_matrix_free(Xinv);
gsl_matrix_free(Vinv);
return den;
}
double mcmclib_iwishart_lpdf_compute(void* in_p, const gsl_vector* x) {
mcmclib_iwishart_lpdf* p = (mcmclib_iwishart_lpdf*) in_p;
const size_t n = p->Psi->size1;
gsl_matrix_const_view X_v = gsl_matrix_const_view_vector(x, n, n);
const gsl_matrix* X = &(X_v.matrix);
gsl_matrix* X1 = p->X1;
gsl_matrix_memcpy(X1, X);
if(mcmclib_cholesky_decomp(X1) != GSL_SUCCESS)
return log(0.0);
double Xdet2 = 0.0;
for(size_t i=0; i<n; i++)
Xdet2 += log(gsl_matrix_get(X1, i, i));
gsl_linalg_cholesky_invert(X1);
gsl_matrix* PsiX = p->PsiX;
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, p->Psi, X1, 0.0, PsiX);
return p->PsiDet - ((double) p->m + (double) n + 1.0) * Xdet2 -0.5 * trace(PsiX);
}
/* Initialise RMHMC kernel with initial parameters x.
* Arguments:
* kernel: a pointer to the RMHMC kernel structure.
* x: an array of N doubles with initial parameters. N must be
* equal to kernel->N.
* Result:
* returns 0 for success and non-zero for error.
*/
static int rmhmc_kernel_init(mcmc_kernel* kernel, const double* x){
int res,i,n;
n = kernel->N;
rmhmc_params* params = (rmhmc_params*)kernel->kernel_params;
/* copy x to the kernel x state */
for ( i=0; i < n; i++)
kernel->x[i] = x[i];
rmhmc_model* model = kernel->model_function;
/* call user function to update all required quantities */
res = model->PosteriorAll(x, model->m_params, &(params->fx), params->dfx, params->cholMx, params->dMx);
/* TODO: write a proper error handler */
if (res != 0){
fprintf(stderr,"rmhmc_kernel_init: Likelihood function failed\n");
return 1;
}
/* calculate cholesky factor for current metric */
gsl_matrix_view cholMx_v = gsl_matrix_view_array(params->cholMx,n,n);
gsl_error_handler_t* old_handle = gsl_set_error_handler_off();
res = gsl_linalg_cholesky_decomp( &cholMx_v.matrix );
if (res != 0){
fprintf(stderr,"Error: matrix not positive definite in rmhmc_init.\n");
return -1;
}
gsl_set_error_handler(old_handle);
/* calculate inverse for current metric */
gsl_matrix_view invMx_v = gsl_matrix_view_array(params->invMx,n,n);
gsl_matrix_memcpy(&invMx_v.matrix, &cholMx_v.matrix );
gsl_linalg_cholesky_invert(&invMx_v.matrix);
/* calculate trace terms from equation (15) in Girolami and Calderhead (2011) */
calculateTraceTerms(n, params->invMx, params->dMx, params->tr_invM_dM);
return 0;
}
double decomposeMatrix(gsl_matrix *ptSigmaMatrix, int nD)
{
double dDet = 0.0;
int status;
int l = 0;
status = gsl_linalg_cholesky_decomp(ptSigmaMatrix);
if(status == GSL_EDOM){
fprintf(stderr,"Failed Cholesky decomposition in decomposeMatrix\n");
fflush(stderr);
exit(EXIT_FAILURE);
}
else{
for(l = 0; l < nD; l++){
double dT = gsl_matrix_get(ptSigmaMatrix,l,l);
dDet += 2.0*log(dT);
}
gsl_linalg_cholesky_invert(ptSigmaMatrix);
return dDet;
}
}
int NBinGlm::nbinfit(gsl_matrix *Y, gsl_matrix *X, gsl_matrix *O, gsl_matrix *B)
{
gsl_set_error_handler_off();
initialGlm(Y, X, O, B);
gsl_rng *rnd=gsl_rng_alloc(gsl_rng_mt19937);
unsigned int i, j; //, isConv;
double yij, mij, vij, hii, uij, wij, wei;
double th, tol, dev_th_b_old;
int status;
// gsl_vector_view b0j, m0j, e0j, v0j;
gsl_matrix *WX = gsl_matrix_alloc(nRows, nParams);
gsl_matrix *TMP = gsl_matrix_alloc(nRows, nParams);
gsl_matrix *XwX = gsl_matrix_alloc(nParams, nParams);
gsl_vector_view Xwi, Xi, vj, dj, hj;
for (j=0; j<nVars; j++) {
betaEst(j, maxiter, &tol, maxtol); //poisson
// Get initial theta estimates
iterconv[j]=0.0;
if (mmRef->estiMethod==CHI2) {
th = getDisper(j, 1.0);
while ( iterconv[j]<maxiter ) {
//printf("th=%.2f, iterconv[%d]=%d\n", th, j, iterconv[j]);
iterconv[j]++;
dev_th_b_old = dev[j];
betaEst(j, 1.0, &tol, th); // 1-step beta
th = getDisper(j, th)/th;
tol = ABS((dev[j]-dev_th_b_old)/(ABS(dev[j])+0.1));
if (tol<eps) break;
} }
else if (mmRef->estiMethod==NEWTON) {
th = thetaML(0.0, j, maxiter);
while ( iterconv[j]<maxiter ) {
iterconv[j]++;
dev_th_b_old = dev[j];
th = thetaML(th, j, maxiter2);
betaEst(j, maxiter2, &tol, th);
tol=ABS((dev[j]-dev_th_b_old)/(ABS(dev[j])+0.1));
if (tol<eps) break;
} }
else {
th = getfAfAdash(0.0, j, maxiter);
/* lm=0;
for (i=0; i<nRows; i++) {
yij = gsl_matrix_get(Y, i, j);
mij = gsl_matrix_get(Mu, i, j);
lm = lm + llfunc( yij, mij, th);
} */
while ( iterconv[j]<maxiter ) {
iterconv[j]++;
dev_th_b_old = dev[j];
betaEst(j, maxiter2, &tol, th);
th = getfAfAdash(th, j, 1.0);
tol=ABS((dev[j]-dev_th_b_old)/(ABS(dev[j])+0.1));
if (tol<eps) break;
}
}
if ((iterconv[j]==maxiter)&(mmRef->warning==TRUE))
printf("Warning: reached maximum itrations - negative binomial may NOT converge in the %d-th variable (dev=%.4f, err=%.4f, theta=%.4f)!\n", j, dev[j], tol, th);
// other properties based on mu and phi
theta[j] = th;
gsl_matrix_memcpy(WX, Xref);
ll[j]=0;
for (i=0; i<nRows; i++) {
yij = gsl_matrix_get(Y, i, j);
mij = gsl_matrix_get(Mu, i, j);
vij = varfunc( mij, th);
gsl_matrix_set(Var, i, j, vij);
wij = sqrt(weifunc(mij, th));
gsl_matrix_set(wHalf, i, j, wij);
gsl_matrix_set(Res, i, j, (yij-mij)/sqrt(vij));
ll[j] = ll[j] + llfunc( yij, mij, th);
// get PIT residuals for discrete data
wei = gsl_rng_uniform_pos (rnd); // wei ~ U(0, 1)
uij=wei*cdf(yij, mij, th);
if (yij>0) uij=uij+(1-wei)*cdf((yij-1),mij,th);
gsl_matrix_set(PitRes, i, j, uij);
// W^1/2 X
Xwi = gsl_matrix_row (WX, i);
gsl_vector_scale(&Xwi.vector, wij);
}
aic[j]=-ll[j]+2*(nParams+1);
// X^T * W * X
gsl_matrix_set_identity (XwX);
gsl_blas_dsyrk (CblasLower, CblasTrans, 1.0, WX, 0.0, XwX);
status=gsl_linalg_cholesky_decomp (XwX);
if (status==GSL_EDOM) {
if (mmRef->warning==TRUE)
printf("Warning: singular matrix in calculating pit-residuals. An eps*I is added to the singular matrix.\n");
gsl_matrix_set_identity (XwX);
gsl_blas_dsyrk (CblasLower, CblasTrans, 1.0, WX, mintol, XwX);
gsl_linalg_cholesky_decomp (XwX);
}
gsl_linalg_cholesky_invert (XwX); // (X'WX)^-1
// Calc varBeta
vj = gsl_matrix_column (varBeta, j);
dj = gsl_matrix_diagonal (XwX);
gsl_vector_memcpy (&vj.vector, &dj.vector);
// hii is diagonal element of H=X*(X'WX)^-1*X'*W
hj = gsl_matrix_column (sqrt1_Hii, j);
gsl_blas_dsymm(CblasRight,CblasLower,1.0,XwX,Xref,0.0,TMP); // X*(X'WX)^-1
for (i=0; i<nRows; i++) {
Xwi=gsl_matrix_row(TMP, i);
Xi=gsl_matrix_row(Xref, i);
wij=gsl_matrix_get(wHalf, i, j);
gsl_blas_ddot(&Xwi.vector, &Xi.vector, &hii);
gsl_vector_set(&hj.vector, i, MAX(mintol, sqrt(MAX(0, 1-wij*wij*hii))));
//printf("hii=%.4f, wij=%.4f, sqrt(1-wij*wij*hii)=%.4f\n", hii, wij, sqrt(1-wij*wij*hii));
}
} // end nVar for j loop
// gsl_matrix_div_elements (Res, sqrt1_Hii);
// subtractMean(Res);
gsl_matrix_free(XwX);
gsl_matrix_free(WX);
gsl_matrix_free(TMP);
gsl_rng_free(rnd);
return SUCCESS;
}
int PoissonGlm::EstIRLS(gsl_matrix *Y, gsl_matrix *X, gsl_matrix *O, gsl_matrix *B, double *a)
{
initialGlm(Y, X, O, B);
gsl_set_error_handler_off();
gsl_rng *rnd=gsl_rng_alloc(gsl_rng_mt19937);
unsigned int i, j;
int status;
double yij, mij, vij, wij, tol, hii, uij, wei;
gsl_vector_view Xwi, Xi, vj, hj, dj;
gsl_matrix *WX = gsl_matrix_alloc(nRows, nParams);
gsl_matrix *TMP = gsl_matrix_alloc(nRows, nParams);
gsl_matrix *XwX = gsl_matrix_alloc(nParams, nParams);
for (j=0; j<nVars; j++) {
if ( a!=NULL ) theta[j]=a[j];
// estimate mu and beta
iterconv[j] = betaEst(j, maxiter, &tol, theta[j]);
if ((mmRef->warning==TRUE)&(iterconv[j]==maxiter))
printf("Warning: EstIRLS reached max iterations, may not converge in the %d-th variable (dev=%.4f, err=%.4f)!\n", j, dev[j], tol);
gsl_matrix_memcpy (WX, X);
for (i=0; i<nRows; i++) {
mij = gsl_matrix_get(Mu, i, j);
// get variance
vij = varfunc( mij, theta[j] );
gsl_matrix_set(Var, i, j, vij);
// get weight
wij = sqrt(weifunc(mij, theta[j]));
gsl_matrix_set(wHalf, i, j, wij);
// get (Pearson) residuals
yij = gsl_matrix_get(Y, i, j);
gsl_matrix_set(Res, i, j, (yij-mij)/sqrt(vij));
// get PIT residuals for discrete data
wei = gsl_rng_uniform_pos (rnd); // wei ~ U(0, 1)
uij = wei*cdf(yij, mij, theta[j]);
if (yij>0) uij=uij+(1-wei)*cdf((yij-1),mij,theta[j]);
gsl_matrix_set(PitRes, i, j, uij);
// get elementry log-likelihood
ll[j] = ll[j] + llfunc( yij, mij, theta[j]);
// W^1/2 X
Xwi = gsl_matrix_row (WX, i);
gsl_vector_scale(&Xwi.vector, wij);
}
aic[j]=-ll[j]+2*(nParams);
// X^T * W * X
gsl_matrix_set_identity(XwX);
gsl_blas_dsyrk (CblasLower, CblasTrans, 1.0, WX, 0.0, XwX);
status=gsl_linalg_cholesky_decomp (XwX);
if (status==GSL_EDOM) {
if (mmRef->warning==TRUE)
printf("Warning: singular matrix in calculating pit-residuals. An eps*I is added to the singular matrix.\n");
gsl_matrix_set_identity(XwX);
gsl_blas_dsyrk (CblasLower, CblasTrans, 1.0, WX, mintol, XwX);
gsl_linalg_cholesky_decomp (XwX);
}
gsl_linalg_cholesky_invert (XwX);
// Calc varBeta
dj = gsl_matrix_diagonal (XwX);
vj = gsl_matrix_column (varBeta, j);
gsl_vector_memcpy (&vj.vector, &dj.vector);
// hii is diagonal element of H=X*(X'WX)^-1*X'*W
hj = gsl_matrix_column (sqrt1_Hii, j);
gsl_blas_dsymm(CblasRight,CblasLower,1.0,XwX,Xref,0.0,TMP); // X*(X'WX)^-1
for (i=0; i<nRows; i++) {
Xwi=gsl_matrix_row(TMP, i);
Xi=gsl_matrix_row(Xref, i);
wij=gsl_matrix_get(wHalf, i, j);
gsl_blas_ddot(&Xwi.vector, &Xi.vector, &hii);
gsl_vector_set(&hj.vector, i, MAX(mintol, sqrt(MAX(0, 1-wij*wij*hii))));
}
}
// standardize perason residuals by rp/sqrt(1-hii)
// gsl_matrix_div_elements (Res, sqrt1_Hii);
// subtractMean(Res); // have mean subtracted
gsl_matrix_free(XwX);
gsl_matrix_free(WX);
gsl_matrix_free(TMP);
gsl_rng_free(rnd);
return SUCCESS;
}
/**
* C++ version of gsl_linalg_cholesky_invert().
* @param cholesky A Cholesky decomposition matrix
* @return Error code on failure
*/
inline int cholesky_invert( matrix& cholesky ){ return gsl_linalg_cholesky_invert( cholesky.get() ); }
// Wald Test used in both summary and anova (polymophism)
int GlmTest::GeeWald(glm *Alt, gsl_matrix *LL, gsl_vector *teststat)
{
gsl_set_error_handler_off();
unsigned int i, j, l;
double alpha, result, sum=0;
unsigned int nP = Alt->nParams;
unsigned int nDF = LL->size1;
unsigned int nVars=tm->nVars, nRows=tm->nRows;
int status;
gsl_vector *LBeta = gsl_vector_alloc(nVars*nDF);
gsl_vector_set_zero(LBeta);
gsl_matrix *w1jX1=gsl_matrix_alloc(nRows, nP);
gsl_matrix *XwX=gsl_matrix_alloc(nP, nP);
gsl_matrix *Rl2 = gsl_matrix_alloc(nDF, nP);
gsl_matrix *IinvN = gsl_matrix_alloc(nDF, nDF);
gsl_matrix *IinvRl = gsl_matrix_alloc(nVars*nDF, nVars*nDF);
gsl_vector *tmp = gsl_vector_alloc(nVars*nDF);
gsl_vector_view tmp2, wj, LBj, bj; //, dj;
gsl_matrix_view Rl;
gsl_matrix_set_zero(IinvRl);
GrpMat *Z = (GrpMat*)malloc(nVars*sizeof(GrpMat));
for (j=0; j<nVars; j++){
Z[j].matrix = gsl_matrix_alloc(nP, nRows);
// w1jX1 = W^1/2 * X
wj=gsl_matrix_column(Alt->wHalf, j);
for (i=0; i<nP; i++)
gsl_matrix_set_col (w1jX1, i, &wj.vector);
gsl_matrix_mul_elements (w1jX1, Alt->Xref);
// LBeta = L*Beta
LBj=gsl_vector_subvector(LBeta, j*nDF, nDF);
bj=gsl_matrix_column(Alt->Beta, j);
gsl_blas_dgemv(CblasNoTrans,1,LL,&bj.vector,0,&LBj.vector);
// Z = (X^T W X)^-1 * X^T W^1/2.
gsl_matrix_set_identity(XwX);
gsl_blas_dsyrk (CblasLower,CblasTrans,1.0,w1jX1,0.0,XwX);
status=gsl_linalg_cholesky_decomp (XwX);
if (status==GSL_EDOM) {
if (tm->warning==TRUE)
printf("Warning:singular matrix in wald test. An eps*I is added to the singular matrix.\n");
gsl_matrix_set_identity(XwX);
gsl_blas_dsyrk(CblasLower,CblasTrans,1.0,w1jX1,eps,XwX);
gsl_linalg_cholesky_decomp(XwX);
}
gsl_linalg_cholesky_invert(XwX);
gsl_blas_dgemm(CblasNoTrans,CblasTrans,1.0,XwX,w1jX1,0.0, Z[j].matrix);
gsl_matrix_memcpy(Rl2, LL);
gsl_blas_dtrmm (CblasRight,CblasLower,CblasNoTrans,CblasNonUnit,1.0,XwX,Rl2); // L*(X'WX)^-1
gsl_blas_dgemm (CblasNoTrans, CblasTrans, 1.0, Rl2, LL, 0.0, IinvN); // L*(X^T*W*X)^-1*L^T
if ( (tm->punit!=NONE) || (tm->corr==IDENTITY) ) {
status=gsl_linalg_cholesky_decomp (IinvN);
if (status==GSL_EDOM) {
if (tm->warning==TRUE)
printf("Warning:singular IinvN in wald test.\n");
}
tmp2=gsl_vector_subvector(tmp, 0, nDF);
gsl_linalg_cholesky_solve (IinvN, &LBj.vector, &tmp2.vector);
gsl_blas_ddot (&LBj.vector, &tmp2.vector, &result);
gsl_vector_set(teststat, j+1, sqrt(result));
sum = sum + result;
}
if (tm->corr!=IDENTITY) {
// IinvRl=L*vSandRl*L^T
for (l=0; l<=j; l++) {
Rl=gsl_matrix_submatrix(IinvRl,j*nDF,l*nDF,nDF,nDF);
alpha = gsl_matrix_get(Rlambda, j, l);
// borrow XwX space to store vSandRl
gsl_blas_dgemm(CblasNoTrans,CblasTrans,alpha,Z[j].matrix,Z[l].matrix, 0.0, XwX);
// Rl2 = L*vSandRl*L^T
gsl_blas_dgemm(CblasNoTrans,CblasNoTrans,1.0,LL,XwX,0.0,Rl2);
gsl_blas_dgemm(CblasNoTrans,CblasTrans,1.0,Rl2,LL,0.0,&Rl.matrix);
} // end l
} // end if (tm->corr)
} // end for j=1:nVars
if ( tm->corr==IDENTITY )
gsl_vector_set(teststat, 0, sqrt(sum));
else {
status=gsl_linalg_cholesky_decomp (IinvRl);
if (status==GSL_EDOM) {
if (tm->warning==TRUE)
printf("Warning:singular matrix in multivariate wald test.\n");
}
gsl_linalg_cholesky_solve (IinvRl, LBeta, tmp);
gsl_blas_ddot (LBeta, tmp, &result);
gsl_vector_set(teststat, 0, sqrt(result));
}
// free memory
for (j=0; j<nVars; j++)
gsl_matrix_free(Z[j].matrix);
free(Z);
gsl_vector_free(LBeta);
gsl_matrix_free(w1jX1);
gsl_matrix_free(XwX);
gsl_matrix_free(Rl2);
gsl_matrix_free(IinvN);
gsl_matrix_free(IinvRl);
gsl_vector_free(tmp);
return SUCCESS;
}
void fnIMIS(const size_t InitSamples, const size_t StepSamples, const size_t FinalResamples, const size_t MaxIter, const size_t NumParam, unsigned long int rng_seed, const char * runName)
{
// Declare and configure GSL RNG
gsl_rng * rng;
const gsl_rng_type * T;
gsl_rng_env_setup();
T = gsl_rng_default;
rng = gsl_rng_alloc (T);
gsl_rng_set(rng, rng_seed);
char strDiagnosticsFile[strlen(runName) + 15 +1];
char strResampleFile[strlen(runName) + 12 +1];
strcpy(strDiagnosticsFile, runName); strcat(strDiagnosticsFile, "Diagnostics.txt");
strcpy(strResampleFile, runName); strcat(strResampleFile, "Resample.txt");
FILE * diagnostics_file = fopen(strDiagnosticsFile, "w");
fprintf(diagnostics_file, "Seeded RNG: %zu\n", rng_seed);
fprintf(diagnostics_file, "Running IMIS. InitSamples: %zu, StepSamples: %zu, FinalResamples %zu, MaxIter %zu\n", InitSamples, StepSamples, FinalResamples, MaxIter);
// Setup IMIS arrays
gsl_matrix * Xmat = gsl_matrix_alloc(InitSamples + StepSamples*MaxIter, NumParam);
double * prior_all = (double*) malloc(sizeof(double) * (InitSamples + StepSamples*MaxIter));
double * likelihood_all = (double*) malloc(sizeof(double) * (InitSamples + StepSamples*MaxIter));
double * imp_weight_denom = (double*) malloc(sizeof(double) * (InitSamples + StepSamples*MaxIter)); // proportional to q(k) in stage 2c of Raftery & Bao
double * gaussian_sum = (double*) calloc(InitSamples + StepSamples*MaxIter, sizeof(double)); // sum of mixture distribution for mode
struct dst * distance = (struct dst *) malloc(sizeof(struct dst) * (InitSamples + StepSamples*MaxIter)); // Mahalanobis distance to most recent mode
double * imp_weights = (double*) malloc(sizeof(double) * (InitSamples + StepSamples*MaxIter));
double * tmp_MVNpdf = (double*) malloc(sizeof(double) * (InitSamples + StepSamples*MaxIter));
gsl_matrix * nearestX = gsl_matrix_alloc(StepSamples, NumParam);
double center_all[MaxIter][NumParam];
gsl_matrix * sigmaChol_all[MaxIter];
gsl_matrix * sigmaInv_all[MaxIter];
// Initial prior samples
sample_prior(rng, InitSamples, Xmat);
// Calculate prior covariance
double prior_invCov_diag[NumParam];
/*
The paper describing the algorithm uses the full prior covariance matrix.
This follows the code in the IMIS R package and diagonalizes the prior
covariance matrix to ensure invertibility.
*/
for(size_t i = 0; i < NumParam; i++){
gsl_vector_view tmpCol = gsl_matrix_subcolumn(Xmat, i, 0, InitSamples);
prior_invCov_diag[i] = gsl_stats_variance(tmpCol.vector.data, tmpCol.vector.stride, InitSamples);
prior_invCov_diag[i] = 1.0/prior_invCov_diag[i];
}
// IMIS steps
fprintf(diagnostics_file, "Step Var(w_i) MargLik Unique Max(w_i) ESS Time\n");
printf("Step Var(w_i) MargLik Unique Max(w_i) ESS Time\n");
time_t time1, time2;
time(&time1);
size_t imisStep = 0, numImisSamples;
for(imisStep = 0; imisStep < MaxIter; imisStep++){
numImisSamples = (InitSamples + imisStep*StepSamples);
// Evaluate prior and likelihood
if(imisStep == 0){ // initial stage
#pragma omp parallel for
for(size_t i = 0; i < numImisSamples; i++){
gsl_vector_const_view theta = gsl_matrix_const_row(Xmat, i);
prior_all[i] = prior(&theta.vector);
likelihood_all[i] = likelihood(&theta.vector);
}
} else { // imisStep > 0
#pragma omp parallel for
for(size_t i = InitSamples + (imisStep-1)*StepSamples; i < numImisSamples; i++){
gsl_vector_const_view theta = gsl_matrix_const_row(Xmat, i);
prior_all[i] = prior(&theta.vector);
likelihood_all[i] = likelihood(&theta.vector);
}
}
// Determine importance weights, find current maximum, calculate monitoring criteria
#pragma omp parallel for
for(size_t i = 0; i < numImisSamples; i++){
imp_weight_denom[i] = (InitSamples*prior_all[i] + StepSamples*gaussian_sum[i])/(InitSamples + StepSamples * imisStep);
imp_weights[i] = (prior_all[i] > 0)?likelihood_all[i]*prior_all[i]/imp_weight_denom[i]:0;
}
double sumWeights = 0.0;
for(size_t i = 0; i < numImisSamples; i++){
sumWeights += imp_weights[i];
}
double maxWeight = 0.0, varImpW = 0.0, entropy = 0.0, expectedUnique = 0.0, effSampSize = 0.0, margLik;
size_t maxW_idx;
#pragma omp parallel for reduction(+: varImpW, entropy, expectedUnique, effSampSize)
for(size_t i = 0; i < numImisSamples; i++){
imp_weights[i] /= sumWeights;
varImpW += pow(numImisSamples * imp_weights[i] - 1.0, 2.0);
entropy += imp_weights[i] * log(imp_weights[i]);
expectedUnique += (1.0 - pow((1.0 - imp_weights[i]), FinalResamples));
effSampSize += pow(imp_weights[i], 2.0);
}
for(size_t i = 0; i < numImisSamples; i++){
if(imp_weights[i] > maxWeight){
maxW_idx = i;
maxWeight = imp_weights[i];
}
}
for(size_t i = 0; i < NumParam; i++)
center_all[imisStep][i] = gsl_matrix_get(Xmat, maxW_idx, i);
varImpW /= numImisSamples;
entropy = -entropy / log(numImisSamples);
effSampSize = 1.0/effSampSize;
margLik = log(sumWeights/numImisSamples);
fprintf(diagnostics_file, "%4zu %8.2f %8.2f %8.2f %8.2f %8.2f %8.2f\n", imisStep, varImpW, margLik, expectedUnique, maxWeight, effSampSize, difftime(time(&time2), time1));
printf("%4zu %8.2f %8.2f %8.2f %8.2f %8.2f %8.2f\n", imisStep, varImpW, margLik, expectedUnique, maxWeight, effSampSize, difftime(time(&time2), time1));
time1 = time2;
// Check for convergence
if(expectedUnique > FinalResamples*(1.0 - exp(-1.0))){
break;
}
// Calculate Mahalanobis distance to current mode
GetMahalanobis_diag(Xmat, center_all[imisStep], prior_invCov_diag, numImisSamples, NumParam, distance);
// Find StepSamples nearest points
// (Note: this was a major bottleneck when InitSamples and StepResamples are large. qsort substantially outperformed GSL sort options.)
qsort(distance, numImisSamples, sizeof(struct dst), cmp_dst);
#pragma omp parallel for
for(size_t i = 0; i < StepSamples; i++){
gsl_vector_const_view tmpX = gsl_matrix_const_row(Xmat, distance[i].idx);
gsl_matrix_set_row(nearestX, i, &tmpX.vector);
}
// Calculate weighted covariance of nearestX
// (a) Calculate weights for nearest points 1...StepSamples
double weightsCov[StepSamples];
#pragma omp parallel for
for(size_t i = 0; i < StepSamples; i++){
weightsCov[i] = 0.5*(imp_weights[distance[i].idx] + 1.0/numImisSamples); // cov_wt function will normalize the weights
}
// (b) Calculate weighted covariance
sigmaChol_all[imisStep] = gsl_matrix_alloc(NumParam, NumParam);
covariance_weighted(nearestX, weightsCov, StepSamples, center_all[imisStep], NumParam, sigmaChol_all[imisStep]);
// (c) Do Cholesky decomposition and inverse of covariance matrix
gsl_linalg_cholesky_decomp(sigmaChol_all[imisStep]);
for(size_t j = 0; j < NumParam; j++) // Note: GSL outputs a symmetric matrix rather than lower tri, so have to set upper tri to zero
for(size_t k = j+1; k < NumParam; k++)
gsl_matrix_set(sigmaChol_all[imisStep], j, k, 0.0);
sigmaInv_all[imisStep] = gsl_matrix_alloc(NumParam, NumParam);
gsl_matrix_memcpy(sigmaInv_all[imisStep], sigmaChol_all[imisStep]);
gsl_linalg_cholesky_invert(sigmaInv_all[imisStep]);
// Sample new inputs
gsl_matrix_view newSamples = gsl_matrix_submatrix(Xmat, numImisSamples, 0, StepSamples, NumParam);
GenerateRandMVnorm(rng, StepSamples, center_all[imisStep], sigmaChol_all[imisStep], NumParam, &newSamples.matrix);
// Evaluate sampling probability from mixture distribution
// (a) For newly sampled points, sum over all previous centers
for(size_t pastStep = 0; pastStep < imisStep; pastStep++){
GetMVNpdf(&newSamples.matrix, center_all[pastStep], sigmaInv_all[pastStep], sigmaChol_all[pastStep], StepSamples, NumParam, tmp_MVNpdf);
#pragma omp parallel for
for(size_t i = 0; i < StepSamples; i++)
gaussian_sum[numImisSamples + i] += tmp_MVNpdf[i];
}
// (b) For all points, add weight for most recent center
gsl_matrix_const_view Xmat_curr = gsl_matrix_const_submatrix(Xmat, 0, 0, numImisSamples + StepSamples, NumParam);
GetMVNpdf(&Xmat_curr.matrix, center_all[imisStep], sigmaInv_all[imisStep], sigmaChol_all[imisStep], numImisSamples + StepSamples, NumParam, tmp_MVNpdf);
#pragma omp parallel for
for(size_t i = 0; i < numImisSamples + StepSamples; i++)
gaussian_sum[i] += tmp_MVNpdf[i];
} // loop over imisStep
//// FINISHED IMIS ROUTINE
fclose(diagnostics_file);
// Resample posterior outputs
int resampleIdx[FinalResamples];
walker_ProbSampleReplace(rng, numImisSamples, imp_weights, FinalResamples, resampleIdx); // Note: Random sampling routine used in R sample() function.
// Print results
FILE * resample_file = fopen(strResampleFile, "w");
for(size_t i = 0; i < FinalResamples; i++){
for(size_t j = 0; j < NumParam; j++)
fprintf(resample_file, "%.15e\t", gsl_matrix_get(Xmat, resampleIdx[i], j));
gsl_vector_const_view theta = gsl_matrix_const_row(Xmat, resampleIdx[i]);
fprintf(resample_file, "\n");
}
fclose(resample_file);
/*
// This outputs Xmat (parameter matrix), centers, and covariance matrices to files for debugging
FILE * Xmat_file = fopen("Xmat.txt", "w");
for(size_t i = 0; i < numImisSamples; i++){
for(size_t j = 0; j < NumParam; j++)
fprintf(Xmat_file, "%.15e\t", gsl_matrix_get(Xmat, i, j));
fprintf(Xmat_file, "%e\t%e\t%e\t%e\t%e\t\n", prior_all[i], likelihood_all[i], imp_weights[i], gaussian_sum[i], distance[i]);
}
fclose(Xmat_file);
FILE * centers_file = fopen("centers.txt", "w");
for(size_t i = 0; i < imisStep; i++){
for(size_t j = 0; j < NumParam; j++)
fprintf(centers_file, "%f\t", center_all[i][j]);
fprintf(centers_file, "\n");
}
fclose(centers_file);
FILE * sigmaInv_file = fopen("sigmaInv.txt", "w");
for(size_t i = 0; i < imisStep; i++){
for(size_t j = 0; j < NumParam; j++)
for(size_t k = 0; k < NumParam; k++)
fprintf(sigmaInv_file, "%f\t", gsl_matrix_get(sigmaInv_all[i], j, k));
fprintf(sigmaInv_file, "\n");
}
fclose(sigmaInv_file);
*/
// free memory allocated by IMIS
for(size_t i = 0; i < imisStep; i++){
gsl_matrix_free(sigmaChol_all[i]);
gsl_matrix_free(sigmaInv_all[i]);
}
// release RNG
gsl_rng_free(rng);
gsl_matrix_free(Xmat);
gsl_matrix_free(nearestX);
free(prior_all);
free(likelihood_all);
free(imp_weight_denom);
free(gaussian_sum);
free(distance);
free(imp_weights);
free(tmp_MVNpdf);
return;
}
