SEXP tmb_invQ(SEXP Lfac){ CHM_FR L=AS_CHM_FR(Lfac); cholmod_common c; M_R_cholmod_start(&c); CHM_SP iQ = tmb_inv_super(L, &c); return M_chm_sparse_to_SEXP(iQ, 1 /* Free */ , 0, 0, "", R_NilValue); }
SEXP destructive_CHM_update(SEXP object, SEXP parent, SEXP mult) { CHM_FR L = AS_CHM_FR(object); CHM_SP A = AS_CHM_SP__(parent); R_CheckStack(); return chm_factor_to_SEXP(chm_factor_update(L, A, asReal(mult)), 0); }
SEXP tmb_invQ_tril_halfdiag(SEXP Lfac){ CHM_FR L=AS_CHM_FR(Lfac); cholmod_common c; M_R_cholmod_start(&c); CHM_SP iQ = tmb_inv_super(L, &c); half_diag(iQ); iQ->stype=0; /* Change to non-sym */ return M_chm_sparse_to_SEXP(iQ, 1 /* Free */ , 0, 0, "", R_NilValue); }
SEXP CHMfactor_update(SEXP object, SEXP parent, SEXP mult) { CHM_FR L = AS_CHM_FR(object), Lcp; CHM_SP A = AS_CHM_SP__(parent); R_CheckStack(); Lcp = cholmod_copy_factor(L, &c); return chm_factor_to_SEXP(chm_factor_update(Lcp, A, asReal(mult)), 1); }
/** * Return a CHOLMOD copy of the cached Cholesky decomposition with the * required perm, LDL and super attributes. If Imult is nonzero, * update the numeric values before returning. * * If no cached copy is available then evaluate one, cache it (for * zero Imult), and return a copy. * * @param Ap dsCMatrix object * @param perm integer indicating if permutation is required (>0), * forbidden (0) or optional (<0) * @param LDL integer indicating if the LDL' form is required (>0), * forbidden (0) or optional (<0) * @param super integer indicating if the supernodal form is required (>0), * forbidden (0) or optional (<0) * @param Imult numeric multiplier of I in |A + Imult * I| */ static CHM_FR internal_chm_factor(SEXP Ap, int perm, int LDL, int super, double Imult) { SEXP facs = GET_SLOT(Ap, Matrix_factorSym); SEXP nms = getAttrib(facs, R_NamesSymbol); int sup, ll; CHM_FR L; CHM_SP A = AS_CHM_SP__(Ap); R_CheckStack(); if (LENGTH(facs)) { for (int i = 0; i < LENGTH(nms); i++) { /* look for a match in cache */ if (chk_nm(CHAR(STRING_ELT(nms, i)), perm, LDL, super)) { L = AS_CHM_FR(VECTOR_ELT(facs, i)); R_CheckStack(); /* copy the factor so later it can safely be cholmod_l_free'd */ L = cholmod_l_copy_factor(L, &c); if (Imult) cholmod_l_factorize_p(A, &Imult, (int*)NULL, 0, L, &c); return L; } } } /* No cached factor - create one */ sup = c.supernodal; /* save current settings */ ll = c.final_ll; c.final_ll = (LDL == 0) ? 1 : 0; c.supernodal = (super > 0) ? CHOLMOD_SUPERNODAL : CHOLMOD_SIMPLICIAL; if (perm) { /* obtain fill-reducing permutation */ L = cholmod_l_analyze(A, &c); } else { /* require identity permutation */ /* save current settings */ int nmethods = c.nmethods, ord0 = c.method[0].ordering, postorder = c.postorder; c.nmethods = 1; c.method[0].ordering = CHOLMOD_NATURAL; c.postorder = FALSE; L = cholmod_l_analyze(A, &c); /* and now restore */ c.nmethods = nmethods; c.method[0].ordering = ord0; c.postorder = postorder; } if (!cholmod_l_factorize_p(A, &Imult, (int*)NULL, 0 /*fsize*/, L, &c)) error(_("Cholesky factorization failed")); c.supernodal = sup; /* restore previous settings */ c.final_ll = ll; if (!Imult) { /* cache the factor */ char fnm[12] = "sPDCholesky"; if (super > 0) fnm[0] = 'S'; if (perm == 0) fnm[1] = 'p'; if (LDL == 0) fnm[2] = 'd'; set_factors(Ap, chm_factor_to_SEXP(L, 0), fnm); } return L; }
SEXP CHMfactor_updown(SEXP upd, SEXP C_, SEXP L_) { CHM_FR L = AS_CHM_FR(L_), Lcp; CHM_SP C = AS_CHM_SP__(C_); int update = asInteger(upd); R_CheckStack(); Lcp = cholmod_copy_factor(L, &c); int r = cholmod_updown(update, C, Lcp, &c); if(!r) error(_("cholmod_updown() returned %d"), r); return chm_factor_to_SEXP(Lcp, 1); }
SEXP CHMfactor_to_sparse(SEXP x) { CHM_FR L = AS_CHM_FR(x), Lcp; CHM_SP Lm; R_CheckStack(); /* cholmod_factor_to_sparse changes its first argument. Make a copy */ Lcp = cholmod_copy_factor(L, &c); if (!(Lcp->is_ll)) if (!cholmod_change_factor(Lcp->xtype, 1, 0, 1, 1, Lcp, &c)) error(_("cholmod_change_factor failed with status %d"), c.status); Lm = cholmod_factor_to_sparse(Lcp, &c); cholmod_free_factor(&Lcp, &c); return chm_sparse_to_SEXP(Lm, 1/*do_free*/, -1/*uploT*/, 0/*Rkind*/, "N"/*non_unit*/, R_NilValue/*dimNames*/); }
SEXP CHMfactor_ldetL2up(SEXP x, SEXP parent, SEXP mult) { SEXP ans = PROTECT(duplicate(mult)); int i, nmult = LENGTH(mult); double *aa = REAL(ans), *mm = REAL(mult); CHM_FR L = AS_CHM_FR(x), Lcp; CHM_SP A = AS_CHM_SP__(parent); R_CheckStack(); Lcp = cholmod_copy_factor(L, &c); for (i = 0; i < nmult; i++) aa[i] = chm_factor_ldetL2(chm_factor_update(Lcp, A, mm[i])); cholmod_free_factor(&Lcp, &c); UNPROTECT(1); return ans; }
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 CHMfactor_spsolve(SEXP a, SEXP b, SEXP system) { CHM_FR L = AS_CHM_FR(a); CHM_SP B = AS_CHM_SP__(b); 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")); // dimnames: SEXP dn = PROTECT(allocVector(VECSXP, 2)); // none from a: our CHMfactor objects have no dimnames SET_VECTOR_ELT(dn, 1, duplicate(VECTOR_ELT(GET_SLOT(b, Matrix_DimNamesSym), 1))); UNPROTECT(1); return chm_sparse_to_SEXP(cholmod_spsolve(sys, L, B, &c), 1/*do_free*/, 0/*uploT*/, 0/*Rkind*/, "", dn); }
SEXP CHMfactor_ldetL2(SEXP x) { CHM_FR L = AS_CHM_FR(x); R_CheckStack(); return ScalarReal(chm_factor_ldetL2(L)); }