SEXP tmb_invQ(SEXP Lfac){
CHM_FR L=AS_CHM_FR(Lfac);
cholmod_common c;
M_R_cholmod_start(&c);
CHM_SP iQ = tmb_inv_super(L, &c);
return M_chm_sparse_to_SEXP(iQ, 1 /* Free */ , 0, 0, "", R_NilValue);
}
void R_init_lme4a(DllInfo *dll)
{
R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
R_useDynamicSymbols(dll, (Rboolean)FALSE);
M_R_cholmod_start(&c);
c.final_ll = 1; /* LL' form of simplicial factorization */
}
void R_init_blme(DllInfo *dll)
{
R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
R_useDynamicSymbols(dll, FALSE);
M_R_cholmod_start(&cholmodCommon);
cholmodCommon.final_ll = 1; /* LL' form of simplicial factorization */
lme4_ASym = install("A");
lme4_CmSym = install("Cm");
lme4_CxSym = install("Cx");
lme4_DimSym = install("Dim");
lme4_GpSym = install("Gp");
lme4_LSym = install("L");
lme4_RXSym = install("RX");
lme4_RZXSym = install("RZX");
lme4_STSym = install("ST");
lme4_VSym = install("V");
lme4_XSym = install("X");
lme4_XstSym = install("Xst");
lme4_ZtSym = install("Zt");
lme4_devianceSym = install("deviance");
lme4_dimsSym = install("dims");
lme4_envSym = install("env");
lme4_etaSym = install("eta");
lme4_fixefSym = install("fixef");
lme4_flistSym = install("flist");
lme4_ghwSym = install("ghw");
lme4_ghxSym = install("ghx");
lme4_gradientSym = install("gradient");
lme4_iSym = install("i");
lme4_ncSym = install("nc");
lme4_nlmodelSym = install("nlmodel");
lme4_muEtaSym = install("muEta");
lme4_muSym = install("mu");
lme4_offsetSym = install("offset");
lme4_pSym = install("p");
lme4_permSym = install("perm");
lme4_pWtSym = install("pWt");
lme4_ranefSym = install("ranef");
lme4_residSym = install("resid");
lme4_sigmaSym = install("sigma");
lme4_sqrtrWtSym = install("sqrtrWt");
lme4_sqrtXWtSym = install("sqrtXWt");
lme4_uSym = install("u");
lme4_varSym = install("var");
lme4_xSym = install("x");
lme4_ySym = install("y");
blme_covariancePriorSym = install("cov.prior");
blme_unmodeledCoefficientPriorSym = install("fixef.prior");
blme_commonScalePriorSym = install("var.prior");
blme_prior_typeSym = install("type");
blme_prior_familiesSym = install("families");
blme_prior_scalesSym = install("scales");
blme_prior_hyperparametersSym = install("hyperparameters");
}
SEXP tmb_invQ_tril_halfdiag(SEXP Lfac){
CHM_FR L=AS_CHM_FR(Lfac);
cholmod_common c;
M_R_cholmod_start(&c);
CHM_SP iQ = tmb_inv_super(L, &c);
half_diag(iQ);
iQ->stype=0; /* Change to non-sym */
return M_chm_sparse_to_SEXP(iQ, 1 /* Free */ , 0, 0, "", R_NilValue);
}
void R_init_lme4(DllInfo *dll)
{
R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
R_useDynamicSymbols(dll, FALSE);
M_R_cholmod_start(&c);
c.final_ll = 1; /* LL' form of simplicial factorization */
/* need own error handler, that resets final_ll (after *_defaults()) : */
c.error_handler = lme4_R_cholmod_error;
lme4_ASym = install("A");
lme4_CmSym = install("Cm");
lme4_CxSym = install("Cx");
lme4_DimSym = install("Dim");
lme4_GpSym = install("Gp");
lme4_LSym = install("L");
lme4_RXSym = install("RX");
lme4_RZXSym = install("RZX");
lme4_STSym = install("ST");
lme4_VSym = install("V");
lme4_XSym = install("X");
lme4_XstSym = install("Xst");
lme4_ZtSym = install("Zt");
lme4_devianceSym = install("deviance");
lme4_dimsSym = install("dims");
lme4_envSym = install("env");
lme4_etaSym = install("eta");
lme4_fixefSym = install("fixef");
lme4_flistSym = install("flist");
lme4_ghwSym = install("ghw");
lme4_ghxSym = install("ghx");
lme4_gradientSym = install("gradient");
lme4_iSym = install("i");
lme4_ncSym = install("nc");
lme4_nlmodelSym = install("nlmodel");
lme4_muEtaSym = install("muEta");
lme4_muSym = install("mu");
lme4_offsetSym = install("offset");
lme4_pSym = install("p");
lme4_permSym = install("perm");
lme4_pWtSym = install("pWt");
lme4_ranefSym = install("ranef");
lme4_residSym = install("resid");
lme4_sigmaSym = install("sigma");
lme4_sqrtrWtSym = install("sqrtrWt");
lme4_sqrtXWtSym = install("sqrtXWt");
lme4_uSym = install("u");
lme4_varSym = install("var");
lme4_xSym = install("x");
lme4_ySym = install("y");
}
/*
* callable function from R
*/
SEXP gmrfLik(
SEXP QR,
SEXP obsCovR,
SEXP xisqTausq,
SEXP YrepAddR
){
int Drep, dooptim, DxisqAgain; // length(xisqTausq)
double oneD=1.0, zeroD=0.0;
double optTol = pow(DBL_EPSILON, 0.25); // tolerence for fmin_brent
double optMin = log(0.01), optMax = log(100); // default interval for optimizer
int NxisqMax = 100; // number of xisqTausq's to retain when optimizing
double *YXVYX, *determinant, *determinantForReml;
double *m2logL, *m2logReL, *varHatMl, *varHatReml, *resultXisqTausq;
void *nothing;
SEXP resultR;
CHM_DN obsCov;
Ltype=0; // set to 1 for reml
Nrep =LENGTH(YrepAddR);
YrepAdd = REAL(YrepAddR);
Nobs = INTEGER(GET_DIM(obsCovR))[0];
Nxy = INTEGER(GET_DIM(obsCovR))[1];
Ncov = Nxy - Nrep;
Nxysq = Nxy*Nxy;
NxisqTausq = LENGTH(xisqTausq);
// if length zero, do optimization
dooptim=!NxisqTausq;
if(dooptim){
NxisqTausq = NxisqMax;
}
// Rprintf("d %d %d", dooptim, NxisqTausq);
resultR = PROTECT(allocVector(REALSXP, Nxysq*NxisqTausq + 8*Nrep*NxisqTausq));
YXVYX = REAL(resultR);
determinant = &REAL(resultR)[Nxysq*NxisqTausq];
determinantForReml = &REAL(resultR)[Nxysq*NxisqTausq + Nrep*NxisqTausq];
m2logL = &REAL(resultR)[Nxysq*NxisqTausq + 2*Nrep*NxisqTausq];
m2logReL = &REAL(resultR)[Nxysq*NxisqTausq + 3*Nrep*NxisqTausq];
varHatMl = &REAL(resultR)[Nxysq*NxisqTausq + 4*Nrep*NxisqTausq];
varHatReml = &REAL(resultR)[Nxysq*NxisqTausq + 5*Nrep*NxisqTausq];
resultXisqTausq = &REAL(resultR)[Nxysq*NxisqTausq + 6*Nrep*NxisqTausq];
YXYX = (double *) calloc(Nxysq,sizeof(double));
copyLx = (double *) calloc(Nxy*Nrep,sizeof(double));
Q = AS_CHM_SP(QR);
obsCov = AS_CHM_DN(obsCovR);
M_R_cholmod_start(&c);
// get some stuff ready
// allocate Lx
Lx = M_cholmod_copy_dense(obsCov,&c);
// likelihood without nugget
// YX Vinv YX
M_cholmod_sdmult(
Q,
0, &oneD, &zeroD, // transpose, scale, scale
obsCov,Lx,// in, out
&c);
// put t(obscov) Q obscov in result
F77_NAME(dgemm)(
// op(A), op(B),
"T", "N",
// nrows of op(A), ncol ob(B), ncol op(A) = nrow(opB)
&Nxy, &Nxy, &Nobs,
// alpha
&oneD,
// A, nrow(A)
obsCov->x, &Nobs,
// B, nrow(B)
Lx->x, &Nobs,
// beta
&zeroD,
// C, nrow(c)
YXVYX, &Nxy);
// Q = P' L D L' P
L = M_cholmod_analyze(Q, &c);
M_cholmod_factorize(Q,L, &c);
// determinant
determinant[0] = M_chm_factor_ldetL2(L);
resultXisqTausq[0]= R_PosInf;
ssqFromXprod(
YXVYX, // N by N
determinantForReml,
Nxy, Nrep,
copyLx);
for(Drep=0;Drep<Nrep;++Drep){
determinant[Drep] = determinant[0];
determinantForReml[Drep] = determinantForReml[0];
m2logL[Drep] = Nobs*log(YXVYX[Drep*Nxy+Drep]) - Nobs*log(Nobs) -
determinant[0] - YrepAdd[Drep];
m2logReL[Drep] = (Nobs-Ncov)*log(YXVYX[Drep*Nxy+Drep]/(Nobs-Ncov)) +
determinantForReml[0] - determinant[0] - YrepAdd[Drep];
varHatMl[Drep] = YXVYX[Drep*Nxy+Drep]/Nobs;
varHatReml[Drep] = YXVYX[Drep*Nxy+Drep]/(Nobs-Ncov);
}
// now with xisqTausq
obsCovRot = M_cholmod_solve(CHOLMOD_P, L,obsCov,&c);
// YXYX cross product of data
F77_NAME(dgemm)(
// op(A), op(B),
"T", "N",
// nrows of op(A), ncol ob(B), ncol op(A) = nrow(opB)
&Nxy, &Nxy, &Nobs,
// alpha
&oneD,
// A, nrow(A)
obsCovRot->x, &Nobs,
// B, nrow(B)
obsCovRot->x, &Nobs,
// beta
&zeroD,
// C, nrow(&c)
YXYX, &Nxy);
YXVYXglobal = YXVYX;
// Rprintf("done zero ", dooptim);
if(dooptim){
// put NA's where DxisqTausq hasnt been used
for(DxisqAgain=1;DxisqAgain < NxisqTausq; ++DxisqAgain){
determinant[DxisqAgain*Nrep] = NA_REAL;
determinantForReml[DxisqAgain*Nrep] = NA_REAL;
m2logL[DxisqAgain*Nrep] = NA_REAL;
m2logReL[DxisqAgain*Nrep] = NA_REAL;
varHatMl[DxisqAgain*Nrep] = NA_REAL;
varHatReml[DxisqAgain*Nrep] = NA_REAL;
}
DxisqTausq=1;
// do optimizer
Brent_fmin(
optMin, optMax,
logLoneLogNugget,
nothing, optTol);
// Rprintf("done opt ", dooptim);
NxisqTausq = DxisqTausq;
} else {
for(DxisqTausq=1;DxisqTausq < NxisqTausq;++DxisqTausq){
logLoneNugget(REAL(xisqTausq)[DxisqTausq], nothing);
}
}
// assign global values into their correct spot
for(DxisqTausq=1;DxisqTausq < NxisqTausq;++DxisqTausq){
for(Drep=0;Drep<Nrep;++Drep){
determinant[DxisqTausq*Nrep+Drep] =
determinant[DxisqTausq*Nrep];
determinantForReml[DxisqTausq*Nrep+Drep]=
determinantForReml[DxisqTausq*Nrep];
m2logL[DxisqTausq*Nrep+Drep] -=
determinant[0];
m2logReL[DxisqTausq*Nrep+Drep] -=
determinant[0];
varHatMl[DxisqTausq*Nrep + Drep] =
YXVYXglobal[DxisqTausq*Nxysq+Drep*Nxy+Drep]/Nobs;
varHatReml[DxisqTausq*Nrep + Drep] =
YXVYXglobal[DxisqTausq*Nxysq+Drep*Nxy+Drep]/(Nobs-Ncov);
resultXisqTausq[DxisqTausq*Nrep + Drep] =
resultXisqTausq[DxisqTausq*Nrep];
}
}
M_cholmod_free_factor(&L, &c);
M_cholmod_free_dense(&obsCovRot, &c);
M_cholmod_free_dense(&Lx, &c);
// don't free Q because it's from an R object
// M_cholmod_free_sparse(&Q, &c);
// don't free obsCov because it's from an R object
// M_cholmod_free_dense(&obsCov, &c);
free(copyLx);
free(YXYX);
M_cholmod_free_dense(&YwkL, &c);
M_cholmod_free_dense(&YwkD, &c);
M_cholmod_free_dense(&EwkL, &c);
M_cholmod_free_dense(&EwkD, &c);
M_cholmod_finish(&c);
UNPROTECT(1);
return resultR;
}
