/**
* Update V, Vtr and fac
*
* Note: May want to update fac in a separate operation. For the
* fixed-effects modules this will update the factor twice because
* it is separately updated in updateRzxRx.
*
* @param Xwt square root of the weights for the model matrices
* @param wtres weighted residuals
*/
void sPredModule::reweight(Rcpp::NumericMatrix const& Xwt,
Rcpp::NumericVector const& wtres) throw(std::runtime_error) {
if (d_coef.size() == 0) return;
double one = 1., zero = 0.;
int Wnc = Xwt.ncol();//, Wnr = Xwt.nrow(),
// Xnc = d_X.ncol, Xnr = d_X.nrow;
if ((Xwt.rows() * Xwt.cols()) != (int)d_X.nrow)
throw std::runtime_error("dimension mismatch");
// Rf_error("%s: dimension mismatch %s(%d,%d), %s(%d,%d)",
// "deFeMod::reweight", "X", Xnr, Xnc,
// "Xwt", Wnr, Wnc);
if (Wnc == 1) {
if (d_V) M_cholmod_free_sparse(&d_V, &c);
d_V = M_cholmod_copy_sparse(&d_X, &c);
chmDn csqrtX(Xwt);
M_cholmod_scale(&csqrtX, CHOLMOD_ROW, d_V, &c);
} else throw runtime_error("sPredModule::reweight: multiple columns in Xwt");
// FIXME write this combination using the triplet representation
chmDn cVtr(d_Vtr);
const chmDn cwtres(wtres);
M_cholmod_sdmult(d_V, 'T', &one, &zero, &cwtres, &cVtr, &c);
CHM_SP Vt = M_cholmod_transpose(d_V, 1/*values*/, &c);
d_fac.update(*Vt);
M_cholmod_free_sparse(&Vt, &c);
}
CHM_r* CHM_rd::rprod_SP(CHM_SP Ut) {
static double one[] = {1,0}, zero[] = {0,0};
CHM_rd *ans =
new CHM_rd(M_cholmod_allocate_dense(Ut->nrow, A->ncol,
Ut->nrow, CHOLMOD_REAL, &c));
M_cholmod_sdmult(Ut, 0/*no transpose*/, one, zero, A, ans->A, &c);
return ans;
}
/**
* Update L, Ut and cu for new weights.
*
* Update Ut from Zt and sqrtXwt, then L from Lambda and Ut
* Update cu from wtres, Lambda and Ut.
*
* @param Xwt Matrix of weights for the model matrix
* @param wtres weighted residuals
*/
void reModule::reweight(Rcpp::NumericMatrix const& Xwt,
Rcpp::NumericVector const& wtres) {
double mone = -1., one = 1.;
int Wnc = Xwt.ncol();
if (d_Ut) M_cholmod_free_sparse(&d_Ut, &c);
if (Wnc == 1) {
d_Ut = M_cholmod_copy_sparse(&d_Zt, &c);
chmDn csqrtX(Xwt);
M_cholmod_scale(&csqrtX, CHOLMOD_COL, d_Ut, &c);
} else {
int n = Xwt.nrow();
CHM_TR tr = M_cholmod_sparse_to_triplet(&d_Zt, &c);
int *j = (int*)tr->j, nnz = tr->nnz;
double *x = (double*)tr->x, *W = Xwt.begin();
for (int k = 0; k < nnz; k++) {
x[k] *= W[j[k]];
j[k] = j[k] % n;
}
tr->ncol = (size_t)n;
d_Ut = M_cholmod_triplet_to_sparse(tr, nnz, &c);
M_cholmod_free_triplet(&tr, &c);
}
// update the factor L
CHM_SP LambdatUt = d_Lambda.crossprod(d_Ut);
d_L.update(*LambdatUt, 1.);
d_ldL2 = d_L.logDet2();
// update cu
chmDn ccu(d_cu), cwtres(wtres);
copy(d_u0.begin(), d_u0.end(), d_cu.begin());
M_cholmod_sdmult(LambdatUt, 0/*trans*/, &one, &mone, &cwtres, &ccu, &c);
M_cholmod_free_sparse(&LambdatUt, &c);
NumericMatrix
ans = d_L.solve(CHOLMOD_L, d_L.solve(CHOLMOD_P, d_cu));
copy(ans.begin(), ans.end(), d_cu.begin());
d_CcNumer = inner_product(d_cu.begin(), d_cu.end(), d_cu.begin(), double());
}
/**
* 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);
}
}
CHM_r* CHM_rd::crossprod_SP(CHM_SP Lam) {
static double one[] = {1,0}, zero[] = {0,0};
CHM_rd *ans = new CHM_rd(M_cholmod_copy_dense(A, &c));
M_cholmod_sdmult(Lam, 1/*transpose*/, one, zero, A, ans->A, &c);
return ans;
}
void CHM_rs::drmult(int transpose, double alpha, double beta,
CHM_DN X, CHM_DN Y){
M_cholmod_sdmult(A, transpose, &alpha, &beta, X, Y, &c);
}
/*
* 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;
}
