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);
}
/**
* 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);
}
// the common-scale can be profiled out (easily) under certain circumstances
//
// in general, the objective function looks like:
// (sigma^2)^(-df/2) * exp(-0.5 * (1 / sigma^2) * stuff)
//
// what determines whether or not it can be profiled is the functional form of the
// exponentiated term. For this, we have the following:
//
// powers: -1 -2 1 2 - estimating equation
// prsnt : 0 X 0 0 - linear in sigma^2 (default scenario)
// 0 X 0 X - quadratic in sigma^2
// X X 0 0 - quadratic in sigma
// 0 X X 0 - cubic in sigma
//
// everything else is even worse
//
// finally, we also have two trumps. if the common scale has a point prior, that is that.
// In addition, if the unmodeled coefficients aren't placed on the common scale, no polynomial
// equation is possible
static commonScaleOptimization_t getCommonScaleOptimizationType(SEXP regression)
{
int isLinearModel = !(MUETA_SLOT(regression) || V_SLOT(regression));
if (!isLinearModel) return(CSOT_NA); // question doesn't apply if is !lmm
int* dims = DIMS_SLOT(regression);
SEXP csPrior = GET_SLOT(regression, blme_commonScalePriorSym);
SEXP ucPrior = GET_SLOT(regression, blme_unmodeledCoefficientPriorSym);
SEXP cvPriorList = GET_SLOT(regression, blme_covariancePriorSym);
priorType_t csPriorType = PRIOR_TYPE_SLOT(csPrior);
priorType_t ucPriorType = PRIOR_TYPE_SLOT(ucPrior);
priorType_t cvPriorType;
priorFamily_t family;
priorPosteriorScale_t posteriorScale;
priorCommonScale_t onCommonScale;
// handle the two trumps first
if (csPriorType == PRIOR_TYPE_DIRECT &&
PRIOR_FAMILIES_SLOT(csPrior)[0] == PRIOR_FAMILY_POINT) {
return(CSOT_NA);
}
if (ucPriorType == PRIOR_TYPE_DIRECT) {
family = PRIOR_FAMILIES_SLOT(ucPrior)[0];
onCommonScale = getCommonScaleBit(PRIOR_SCALES_SLOT(ucPrior)[0]);
if (family != PRIOR_FAMILY_FLAT &&
(family != PRIOR_FAMILY_GAUSSIAN || !onCommonScale)) return(CSOT_BRUTE_FORCE);
}
// catalog whether or not certain powers are present
int mOneInExp = 0; // purposefully using 0/1 instead of false/true as we will do some math with them at the end
int oneInExp = 0;
int twoInExp = 0;
if (csPriorType == PRIOR_TYPE_DIRECT) {
family = PRIOR_FAMILIES_SLOT(csPrior)[0];
posteriorScale = getPosteriorScaleBit(PRIOR_SCALES_SLOT(csPrior)[0]);
if (family == PRIOR_FAMILY_GAMMA) {
if (posteriorScale == PRIOR_POSTERIOR_SCALE_SD)
oneInExp = 1;
else
twoInExp = 1;
} else if (family == PRIOR_FAMILY_INVGAMMA) {
if (posteriorScale == PRIOR_POSTERIOR_SCALE_SD)
mOneInExp = 1;
} else {
// huh? Shouldn't happen. caught point priors above...
return(CSOT_BRUTE_FORCE);
}
}
// now for the covariance priors; have to loop over factors and over dimensions within
SEXP stList = GET_SLOT(regression, lme4_STSym);
int numFactors = dims[nt_POS];
for (int i = 0; i < numFactors; ++i) {
SEXP cvPrior = VECTOR_ELT(cvPriorList, i);
SEXP stMatrix = VECTOR_ELT(stList, i);
int factorDimension = INTEGER(getAttrib(stMatrix, R_DimSymbol))[0];
cvPriorType = PRIOR_TYPE_SLOT(cvPrior);
priorFamily_t* families;
int* scales;
switch (cvPriorType) {
case PRIOR_TYPE_DIRECT:
onCommonScale = getCommonScaleBit(PRIOR_SCALES_SLOT(cvPrior)[0]);
if (onCommonScale) continue;
family = PRIOR_FAMILIES_SLOT(cvPrior)[0];
posteriorScale = getPosteriorScaleBit(PRIOR_SCALES_SLOT(cvPrior)[0]);
switch (family) {
case PRIOR_FAMILY_GAMMA:
if (posteriorScale == PRIOR_POSTERIOR_SCALE_SD) oneInExp = 1;
else twoInExp = 1;
break;
case PRIOR_FAMILY_INVGAMMA:
if (posteriorScale == PRIOR_POSTERIOR_SCALE_SD) mOneInExp = 1;
break;
case PRIOR_FAMILY_WISHART:
twoInExp = 1;
break;
default: break;
}
case PRIOR_TYPE_CORRELATION:
families = PRIOR_FAMILIES_SLOT(cvPrior);
scales = PRIOR_SCALES_SLOT(cvPrior);
for (int j = 0; j < factorDimension; ++j) {
onCommonScale = getCommonScaleBit(scales[j]);
if (onCommonScale) continue;
family = families[j];
switch (family) {
case PRIOR_FAMILY_GAMMA:
oneInExp = 1;
break;
case PRIOR_FAMILY_INVGAMMA:
mOneInExp = 1;
break;
default: break;
}
}
family = families[factorDimension];
onCommonScale = getCommonScaleBit(scales[factorDimension]);
if (onCommonScale) continue;
switch (family) {
case PRIOR_FAMILY_WISHART:
oneInExp = 1;
break;
case PRIOR_FAMILY_INVWISHART:
mOneInExp = 1;
break;
default: break;
}
case PRIOR_TYPE_SPECTRAL:
families = PRIOR_FAMILIES_SLOT(cvPrior);
scales = PRIOR_SCALES_SLOT(cvPrior);
for (int j = 0; j < factorDimension; ++j) {
onCommonScale = getCommonScaleBit(scales[j]);
if (onCommonScale) continue;
family = families[j];
posteriorScale = getPosteriorScaleBit(scales[j]);
switch (family) {
case PRIOR_FAMILY_GAMMA:
if (posteriorScale == PRIOR_POSTERIOR_SCALE_SD) oneInExp = 1;
else twoInExp = 1;
break;
case PRIOR_FAMILY_INVGAMMA:
if (posteriorScale == PRIOR_POSTERIOR_SCALE_SD) mOneInExp = 1;
break;
default: break;
}
}
default: break;
} // switch (cvPriorType)
} // for (int i = 0; i < numFactors; ++i)
int numPowers = mOneInExp + oneInExp + twoInExp;
if (numPowers == 0) return(CSOT_LINEAR);
if (numPowers > 1) return(CSOT_BRUTE_FORCE);
if (mOneInExp) return(CSOT_QUADRATIC_SIGMA);
if (twoInExp) return(CSOT_QUADRATIC_SIGMA_SQ);
return(CSOT_BRUTE_FORCE);
}
