/**
* Save parameters to the ns_th row of the simulation results
*
* @param da a bcplm_input object
* @param ns indicates the ns_th row
* @param nS number of rows in sims
* @param sims a long vector to store simulations results
*
*/
static void set_sims(SEXP da, int ns, int nS, double *sims){
int *dm = DIMS_SLOT(da) ;
int pos = 0, nB = dm[nB_POS], nU = dm[nU_POS],
nT = dm[nT_POS];
double *beta = FIXEF_SLOT(da), *u = U_SLOT(da);
for (int j = 0; j < nB; j++)
sims[j * nS + ns] = beta[j] ;
sims[nB * nS + ns] = *PHI_SLOT(da) ;
sims[(nB + 1) * nS + ns] = *P_SLOT(da) ;
/* set U and Sigma */
if (nU) {
SEXP V = GET_SLOT(da, install("Sigma"));
int *nc = NCOL_SLOT(da), st = nB + 2;
double *v;
for (int j = 0; j < nU; j++)
sims[(j + st) * nS + ns] = u[j] ;
for (int i = 0; i < nT; i++){
v = REAL(VECTOR_ELT(V, i));
for (int j = 0; j < nc[i] * nc[i]; j++)
sims[(st + nU + pos + j) * nS + ns] = v[j] ;
pos += nc[i] * nc[i] ;
}
}
}
/**
* Simulate beta using the naive Gibbs update
*
* @param da an SEXP struct
*
*/
static void sim_beta(SEXP da){
int *dm = DIMS_SLOT(da), *k = K_SLOT(da);
int nB = dm[nB_POS];
double *beta = FIXEF_SLOT(da), *mh_sd = MHSD_SLOT(da), *l = CLLIK_SLOT(da),
*pm = PBM_SLOT(da), *pv = PBV_SLOT(da), *acc = ACC_SLOT(da);
double xo, xn, l1, l2, A;
/* initialize llik_mu*/
*l = llik_mu(da);
for (int j = 0; j < nB; j++){
*k = j;
xo = beta[j];
xn = rnorm(xo, mh_sd[j]);
l1 = *l;
l2 = post_betak(xn, da);
A = exp(l2 - l1 + 0.5 * (xo - pm[j]) * (xo - pm[j]) / pv[j]);
/* determine whether to accept the sample */
if (A < 1 && runif(0, 1) >= A){ /* not accepted */
*l = l1; /* revert the likelihood (this is updated in post_betak) */
}
else {
beta[j] = xn;
acc[j]++;
}
} /* update the mean using the new beta */
if (dm[nU_POS]) cpglmm_fitted(beta, 1, da);
else cpglm_fitted(beta, da);
}
static void get_init(SEXP da, int k){
SEXP inits = GET_SLOT(da, install("inits")); /* inits is a list */
int *dm = DIMS_SLOT(da);
int nB = dm[nB_POS], nU = dm[nU_POS], nT = dm[nT_POS];
double *init = REAL(VECTOR_ELT(inits, k));
/* set beta, phi, p*/
Memcpy(FIXEF_SLOT(da), init, nB) ;
*PHI_SLOT(da) = init[nB] ;
*P_SLOT(da) = init[nB + 1] ;
/* set U and Sigma */
if (nU) {
SEXP V = GET_SLOT(da, install("Sigma"));
int pos = 0, st = nB + 2, *nc = NCOL_SLOT(da) ;
double *v ;
Memcpy(U_SLOT(da), init + st, nU);
/* set Sigma */
for (int i = 0; i < nT; i++){
v = REAL(VECTOR_ELT(V, i)) ;
Memcpy(v, init + st + nU + pos, nc[i] * nc[i]) ;
pos += nc[i] * nc[i] ;
}
}
}
/**
* the log posterior density of beta_k, assuming Zu has been updated in cpglmm
*
* @param x the value of beta_k
* @param data a void struct that is coerced to SEXP
*
* @return log posterior density for beta_k
*
*/
static double post_betak(double x, void *data){
SEXP da = data ;
int k = K_SLOT(da)[0], nU = DIMS_SLOT(da)[nU_POS];
double pm = PBM_SLOT(da)[k], pv = PBV_SLOT(da)[k],
*l = CLLIK_SLOT(da), *beta = FIXEF_SLOT(da);
double tmp = beta[k];
beta[k] = x ; /* update beta to compute mu */
if (nU) cpglmm_fitted(beta, 1, da);
else cpglm_fitted(beta, da) ;
beta[k] = tmp ; /* restore old beta values */
*l = llik_mu(da) ; /* this is stored and reused to speed up the simulation */
return *l - 0.5 * (x - pm) * (x - pm) / pv ;
}
static void cpglm_fitted(double *x, SEXP da){
int *dm = DIMS_SLOT(da) ;
int nO = dm[nO_POS], nB = dm[nB_POS];
double *X = X_SLOT(da),
*beta = FIXEF_SLOT(da), *eta = ETA_SLOT(da),
*mu = MU_SLOT(da), *offset = OFFSET_SLOT(da),
lp = LKP_SLOT(da)[0] ;
if (x) beta = x ; /* point beta to x if x is not NULL */
/* eta = X %*% beta */
mult_mv("N", nO, nB, X, beta, eta) ;
for (int i = 0; i < nO; i++){
eta[i] += offset[i] ;
mu[i] = link_inv(eta[i], lp);
}
}
/**
* 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);
}
/**
* Update the Xb, Zu, eta and mu slots in cpglmm according to x
*
* @param x pointer to the vector of values for beta or u
* @param is_beta indicates whether x contains the values for beta or u.
* 1: x contains values of beta, and Zu is not updated. If x is null, the fixef slot is used;
* 0: x contains values of u, and Xb is not updated. If x is null, the u slot is used;
* -1: x is ignored, and the fixef and u slots are used.
* @param da an SEXP object
*
*/
static void cpglmm_fitted(double *x, int is_beta, SEXP da){
int *dm = DIMS_SLOT(da) ;
int nO = dm[nO_POS], nB = dm[nB_POS], nU = dm[nU_POS];
double *X = X_SLOT(da), *eta = ETA_SLOT(da),
*mu = MU_SLOT(da), *beta = FIXEF_SLOT(da),
*u = U_SLOT(da), *offset= OFFSET_SLOT(da),
*Xb = XB_SLOT(da), *Zu = ZU_SLOT(da),
lp = LKP_SLOT(da)[0], one[] = {1, 0}, zero[] = {0, 0};
if (is_beta == -1) x = NULL ; /* update from the fixef and u slots */
/* update Xb */
if (is_beta == 1 || is_beta == -1){ /* beta is updated */
if (x) beta = x ; /* point beta to x if x is not NULL */
mult_mv("N", nO, nB, X, beta, Xb) ; /* Xb = x * beta */
}
/* update Zu */
if (is_beta == 0 || is_beta == -1){ /* u is updated */
SEXP tmp; /* create an SEXP object to be coerced to CHM_DN */
PROTECT(tmp = allocVector(REALSXP, nU));
if (x) Memcpy(REAL(tmp), x, nU);
else Memcpy(REAL(tmp), u, nU);
CHM_DN ceta, us = AS_CHM_DN(tmp);
CHM_SP Zt = Zt_SLOT(da);
R_CheckStack();
ceta = N_AS_CHM_DN(Zu, nO, 1); /* update Zu */
R_CheckStack(); /* Y = alpha * A * X + beta * Y */
if (!M_cholmod_sdmult(Zt, 1 , one, zero, us, ceta, &c))
error(_("cholmod_sdmult error returned"));
UNPROTECT(1) ;
}
for (int i = 0; i < nO; i++){ /* update mu */
eta[i] = Xb[i] + Zu[i] + offset[i]; /* eta = Xb + Z * u + offset*/
mu[i] = link_inv(eta[i], lp);
}
}
/**
* Update the theta_S parameters from the ST arrays in place.
*
* @param x an mer object
* @param sigma current standard deviation of the per-observation
* noise terms.
*/
static void MCMC_S(SEXP x, double sigma)
{
CHM_SP A = A_SLOT(x), Zt = Zt_SLOT(x);
int *Gp = Gp_SLOT(x), *ai = (int*)(A->i),
*ap = (int*)(A->p), *dims = DIMS_SLOT(x), *perm = PERM_VEC(x);
int annz = ap[A->ncol], info, i1 = 1, n = dims[n_POS],
nt = dims[nt_POS], ns, p = dims[p_POS], pos,
q = dims[q_POS], znnz = ((int*)(Zt->p))[Zt->ncol];
double *R, *ax = (double*)(A->x), *b = RANEF_SLOT(x),
*eta = ETA_SLOT(x), *offset = OFFSET_SLOT(x),
*rr, *ss, one = 1, *u = U_SLOT(x), *y = Y_SLOT(x);
int *nc = Alloca(nt, int), *nlev = Alloca(nt, int),
*spt = Alloca(nt + 1, int);
double **st = Alloca(nt, double*);
R_CheckStack();
ST_nc_nlev(GET_SLOT(x, lme4_STSym), Gp, st, nc, nlev);
ns = 0; /* ns is length(theta_S) */
spt[0] = 0; /* pointers into ss for terms */
for (int i = 0; i < nt; i++) {
ns += nc[i];
spt[i + 1] = spt[i] + nc[i];
}
if (annz == znnz) { /* Copy Z' to A unless A has new nonzeros */
Memcpy(ax, (double*)(Zt->x), znnz);
} else error("Code not yet written for MCMC_S with NLMMs");
/* Create T'Zt in A */
Tt_Zt(A, Gp, nc, nlev, st, nt);
/* Create P'u in ranef slot */
for (int i = 0; i < q; i++) b[perm[i]] = u[i];
/* Create X\beta + offset in eta slot */
for (int i = 0; i < n; i++) eta[i] = offset ? offset[i] : 0;
F77_CALL(dgemv)("N", &n, &p, &one, X_SLOT(x), &n,
FIXEF_SLOT(x), &i1, &one, eta, &i1);
/* Allocate R, rr and ss */
R = Alloca(ns * ns, double); /* crossproduct matrix then factor */
rr = Alloca(ns, double); /* row of model matrix for theta_S */
ss = Alloca(ns, double); /* right hand side, then theta_S */
R_CheckStack();
AZERO(R, ns * ns);
AZERO(ss, ns);
/* Accumulate crossproduct from pseudo-data part of model matrix */
for (int i = 0; i < q; i++) {
int sj = theta_S_ind(i, nt, Gp, nlev, spt);
AZERO(rr, ns);
rr[sj] = b[i];
F77_CALL(dsyr)("U", &ns, &one, rr, &i1, R, &ns);
}
/* Accumulate crossproduct and residual product of the model matrix. */
/* This is done one row at a time. Rows of the model matrix
* correspond to columns of T'Zt */
for (int j = 0; j < n; j++) { /* jth column of T'Zt */
AZERO(rr, ns);
for (int p = ap[j]; p < ap[j + 1]; p++) {
int i = ai[p]; /* row in T'Zt */
int sj = theta_S_ind(i, nt, Gp, nlev, spt);
rr[sj] += ax[p] * b[i];
ss[sj] += rr[sj] * (y[j] - eta[j]);
}
F77_CALL(dsyr)("U", &ns, &one, rr, &i1, R, &ns);
}
F77_CALL(dposv)("U", &ns, &i1, R, &ns, ss, &ns, &info);
if (info)
error(_("Model matrix for theta_S is not positive definite, %d."), info);
for (int j = 0; j < ns; j++) rr[j] = sigma * norm_rand();
/* Sample from the conditional Gaussian distribution */
F77_CALL(dtrsv)("U", "N", "N", &ns, R, &ns, rr, &i1);
for (int j = 0; j < ns; j++) ss[j] += rr[j];
/* Copy positive part of solution onto diagonals of ST */
pos = 0;
for (int i = 0; i < nt; i++) {
for (int j = 0; j < nc[i]; j++) {
st[i][j * (nc[i] + 1)] = (ss[pos] > 0) ? ss[pos] : 0;
pos++;
}
}
update_A(x);
}
