/**
* "Indexing" aka subsetting : Compute x[i,j], also for vectors i and j
* Working via CHOLMOD_submatrix, see ./CHOLMOD/MatrixOps/cholmod_submatrix.c
* @param x CsparseMatrix
* @param i row indices (0-origin), or NULL (R's)
* @param j columns indices (0-origin), or NULL
*
* @return x[i,j] still CsparseMatrix --- currently, this loses dimnames
*/
SEXP Csparse_submatrix(SEXP x, SEXP i, SEXP j)
{
CHM_SP chx = AS_CHM_SP(x); /* << does diagU2N() when needed */
int rsize = (isNull(i)) ? -1 : LENGTH(i),
csize = (isNull(j)) ? -1 : LENGTH(j);
int Rkind = (chx->xtype != CHOLMOD_PATTERN) ? Real_kind(x) : 0;
R_CheckStack();
if (rsize >= 0 && !isInteger(i))
error(_("Index i must be NULL or integer"));
if (csize >= 0 && !isInteger(j))
error(_("Index j must be NULL or integer"));
if (!chx->stype) {/* non-symmetric Matrix */
return chm_sparse_to_SEXP(cholmod_submatrix(chx,
(rsize < 0) ? NULL : INTEGER(i), rsize,
(csize < 0) ? NULL : INTEGER(j), csize,
TRUE, TRUE, &c),
1, 0, Rkind, "",
/* FIXME: drops dimnames */ R_NilValue);
}
/* for now, cholmod_submatrix() only accepts "generalMatrix" */
CHM_SP tmp = cholmod_copy(chx, /* stype: */ 0, chx->xtype, &c);
CHM_SP ans = cholmod_submatrix(tmp,
(rsize < 0) ? NULL : INTEGER(i), rsize,
(csize < 0) ? NULL : INTEGER(j), csize,
TRUE, TRUE, &c);
cholmod_free_sparse(&tmp, &c);
return chm_sparse_to_SEXP(ans, 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 dsCMatrix_chol(SEXP x, SEXP pivot)
{
cholmod_factor
*N = as_cholmod_factor(dsCMatrix_Cholesky(x, pivot,
ScalarLogical(FALSE),
ScalarLogical(FALSE)));
/* Must use a copy; cholmod_factor_to_sparse modifies first arg. */
cholmod_factor *Ncp = cholmod_copy_factor(N, &c);
cholmod_sparse *L, *R;
SEXP ans;
L = cholmod_factor_to_sparse(Ncp, &c); cholmod_free_factor(&Ncp, &c);
R = cholmod_transpose(L, /*values*/ 1, &c); cholmod_free_sparse(&L, &c);
ans = PROTECT(chm_sparse_to_SEXP(R, /*cholmod_free*/ 1,
/*uploT*/ 1, /*diag*/ "N",
GET_SLOT(x, Matrix_DimNamesSym)));
if (asLogical(pivot)) {
SEXP piv = PROTECT(allocVector(INTSXP, N->n));
int *dest = INTEGER(piv), *src = (int*)N->Perm, i;
for (i = 0; i < N->n; i++) dest[i] = src[i] + 1;
setAttrib(ans, install("pivot"), piv);
/* FIXME: Because of the cholmod_factor -> S4 obj ->
* cholmod_factor conversions, the value of N->minor will
* always be N->n. Change as_cholmod_factor and
* chm_factor_as_SEXP to keep track of Minor.
*/
setAttrib(ans, install("rank"), ScalarInteger((size_t) N->minor));
UNPROTECT(1);
}
Free(N);
UNPROTECT(1);
return ans;
}
SEXP dsCMatrix_chol(SEXP x, SEXP pivot)
{
int pivP = asLogical(pivot);
CHM_FR L = internal_chm_factor(x, pivP, 0, 0, 0.);
CHM_SP R, Rt;
SEXP ans;
Rt = cholmod_l_factor_to_sparse(L, &c);
R = cholmod_l_transpose(Rt, /*values*/ 1, &c);
cholmod_l_free_sparse(&Rt, &c);
ans = PROTECT(chm_sparse_to_SEXP(R, 1/*do_free*/, 1/*uploT*/, 0/*Rkind*/,
"N"/*diag*/, GET_SLOT(x, Matrix_DimNamesSym)));
if (pivP) {
SEXP piv = PROTECT(allocVector(INTSXP, L->n));
int *dest = INTEGER(piv), *src = (int*)L->Perm;
for (int i = 0; i < L->n; i++) dest[i] = src[i] + 1;
setAttrib(ans, install("pivot"), piv);
setAttrib(ans, install("rank"), ScalarInteger((size_t) L->minor));
UNPROTECT(1);
}
cholmod_l_free_factor(&L, &c);
UNPROTECT(1);
return ans;
}
SEXP dense_to_Csparse(SEXP x)
{
CHM_DN chxd = AS_CHM_xDN(PROTECT(mMatrix_as_geMatrix(x)));
/* cholmod_dense_to_sparse() in CHOLMOD/Core/ below does only work for
"REAL" 'xtypes', i.e. *not* for "nMatrix".
===> need "_x" in above AS_CHM_xDN() call.
Also it cannot keep symmetric / triangular, hence the
as_geMatrix() above. Note that this is already a *waste* for
symmetric matrices; However, we could conceivably use an
enhanced cholmod_dense_to_sparse(), with an extra boolean
argument for symmetry.
*/
CHM_SP chxs = cholmod_dense_to_sparse(chxd, 1, &c);
int Rkind = (chxd->xtype == CHOLMOD_REAL) ? Real_KIND2(x) : 0;
/* Note: when 'x' was integer Matrix, Real_KIND(x) = -1, but *_KIND2(.) = 0 */
R_CheckStack();
UNPROTECT(1);
/* chm_sparse_to_SEXP() *could* deal with symmetric
* if chxs had such an stype; and we should be able to use uplo below */
return chm_sparse_to_SEXP(chxs, 1, 0/*TODO: uplo_P(x) if x has an uplo slot*/,
Rkind, "",
isMatrix(x) ? getAttrib(x, R_DimNamesSymbol)
: GET_SLOT(x, Matrix_DimNamesSym));
}
SEXP csc_transpose(SEXP x)
{
cholmod_sparse *chx = as_cholmod_sparse(x);
SEXP ans =
chm_sparse_to_SEXP(cholmod_transpose(chx, 1, &c), 1);
Free(chx);
return ans;
}
SEXP dense_to_Csparse(SEXP x)
{
cholmod_dense *chxd = as_cholmod_dense(x);
cholmod_sparse *chxs = cholmod_dense_to_sparse(chxd, 1, &c);
Free(chxd);
return chm_sparse_to_SEXP(chxs, 1);
}
SEXP dtTMatrix_as_dgCMatrix(SEXP x)
{
cholmod_triplet *tx = as_cholmod_triplet(x);
cholmod_sparse *cx = cholmod_triplet_to_sparse(tx, tx->nzmax, &c);
Free(tx);
/* chm_sparse_to_SEXP cholmod_frees cx */
return chm_sparse_to_SEXP(cx, 1, 0, "",
GET_SLOT(x, Matrix_DimNamesSym));
}
SEXP csc_tcrossprod(SEXP x)
{
cholmod_sparse *cha = cholmod_aat(as_cholmod_sparse(x),
(int *) NULL, 0, 1, &c);
cha->stype = -1; /* set the symmetry */
cholmod_sort(cha, &c); /* drop redundant entries */
return chm_sparse_to_SEXP(cha, -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));
}
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));
}
// 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));
}
SEXP dsCMatrix_Csparse_solve(SEXP a, SEXP b)
{
CHM_FR L = internal_chm_factor(a, -1, -1, -1, 0.);
CHM_SP cx, cb = AS_CHM_SP(b);
R_CheckStack();
cx = cholmod_l_spsolve(CHOLMOD_A, L, cb, &c);
cholmod_l_free_factor(&L, &c);
return chm_sparse_to_SEXP(cx, /*do_free*/ 1, /*uploT*/ 0,
/*Rkind*/ 0, /*diag*/ "N",
/*dimnames = */ R_NilValue);
}
/* Should generalize this, also for ltT -> lgC --
* along the lines in ./TMatrix_as.c ..... or drop completely : */
SEXP dtTMatrix_as_dgCMatrix(SEXP x)
{
CHM_TR tx = AS_CHM_TR(x);
CHM_SP cx = cholmod_triplet_to_sparse(tx, tx->nzmax, &c);
R_CheckStack();
/* FIXME
* int Rkind = (tx->xtype == CHOLMOD_REAL) ? Real_kind(x) : 0;
*/
return chm_sparse_to_SEXP(cx, 1/*do_free*/, 0, /*Rkind*/ 0, "",
GET_SLOT(x, Matrix_DimNamesSym));
}
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);
}
/**
* Return a SuiteSparse QR factorization of the sparse matrix A
*
* @param Ap (pointer to) a [m x n] dgCMatrix
* @param ordering integer SEXP specifying the ordering strategy to be used
* see SPQR/Include/SuiteSparseQR_definitions.h
* @param econ integer SEXP ("economy"): number of rows of R and columns of Q
* to return. The default is m. Using n gives the standard economy form.
* A value less than the estimated rank r is set to r, so econ=0 gives the
* "rank-sized" factorization, where nrow(R)==nnz(diag(R))==r.
* @param tol double SEXP: if tol <= -2 use SPQR's default,
* if -2 < tol < 0, then no tol is used; otherwise,
* tol > 0, use as tolerance: columns with 2-norm <= tol treated as 0
*
*
* @return SEXP "SPQR" object with slots (Q, R, p, rank, Dim):
* Q: dgCMatrix; R: dgCMatrix [subject to change to dtCMatrix FIXME ?]
* p: integer: 0-based permutation (or length 0 <=> identity);
* rank: integer, the "revealed" rank Dim: integer, original matrix dim.
*/
SEXP dgCMatrix_SPQR(SEXP Ap, SEXP ordering, SEXP econ, SEXP tol)
{
/* SEXP ans = PROTECT(allocVector(VECSXP, 4)); */
SEXP ans = PROTECT(NEW_OBJECT(MAKE_CLASS("SPQR")));
CHM_SP A = AS_CHM_SP(Ap), Q, R;
SuiteSparse_long *E, rank;/* not always = int FIXME (Windows_64 ?) */
if ((rank = SuiteSparseQR_C_QR(asInteger(ordering),
asReal(tol),/* originally had SPQR_DEFAULT_TOL */
(SuiteSparse_long)asInteger(econ),/* originally had 0 */
A, &Q, &R, &E, &cl)) == -1)
error(_("SuiteSparseQR_C_QR returned an error code"));
slot_dup(ans, Ap, Matrix_DimSym);
/* SET_VECTOR_ELT(ans, 0, */
/* chm_sparse_to_SEXP(Q, 0, 0, 0, "", R_NilValue)); */
SET_SLOT(ans, install("Q"),
chm_sparse_to_SEXP(Q, 0, 0, 0, "", R_NilValue));
/* Also gives a dgCMatrix (not a dtC* *triangular*) :
* may make sense if to be used in the "spqr_solve" routines .. ?? */
/* SET_VECTOR_ELT(ans, 1, */
/* chm_sparse_to_SEXP(R, 0, 0, 0, "", R_NilValue)); */
SET_SLOT(ans, install("R"),
chm_sparse_to_SEXP(R, 0, 0, 0, "", R_NilValue));
cholmod_free_sparse(&Al, &cl);
cholmod_free_sparse(&R, &cl);
cholmod_free_sparse(&Q, &cl);
if (E) {
int *Er;
SET_VECTOR_ELT(ans, 2, allocVector(INTSXP, A->ncol));
Er = INTEGER(VECTOR_ELT(ans, 2));
for (int i = 0; i < A->ncol; i++) Er[i] = (int) E[i];
Free(E);
} else SET_VECTOR_ELT(ans, 2, allocVector(INTSXP, 0));
SET_VECTOR_ELT(ans, 3, ScalarInteger((int)rank));
UNPROTECT(1);
return ans;
}
/* 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 Tsparse_to_Csparse(SEXP x, SEXP tri)
{
CHM_TR chxt = AS_CHM_TR__(x); /* << should *preserve* diag = "U" ! */
CHM_SP chxs = cholmod_l_triplet_to_sparse(chxt, chxt->nnz, &c);
int tr = asLogical(tri);
int Rkind = (chxt->xtype != CHOLMOD_PATTERN) ? Real_kind(x) : 0;
R_CheckStack();
return chm_sparse_to_SEXP(chxs, 1,
tr ? ((*uplo_P(x) == 'U') ? 1 : -1) : 0,
Rkind, tr ? diag_P(x) : "",
GET_SLOT(x, Matrix_DimNamesSym));
}
/* speedup utility, needed e.g. after subsetting: */
SEXP Tsparse_to_tCsparse(SEXP x, SEXP uplo, SEXP diag)
{
CHM_TR chxt = AS_CHM_TR__(x);
CHM_SP chxs = cholmod_l_triplet_to_sparse(chxt, chxt->nnz, &c);
int Rkind = (chxt->xtype != CHOLMOD_PATTERN) ? Real_kind(x) : 0;
R_CheckStack();
return chm_sparse_to_SEXP(chxs, 1,
/* uploT = */ (*CHAR(asChar(uplo)) == 'U')? 1: -1,
Rkind,
/* diag = */ CHAR(STRING_ELT(diag, 0)),
GET_SLOT(x, Matrix_DimNamesSym));
}
SEXP Tsparse_to_Csparse(SEXP x, SEXP tri)
{
cholmod_triplet *chxt = as_cholmod_triplet(x);
cholmod_sparse *chxs = cholmod_triplet_to_sparse(chxt, chxt->nnz, &c);
int uploT = 0; char *diag = "";
Free(chxt);
if (asLogical(tri)) { /* triangular sparse matrices */
uploT = (strcmp(CHAR(asChar(GET_SLOT(x, Matrix_uploSym))), "U")) ?
-1 : 1;
diag = CHAR(asChar(GET_SLOT(x, Matrix_diagSym)));
}
return chm_sparse_to_SEXP(chxs, 1, uploT, diag,
duplicate(GET_SLOT(x, Matrix_DimNamesSym)));
}
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*/);
}
/* 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 Csparse_Csparse_prod(SEXP a, SEXP b)
{
CHM_SP
cha = AS_CHM_SP(a),
chb = AS_CHM_SP(b),
chc = cholmod_l_ssmult(cha, chb, /*out_stype:*/ 0,
/* values:= is_numeric (T/F) */ cha->xtype > 0,
/*out sorted:*/ 1, &c);
const char *cl_a = class_P(a), *cl_b = class_P(b);
char diag[] = {'\0', '\0'};
int uploT = 0;
SEXP dn = PROTECT(allocVector(VECSXP, 2));
R_CheckStack();
#ifdef DEBUG_Matrix_verbose
Rprintf("DBG Csparse_C*_prod(%s, %s)\n", cl_a, cl_b);
#endif
/* Preserve triangularity and even unit-triangularity if appropriate.
* Note that in that case, the multiplication itself should happen
* faster. But there's no support for that in CHOLMOD */
/* UGLY hack -- rather should have (fast!) C-level version of
* is(a, "triangularMatrix") etc */
if (cl_a[1] == 't' && cl_b[1] == 't')
/* FIXME: fails for "Cholesky","BunchKaufmann"..*/
if(*uplo_P(a) == *uplo_P(b)) { /* both upper, or both lower tri. */
uploT = (*uplo_P(a) == 'U') ? 1 : -1;
if(*diag_P(a) == 'U' && *diag_P(b) == 'U') { /* return UNIT-triag. */
/* "remove the diagonal entries": */
chm_diagN2U(chc, uploT, /* do_realloc */ FALSE);
diag[0]= 'U';
}
else diag[0]= 'N';
}
SET_VECTOR_ELT(dn, 0, /* establish dimnames */
duplicate(VECTOR_ELT(GET_SLOT(a, Matrix_DimNamesSym), 0)));
SET_VECTOR_ELT(dn, 1,
duplicate(VECTOR_ELT(GET_SLOT(b, Matrix_DimNamesSym), 1)));
UNPROTECT(1);
return chm_sparse_to_SEXP(chc, 1, uploT, /*Rkind*/0, diag, 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);
}
/* Computes x'x or x x' -- *also* for Tsparse (triplet = TRUE)
see Csparse_Csparse_crossprod above for x'y and x y' */
SEXP Csparse_crossprod(SEXP x, SEXP trans, SEXP triplet)
{
int trip = asLogical(triplet),
tr = asLogical(trans); /* gets reversed because _aat is tcrossprod */
#ifdef AS_CHM_DIAGU2N_FIXED_FINALLY
CHM_TR cht = trip ? AS_CHM_TR(x) : (CHM_TR) NULL;
#else /* workaround needed:*/
SEXP xx = PROTECT(Tsparse_diagU2N(x));
CHM_TR cht = trip ? AS_CHM_TR__(xx) : (CHM_TR) NULL;
#endif
CHM_SP chcp, chxt,
chx = (trip ?
cholmod_l_triplet_to_sparse(cht, cht->nnz, &c) :
AS_CHM_SP(x));
SEXP dn = PROTECT(allocVector(VECSXP, 2));
R_CheckStack();
if (!tr) chxt = cholmod_l_transpose(chx, chx->xtype, &c);
chcp = cholmod_l_aat((!tr) ? chxt : chx, (int *) NULL, 0, chx->xtype, &c);
if(!chcp) {
UNPROTECT(1);
error(_("Csparse_crossprod(): error return from cholmod_l_aat()"));
}
cholmod_l_band_inplace(0, chcp->ncol, chcp->xtype, chcp, &c);
chcp->stype = 1;
if (trip) cholmod_l_free_sparse(&chx, &c);
if (!tr) cholmod_l_free_sparse(&chxt, &c);
SET_VECTOR_ELT(dn, 0, /* establish dimnames */
duplicate(VECTOR_ELT(GET_SLOT(x, Matrix_DimNamesSym),
(tr) ? 0 : 1)));
SET_VECTOR_ELT(dn, 1, duplicate(VECTOR_ELT(dn, 0)));
#ifdef AS_CHM_DIAGU2N_FIXED_FINALLY
UNPROTECT(1);
#else
UNPROTECT(2);
#endif
return chm_sparse_to_SEXP(chcp, 1, 0, 0, "", 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_Csparse_crossprod(SEXP a, SEXP b, SEXP trans)
{
int tr = asLogical(trans);
CHM_SP
cha = AS_CHM_SP(a),
chb = AS_CHM_SP(b),
chTr, chc;
const char *cl_a = class_P(a), *cl_b = class_P(b);
char diag[] = {'\0', '\0'};
int uploT = 0;
SEXP dn = PROTECT(allocVector(VECSXP, 2));
R_CheckStack();
chTr = cholmod_l_transpose((tr) ? chb : cha, chb->xtype, &c);
chc = cholmod_l_ssmult((tr) ? cha : chTr, (tr) ? chTr : chb,
/*out_stype:*/ 0, cha->xtype, /*out sorted:*/ 1, &c);
cholmod_l_free_sparse(&chTr, &c);
/* Preserve triangularity and unit-triangularity if appropriate;
* see Csparse_Csparse_prod() for comments */
if (cl_a[1] == 't' && cl_b[1] == 't')
if(*uplo_P(a) != *uplo_P(b)) { /* one 'U', the other 'L' */
uploT = (*uplo_P(b) == 'U') ? 1 : -1;
if(*diag_P(a) == 'U' && *diag_P(b) == 'U') { /* return UNIT-triag. */
chm_diagN2U(chc, uploT, /* do_realloc */ FALSE);
diag[0]= 'U';
}
else diag[0]= 'N';
}
SET_VECTOR_ELT(dn, 0, /* establish dimnames */
duplicate(VECTOR_ELT(GET_SLOT(a, Matrix_DimNamesSym), (tr) ? 0 : 1)));
SET_VECTOR_ELT(dn, 1,
duplicate(VECTOR_ELT(GET_SLOT(b, Matrix_DimNamesSym), (tr) ? 0 : 1)));
UNPROTECT(1);
return chm_sparse_to_SEXP(chc, 1, uploT, /*Rkind*/0, diag, dn);
}