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));
}
}
/* to bu used for all three: '%*%', crossprod() and tcrossprod() */
SEXP dtrMatrix_matrix_mm(SEXP a, SEXP b, SEXP right, SEXP trans)
{
/* Because a must be square, the size of the answer, val,
* is the same as the size of b */
SEXP val = PROTECT(dup_mMatrix_as_dgeMatrix(b));
int rt = asLogical(right); /* if(rt), compute b %*% op(a), else op(a) %*% b */
int tr = asLogical(trans);/* if true, use t(a) */
int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)),
*bdims = INTEGER(GET_SLOT(val, Matrix_DimSym));
int m = bdims[0], n = bdims[1];
double one = 1.;
if (adims[0] != adims[1])
error(_("dtrMatrix must be square"));
if ((rt && adims[0] != n) || (!rt && adims[1] != m))
error(_("Matrices are not conformable for multiplication"));
if (m < 1 || n < 1) {
/* error(_("Matrices with zero extents cannot be multiplied")); */
} else /* BLAS */
F77_CALL(dtrmm)(rt ? "R" : "L", uplo_P(a),
/*trans_A = */ tr ? "T" : "N",
diag_P(a), &m, &n, &one,
REAL(GET_SLOT(a, Matrix_xSym)), adims,
REAL(GET_SLOT(val, Matrix_xSym)), &m);
UNPROTECT(1);
return val;
}
SEXP tsc_to_dgTMatrix(SEXP x)
{
SEXP ans;
if (*diag_P(x) != 'U')
ans = compressed_to_dgTMatrix(x, ScalarLogical(1));
else { /* unit triangular matrix */
SEXP islot = GET_SLOT(x, Matrix_iSym),
pslot = GET_SLOT(x, Matrix_pSym);
int *ai, *aj, j,
n = length(pslot) - 1,
nod = length(islot),
nout = n + nod,
*p = INTEGER(pslot);
double *ax;
ans = PROTECT(NEW_OBJECT(MAKE_CLASS("dgTMatrix")));
SET_SLOT(ans, Matrix_DimSym, duplicate(GET_SLOT(x, Matrix_DimSym)));
SET_SLOT(ans, Matrix_iSym, allocVector(INTSXP, nout));
ai = INTEGER(GET_SLOT(ans, Matrix_iSym));
Memcpy(ai, INTEGER(islot), nod);
SET_SLOT(ans, Matrix_jSym, allocVector(INTSXP, nout));
aj = INTEGER(GET_SLOT(ans, Matrix_jSym));
SET_SLOT(ans, Matrix_xSym, allocVector(REALSXP, nout));
ax = REAL(GET_SLOT(ans, Matrix_xSym));
Memcpy(ax, REAL(GET_SLOT(x, Matrix_xSym)), nod);
for (j = 0; j < n; j++) {
int jj, npj = nod + j, p2 = p[j+1];
aj[npj] = ai[npj] = j;
ax[npj] = 1.;
for (jj = p[j]; jj < p2; jj++) aj[jj] = j;
}
UNPROTECT(1);
}
return ans;
}
SEXP dtrMatrix_solve(SEXP a)
{
SEXP val = PROTECT(duplicate(a));
int info, *Dim = INTEGER(GET_SLOT(val, Matrix_DimSym));
F77_CALL(dtrtri)(uplo_P(val), diag_P(val), Dim,
REAL(GET_SLOT(val, Matrix_xSym)), Dim, &info);
UNPROTECT(1);
return val;
}
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);
}
// 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));
}
static int *
install_diagonal_int(int *dest, SEXP A)
{
int nc = INTEGER(GET_SLOT(A, Matrix_DimSym))[0];
int i, ncp1 = nc + 1, unit = *diag_P(A) == 'U';
int *ax = INTEGER(GET_SLOT(A, Matrix_xSym));
AZERO(dest, nc * nc);
for (i = 0; i < nc; i++)
dest[i * ncp1] = (unit) ? 1 : ax[i];
return dest;
}
SEXP dtrMatrix_rcond(SEXP obj, SEXP type)
{
char typnm[] = {'\0', '\0'};
int *dims = INTEGER(GET_SLOT(obj, Matrix_DimSym)), info;
double rcond;
typnm[0] = rcond_type(CHAR(asChar(type)));
F77_CALL(dtrcon)(typnm, uplo_P(obj), diag_P(obj), dims,
REAL(GET_SLOT(obj, Matrix_xSym)), dims, &rcond,
(double *) R_alloc(3*dims[0], sizeof(double)),
(int *) R_alloc(dims[0], sizeof(int)), &info);
return ScalarReal(rcond);
}
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));
}
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));
}
SEXP dtrMatrix_addDiag(SEXP x, SEXP d) {
int n = INTEGER(GET_SLOT(x, Matrix_DimSym))[0];
SEXP ret = PROTECT(duplicate(x)),
r_x = GET_SLOT(ret, Matrix_xSym);
double *dv = REAL(d), *rv = REAL(r_x);
if ('U' == diag_P(x)[0])
error(_("cannot add diag() as long as 'diag = \"U\"'"));
for (int i = 0; i < n; i++) rv[i * (n + 1)] += dv[i];
UNPROTECT(1);
return ret;
}
static
double get_norm(SEXP obj, const char *typstr)
{
char typnm[] = {'\0', '\0'};
int *dims = INTEGER(GET_SLOT(obj, Matrix_DimSym));
double *work = (double *) NULL;
typnm[0] = norm_type(typstr);
if (*typnm == 'I') {
work = (double *) R_alloc(dims[0], sizeof(double));
}
return F77_CALL(dlantr)(typnm, uplo_P(obj), diag_P(obj), dims, dims+1,
REAL(GET_SLOT(obj, Matrix_xSym)), dims, work);
}
void tr_l_packed_getDiag( int *dest, SEXP x)
{
int n = INTEGER(GET_SLOT(x, Matrix_DimSym))[0];
SEXP val = PROTECT(allocVector(LGLSXP, n));
int *v = LOGICAL(val);
if (*diag_P(x) == 'U') {
int j;
for (j = 0; j < n; j++) v[j] = 1;
} else {
l_packed_getDiag(v, x, n);
}
UNPROTECT(1);
return;
}
void tr_d_packed_getDiag(double *dest, SEXP x)
{
int n = INTEGER(GET_SLOT(x, Matrix_DimSym))[0];
SEXP val = PROTECT(allocVector(REALSXP, n));
double *v = REAL(val);
if (*diag_P(x) == 'U') {
int j;
for (j = 0; j < n; j++) v[j] = 1.;
} else {
d_packed_getDiag(v, x, n);
}
UNPROTECT(1);
return;
}
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);
}
SEXP dtrMatrix_matrix_solve(SEXP a, SEXP b)
{
SEXP ans = PROTECT(dup_mMatrix_as_dgeMatrix(b));
int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)),
*bdims = INTEGER(GET_SLOT(ans, Matrix_DimSym));
int n = bdims[0], nrhs = bdims[1];
double one = 1.0;
if (*adims != *bdims || bdims[1] < 1 || *adims < 1 || *adims != adims[1])
error(_("Dimensions of system to be solved are inconsistent"));
F77_CALL(dtrsm)("L", uplo_P(a), "N", diag_P(a),
&n, &nrhs, &one, REAL(GET_SLOT(a, Matrix_xSym)), &n,
REAL(GET_SLOT(ans, Matrix_xSym)), &n);
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 dtrMatrix_dgeMatrix_mm_R(SEXP a, SEXP b)
{
int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)),
*bdims = INTEGER(GET_SLOT(b, Matrix_DimSym)),
m = adims[0], n = bdims[1], k = adims[1];
SEXP val = PROTECT(duplicate(b));
double one = 1.;
if (bdims[0] != k)
error(_("Matrices are not conformable for multiplication"));
if (m < 1 || n < 1 || k < 1)
error(_("Matrices with zero extents cannot be multiplied"));
F77_CALL(dtrmm)("R", uplo_P(a), "N", diag_P(a), adims, bdims+1, &one,
REAL(GET_SLOT(a, Matrix_xSym)), adims,
REAL(GET_SLOT(val, Matrix_xSym)), bdims);
UNPROTECT(1);
return val;
}
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);
}
/* Because a must be square, the size of the answer is the same as the
* size of b */
SEXP dtrMatrix_matrix_mm(SEXP a, SEXP b, SEXP right)
{
SEXP val = PROTECT(dup_mMatrix_as_dgeMatrix(b));
int rt = asLogical(right);
int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)),
*bdims = INTEGER(GET_SLOT(val, Matrix_DimSym));
int m = bdims[0], n = bdims[1];
double one = 1.;
if (adims[0] != adims[1]) error(_("dtrMatrix in %*% must be square"));
if ((rt && (adims[0] != m)) || (!rt && (bdims[0] != m)))
error(_("Matrices are not conformable for multiplication"));
if (m < 1 || n < 1)
error(_("Matrices with zero extents cannot be multiplied"));
F77_CALL(dtrmm)(rt ? "R" : "L", uplo_P(a), "N", diag_P(a), &m, &n,
&one, REAL(GET_SLOT(a, Matrix_xSym)), adims,
REAL(GET_SLOT(val, Matrix_xSym)), &m);
UNPROTECT(1);
return val;
}
/** Matrix products dense triangular Matrices o <matrix>
*
* @param a triangular matrix of class "dtrMatrix"
* @param b a <matrix> or <any-denseMatrix>
* @param right logical, if true, compute b %*% a, else a %*% b
* @param trans logical, if true, "transpose a", i.e., use t(a), otherwise a
*
* @return the matrix product, one of a %*% b, t(a) %*% b, b %*% a, or b %*% t(a)
* depending on (right, trans) = (F, F) (F, T) (T, F) (T, T)
*/
SEXP dtrMatrix_matrix_mm(SEXP a, SEXP b, SEXP right, SEXP trans)
{
/* called from "%*%", crossprod() and tcrossprod() in ../R/products.R
*
* Because 'a' must be square, the size of the answer 'val',
* is the same as the size of 'b' */
SEXP val = PROTECT(dup_mMatrix_as_dgeMatrix(b));
int rt = asLogical(right); /* if(rt), compute b %*% op(a), else op(a) %*% b */
int tr = asLogical(trans);/* if true, use t(a) */
int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)),
*bdims = INTEGER(GET_SLOT(val, Matrix_DimSym));
int m = bdims[0], n = bdims[1];
double one = 1.;
if (adims[0] != adims[1])
error(_("dtrMatrix must be square"));
if ((rt && adims[0] != n) || (!rt && adims[1] != m))
error(_("Matrices are not conformable for multiplication"));
if (m >= 1 && n >= 1) {
// Level 3 BLAS - DTRMM() --> see call further below
F77_CALL(dtrmm)(rt ? "R" : "L", uplo_P(a),
/*trans_A = */ tr ? "T" : "N",
diag_P(a), &m, &n, &one,
REAL(GET_SLOT(a, Matrix_xSym)), adims,
REAL(GET_SLOT(val, Matrix_xSym)), &m);
}
SEXP
dn_a = GET_SLOT( a, Matrix_DimNamesSym),
dn = GET_SLOT(val, Matrix_DimNamesSym);
/* matrix product a %*% b, t(a) %*% b, b %*% a, or b %*% t(a)
* (right, trans) = (F, F) (F, T) (T, F) (T, T)
* set:from_a = 0:0 0:1 1:1 1:0
*/
SET_VECTOR_ELT(dn, rt ? 1 : 0, VECTOR_ELT(dn_a, (rt+tr) % 2));
UNPROTECT(1);
return val;
}
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 tsc_transpose(SEXP x)
{
SEXP ans = PROTECT(NEW_OBJECT(MAKE_CLASS("dtCMatrix"))),
islot = GET_SLOT(x, Matrix_iSym);
int nnz = length(islot),
*adims, *xdims = INTEGER(GET_SLOT(x, Matrix_DimSym));
int up = uplo_P(x)[0] == 'U';
adims = INTEGER(ALLOC_SLOT(ans, Matrix_DimSym, INTSXP, 2));
adims[0] = xdims[1]; adims[1] = xdims[0];
if(*diag_P(x) == 'U')
SET_SLOT(ans, Matrix_diagSym, duplicate(GET_SLOT(x, Matrix_diagSym)));
SET_SLOT(ans, Matrix_uploSym, mkString(up ? "L" : "U"));
csc_compTr(xdims[0], xdims[1], nnz,
INTEGER(GET_SLOT(x, Matrix_pSym)), INTEGER(islot),
REAL(GET_SLOT(x, Matrix_xSym)),
INTEGER(ALLOC_SLOT(ans, Matrix_pSym, INTSXP, xdims[0] + 1)),
INTEGER(ALLOC_SLOT(ans, Matrix_iSym, INTSXP, nnz)),
REAL(ALLOC_SLOT(ans, Matrix_xSym, REALSXP, nnz)));
UNPROTECT(1);
return ans;
}
/**
* 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_TR() or AS_CHM_TR__(). It is unusual to call it directly.
*
* @param ans a CHM_TR pointer
* @param x pointer to an object that inherits from TsparseMatrix
* @param check_Udiag boolean - should a check for (and consequent
* expansion of) a unit diagonal be performed.
*
* @return ans containing pointers to the slots of x, *unless*
* check_Udiag and x is unitriangular.
*/
CHM_TR as_cholmod_triplet(CHM_TR ans, SEXP x, Rboolean check_Udiag)
{
static const char *valid[] = { MATRIX_VALID_Tsparse, ""};
int ctype = R_check_class_etc(x, valid),
*dims = INTEGER(GET_SLOT(x, Matrix_DimSym));
SEXP islot = GET_SLOT(x, Matrix_iSym);
int m = LENGTH(islot);
Rboolean do_Udiag = (check_Udiag && ctype % 3 == 2 && (*diag_P(x) == 'U'));
if (ctype < 0) error(_("invalid class of object to as_cholmod_triplet"));
memset(ans, 0, sizeof(cholmod_triplet)); /* zero the struct */
ans->itype = CHOLMOD_INT; /* characteristics of the system */
ans->dtype = CHOLMOD_DOUBLE;
/* nzmax, dimensions, types and slots : */
ans->nnz = ans->nzmax = m;
ans->nrow = dims[0];
ans->ncol = dims[1];
ans->stype = stype(ctype, x);
ans->xtype = xtype(ctype);
ans->i = (void *) INTEGER(islot);
ans->j = (void *) INTEGER(GET_SLOT(x, Matrix_jSym));
ans->x = xpt(ctype, x);
if(do_Udiag) {
/* diagU2N(.) "in place", similarly to Tsparse_diagU2N [./Tsparse.c]
(but without new SEXP): */
int k = m + dims[0];
CHM_TR tmp = cholmod_l_copy_triplet(ans, &cl);
int *a_i, *a_j;
if(!cholmod_reallocate_triplet((size_t) k, tmp, &cl))
error(_("as_cholmod_triplet(): could not reallocate for internal diagU2N()"
));
/* TODO? instead of copy_triplet() & reallocate_triplet()
* ---- allocate to correct length + Memcpy() here, as in
* Tsparse_diagU2N() & chTr2Ralloc() below */
a_i = tmp->i;
a_j = tmp->j;
/* add (@i, @j)[k+m] = k, @x[k+m] = 1. for k = 0,..,(n-1) */
for(k=0; k < dims[0]; k++) {
a_i[k+m] = k;
a_j[k+m] = k;
switch(ctype / 3) {
case 0: { /* "d" */
double *a_x = tmp->x;
a_x[k+m] = 1.;
break;
}
case 1: { /* "l" */
int *a_x = tmp->x;
a_x[k+m] = 1;
break;
}
case 2: /* "n" */
break;
case 3: { /* "z" */
double *a_x = tmp->x;
a_x[2*(k+m) ] = 1.;
a_x[2*(k+m)+1] = 0.;
break;
}
}
} /* for(k) */
chTr2Ralloc(ans, tmp);
cholmod_l_free_triplet(&tmp, &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;
}
SEXP dtrMatrix_dtrMatrix_mm(SEXP a, SEXP b, SEXP right, SEXP trans)
{
/* to be called from "%*%" and crossprod(), tcrossprod(),
* from ../R/products.R
*
* TWO cases : (1) result is triangular <=> uplo are equal
* === (2) result is "general"
*/
SEXP val,/* = in case (2): PROTECT(dup_mMatrix_as_dgeMatrix(b)); */
d_a = GET_SLOT(a, Matrix_DimSym),
uplo_a = GET_SLOT(a, Matrix_uploSym),
diag_a = GET_SLOT(a, Matrix_diagSym);
/* if(rt), compute b %*% a, else a %*% b */
int rt = asLogical(right);
int tr = asLogical(trans);/* if true, use t(a) */
int *adims = INTEGER(d_a), n = adims[0];
double *valx = (double *) NULL /*Wall*/;
const char
*uplo_a_ch = CHAR(STRING_ELT(uplo_a, 0)), /* = uplo_P(a) */
*diag_a_ch = CHAR(STRING_ELT(diag_a, 0)); /* = diag_P(a) */
Rboolean same_uplo = (*uplo_a_ch == *uplo_P(b)),
uDiag_b = /* -Wall: */ FALSE;
if (INTEGER(GET_SLOT(b, Matrix_DimSym))[0] != n)
/* validity checking already "assures" square matrices ... */
error(_("dtrMatrices in %*% must have matching (square) dim."));
if(same_uplo) {
/* ==> result is triangular -- "dtrMatrix" !
* val := dup_mMatrix_as_dtrMatrix(b) : */
int sz = n * n;
val = PROTECT(NEW_OBJECT(MAKE_CLASS("dtrMatrix")));
SET_SLOT(val, Matrix_uploSym, duplicate(uplo_a));
SET_SLOT(val, Matrix_DimSym, duplicate(d_a));
SET_DimNames(val, b);
valx = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, sz));
Memcpy(valx, REAL(GET_SLOT(b, Matrix_xSym)), sz);
if((uDiag_b = *diag_P(b) == 'U')) {
/* unit-diagonal b - may contain garbage in diagonal */
for (int i = 0; i < n; i++)
valx[i * (n+1)] = 1.;
}
} else { /* different "uplo" ==> result is "dgeMatrix" ! */
val = PROTECT(dup_mMatrix_as_dgeMatrix(b));
}
if (n >= 1) {
double alpha = 1.;
/* Level 3 BLAS - DTRMM(): Compute one of the matrix multiplication operations
* B := alpha*op( A )*B ["L"], or B := alpha*B*op( A ) ["R"],
* where trans_A determines op(A):= A "N"one or
* op(A):= t(A) "T"ransposed */
F77_CALL(dtrmm)(rt ? "R" : "L", uplo_a_ch,
/*trans_A = */ tr ? "T" : "N", diag_a_ch, &n, &n, &alpha,
REAL(GET_SLOT(a, Matrix_xSym)), adims,
REAL(GET_SLOT(val, Matrix_xSym)), &n);
}
if(same_uplo) {
make_d_matrix_triangular(valx, a); /* set "other triangle" to 0 */
if(*diag_a_ch == 'U' && uDiag_b) /* result remains uni-diagonal */
SET_SLOT(val, Matrix_diagSym, duplicate(diag_a));
}
UNPROTECT(1);
return val;
}
SEXP Tsparse_diagU2N(SEXP x)
{
static const char *valid[] = {
"dtTMatrix", /* 0 */
"ltTMatrix", /* 1 */
"ntTMatrix", /* 2 : no x slot */
"ztTMatrix", /* 3 */
""};
/* #define xSXP(iTyp) ((iTyp == 0) ? REALSXP : ((iTyp == 1) ? LGLSXP : /\* else *\/ CPLXSXP)); */
/* #define xTYPE(iTyp) ((iTyp == 0) ? double : ((iTyp == 1) ? int : /\* else *\/ Rcomplex)); */
int ctype = Matrix_check_class_etc(x, valid);
if (ctype < 0 || *diag_P(x) != 'U') {
/* "trivially fast" when not triangular (<==> no 'diag' slot),
or not *unit* triangular */
return (x);
}
else { /* instead of going to Csparse -> Cholmod -> Csparse -> Tsparse, work directly: */
int i, n = INTEGER(GET_SLOT(x, Matrix_DimSym))[0],
nnz = length(GET_SLOT(x, Matrix_iSym)),
new_n = nnz + n;
SEXP ans = PROTECT(NEW_OBJECT(MAKE_CLASS(class_P(x))));
int *islot = INTEGER(ALLOC_SLOT(ans, Matrix_iSym, INTSXP, new_n)),
*jslot = INTEGER(ALLOC_SLOT(ans, Matrix_jSym, INTSXP, new_n));
slot_dup(ans, x, Matrix_DimSym);
SET_DimNames(ans, x);
slot_dup(ans, x, Matrix_uploSym);
SET_SLOT(ans, Matrix_diagSym, mkString("N"));
/* Build the new i- and j- slots : first copy the current : */
Memcpy(islot, INTEGER(GET_SLOT(x, Matrix_iSym)), nnz);
Memcpy(jslot, INTEGER(GET_SLOT(x, Matrix_jSym)), nnz);
/* then, add the new (i,j) slot entries: */
for(i = 0; i < n; i++) {
islot[i + nnz] = i;
jslot[i + nnz] = i;
}
/* build the new x-slot : */
switch(ctype) {
case 0: { /* "d" */
double *x_new = REAL(ALLOC_SLOT(ans, Matrix_xSym,
REALSXP, new_n));
Memcpy(x_new, REAL(GET_SLOT(x, Matrix_xSym)), nnz);
for(i = 0; i < n; i++) /* add x[i,i] = 1. */
x_new[i + nnz] = 1.;
break;
}
case 1: { /* "l" */
int *x_new = LOGICAL(ALLOC_SLOT(ans, Matrix_xSym,
LGLSXP, new_n));
Memcpy(x_new, LOGICAL(GET_SLOT(x, Matrix_xSym)), nnz);
for(i = 0; i < n; i++) /* add x[i,i] = 1 (= TRUE) */
x_new[i + nnz] = 1;
break;
}
case 2: /* "n" */
/* nothing to do here */
break;
case 3: { /* "z" */
Rcomplex *x_new = COMPLEX(ALLOC_SLOT(ans, Matrix_xSym,
CPLXSXP, new_n));
Memcpy(x_new, COMPLEX(GET_SLOT(x, Matrix_xSym)), nnz);
for(i = 0; i < n; i++) /* add x[i,i] = 1 (= TRUE) */
x_new[i + nnz] = (Rcomplex) {1., 0.};
break;
}
}/* switch() */
UNPROTECT(1);
return ans;
}
}
/**
* 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;
}
