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