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