// called from package MatrixModels's R code:
SEXP dgCMatrix_cholsol(SEXP x, SEXP y)
{
/* Solve Sparse Least Squares X %*% beta ~= y with dense RHS y,
* where X = t(x) i.e. we pass x = t(X) as argument,
* via "Cholesky(X'X)" .. well not really:
* cholmod_factorize("x", ..) finds L in X'X = L'L directly */
CHM_SP cx = AS_CHM_SP(x);
/* FIXME: extend this to work in multivariate case, i.e. y a matrix with > 1 column ! */
CHM_DN cy = AS_CHM_DN(coerceVector(y, REALSXP)), rhs, cAns, resid;
CHM_FR L;
int n = cx->ncol;/* #{obs.} {x = t(X) !} */
double one[] = {1,0}, zero[] = {0,0}, neg1[] = {-1,0};
const char *nms[] = {"L", "coef", "Xty", "resid", ""};
SEXP ans = PROTECT(Rf_mkNamed(VECSXP, nms));
R_CheckStack();
if (n < cx->nrow || n <= 0)
error(_("dgCMatrix_cholsol requires a 'short, wide' rectangular matrix"));
if (cy->nrow != n)
error(_("Dimensions of system to be solved are inconsistent"));
rhs = cholmod_allocate_dense(cx->nrow, 1, cx->nrow, CHOLMOD_REAL, &c);
/* cholmod_sdmult(A, transp, alpha, beta, X, Y, &c):
* Y := alpha*(A*X) + beta*Y or alpha*(A'*X) + beta*Y ;
* here: rhs := 1 * x %*% y + 0 = x %*% y = X'y */
if (!(cholmod_sdmult(cx, 0 /* trans */, one, zero, cy, rhs, &c)))
error(_("cholmod_sdmult error (rhs)"));
L = cholmod_analyze(cx, &c);
if (!cholmod_factorize(cx, L, &c))
error(_("cholmod_factorize failed: status %d, minor %d from ncol %d"),
c.status, L->minor, L->n);
/* FIXME: Do this in stages so an "effects" vector can be calculated */
if (!(cAns = cholmod_solve(CHOLMOD_A, L, rhs, &c)))
error(_("cholmod_solve (CHOLMOD_A) failed: status %d, minor %d from ncol %d"),
c.status, L->minor, L->n);
/* L : */
SET_VECTOR_ELT(ans, 0, chm_factor_to_SEXP(L, 0));
/* coef : */
SET_VECTOR_ELT(ans, 1, allocVector(REALSXP, cx->nrow));
Memcpy(REAL(VECTOR_ELT(ans, 1)), (double*)(cAns->x), cx->nrow);
/* X'y : */
/* FIXME: Change this when the "effects" vector is available */
SET_VECTOR_ELT(ans, 2, allocVector(REALSXP, cx->nrow));
Memcpy(REAL(VECTOR_ELT(ans, 2)), (double*)(rhs->x), cx->nrow);
/* resid := y */
resid = cholmod_copy_dense(cy, &c);
/* cholmod_sdmult(A, transp, alp, bet, X, Y, &c):
* Y := alp*(A*X) + bet*Y or alp*(A'*X) + beta*Y ;
* here: resid := -1 * x' %*% coef + 1 * y = y - X %*% coef */
if (!(cholmod_sdmult(cx, 1/* trans */, neg1, one, cAns, resid, &c)))
error(_("cholmod_sdmult error (resid)"));
/* FIXME: for multivariate case, i.e. resid *matrix* with > 1 column ! */
SET_VECTOR_ELT(ans, 3, allocVector(REALSXP, n));
Memcpy(REAL(VECTOR_ELT(ans, 3)), (double*)(resid->x), n);
cholmod_free_factor(&L, &c);
cholmod_free_dense(&rhs, &c);
cholmod_free_dense(&cAns, &c);
UNPROTECT(1);
return ans;
}
SEXP Csparse_dense_prod(SEXP a, SEXP b)
{
CHM_SP cha = AS_CHM_SP(a);
SEXP b_M = PROTECT(mMatrix_as_dgeMatrix(b));
CHM_DN chb = AS_CHM_DN(b_M);
CHM_DN chc = cholmod_l_allocate_dense(cha->nrow, chb->ncol, cha->nrow,
chb->xtype, &c);
SEXP dn = PROTECT(allocVector(VECSXP, 2));
double one[] = {1,0}, zero[] = {0,0};
int nprot = 2;
R_CheckStack();
/* Tim Davis, please FIXME: currently (2010-11) *fails* when a is a pattern matrix:*/
if(cha->xtype == CHOLMOD_PATTERN) {
/* warning(_("Csparse_dense_prod(): cholmod_sdmult() not yet implemented for pattern./ ngCMatrix" */
/* " --> slightly inefficient coercion")); */
// This *fails* to produce a CHOLMOD_REAL ..
// CHM_SP chd = cholmod_l_copy(cha, cha->stype, CHOLMOD_REAL, &c);
// --> use our Matrix-classes
SEXP da = PROTECT(nz2Csparse(a, x_double)); nprot++;
cha = AS_CHM_SP(da);
}
cholmod_l_sdmult(cha, 0, one, zero, chb, chc, &c);
SET_VECTOR_ELT(dn, 0, /* establish dimnames */
duplicate(VECTOR_ELT(GET_SLOT(a, Matrix_DimNamesSym), 0)));
SET_VECTOR_ELT(dn, 1,
duplicate(VECTOR_ELT(GET_SLOT(b_M, Matrix_DimNamesSym), 1)));
UNPROTECT(nprot);
return chm_dense_to_SEXP(chc, 1, 0, dn);
}
SEXP dense_to_Csparse(SEXP x)
{
CHM_DN chxd = AS_CHM_DN(PROTECT(mMatrix_as_geMatrix(x)));
/* cholmod_dense_to_sparse() in CHOLMOD/Core/ below does only work for
"REAL" 'xtypes', i.e. *not* for "nMatrix".
===> need "_x" in above call.
Also it cannot keep symmetric / triangular, hence the
as_geMatrix() above. Note that this is already a *waste* for
symmetric matrices; However, we could conceivably use an
enhanced cholmod_dense_to_sparse(), with an extra boolean
argument for symmetry.
*/
CHM_SP chxs = cholmod_dense_to_sparse(chxd, 1, &c);
int Rkind = (chxd->xtype == CHOLMOD_REAL) ? Real_KIND2(x) : 0;
/* Note: when 'x' was integer Matrix, Real_KIND(x) = -1, but *_KIND2(.) = 0 */
R_CheckStack();
UNPROTECT(1);
/* chm_sparse_to_SEXP() *could* deal with symmetric
* if chxs had such an stype; and we should be able to use uplo below */
return chm_sparse_to_SEXP(chxs, 1, 0/*TODO: uplo_P(x) if x has an uplo slot*/,
Rkind, "",
isMatrix(x) ? getAttrib(x, R_DimNamesSymbol)
: GET_SLOT(x, Matrix_DimNamesSym));
}
SEXP dsCMatrix_matrix_solve(SEXP a, SEXP b)
{
CHM_FR L = internal_chm_factor(a, -1, -1, -1, 0.);
CHM_DN cx, cb = AS_CHM_DN(PROTECT(mMatrix_as_dgeMatrix(b)));
R_CheckStack();
cx = cholmod_l_solve(CHOLMOD_A, L, cb, &c);
cholmod_l_free_factor(&L, &c);
UNPROTECT(1);
return chm_dense_to_SEXP(cx, 1, 0, /*dimnames = */ R_NilValue);
}
SEXP CHMfactor_solve(SEXP a, SEXP b, SEXP system)
{
CHM_FR L = AS_CHM_FR(a);
SEXP bb = PROTECT(dup_mMatrix_as_dgeMatrix(b));
CHM_DN B = AS_CHM_DN(bb), X;
int sys = asInteger(system);
R_CheckStack();
if (!(sys--)) /* align with CHOLMOD defs: R's {1:9} --> {0:8},
see ./CHOLMOD/Cholesky/cholmod_solve.c */
error(_("system argument is not valid"));
X = cholmod_solve(sys, L, B, &c);
UNPROTECT(1);
return chm_dense_to_SEXP(X, 1/*do_free*/, 0/*Rkind*/,
GET_SLOT(bb, Matrix_DimNamesSym), FALSE);
}
SEXP Csparse_dense_crossprod(SEXP a, SEXP b)
{
CHM_SP cha = AS_CHM_SP(a);
SEXP b_M = PROTECT(mMatrix_as_dgeMatrix(b));
CHM_DN chb = AS_CHM_DN(b_M);
CHM_DN chc = cholmod_l_allocate_dense(cha->ncol, chb->ncol, cha->ncol,
chb->xtype, &c);
SEXP dn = PROTECT(allocVector(VECSXP, 2)); int nprot = 2;
double one[] = {1,0}, zero[] = {0,0};
R_CheckStack();
// -- see Csparse_dense_prod() above :
if(cha->xtype == CHOLMOD_PATTERN) {
SEXP da = PROTECT(nz2Csparse(a, x_double)); nprot++;
cha = AS_CHM_SP(da);
}
cholmod_l_sdmult(cha, 1, one, zero, chb, chc, &c);
SET_VECTOR_ELT(dn, 0, /* establish dimnames */
duplicate(VECTOR_ELT(GET_SLOT(a, Matrix_DimNamesSym), 1)));
SET_VECTOR_ELT(dn, 1,
duplicate(VECTOR_ELT(GET_SLOT(b_M, Matrix_DimNamesSym), 1)));
UNPROTECT(nprot);
return chm_dense_to_SEXP(chc, 1, 0, dn);
}
/**
* 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);
}
}
/*
* 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;
}
