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; }