static void weightDenseComponents(SEXP regression, MERCache* cache)
{
const int* dims = DIMS_SLOT(regression);
int numObservations = dims[n_POS];
int numUnmodeledCoefs = dims[p_POS];
double* sqrtObservationWeight = SXWT_SLOT(regression);
double* offsets = OFFSET_SLOT(regression);
const double* denseDesignMatrix = X_SLOT(regression);
double* weightedDenseDesignMatrix = cache->weightedDenseDesignMatrix;
const double* response = Y_SLOT(regression);
double* weightedResponse = cache->weightedResponse;
cache->responseSumOfSquares = 0.0;
for (int row = 0; row < numObservations; ++row) {
double rowWeight = (sqrtObservationWeight ? sqrtObservationWeight[row] : 1.0);
for (int col = 0; col < numUnmodeledCoefs; ++col) {
int matrixIndex = row + col * numObservations;
weightedDenseDesignMatrix[matrixIndex] = denseDesignMatrix[matrixIndex] * rowWeight;
}
weightedResponse[row] = (response[row] - (offsets ? offsets[row] : 0.0)) * rowWeight;
cache->responseSumOfSquares += weightedResponse[row] * weightedResponse[row];
}
}
static double llik_mu(SEXP da){
int *dm = DIMS_SLOT(da), *ygt0 = YPO_SLOT(da), k = 0;
double *Y = Y_SLOT(da), *mu = MU_SLOT(da), *pwt = PWT_SLOT(da),
p = P_SLOT(da)[0], phi = PHI_SLOT(da)[0] ;
double ld = 0.0, p2 = 2.0 - p, p1 = p - 1.0 ;
for (int i = 0; i < dm[nO_POS]; i++)
ld += pow(mu[i], p2) * pwt[i];
ld /= - phi * p2 ;
for (int i = 0; i < dm[nP_POS]; i++){
k = ygt0[i] ;
ld += - Y[k] * pow(mu[k], -p1) * pwt[k] / (phi * p1);
}
return ld ;
}
/**
* the log posterior density of the dispersion parameter phi
* (this is the same in both bcpglm and bcpglmm)
*
* @param x the value of phi at which the log density is to be calculated
* @param data a void struct, cocerced to SEXP internally
*
* @return log posterior density for phi
*/
static double post_phi(double x, void *data){
SEXP da = data ;
double *Y = Y_SLOT(da), *mu = MU_SLOT(da), p = P_SLOT(da)[0],
*pwt = PWT_SLOT(da) ;
return -0.5 * dl2tweedie(DIMS_SLOT(da)[nO_POS], Y, mu, x, p, pwt) ;
}
/**
* 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);
}
