SEXP bcplm_mcmc (SEXP da){
/* get dimensions */
int *dm = DIMS_SLOT(da) ;
int nR = dm[rpt_POS];
SEXP ans, ans_tmp;
/* tune the scale parameter for M-H update */
if (dm[tnit_POS]) {
update_mu(da); /* update eta mu*/
tune_mcmc(da);
}
/* run Markov chains */
PROTECT(ans = allocVector(VECSXP, dm[chn_POS])) ;
for (int k = 0; k < dm[chn_POS]; k++){
if (nR) Rprintf(_("Start Markov chain %d\n"), k + 1);
get_init(da, k) ; /* initialize the chain */
update_mu(da) ; /* update eta and mu */
/* run MCMC and store result */
PROTECT(ans_tmp = allocMatrix(REALSXP, dm[kp_POS], dm[nA_POS]));
do_mcmc(da, dm[itr_POS], dm[bun_POS], dm[thn_POS],
dm[kp_POS], nR, REAL(ans_tmp));
SET_VECTOR_ELT(ans, k, ans_tmp);
UNPROTECT(1) ;
if (nR) print_line();
}
UNPROTECT(1) ;
if (nR) Rprintf(_("Markov Chain Monte Carlo ends!\n"));
return ans ;
}
/**
* Update the fixed effects and the orthogonal random effects in an MCMC sample
* from an mer object.
*
* @param x an mer object
* @param sigma current standard deviation of the per-observation
* noise terms.
* @param fvals pointer to memory in which to store the updated beta
* @param rvals pointer to memory in which to store the updated b (may
* be (double*)NULL)
*/
static void MCMC_beta_u(SEXP x, double sigma, double *fvals, double *rvals)
{
int *dims = DIMS_SLOT(x);
int i1 = 1, p = dims[p_POS], q = dims[q_POS];
double *V = V_SLOT(x), *fixef = FIXEF_SLOT(x), *muEta = MUETA_SLOT(x),
*u = U_SLOT(x), mone[] = {-1,0}, one[] = {1,0};
CHM_FR L = L_SLOT(x);
double *del1 = Calloc(q, double), *del2 = Alloca(p, double);
CHM_DN sol, rhs = N_AS_CHM_DN(del1, q, 1);
R_CheckStack();
if (V || muEta) {
error(_("Update not yet written"));
} else { /* Linear mixed model */
update_L(x);
update_RX(x);
lmm_update_fixef_u(x);
/* Update beta */
for (int j = 0; j < p; j++) del2[j] = sigma * norm_rand();
F77_CALL(dtrsv)("U", "N", "N", &p, RX_SLOT(x), &p, del2, &i1);
for (int j = 0; j < p; j++) fixef[j] += del2[j];
/* Update u */
for (int j = 0; j < q; j++) del1[j] = sigma * norm_rand();
F77_CALL(dgemv)("N", &q, &p, mone, RZX_SLOT(x), &q,
del2, &i1, one, del1, &i1);
sol = M_cholmod_solve(CHOLMOD_Lt, L, rhs, &c);
for (int j = 0; j < q; j++) u[j] += ((double*)(sol->x))[j];
M_cholmod_free_dense(&sol, &c);
update_mu(x); /* and parts of the deviance slot */
}
Memcpy(fvals, fixef, p);
if (rvals) {
update_ranef(x);
Memcpy(rvals, RANEF_SLOT(x), q);
}
Free(del1);
}
/**
* R callable function to update the mean in a bcplm object
*
* @param da an bcplm_input object
*
*/
SEXP bcplm_update_mu(SEXP da){
update_mu(da);
return R_NilValue;
}
