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