/**
* tune the proposal variances
*
* @param da an input list object
*
*/
static void tune_mcmc(SEXP da){
int *dm = DIMS_SLOT(da);
int nmh = dm[nmh_POS],
etn = ceil(dm[tnit_POS] * 1.0 / dm[ntn_POS]) ; // # iters per tuning loop;
double *mh_sd = MHSD_SLOT(da), *acc = ACC_SLOT(da),
*sims = Calloc(etn * dm[nA_POS], double);
int nmark = 0, *mark = Calloc(nmh, int);
AZERO(mark, nmh);
/* run MCMC and tune parameters */
if (dm[rpt_POS]) Rprintf(_("Tuning phase...\n"));
for (int i = 0; i < dm[ntn_POS]; i++) {
do_mcmc(da, etn, 0, 1, etn, 0, sims); /* run mcmc */
tune_var(nmh, acc, mh_sd, mark); /* adjust proposal sd's */
/* determine whether the parameters are fully tuned */
nmark = 0;
for (int j = 0; j < nmh; j++)
if (mark[j] >= 3) nmark++;
if (nmark == nmh) break;
}
if (dm[rpt_POS]){
print_acc(1, nmh, acc, 1);
print_line();
}
Free(sims);
Free(mark);
}
/**
* 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] ;
}
}
}
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 ;
}
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] ;
}
}
}
double getCovarianceDevianceConstantPart(SEXP regression)
{
double result = 0.0;
int numFactors = DIMS_SLOT(regression)[nt_POS];
SEXP stList = GET_SLOT(regression, lme4_STSym);
SEXP priorList = GET_SLOT(regression, blme_covariancePriorSym);
for (int i = 0; i < numFactors; ++i) {
SEXP st = VECTOR_ELT(stList, i);
SEXP prior = VECTOR_ELT(priorList, i);
priorType_t priorType = PRIOR_TYPE_SLOT(prior);
int factorDimension = INTEGER(getAttrib(st, R_DimSymbol))[0];
switch (priorType) {
case PRIOR_TYPE_CORRELATION:
result += getCorrelationDevianceConstantPart(prior, factorDimension);
break;
case PRIOR_TYPE_SPECTRAL:
result += getSpectralDevianceConstantPart(prior, factorDimension);
break;
case PRIOR_TYPE_DIRECT:
result += getDirectDevianceConstantPart(prior, factorDimension);
break;
default:
break;
}
}
return(result);
}
void setCovariancePriorCommonScaleExponentialVaryingParts(SEXP regression, MERCache* cache, const double* parameters)
{
int numFactors = DIMS_SLOT(regression)[nt_POS];
SEXP stList = GET_SLOT(regression, lme4_STSym);
SEXP priorList = GET_SLOT(regression, blme_covariancePriorSym);
for (int i = 0; i < numFactors; ++i) {
SEXP st = VECTOR_ELT(stList, i);
SEXP prior = VECTOR_ELT(priorList, i);
priorType_t priorType = PRIOR_TYPE_SLOT(prior);
int factorDimension = INTEGER(getAttrib(st, R_DimSymbol))[0];
switch (priorType) {
case PRIOR_TYPE_CORRELATION:
setCorrelationExponentialVaryingParts(prior, cache, parameters, factorDimension);
break;
case PRIOR_TYPE_SPECTRAL:
setSpectralExponentialVaryingParts(prior, cache, parameters, factorDimension);
break;
case PRIOR_TYPE_DIRECT:
setDirectExponentialVaryingParts(prior, cache, parameters, factorDimension);
break;
default: break;
}
parameters += getNumCovarianceParametersForPrior(priorType, factorDimension);
}
}
void optimizeCommonScale(SEXP regression, MERCache* cache)
{
const double* deviances = DEV_SLOT(regression);
const int* dims = DIMS_SLOT(regression);
int commonScaleRequiresBruteForce = cache->commonScaleOptimization == CSOT_BRUTE_FORCE;
int commonScaleCanBeProfiled = cache->commonScaleOptimization != CSOT_BRUTE_FORCE &&
cache->commonScaleOptimization != CSOT_NA;
// Rprintf("csot: %d, brute: %d, prof: %d\n", cache->commonScaleOptimization, commonScaleRequiresBruteForce, commonScaleCanBeProfiled);
if (commonScaleRequiresBruteForce) {
double currCommonScale = deviances[dims[isREML_POS] ? sigmaREML_POS : sigmaML_POS];
double prevCommonScale;
do {
prevCommonScale = currCommonScale;
// implictly updates the dense factorization and the half-projection that depends on it
// also updates the deviances array
currCommonScale = performOneStepOfNewtonsMethodForCommonScale(regression, cache);
} while (fabs(currCommonScale - prevCommonScale) >= COMMON_SCALE_OPTIMIZATION_TOLERANCE);
} else if (commonScaleCanBeProfiled) {
profileCommonScale(regression, cache);
}
}
/**
* 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 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 void sim_u(SEXP da){
int *dm = DIMS_SLOT(da), *k = K_SLOT(da);
int nB = dm[nB_POS], nU = dm[nU_POS];
double *u = U_SLOT(da), *l = CLLIK_SLOT(da),
*mh_sd = MHSD_SLOT(da) + nB + 2, /* shift the proposal variance pointer */
*acc = ACC_SLOT(da) + nB + 2; /* shift the acc pointer */
double xo, xn, l1, l2, A;
/* initialize llik_mu*/
*l = llik_mu(da);
for (int j = 0; j < nU; j++){
*k = j ;
xo = u[j];
xn = rnorm(xo, mh_sd[j]);
l1 = *l;
l2 = post_uk(xn, da);
A = exp(l2 - (l1 + prior_uk(xo, da)));
/* determine whether to accept the sample */
if (A < 1 && runif(0, 1) >= A){
*l = l1; /* revert llik_mu (this is updated in post_uk) */
}
else{
u[j] = xn;
acc[j]++;
}
}
cpglmm_fitted(u, 0, da) ; /* update the mean using the new u */
}
static void updateRegressionForNewCommonScale(SEXP regression, MERCache* cache)
{
// the update is only required if the total sum of squares term depends on the common scale,
// itself being a question of whether or not the unmodeled coefficient prior is
SEXP unmodeledCoefPrior = GET_SLOT(regression, blme_unmodeledCoefficientPriorSym);
if (PRIOR_TYPE_SLOT(unmodeledCoefPrior) != PRIOR_TYPE_DIRECT ||
PRIOR_FAMILIES_SLOT(unmodeledCoefPrior)[0] != PRIOR_FAMILY_GAUSSIAN ||
getCommonScaleBit(PRIOR_SCALES_SLOT(unmodeledCoefPrior)[0]) != PRIOR_COMMON_SCALE_FALSE)
return;
const int* dims = DIMS_SLOT(regression);
double* deviances = DEV_SLOT(regression);
int numUnmodeledCoefs = dims[p_POS];
// we need to refactor (X'X - Rzx'Rzx + sigma^2 / sigma_beta^2 * I)
double* lowerRightBlockRightFactorization = RX_SLOT(regression);
// recover the cached version of X'X - Rzx'Rzx
Memcpy(lowerRightBlockRightFactorization, (const double*) cache->downdatedDenseCrossproduct,
numUnmodeledCoefs * numUnmodeledCoefs);
addGaussianContributionToDenseBlock(regression, lowerRightBlockRightFactorization,
deviances[dims[isREML_POS] ? sigmaREML_POS : sigmaML_POS]);
int choleskyResult = getDenseCholeskyDecomposition(lowerRightBlockRightFactorization, numUnmodeledCoefs, TRIANGLE_TYPE_UPPER);
if (choleskyResult > 0) error("Leading minor %d of downdated X'X is not positive definite.", choleskyResult);
if (choleskyResult < 0) error("Illegal argument %d to cholesky decomposition (dpotrf).", -choleskyResult);
deviances[ldRX2_POS] = 0.0;
for (int j = 0; j < numUnmodeledCoefs; ++j) {
deviances[ldRX2_POS] += 2.0 * log(lowerRightBlockRightFactorization[j * (numUnmodeledCoefs + 1)]);
}
// at this point, we have the correct Rx stored. now we need to
// compute the new half projection and the new sum of squares
double* unmodeledCoefProjection = cache->unmodeledCoefProjection;
// copy in (X'Y - Rzx' theta half projection); beta half projection is Rx^-1 times that
Memcpy(unmodeledCoefProjection, (const double*) cache->downdatedDenseResponseRotation,
numUnmodeledCoefs);
int i_one = 1;
// solve A'x = b for A an Upper triangular, Tranposed, Non-unit matrix
F77_CALL(dtrsv)("U", "T", "N",
&numUnmodeledCoefs,
lowerRightBlockRightFactorization,
&numUnmodeledCoefs,
unmodeledCoefProjection,
&i_one);
// now update the sums of squares
double newSumOfSquares = getSumOfSquares(unmodeledCoefProjection, numUnmodeledCoefs);
cache->totalSumOfSquares -= newSumOfSquares - cache->unmodeledCoefProjectionSumOfSquares;
cache->unmodeledCoefProjectionSumOfSquares = newSumOfSquares;
}
static double prior_uk(double x, SEXP da){
int *dm = DIMS_SLOT(da), *Gp = Gp_SLOT(da), k = K_SLOT(da)[0];
int gn = Gp_grp(k, dm[nT_POS], Gp); /* group number of u_k */
double *u = U_SLOT(da), tmp = U_SLOT(da)[k], ans;
u[k] = x ;
ans = prior_u_Gp(gn, da); /* compute log prior for group gn */
u[k] = tmp ;
return ans;
}
/* FIXME: Probably should fold this function into MCMC_S */
static void MCMC_T(SEXP x, double sigma)
{
int *Gp = Gp_SLOT(x), nt = (DIMS_SLOT(x))[nt_POS];
double **st = Alloca(nt, double*);
int *nc = Alloca(nt, int), *nlev = Alloca(nt, int);
R_CheckStack();
if (ST_nc_nlev(GET_SLOT(x, lme4_STSym), Gp, st, nc, nlev) < 2) return;
error("Code for non-trivial theta_T not yet written");
}
/**
* 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 ;
}
// As Newton's method is x_n+1 = x_n - f'(x) / f"(x), this function
// computes f'(x) and f"(x) as a function of the common scale
//
// the calculations it uses are in the accompanying pdf, but briefly
// the first derivative is related to the sample size, the residual sum of
// squares, and a new term which involves rotating the projection
// of the unmodeled coefficients
//
// the second derivative involves all of the above, plus the projection
// of the unmodeled coefficients rotated twice
//
// that is
// f'(x) = a * N + b * SS + c * || Rx^-1 beta.tilde ||^2
// f"(x) = d * N + e * SS + f * || Rx^-1 beta.tilde ||^2 + g * || Rx^-T Rx^-1 beta.tilde ||^2
//
// other terms relating to the other priors might also exist, but are thankfully
// polynomial in the common scale
void getCommonScaleDerivatives(SEXP regression, MERCache* cache, double* firstDerivative, double* secondDerivative)
{
const int* dims = DIMS_SLOT(regression);
const double* deviances = DEV_SLOT(regression);
double sigma = deviances[dims[isREML_POS] ? sigmaREML_POS : sigmaML_POS];
double sigma_sq = sigma * sigma;
double sigma_cu = sigma * sigma_sq;
double sigma_fo = sigma_sq * sigma_sq;
// handle the polynomial term first
double degreesOfFreedom = cache->priorCommonScaleDegreesOfFreedom;
degreesOfFreedom += (double) (dims[n_POS] - (dims[isREML_POS] ? dims[p_POS] : 0));
*firstDerivative = -degreesOfFreedom / sigma;
*secondDerivative = degreesOfFreedom / sigma_sq;
// handle the sum of squares and likelihood part directly
*firstDerivative += cache->totalSumOfSquares / sigma_cu;
*secondDerivative -= 3.0 * cache->totalSumOfSquares / sigma_fo;
// if the unmodeled coef prior is not on the common scale, further derivatives are required
SEXP unmodeledCoefPrior = GET_SLOT(regression, blme_unmodeledCoefficientPriorSym);
if (PRIOR_TYPE_SLOT(unmodeledCoefPrior) == PRIOR_TYPE_DIRECT &&
PRIOR_FAMILIES_SLOT(unmodeledCoefPrior)[0] == PRIOR_FAMILY_GAUSSIAN &&
getCommonScaleBit(PRIOR_SCALES_SLOT(unmodeledCoefPrior)[0]) == PRIOR_COMMON_SCALE_FALSE)
{
getDerivativesOfSumOfSquares(regression, cache, firstDerivative, secondDerivative);
}
// now for prior parts
// exp(-a / sigma^2) => 2a * / sigma^3, -6a / sigma^4
double a = cache->mTwoExponentialTermConstantPart + cache->mTwoExponentialTermVaryingPart;
*firstDerivative += 2.0 * a / sigma_cu;
*secondDerivative -= 6.0 * a / sigma_fo;
// exp(-a / sigma) => a / sigma^2, -2a / sigma^3
a = cache->mOneExponentialTermConstantPart + cache->mOneExponentialTermVaryingPart;
*firstDerivative += a / sigma_sq;
*secondDerivative -= 2.0 * a / sigma_cu;
// exp(-a * sigma^2) => -2a * sigma, -2a
a = cache->twoExponentialTermConstantPart + cache->twoExponentialTermVaryingPart;
*firstDerivative -= 2.0 * a * sigma;
*secondDerivative -= 2.0 * a;
// exp(-a * sigma) => -a, 0
*firstDerivative -= cache->oneExponentialTermConstantPart + cache->oneExponentialTermVaryingPart;
}
MERCache *createGLMMCache(SEXP regression)
{
MERCache* result = (MERCache *) malloc(sizeof(MERCache));
const int* dims = DIMS_SLOT(regression);
SEXP unmodeledCoefPrior = GET_SLOT(regression, blme_unmodeledCoefficientPriorSym);
result->priorDevianceConstantPart =
getUnmodeledCoefficientDevianceConstantPart(unmodeledCoefPrior, dims[p_POS]) +
getCovarianceDevianceConstantPart(regression);
return(result);
}
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);
}
}
static void sim_phi_p(SEXP da){
int *dm = DIMS_SLOT(da);
int nB = dm[nB_POS];
double *p = P_SLOT(da), *phi = PHI_SLOT(da),
*mh_sd = MHSD_SLOT(da), *acc = ACC_SLOT(da),
xn = 0.0;
/* update phi */
acc[nB] += metrop_tnorm_rw(*phi, mh_sd[nB], 0, BDPHI_SLOT(da)[0],
&xn, post_phi, (void *) da);
*phi = xn ;
/* update p */
acc[nB + 1] += metrop_tnorm_rw(*p, mh_sd[nB + 1], BDP_SLOT(da)[0],
BDP_SLOT(da)[1], &xn, post_p, (void *) da);
*p = xn ;
}
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 ;
}
double getCovarianceDevianceVaryingPart(SEXP regression, const double* parameters, int* numParametersUsed)
{
double result = 0.0;
*numParametersUsed = 0;
int numParametersForPrior;
const int* dims = DIMS_SLOT(regression);
int isLinearModel = !(MUETA_SLOT(regression) || V_SLOT(regression));
double commonScale = 1.0;
if (isLinearModel) {
commonScale = DEV_SLOT(regression)[dims[isREML_POS] ? sigmaREML_POS : sigmaML_POS];
commonScale *= commonScale;
}
int numFactors = dims[nt_POS];
SEXP stList = GET_SLOT(regression, lme4_STSym);
SEXP priorList = GET_SLOT(regression, blme_covariancePriorSym);
for (int i = 0; i < numFactors; ++i) {
SEXP st = VECTOR_ELT(stList, i);
SEXP prior = VECTOR_ELT(priorList, i);
priorType_t priorType = PRIOR_TYPE_SLOT(prior);
int factorDimension = INTEGER(getAttrib(st, R_DimSymbol))[0];
switch (priorType) {
case PRIOR_TYPE_CORRELATION:
result += getCorrelationDevianceVaryingPart(prior, commonScale, parameters, factorDimension);
break;
case PRIOR_TYPE_SPECTRAL:
result += getSpectralDevianceVaryingPart(prior, commonScale, parameters, factorDimension);
break;
case PRIOR_TYPE_DIRECT:
result += getDirectDevianceVaryingPart(prior, commonScale, parameters, factorDimension);
break;
default: break;
}
numParametersForPrior = getNumCovarianceParametersForPrior(priorType, factorDimension);
parameters += numParametersForPrior;
*numParametersUsed += numParametersForPrior;
}
return(result);
}
MERCache* createLMMCache(SEXP regression)
{
MERCache* result = (MERCache*) malloc(sizeof(MERCache));
const int* dims = DIMS_SLOT(regression);
int numObservations = dims[n_POS];
int numUnmodeledCoefs = dims[p_POS];
int numModeledCoefs = dims[q_POS];
// allocation
result->weightedDenseDesignMatrix = (double*) malloc(numObservations * numUnmodeledCoefs * sizeof(double));
result->weightedResponse = (double*) malloc(numObservations * sizeof(double));
result->downdatedDenseResponseRotation = (double*) malloc(numUnmodeledCoefs * sizeof(double));
result->downdatedDenseCrossproduct = (double*) malloc(numUnmodeledCoefs * numUnmodeledCoefs * sizeof(double));
result->unmodeledCoefProjection = (double*) malloc(numUnmodeledCoefs * sizeof(double));
result->modeledCoefProjection = (double*) malloc(numModeledCoefs * sizeof(double));
if (result->weightedDenseDesignMatrix == NULL || result->weightedResponse == NULL || result->downdatedDenseResponseRotation == NULL ||
result->downdatedDenseCrossproduct == NULL || result->unmodeledCoefProjection == NULL || result->modeledCoefProjection == NULL)
error("Unable to allocate cache, out of memory\n");
weightDenseComponents(regression, result); // also fills in sum( weighted response^2 );
// constants derived from priors
// flow control
result->commonScaleOptimization = getCommonScaleOptimizationType(regression);
result->priorDevianceConstantPart = getPriorDevianceConstantPart(regression);
setPriorConstantContributionsToCommonScale(regression, result);
result->mOneExponentialTermVaryingPart = R_NaN;
result->mTwoExponentialTermVaryingPart = R_NaN;
result->oneExponentialTermVaryingPart = R_NaN;
result->twoExponentialTermVaryingPart = R_NaN;
result->objectiveFunctionValue = R_NaN;
result->priorContribution = R_NaN;
// printLMMCache(result);
return(result);
}
void profileCommonScale(SEXP regression, MERCache* cache)
{
const int* dims = DIMS_SLOT(regression);
double* deviances = DEV_SLOT(regression);
double MLDegreesOfFreedom = cache->priorCommonScaleDegreesOfFreedom + (double) dims[n_POS];
double REMLDegreesOfFreedom = MLDegreesOfFreedom - (double) dims[p_POS];
double a = cache->totalSumOfSquares + 2.0 * (cache->mTwoExponentialTermConstantPart + cache->mTwoExponentialTermVaryingPart);
double b, df;
switch (cache->commonScaleOptimization) {
case CSOT_LINEAR:
// (sigma^2)^-(df/2) * exp(-0.5 * a / sigma^2)
// sigma^2_hat = a / df
deviances[sigmaML_POS] = sqrt(a / MLDegreesOfFreedom);
deviances[sigmaREML_POS] = sqrt(a / REMLDegreesOfFreedom);
break;
case CSOT_QUADRATIC_SIGMA:
// (sigma^2)^-(df/2) * exp(-0.5 * a / sigma^2 - b / sigma)
// sigma_hat = 0.5 * (b + sqrt(b^2 + 4 * a * df)) / df
b = cache->mOneExponentialTermConstantPart + cache->mOneExponentialTermVaryingPart;
df = MLDegreesOfFreedom;
deviances[sigmaML_POS] = 0.5 * (b + sqrt(b * b + 4.0 * a * df)) / df;
df = REMLDegreesOfFreedom;
deviances[sigmaREML_POS] = 0.5 * (b + sqrt(b * b + 4.0 * a * df)) / df;
break;
case CSOT_QUADRATIC_SIGMA_SQ:
// (sigma^2)^(-df/2) * exp(-0.5 * a / sigma^2 - b * sigma^2)
// sigma^2_hat = (sqrt(df^2 + 8 * a * b) - df) / (4 * b)
b = cache->twoExponentialTermConstantPart + cache->twoExponentialTermVaryingPart;
df = MLDegreesOfFreedom;
deviances[sigmaML_POS] = sqrt(0.25 * (sqrt(df * df + 8.0 * a * b) - df) / b);
df = REMLDegreesOfFreedom;
deviances[sigmaREML_POS] = sqrt(0.25 * (sqrt(df * df + 8.0 * a * b) - df) / b);
break;
default: break;
}
}
static void do_mcmc(SEXP da, int nit, int nbn, int nth, int nS,
int nR, double *sims){
int *dm = DIMS_SLOT(da);
int nU = dm[nU_POS], nmh = dm[nmh_POS],
ns = 0, do_print = 0;
/* initialize acc */
double *acc = ACC_SLOT(da);
AZERO(acc, nmh);
/* run MCMC simulatons */
GetRNGstate();
for (int iter = 0; iter < nit; iter++){
do_print = (nR > 0 && (iter + 1) % nR == 0);
if (do_print) Rprintf(_("Iteration: %d \n "), iter + 1);
/* update parameters */
sim_beta(da);
sim_phi_p(da);
if (nU){
sim_u(da);
sim_Sigma(da);
}
/* store results */
if (iter >= nbn && (iter + 1 - nbn) % nth == 0 ){
ns = (iter + 1 - nbn) / nth - 1;
set_sims(da, ns, nS, sims);
}
/* print out acceptance rate if necessary */
if (do_print) print_acc(iter + 1, nmh, acc, 0);
R_CheckUserInterrupt();
}
PutRNGstate();
/* compute acceptance percentage */
for (int i = 0; i < nmh; i++) acc[i] /= nit ;
}
/**
* 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);
}
double performOneStepOfNewtonsMethodForCommonScale(SEXP regression, MERCache* cache)
{
double* deviances = DEV_SLOT(regression);
int* dims = DIMS_SLOT(regression);
double firstDerivative, secondDerivative;
getCommonScaleDerivatives(regression, cache, &firstDerivative, &secondDerivative);
double oldCommonScale = deviances[dims[isREML_POS] ? sigmaREML_POS : sigmaML_POS];
double commonScaleDelta = firstDerivative / secondDerivative;
double newCommonScale = oldCommonScale - commonScaleDelta;
if (newCommonScale < 0.0) {
newCommonScale = oldCommonScale / 2.0; // revert to bissection
} else if (commonScaleDelta < 0.0 && secondDerivative > 0.0) {
// There should be a convex region that extends from 0 up to a point.
// When we're past that point, updating to larger values of
// the scale parameter is a bad idea (should asymptote somewhere
// below a root). We can identify this region by the change in
// sign of the second derivative (that the log-likelihood goes
// to -Inf at 0 and the convex region gives us that the sign
// should be positive).
//
// When this happens, we need to move inward, not outward. Could
// perhaps do something scaled to the second derivative, but
// this seems as reasonable as anything else.
newCommonScale = oldCommonScale / 2.0;
}
deviances[dims[isREML_POS] ? sigmaREML_POS : sigmaML_POS] = newCommonScale;
updateRegressionForNewCommonScale(regression, cache);
return (deviances[dims[isREML_POS] ? sigmaREML_POS : sigmaML_POS]);
}
/**
* 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);
}
}
static void sim_Sigma(SEXP da){
SEXP V = GET_SLOT(da, install("Sigma")) ;
int *dm = DIMS_SLOT(da), *Gp = Gp_SLOT(da),
*nc = NCOL_SLOT(da), *nlev = NLEV_SLOT(da);
int nT = dm[nT_POS], mc = imax(nc, nT);
double *v, su, *u = U_SLOT(da),
*scl = Alloca(mc * mc, double);
R_CheckStack();
for (int i = 0; i < nT; i++){
v = REAL(VECTOR_ELT(V, i));
if (nc[i] == 1){ /* simulate from the inverse-Gamma */
su = sqr_length(u + Gp[i], nlev[i]);
v[0] = 1/rgamma(0.5 * nlev[i] + IG_SHAPE, 1.0/(su * 0.5 + IG_SCALE));
}
else { /* simulate from the inverse-Wishart */
mult_xtx(nlev[i], nc[i], u + Gp[i], scl); /* t(x) * (x) */
for (int j = 0; j < nc[i]; j++) scl[j * j] += 1.0; /* add prior (identity) scale matrix */
solve_po(nc[i], scl, v);
rwishart(nc[i], (double) (nlev[i] + nc[i]), v, scl);
solve_po(nc[i], scl, v);
}
}
}
/**
* 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) ;
}
static void getDerivativesOfSumOfSquares(SEXP regression, MERCache* cache,
double* firstDerivative, double* secondDerivative)
{
const int* dims = DIMS_SLOT(regression);
double* deviances = DEV_SLOT(regression);
int i_one = 1;
double d_one = 1.0;
int numUnmodeledCoefs = dims[p_POS];
SEXP unmodeledCoefPrior = GET_SLOT(regression, blme_unmodeledCoefficientPriorSym);
const double* hyperparameters = PRIOR_HYPERPARAMETERS_SLOT(unmodeledCoefPrior) + 1; // skip over the log det of the covar, not needed here
unsigned int numHyperparameters = LENGTH(GET_SLOT(unmodeledCoefPrior, blme_prior_hyperparametersSym)) - 1;
// take Rx and get Rx^-1
const double* lowerRightFactor = RX_SLOT(regression);
double rightFactorInverse[numUnmodeledCoefs * numUnmodeledCoefs]; // Rx^-1
invertUpperTriangularMatrix(lowerRightFactor, numUnmodeledCoefs, rightFactorInverse);
// calculate Lbeta^-1 * Rx^-1
int factorIsTriangular = TRUE;
if (numHyperparameters == 1) {
// multiply by a scalar
// printMatrix(lowerRightFactor, numUnmodeledCoefs, numUnmodeledCoefs);
for (int col = 0; col < numUnmodeledCoefs; ++col) {
int offset = col * numUnmodeledCoefs;
for (int row = 0; row <= col; ++row) {
rightFactorInverse[offset++] *= hyperparameters[0];
}
}
// printMatrix(rightFactorInverse, numUnmodeledCoefs, numUnmodeledCoefs);
} else if (numHyperparameters == numUnmodeledCoefs) {
// left multiply by a diagonal matrix
const double *diagonal = hyperparameters;
for (int col = 0; col < numUnmodeledCoefs; ++col) {
int offset = col * numUnmodeledCoefs;
for (int row = 0; row <= col; ++row) {
rightFactorInverse[offset++] *= diagonal[row];
}
}
} else {
const double* priorLeftFactorInverse = hyperparameters;
// want L * R
// Left multiply, Lower triangluar matrix, No-transpose, Non-unit
F77_CALL(dtrmm)("L", "L", "N", "N", &numUnmodeledCoefs, &numUnmodeledCoefs, &d_one,
(double*) priorLeftFactorInverse, &numUnmodeledCoefs,
rightFactorInverse, &numUnmodeledCoefs);
factorIsTriangular = FALSE;
}
double projectionRotation[numUnmodeledCoefs];
Memcpy(projectionRotation, (const double *) cache->unmodeledCoefProjection, numUnmodeledCoefs);
// this step corresponds to Rx^-1 * unmodeled coef projection
if (factorIsTriangular) {
// X := A x, A triangular
F77_CALL(dtrmv)("Upper triangular", "Non transposed", "Non unit diagonal",
&numUnmodeledCoefs, rightFactorInverse, &numUnmodeledCoefs,
projectionRotation, &i_one);
} else {
applyMatrixToVector(rightFactorInverse, numUnmodeledCoefs, numUnmodeledCoefs, FALSE,
projectionRotation, projectionRotation);
}
double firstRotationSumOfSquares = getSumOfSquares(projectionRotation, numUnmodeledCoefs);
// now for Rx^-T Rx^-1 * modeled coef projection
if (factorIsTriangular) {
// X: = A' x, A triangular
F77_CALL(dtrmv)("Upper triangular", "Transposed", "Non unit diagonal",
&numUnmodeledCoefs, rightFactorInverse, &numUnmodeledCoefs,
projectionRotation, &i_one);
} else {
applyMatrixToVector(rightFactorInverse, numUnmodeledCoefs, numUnmodeledCoefs, TRUE,
projectionRotation, projectionRotation);
}
double secondRotationSumOfSquares = getSumOfSquares(projectionRotation, numUnmodeledCoefs);
// in general, DoF depends on unmodeled coefficient prior scale, as we can get back those
// lost DoF. However, in that case we can't get here, where optimization is required.
double sigma = deviances[dims[isREML_POS] ? sigmaREML_POS : sigmaML_POS];
double sigma_sq = sigma * sigma;
*firstDerivative -= firstRotationSumOfSquares / sigma;
*secondDerivative += 3.0 * firstRotationSumOfSquares / sigma_sq + 4.0 * secondRotationSumOfSquares;
// From here, done unless REML. REML involves taking the derivative of
// the log determinant of LxLx' (with some unmodeled covariance terms),
// which is just the trace of the product. The second derivative is
// the trace of the "square" of that product.
if (dims[isREML_POS]) {
int covarianceMatrixLength = numUnmodeledCoefs * numUnmodeledCoefs;
double crossproduct[covarianceMatrixLength];
// we square the left factor Lx^-T * Lx^-1. the trace of this is immediately
// useful, but we also need the trace of its square. Fortunately, the trace
// of AA' is simply the sum of the squares of all of the elements.
if (factorIsTriangular) {
// want UU'
singleTriangularMatrixCrossproduct(rightFactorInverse, numUnmodeledCoefs, TRUE,
TRIANGLE_TYPE_UPPER, crossproduct);
} else {
singleMatrixCrossproduct(rightFactorInverse, numUnmodeledCoefs, numUnmodeledCoefs,
crossproduct, TRUE, TRIANGLE_TYPE_UPPER);
}
double firstOrderTrace = 0.0;
double secondOrderTrace = 0.0;
int offset;
// as the cross product is symmetric, we only have to use its upper
// triangle and the diagonal
for (int col = 0; col < numUnmodeledCoefs; ++col) {
offset = col * numUnmodeledCoefs;
for (int row = 0; row < col; ++row) {
secondOrderTrace += 2.0 * crossproduct[offset] * crossproduct[offset];
++offset;
}
firstOrderTrace += crossproduct[offset];
secondOrderTrace += crossproduct[offset] * crossproduct[offset];
}
*firstDerivative -= sigma * firstOrderTrace;
*secondDerivative += -firstOrderTrace + 2.0 * sigma_sq * secondOrderTrace;
}
}
/**
* Update the Xb, Zu, eta and mu slots in bcplm using FIXEF and U
*
* @param da a list object
*
*/
static void update_mu(SEXP da){
if (DIMS_SLOT(da)[nU_POS])
cpglmm_fitted((double *) NULL, -1, da);
else
cpglm_fitted((double *) NULL, da);
}
