SEXP Csparse_diagU2N(SEXP x)
{
const char *cl = class_P(x);
/* dtCMatrix, etc; [1] = the second character =?= 't' for triangular */
if (cl[1] != 't' || *diag_P(x) != 'U') {
/* "trivially fast" when not triangular (<==> no 'diag' slot),
or not *unit* triangular */
return (x);
}
else { /* unit triangular (diag='U'): "fill the diagonal" & diag:= "N" */
CHM_SP chx = AS_CHM_SP__(x);
CHM_SP eye = cholmod_speye(chx->nrow, chx->ncol, chx->xtype, &c);
double one[] = {1, 0};
CHM_SP ans = cholmod_add(chx, eye, one, one, TRUE, TRUE, &c);
int uploT = (*uplo_P(x) == 'U') ? 1 : -1;
int Rkind = (chx->xtype != CHOLMOD_PATTERN) ? Real_kind(x) : 0;
R_CheckStack();
cholmod_free_sparse(&eye, &c);
return chm_sparse_to_SEXP(ans, 1, uploT, Rkind, "N",
GET_SLOT(x, Matrix_DimNamesSym));
}
}
void MultivariateFNormalSufficientSparse::set_Sigma(
const SparseMatrix<double>& Sigma)
{
if (Sigma.cols() != Sigma.rows()) {
IMP_THROW("need a square matrix!", ModelException);
}
//std::cout << "set_sigma" << std::endl;
if (Sigma_) cholmod_free_sparse(&Sigma_, c_);
cholmod_sparse A(Eigen::viewAsCholmod(
Sigma.selfadjointView<Eigen::Upper>()));
Sigma_=cholmod_copy_sparse(&A, c_);
//cholmod_print_sparse(Sigma_,"Sigma",c_);
IMP_LOG(TERSE, "MVNsparse: set Sigma to new matrix" << std::endl);
IMP_LOG(TERSE, "MVNsparse: computing Cholesky decomposition"
<< std::endl);
// compute Cholesky decomposition for determinant and inverse
//c_->final_asis=1; // setup LDLT calculation
//c_->supernodal = CHOLMOD_SIMPLICIAL;
// convert matrix to cholmod format
//symbolic and numeric factorization
L_ = cholmod_analyze(Sigma_, c_);
int success = cholmod_factorize(Sigma_, L_, c_);
//cholmod_print_factor(L_,"L",c_);
if (success == 0 || L_->minor < L_->n)
IMP_THROW("Sigma matrix is not positive semidefinite!",
ModelException);
// determinant and derived constants
cholmod_factor *Lcp(cholmod_copy_factor(L_, c_));
cholmod_sparse *Lsp(cholmod_factor_to_sparse(Lcp,c_));
double logDetSigma=0;
if ((Lsp->itype != CHOLMOD_INT) &&
(Lsp->xtype != CHOLMOD_REAL))
IMP_THROW("types are not int and real, update them here first",
ModelException);
int *p=(int*) Lsp->p;
double *x=(double*) Lsp->x;
for (size_t i=0; i < (size_t) M_; ++i)
logDetSigma += std::log(x[p[i]]);
cholmod_free_sparse(&Lsp,c_);
cholmod_free_factor(&Lcp,c_);
IMP_LOG(TERSE, "MVNsparse: log det(Sigma) = "
<< logDetSigma << std::endl);
IMP_LOG(TERSE, "MVNsparse: det(Sigma) = "
<< exp(logDetSigma) << std::endl);
norm_= std::pow(2*IMP::PI, -double(N_*M_)/2.0)
* exp(-double(N_)/2.0*logDetSigma);
lnorm_=double(N_*M_)/2 * log(2*IMP::PI) + double(N_)/2 * logDetSigma;
IMP_LOG(TERSE, "MVNsparse: norm = " << norm_ << " lnorm = "
<< lnorm_ << std::endl);
//inverse
IMP_LOG(TERSE, "MVNsparse: solving for inverse" << std::endl);
cholmod_sparse* id = cholmod_speye(M_,M_,CHOLMOD_REAL,c_);
if (P_) cholmod_free_sparse(&P_, c_);
P_ = cholmod_spsolve(CHOLMOD_A, L_, id, c_);
cholmod_free_sparse(&id, c_);
if (!P_) IMP_THROW("Unable to solve for inverse!", ModelException);
//WP
IMP_LOG(TERSE, "MVNsparse: solving for PW" << std::endl);
if (PW_) cholmod_free_sparse(&PW_, c_);
PW_ = cholmod_spsolve(CHOLMOD_A, L_, W_, c_);
if (!PW_) IMP_THROW("Unable to solve for PW!", ModelException);
IMP_LOG(TERSE, "MVNsparse: done" << std::endl);
}
/**
* Populate ans with the pointers from x and modify its scalar
* elements accordingly. Note that later changes to the contents of
* ans will change the contents of the SEXP.
*
* In most cases this function is called through the macros
* AS_CHM_SP() or AS_CHM_SP__(). It is unusual to call it directly.
*
* @param ans a CHM_SP pointer
* @param x pointer to an object that inherits from CsparseMatrix
* @param check_Udiag boolean - should a check for (and consequent
* expansion of) a unit diagonal be performed.
* @param sort_in_place boolean - if the i and x slots are to be sorted
* should they be sorted in place? If the i and x slots are pointers
* to an input SEXP they should not be modified.
*
* @return ans containing pointers to the slots of x, *unless*
* check_Udiag and x is unitriangular.
*/
CHM_SP as_cholmod_sparse(CHM_SP ans, SEXP x,
Rboolean check_Udiag, Rboolean sort_in_place)
{
static const char *valid[] = { MATRIX_VALID_Csparse, ""};
int *dims = INTEGER(GET_SLOT(x, Matrix_DimSym)),
ctype = R_check_class_etc(x, valid);
SEXP islot = GET_SLOT(x, Matrix_iSym);
if (ctype < 0) error(_("invalid class of object to as_cholmod_sparse"));
if (!isValid_Csparse(x))
error(_("invalid object passed to as_cholmod_sparse"));
memset(ans, 0, sizeof(cholmod_sparse)); /* zero the struct */
ans->itype = CHOLMOD_INT; /* characteristics of the system */
ans->dtype = CHOLMOD_DOUBLE;
ans->packed = TRUE;
/* slots always present */
ans->i = INTEGER(islot);
ans->p = INTEGER(GET_SLOT(x, Matrix_pSym));
/* dimensions and nzmax */
ans->nrow = dims[0];
ans->ncol = dims[1];
/* Allow for over-allocation of the i and x slots. Needed for
* sparse X form in lme4. Right now it looks too difficult to
* check for the length of the x slot, because of the xpt
* utility, but the lengths of x and i should agree. */
ans->nzmax = LENGTH(islot);
/* values depending on ctype */
ans->x = xpt(ctype, x);
ans->stype = stype(ctype, x);
ans->xtype = xtype(ctype);
/* are the columns sorted (increasing row numbers) ?*/
ans->sorted = check_sorted_chm(ans);
if (!(ans->sorted)) { /* sort columns */
if(sort_in_place) {
if (!cholmod_sort(ans, &c))
error(_("in_place cholmod_sort returned an error code"));
ans->sorted = 1;
}
else {
CHM_SP tmp = cholmod_copy_sparse(ans, &c);
if (!cholmod_sort(tmp, &c))
error(_("cholmod_sort returned an error code"));
#ifdef DEBUG_Matrix
/* This "triggers" exactly for return values of dtCMatrix_sparse_solve():*/
/* Don't want to translate this: want it report */
Rprintf("Note: as_cholmod_sparse() needed cholmod_sort()ing\n");
#endif
chm2Ralloc(ans, tmp);
cholmod_free_sparse(&tmp, &c);
}
}
if (check_Udiag && ctype % 3 == 2 // triangular
&& (*diag_P(x) == 'U')) { /* diagU2N(.) "in place" : */
double one[] = {1, 0};
CHM_SP eye = cholmod_speye(ans->nrow, ans->ncol, ans->xtype, &c);
CHM_SP tmp = cholmod_add(ans, eye, one, one, TRUE, TRUE, &c);
#ifdef DEBUG_Matrix_verbose /* happens quite often, e.g. in ../tests/indexing.R : */
Rprintf("Note: as_cholmod_sparse(<ctype=%d>) - diagU2N\n", ctype);
#endif
chm2Ralloc(ans, tmp);
cholmod_free_sparse(&tmp, &c);
cholmod_free_sparse(&eye, &c);
} /* else :
* NOTE: if(*diag_P(x) == 'U'), the diagonal is lost (!);
* ---- that may be ok, e.g. if we are just converting from/to Tsparse,
* but is *not* at all ok, e.g. when used before matrix products */
return ans;
}
