/** * Populate a css object with the contents of x. * * @param ans pointer to a csn object * @param x pointer to an object of class css_LU or css_QR. * * @return pointer to a cs object that contains pointers * to the slots of x. */ css *Matrix_as_css(css *ans, SEXP x) { char *cl = class_P(x); *valid[] = {"css_LU", "css_QR", ""}; int *nz = INTEGER(GET_SLOT(x, install("nz"))), ctype = Matrix_check_class(cl, valid); if (ctype < 0) error("invalid class of object to Matrix_as_css"); ans->q = INTEGER(GET_SLOT(x, install("Q"))); ans->m2 = nz[0]; ans->lnz = nz[1]; ans->unz = nz[2]; switch(ctype) { case 0: /* css_LU */ ans->pinv = (int *) NULL; ans->parent = (int *) NULL; ans->cp = (int *) NULL; break; case 1: /* css_QR */ ans->pinv = INTEGER(GET_SLOT(x, install("Pinv"))); ans->parent = INTEGER(GET_SLOT(x, install("parent"))); ans->cp = INTEGER(GET_SLOT(x, install("cp"))); break; default: error("invalid class of object to Matrix_as_css"); } return ans; }
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 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 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); }
// n.CMatrix --> [dli].CMatrix (not going through CHM!) SEXP nz2Csparse(SEXP x, enum x_slot_kind r_kind) { const char *cl_x = class_P(x); if(cl_x[0] != 'n') error(_("not a 'n.CMatrix'")); if(cl_x[2] != 'C') error(_("not a CsparseMatrix")); int nnz = LENGTH(GET_SLOT(x, Matrix_iSym)); SEXP ans; char *ncl = strdup(cl_x); double *dx_x; int *ix_x; ncl[0] = (r_kind == x_double ? 'd' : (r_kind == x_logical ? 'l' : /* else (for now): r_kind == x_integer : */ 'i')); PROTECT(ans = NEW_OBJECT(MAKE_CLASS(ncl))); // create a correct 'x' slot: switch(r_kind) { int i; case x_double: // 'd' dx_x = REAL(ALLOC_SLOT(ans, Matrix_xSym, REALSXP, nnz)); for (i=0; i < nnz; i++) dx_x[i] = 1.; break; case x_logical: // 'l' ix_x = LOGICAL(ALLOC_SLOT(ans, Matrix_xSym, LGLSXP, nnz)); for (i=0; i < nnz; i++) ix_x[i] = TRUE; break; case x_integer: // 'i' ix_x = INTEGER(ALLOC_SLOT(ans, Matrix_xSym, INTSXP, nnz)); for (i=0; i < nnz; i++) ix_x[i] = 1; break; default: error(_("nz2Csparse(): invalid/non-implemented r_kind = %d"), r_kind); } // now copy all other slots : slot_dup(ans, x, Matrix_iSym); slot_dup(ans, x, Matrix_pSym); slot_dup(ans, x, Matrix_DimSym); slot_dup(ans, x, Matrix_DimNamesSym); if(ncl[1] != 'g') { // symmetric or triangular ... slot_dup_if_has(ans, x, Matrix_uploSym); slot_dup_if_has(ans, x, Matrix_diagSym); } 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)); }
double* gematrix_real_x(SEXP x, int nn) { if(class_P(x)[0] == 'd') // <<- FIXME: use R_check_class_etc(x, valid) !!! return REAL(GET_SLOT(x, Matrix_xSym)); #ifdef _potentically_more_efficient_but_not_working // else : 'l' or 'n' (for now !!) int *xi = INTEGER(GET_SLOT(x, Matrix_xSym)); double *x_x; C_or_Alloca_TO(x_x, nn, double); for(int i=0; i < nn; i++) x_x[i] = (double) xi[i]; // FIXME: this is not possible either; the *caller* would have to Free(.) if(nn >= SMALL_4_Alloca) Free(x_x); #else // ideally should be PROTECT()ed ==> make sure R does not run gc() now! double *x_x = REAL(coerceVector(GET_SLOT(x, Matrix_xSym), REALSXP)); #endif return x_x; }
/** * Create a cs object with the contents of x. * * @param x pointer to an object that inherits from CsparseMatrix * * @return pointer to a cs object that contains pointers * to the slots of x. */ cs *Matrix_as_cs(cs *ans, SEXP x) { char *valid[] = {"dgCMatrix", "dtCMatrix", ""};/* had also "dsCMatrix", but that * only stores one triangle */ int *dims, ctype = Matrix_check_class(class_P(x), valid); SEXP islot; if (ctype < 0) error("invalid class of object to Matrix_as_cs"); /* dimensions and nzmax */ dims = INTEGER(GET_SLOT(x, Matrix_DimSym)); ans->m = dims[0]; ans->n = dims[1]; islot = GET_SLOT(x, Matrix_iSym); ans->nz = -1; /* indicates compressed column storage */ ans->nzmax = LENGTH(islot); ans->i = INTEGER(islot); ans->p = INTEGER(GET_SLOT(x, Matrix_pSym)); ans->x = REAL(GET_SLOT(x, Matrix_xSym)); return ans; }
SEXP R_to_CMatrix(SEXP x) { SEXP ans, tri = PROTECT(allocVector(LGLSXP, 1)); char *ncl = strdup(class_P(x)); static const char *valid[] = { MATRIX_VALID_Rsparse, ""}; int ctype = R_check_class_etc(x, valid); int *x_dims = INTEGER(GET_SLOT(x, Matrix_DimSym)), *a_dims; PROTECT_INDEX ipx; if (ctype < 0) error(_("invalid class(x) '%s' in R_to_CMatrix(x)"), ncl); /* replace 'R' with 'C' : */ ncl[2] = 'C'; PROTECT_WITH_INDEX(ans = NEW_OBJECT(MAKE_CLASS(ncl)), &ipx); a_dims = INTEGER(ALLOC_SLOT(ans, Matrix_DimSym, INTSXP, 2)); /* reversed dim() since we will transpose: */ a_dims[0] = x_dims[1]; a_dims[1] = x_dims[0]; /* triangular: */ LOGICAL(tri)[0] = 0; if((ctype / 3) != 2) /* not n..Matrix */ slot_dup(ans, x, Matrix_xSym); if(ctype % 3) { /* s(ymmetric) or t(riangular) : */ SET_SLOT(ans, Matrix_uploSym, mkString((*uplo_P(x) == 'U') ? "L" : "U")); if(ctype % 3 == 2) { /* t(riangular) : */ LOGICAL(tri)[0] = 1; slot_dup(ans, x, Matrix_diagSym); } } SET_SLOT(ans, Matrix_iSym, duplicate(GET_SLOT(x, Matrix_jSym))); slot_dup(ans, x, Matrix_pSym); REPROTECT(ans = Csparse_transpose(ans, tri), ipx); SET_DimNames(ans, x); // possibly asymmetric for symmetricMatrix is ok free(ncl); UNPROTECT(2); return ans; }
/* This and the following R_to_CMatrix() lead to memory-not-mapped seg.faults * only with {32bit + R-devel + enable-R-shlib} -- no idea why */ SEXP compressed_to_TMatrix(SEXP x, SEXP colP) { int col = asLogical(colP); /* 1 if "C"olumn compressed; 0 if "R"ow */ /* however, for Csparse, we now effectively use the cholmod-based * Csparse_to_Tsparse() in ./Csparse.c ; maybe should simply write * an as_cholmod_Rsparse() function and then do "as there" ...*/ SEXP indSym = col ? Matrix_iSym : Matrix_jSym, ans, indP = GET_SLOT(x, indSym), pP = GET_SLOT(x, Matrix_pSym); int npt = length(pP) - 1; char *ncl = strdup(class_P(x)); static const char *valid[] = { MATRIX_VALID_Csparse, MATRIX_VALID_Rsparse, ""}; int ctype = R_check_class_etc(x, valid); if (ctype < 0) error(_("invalid class(x) '%s' in compressed_to_TMatrix(x)"), ncl); /* replace 'C' or 'R' with 'T' :*/ ncl[2] = 'T'; ans = PROTECT(NEW_OBJECT(MAKE_CLASS(ncl))); slot_dup(ans, x, Matrix_DimSym); if((ctype / 3) % 4 != 2) /* not n..Matrix */ slot_dup(ans, x, Matrix_xSym); if(ctype % 3) { /* s(ymmetric) or t(riangular) : */ slot_dup(ans, x, Matrix_uploSym); if(ctype % 3 == 2) /* t(riangular) : */ slot_dup(ans, x, Matrix_diagSym); } SET_DimNames(ans, x); // possibly asymmetric for symmetricMatrix is ok SET_SLOT(ans, indSym, duplicate(indP)); expand_cmprPt(npt, INTEGER(pP), INTEGER(ALLOC_SLOT(ans, col ? Matrix_jSym : Matrix_iSym, INTSXP, length(indP)))); free(ncl); UNPROTECT(1); return ans; }
/** * Populate a csn object with the contents of x. * * @param ans pointer to a csn object * @param x pointer to an object of class csn_LU or csn_QR. * * @return pointer to a cs object that contains pointers * to the slots of x. */ csn *Matrix_as_csn(csn *ans, SEXP x) { char *valid[] = {"csn_LU", "csn_QR", ""}; int ctype = Matrix_check_class(class_P(x), valid); if (ctype < 0) error("invalid class of object to Matrix_as_csn"); ans->U = Matrix_as_cs(GET_SLOT(x, install("U"))); ans->L = Matrix_as_cs(GET_SLOT(x, install("L"))); switch(ctype) { case 0: ans->B = (double*) NULL; ans->pinv = INTEGER(GET_SLOT(x, install("Pinv"))); break; case 1: ans->B = REAL(GET_SLOT(x, install("beta"))); ans->pinv = (int*) NULL; break; default: error("invalid class of object to Matrix_as_csn"); } return ans; }
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 dense_band(SEXP x, SEXP k1P, SEXP k2P) /* Always returns a full matrix with entries outside the band zeroed * Class of the value can be [dln]trMatrix or [dln]geMatrix */ { int k1 = asInteger(k1P), k2 = asInteger(k2P); if (k1 > k2) { error(_("Lower band %d > upper band %d"), k1, k2); return R_NilValue; /* -Wall */ } else { SEXP ans = PROTECT(dup_mMatrix_as_geMatrix(x)); int *adims = INTEGER(GET_SLOT(ans, Matrix_DimSym)), j, m = adims[0], n = adims[1], sqr = (adims[0] == adims[1]), tru = (k1 >= 0), trl = (k2 <= 0); const char *cl = class_P(ans); enum dense_enum { ddense, ldense, ndense } M_type = ( (cl[0] == 'd') ? ddense : ((cl[0] == 'l') ? ldense : ndense)); #define SET_ZERO_OUTSIDE \ for (j = 0; j < n; j++) { \ int i, i1 = j - k2, i2 = j + 1 - k1; \ if(i1 > m) i1 = m; \ if(i2 < 0) i2 = 0; \ for (i = 0; i < i1; i++) xx[i + j * m] = 0; \ for (i = i2; i < m; i++) xx[i + j * m] = 0; \ } if(M_type == ddense) { double *xx = REAL(GET_SLOT(ans, Matrix_xSym)); SET_ZERO_OUTSIDE } else { /* (M_type == ldense || M_type == ndense) */
/* Generalized -- "geMatrix" -- dispatch where needed : */ SEXP dup_mMatrix_as_geMatrix(SEXP A) { SEXP ans, ad = R_NilValue, an = R_NilValue; /* -Wall */ char *valid[] = {"_NOT_A_CLASS_",/* *_CLASSES defined in ./Mutils.h */ ddense_CLASSES, /* 14 */ ldense_CLASSES, /* 6 */ ndense_CLASSES, /* 5 */ ""}; int sz, ctype = Matrix_check_class_etc(A, valid), nprot = 1; enum dense_enum { ddense, ldense, ndense } M_type = ddense /* -Wall */; if (ctype > 0) { /* a [nld]denseMatrix object */ ad = GET_SLOT(A, Matrix_DimSym); an = GET_SLOT(A, Matrix_DimNamesSym); M_type = (ctype <= 14) ? ddense : ((ctype <= 14+6) ? ldense : ndense); } else if (ctype < 0) { /* not a (recognized) classed matrix */ if (isReal(A)) M_type = ddense; else if (isInteger(A)) { A = PROTECT(coerceVector(A, REALSXP)); nprot++; M_type = ddense; } else if (isLogical(A)) M_type = ldense; else error(_("invalid class '%s' to dup_mMatrix_as_geMatrix"), class_P(A)); #define DUP_MMATRIX_NON_CLASS \ if (isMatrix(A)) { /* "matrix" */ \ ad = getAttrib(A, R_DimSymbol); \ an = getAttrib(A, R_DimNamesSymbol); \ } else {/* maybe "numeric" (incl integer,logical) --> (n x 1) */\ int* dd = INTEGER(ad = PROTECT(allocVector(INTSXP, 2))); \ nprot++; \ dd[0] = LENGTH(A); \ dd[1] = 1; \ an = R_NilValue; \ } \ ctype = 0 DUP_MMATRIX_NON_CLASS; } ans = PROTECT(NEW_OBJECT(MAKE_CLASS(M_type == ddense ? "dgeMatrix" : (M_type == ldense ? "lgeMatrix" : "ngeMatrix")))); #define DUP_MMATRIX_SET_1 \ SET_SLOT(ans, Matrix_DimSym, duplicate(ad)); \ SET_SLOT(ans, Matrix_DimNamesSym, (LENGTH(an) == 2) ? \ duplicate(an): allocVector(VECSXP, 2)); \ sz = INTEGER(ad)[0] * INTEGER(ad)[1] DUP_MMATRIX_SET_1; if(M_type == ddense) { /* ddense -> dge */ double *ansx; #define DUP_MMATRIX_ddense_CASES \ ansx = REAL(ALLOC_SLOT(ans, Matrix_xSym, REALSXP, sz)); \ switch(ctype) { \ case 0: /* unclassed real matrix */ \ Memcpy(ansx, REAL(A), sz); \ break; \ case 1: /* dgeMatrix */ \ Memcpy(ansx, REAL(GET_SLOT(A, Matrix_xSym)), sz); \ break; \ case 2: /* dtrMatrix and subclasses */ \ case 9: case 10: case 11: /* --- Cholesky, LDL, BunchKaufman */ \ Memcpy(ansx, REAL(GET_SLOT(A, Matrix_xSym)), sz); \ make_d_matrix_triangular(ansx, A); \ break; \ case 3: /* dsyMatrix */ \ case 4: /* dpoMatrix + subclass */ \ case 14: /* --- corMatrix */ \ Memcpy(ansx, REAL(GET_SLOT(A, Matrix_xSym)), sz); \ make_d_matrix_symmetric(ansx, A); \ break; \ case 5: /* ddiMatrix */ \ install_diagonal(ansx, A); \ break; \ case 6: /* dtpMatrix + subclasses */ \ case 12: case 13: /* --- pCholesky, pBunchKaufman */ \ packed_to_full_double(ansx, REAL(GET_SLOT(A, Matrix_xSym)), \ INTEGER(ad)[0], \ *uplo_P(A) == 'U' ? UPP : LOW); \ make_d_matrix_triangular(ansx, A); \ break; \ case 7: /* dspMatrix */ \ case 8: /* dppMatrix */ \ packed_to_full_double(ansx, REAL(GET_SLOT(A, Matrix_xSym)), \ INTEGER(ad)[0], \ *uplo_P(A) == 'U' ? UPP : LOW); \ make_d_matrix_symmetric(ansx, A); \ break; \ } /* switch(ctype) */ DUP_MMATRIX_ddense_CASES }
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; } }