Rcpp::List reTrms::condVar(double scale) {
if (scale < 0 || !R_finite(scale))
throw runtime_error("scale must be non-negative and finite");
int nf = d_flist.size();
IntegerVector nc = ncols(), nl = nlevs(), nct = nctot(), off = offsets();
List ans(nf);
CharacterVector nms = d_flist.names();
ans.names() = clone(nms);
for (int i = 0; i < nf; i++) {
int ncti = nct[i], nli = nl[i];
IntegerVector trms = terms(i);
int *cset = new int[ncti], nct2 = ncti * ncti;
NumericVector ansi(Dimension(ncti, ncti, nli));
ans[i] = ansi;
double *ai = ansi.begin();
for (int j = 0; j < nli; j++) {
int kk = 0;
for (int jj = 0; jj < trms.size(); jj++) {
int tjj = trms[jj];
for (int k = 0; k < nc[tjj]; k++)
cset[kk++] = off[tjj] + j * nc[tjj] + k;
}
CHM_SP cols =
M_cholmod_submatrix(&d_Lambda, (int*)NULL, -1, cset, ncti,
1/*values*/, 1/*sorted*/, &c);
CHM_SP sol = d_L.spsolve(CHOLMOD_A, cols);
CHM_SP tcols = M_cholmod_transpose(cols, 1/*values*/, &c);
M_cholmod_free_sparse(&cols, &c);
CHM_SP var = M_cholmod_ssmult(tcols, sol, 0/*stype*/,
1/*values*/, 1/*sorted*/, &c);
M_cholmod_free_sparse(&sol, &c);
M_cholmod_free_sparse(&tcols, &c);
CHM_DN dvar = M_cholmod_sparse_to_dense(var, &c);
M_cholmod_free_sparse(&var, &c);
Memcpy(ai + j * nct2, (double*)dvar->x, nct2);
M_cholmod_free_dense(&dvar, &c);
}
delete[] cset;
transform(ansi.begin(), ansi.end(), ansi.begin(),
bind2nd(multiplies<double>(), scale * scale));
}
return ans;
}
void solveSparseCholeskySystem(int operationType, const_CHM_FR leftHandSide,
const double *rightHandSide, int numColsRightHandSide,
double *target)
{
int commonDim = leftHandSide->n;
CHM_DN chol_rightHandSide = N_AS_CHM_DN((double *) rightHandSide, commonDim, numColsRightHandSide);
CHM_DN solution;
R_CheckStack();
solution = M_cholmod_solve(operationType,
leftHandSide,
chol_rightHandSide,
&cholmodCommon);
if (!solution) error("cholmod_solve (%d) failed", operationType);
// copy result into the dense, non-cholmod matrix
Memcpy(target, (const double *) (solution->x),
commonDim * numColsRightHandSide);
M_cholmod_free_dense(&solution, &cholmodCommon);
}
/**
* 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);
}
/*
* 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;
}
/* Perform recursions for k'th supernode */
void tmb_recursion_super(CHM_SP Lsparse, int k, CHM_FR L, cholmod_common *c){
int* super=L->super;
int* Ls=L->s;
int* Lpi=L->pi;
int ncol=super[k+1]-super[k]; /* ncol of supernode */
int nrow=Lpi[k+1]-Lpi[k]; /* Number of rows in supernode */
/* q contains row-indices of *entire* supernode */
/* p contains row-indices excluding those of diagonal */
/* s contains row-indices of diagonal - setdiff(q,p) */
int* q=Ls+Lpi[k]; /* Pointer to L->s [L->pi [k]] */
int nq=nrow; /* length of q */
// int* p=q+ncol; /* Exclude triangle in diagonal */
int np=nq-ncol; /* length of p */
int* s=q;
int ns=ncol; /* length of s */
/* do not sort because p is sorted */
int info; /* For lapack */
int i,j;
double ONE=1.0, ZERO=0.0, MONE=-1.0;
CHM_DN x = densesubmatrix(Lsparse,q,nq,q,nq,c);
double *xx=x->x;
double *Lss=xx, *Lps=xx+ns, *Ssp=xx+(nq*ns), *Spp=xx+(nq*ns+ns);
/* Workspace to hold output from dsymm */
double *wrk=malloc(nq*ns*sizeof(double));
double *wrkps=wrk+ns;
if(np>0){
F77_CALL(dtrsm)("Right","Lower","No transpose","Not unit",
&np,&ns,&MONE,Lss,&nq,Lps,&nq);
for(i=ns;i<nq;i++){for(j=0;j<ns;j++)Lss[j+nq*i] = Lss[i+nq*j];} /* Copy Transpose*/
memcpy(wrk,Lss,nq*ns*sizeof(double));
F77_CALL(dsymm)("Left","Lower",&np,&ns,&ONE,Spp,&nq,Lps,&nq,&ZERO,wrkps,&nq);
memcpy(Lss,wrk,nq*ns*sizeof(double));
F77_CALL(dpotri)("L",&ns,Lss,&nq,&info);
F77_CALL(dgemm)("N","N",&ns,&ns,&np,&ONE,Ssp,&nq,Lps,&nq,&ONE,Lss,&nq);
} else {
F77_CALL(dpotri)("L",&ns,Lss,&nq,&info);
}
/* ----------- Fill results into L(q,s) -------*/
double *Lx=Lsparse->x;
int *Lp=Lsparse->p;
int m=Lp[s[0]];
for(j=0;j<ns;j++){
for(i=j;i<nq;i++){
Lx[m]=Lss[i+j*nq];
m++;
}
}
/* Count flops */
/* if(control.countflops){ */
/* double Ns=ns; */
/* double Np=np; */
/* if(np>0){ */
/* flopcount[0]+=(Ns*(Ns+1))*0.5*Np; /\* dtrsm *\/ */
/* flopcount[1]+=Np*Np*Ns; /\* dsymm *\/ */
/* flopcount[2]+=2.0*(Ns*Ns*Ns)/3.0; /\* dpotri *\/ */
/* flopcount[3]+=Ns*Np*Ns; /\* dgemm *\/ */
/* } else { */
/* flopcount[2]+=2.0*(Ns*Ns*Ns)/3.0; /\* dpotri *\/ */
/* } */
/* } */
/* Clean up */
M_cholmod_free_dense(&x,c);
free(wrk);
}
