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); }