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