SEXP Csparse_vertcat(SEXP x, SEXP y)
{
CHM_SP chx = AS_CHM_SP__(x), chy = AS_CHM_SP__(y);
int Rk_x = (chx->xtype != CHOLMOD_PATTERN) ? Real_kind(x) : 0,
Rk_y = (chy->xtype != CHOLMOD_PATTERN) ? Real_kind(y) : 0,
Rkind = /* logical if both x and y are */ (Rk_x == 1 && Rk_y == 1) ? 1 : 0;
R_CheckStack();
/* TODO: currently drops dimnames - and we fix at R level */
return chm_sparse_to_SEXP(cholmod_l_vertcat(chx, chy, 1, &c),
1, 0, Rkind, "", R_NilValue);
}
SEXP Csparse_diagN2U(SEXP x)
{
const char *cl = class_P(x);
/* dtCMatrix, etc; [1] = the second character =?= 't' for triangular */
if (cl[1] != 't' || *diag_P(x) != 'N') {
/* "trivially fast" when not triangular (<==> no 'diag' slot),
or already *unit* triangular */
return (x);
}
else { /* triangular with diag='N'): now drop the diagonal */
/* duplicate, since chx will be modified: */
SEXP xx = PROTECT(duplicate(x));
CHM_SP chx = AS_CHM_SP__(xx);
int uploT = (*uplo_P(x) == 'U') ? 1 : -1,
Rkind = (chx->xtype != CHOLMOD_PATTERN) ? Real_kind(x) : 0;
R_CheckStack();
chm_diagN2U(chx, uploT, /* do_realloc */ FALSE);
UNPROTECT(1);
return chm_sparse_to_SEXP(chx, /*dofree*/ 0/* or 1 ?? */,
uploT, Rkind, "U",
GET_SLOT(x, Matrix_DimNamesSym));
}
}
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 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);
}
SEXP Csparse_band(SEXP x, SEXP k1, SEXP k2)
{
CHM_SP chx = AS_CHM_SP__(x);
int Rkind = (chx->xtype != CHOLMOD_PATTERN) ? Real_kind(x) : 0;
CHM_SP ans = cholmod_l_band(chx, asInteger(k1), asInteger(k2), chx->xtype, &c);
R_CheckStack();
return chm_sparse_to_SEXP(ans, 1, 0, Rkind, "",
GET_SLOT(x, Matrix_DimNamesSym));
}
/**
* 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);
}
// FIXME: do not go via CHM (should not be too hard, to just *drop* the x-slot, right?
SEXP Csparse_to_nz_pattern(SEXP x, SEXP tri)
{
CHM_SP chxs = AS_CHM_SP__(x);
CHM_SP chxcp = cholmod_l_copy(chxs, chxs->stype, CHOLMOD_PATTERN, &c);
int tr = asLogical(tri);
R_CheckStack();
return chm_sparse_to_SEXP(chxcp, 1/*do_free*/,
tr ? ((*uplo_P(x) == 'U') ? 1 : -1) : 0,
0, tr ? diag_P(x) : "",
GET_SLOT(x, Matrix_DimNamesSym));
}
/* Can only return [dln]geMatrix (no symm/triang);
* FIXME: replace by non-CHOLMOD code ! */
SEXP Csparse_to_dense(SEXP x)
{
CHM_SP chxs = AS_CHM_SP__(x);
/* This loses the symmetry property, since cholmod_dense has none,
* BUT, much worse (FIXME!), it also transforms CHOLMOD_PATTERN ("n") matrices
* to numeric (CHOLMOD_REAL) ones : */
CHM_DN chxd = cholmod_l_sparse_to_dense(chxs, &c);
int Rkind = (chxs->xtype == CHOLMOD_PATTERN)? -1 : Real_kind(x);
R_CheckStack();
return chm_dense_to_SEXP(chxd, 1, Rkind, GET_SLOT(x, Matrix_DimNamesSym));
}
SEXP Csparse_general_to_symmetric(SEXP x, SEXP uplo)
{
CHM_SP chx = AS_CHM_SP__(x), chgx;
int uploT = (*CHAR(STRING_ELT(uplo,0)) == 'U') ? 1 : -1;
int Rkind = (chx->xtype != CHOLMOD_PATTERN) ? Real_kind(x) : 0;
R_CheckStack();
chgx = cholmod_l_copy(chx, /* stype: */ uploT, chx->xtype, &c);
/* xtype: pattern, "real", complex or .. */
return chm_sparse_to_SEXP(chgx, 1, 0, Rkind, "",
GET_SLOT(x, Matrix_DimNamesSym));
}
/* this used to be called sCMatrix_to_gCMatrix(..) [in ./dsCMatrix.c ]: */
SEXP Csparse_symmetric_to_general(SEXP x)
{
CHM_SP chx = AS_CHM_SP__(x), chgx;
int Rkind = (chx->xtype != CHOLMOD_PATTERN) ? Real_kind(x) : 0;
R_CheckStack();
if (!(chx->stype))
error(_("Nonsymmetric matrix in Csparse_symmetric_to_general"));
chgx = cholmod_l_copy(chx, /* stype: */ 0, chx->xtype, &c);
/* xtype: pattern, "real", complex or .. */
return chm_sparse_to_SEXP(chgx, 1, 0, Rkind, "",
GET_SLOT(x, Matrix_DimNamesSym));
}
SEXP Csparse_to_Tsparse(SEXP x, SEXP tri)
{
CHM_SP chxs = AS_CHM_SP__(x);
CHM_TR chxt = cholmod_l_sparse_to_triplet(chxs, &c);
int tr = asLogical(tri);
int Rkind = (chxs->xtype != CHOLMOD_PATTERN) ? Real_kind(x) : 0;
R_CheckStack();
return chm_triplet_to_SEXP(chxt, 1,
tr ? ((*uplo_P(x) == 'U') ? 1 : -1) : 0,
Rkind, tr ? diag_P(x) : "",
GET_SLOT(x, Matrix_DimNamesSym));
}
/* FIXME: Create a more general version of this operation: also for lsC, (dsR?),..
* e.g. make compressed_to_dgTMatrix() in ./dgCMatrix.c work for dsC */
SEXP dsCMatrix_to_dgTMatrix(SEXP x)
{
CHM_SP A = AS_CHM_SP__(x);
CHM_SP Afull = cholmod_l_copy(A, /*stype*/ 0, /*mode*/ 1, &c);
CHM_TR At = cholmod_l_sparse_to_triplet(Afull, &c);
R_CheckStack();
if (!A->stype)
error("Non-symmetric matrix passed to dsCMatrix_to_dgTMatrix");
cholmod_l_free_sparse(&Afull, &c);
return chm_triplet_to_SEXP(At, 1, /*uploT*/ 0, /*Rkind*/ 0, "",
GET_SLOT(x, Matrix_DimNamesSym));
}
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;
}
/* Csparse_drop(x, tol): drop entries with absolute value < tol, i.e,
* at least all "explicit" zeros */
SEXP Csparse_drop(SEXP x, SEXP tol)
{
const char *cl = class_P(x);
/* dtCMatrix, etc; [1] = the second character =?= 't' for triangular */
int tr = (cl[1] == 't');
CHM_SP chx = AS_CHM_SP__(x);
CHM_SP ans = cholmod_l_copy(chx, chx->stype, chx->xtype, &c);
double dtol = asReal(tol);
int Rkind = (chx->xtype != CHOLMOD_PATTERN) ? Real_kind(x) : 0;
R_CheckStack();
if(!cholmod_l_drop(dtol, ans, &c))
error(_("cholmod_l_drop() failed"));
return chm_sparse_to_SEXP(ans, 1,
tr ? ((*uplo_P(x) == 'U') ? 1 : -1) : 0,
Rkind, tr ? diag_P(x) : "",
GET_SLOT(x, Matrix_DimNamesSym));
}
SEXP Csparse_transpose(SEXP x, SEXP tri)
{
/* TODO: lgCMatrix & igC* currently go via double prec. cholmod -
* since cholmod (& cs) lacks sparse 'int' matrices */
CHM_SP chx = AS_CHM_SP__(x);
int Rkind = (chx->xtype != CHOLMOD_PATTERN) ? Real_kind(x) : 0;
CHM_SP chxt = cholmod_l_transpose(chx, chx->xtype, &c);
SEXP dn = PROTECT(duplicate(GET_SLOT(x, Matrix_DimNamesSym))), tmp;
int tr = asLogical(tri);
R_CheckStack();
tmp = VECTOR_ELT(dn, 0); /* swap the dimnames */
SET_VECTOR_ELT(dn, 0, VECTOR_ELT(dn, 1));
SET_VECTOR_ELT(dn, 1, tmp);
UNPROTECT(1);
return chm_sparse_to_SEXP(chxt, 1, /* SWAP 'uplo' for triangular */
tr ? ((*uplo_P(x) == 'U') ? -1 : 1) : 0,
Rkind, tr ? diag_P(x) : "", dn);
}
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 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_l_speye(chx->nrow, chx->ncol, chx->xtype, &c);
double one[] = {1, 0};
CHM_SP ans = cholmod_l_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_l_free_sparse(&eye, &c);
return chm_sparse_to_SEXP(ans, 1, uploT, Rkind, "N",
GET_SLOT(x, Matrix_DimNamesSym));
}
}
SEXP Csparse_to_matrix(SEXP x)
{
return chm_dense_to_matrix(cholmod_l_sparse_to_dense(AS_CHM_SP__(x), &c),
1 /*do_free*/, GET_SLOT(x, Matrix_DimNamesSym));
}
/**
* colSums(), colMeans(), rowSums() and rowMeans() for all sparce *gCMatrix()es
* @param x a ?gCMatrix, i.e. sparse column-compressed Matrix
* @param NArm logical indicating if NA's should be remove 'na.rm' in R
* @param spRes logical = 'sparseResult' indicating if result should be sparse
* @param trans logical: TRUE <==> row[Sums/Means] <==> compute col*s( t(x) )
* @param means logical: TRUE <==> compute [row/col]Means() , not *Sums()
*/
SEXP gCMatrix_colSums(SEXP x, SEXP NArm, SEXP spRes, SEXP trans, SEXP means)
{
int mn = asLogical(means), sp = asLogical(spRes), tr = asLogical(trans);
/* cholmod_sparse: drawback of coercing lgC to double: */
CHM_SP cx = AS_CHM_SP__(x);
R_CheckStack();
if (tr) {
cholmod_sparse *cxt = cholmod_transpose(cx, (int)cx->xtype, &c);
cx = cxt;
}
/* everything else *after* the above potential transpose : */
int j, nc = cx->ncol;
int *xp = (int *)(cx -> p);
#ifdef _has_x_slot_
int na_rm = asLogical(NArm), // can have NAs only with an 'x' slot
i, dnm = 0/*Wall*/;
double *xx = (double *)(cx -> x);
#endif
// result value: sparseResult (==> "*sparseVector") or dense (atomic)vector
SEXP ans = PROTECT(sp ? NEW_OBJECT(MAKE_CLASS(SparseResult_class))
: allocVector(SXP_ans, nc));
if (sp) { // sparseResult, i.e. *sparseVector (never allocating length-nc)
int nza, i1, i2, p, *ai;
Type_ans *ax;
for (j = 0, nza = 0; j < nc; j++)
if(xp[j] < xp[j + 1])
nza++;
ai = INTEGER(ALLOC_SLOT(ans, Matrix_iSym, INTSXP, nza));
ax = STYP_ans(ALLOC_SLOT(ans, Matrix_xSym, SXP_ans, nza));
SET_SLOT(ans, Matrix_lengthSym, ScalarInteger(nc));
i2 = xp[0];
for (j = 1, p = 0; j <= nc; j++) {
/* j' =j+1, since 'i' slot will be 1-based */
i1 = i2; i2 = xp[j];
if(i1 < i2) {
Type_ans sum;
ColSUM_column(i1,i2, sum);
ai[p] = j;
ax[p++] = sum;
}
}
}
else { /* "numeric" (non sparse) result */
Type_ans *a = STYP_ans(ans);
for (j = 0; j < nc; j++) {
ColSUM_column(xp[j], xp[j + 1], a[j]);
}
}
if (tr) cholmod_free_sparse(&cx, &c);
if (!sp) {
SEXP nms = VECTOR_ELT(GET_SLOT(x, Matrix_DimNamesSym), tr ? 0 : 1);
if (!isNull(nms))
setAttrib(ans, R_NamesSymbol, duplicate(nms));
}
UNPROTECT(1);
return ans;
}