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;
}
bool Matrix_isclass_CHMfactor(SEXP x) {
return R_check_class_etc(x, Matrix_valid_CHMfactor) >= 0;
}
bool Matrix_isclass_dense(SEXP x) {
return R_check_class_etc(x, Matrix_valid_dense) >= 0;
}
bool Matrix_isclass_triplet(SEXP x) {
return R_check_class_etc(x, Matrix_valid_triplet) >= 0;
}
// for now still *export* M_Matrix_check_class_etc()
int M_Matrix_check_class_etc(SEXP x, const char **valid)
{
REprintf("M_Matrix_check_class_etc() is deprecated; use R_check_class_etc() instead");
return R_check_class_etc(x, valid);
}
/**
* 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;
}
/**
* 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;
}
/**
* 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.
*
* @param ans an CHM_FR object
* @param x pointer to an object that inherits from CHMfactor
* @param do_check logical indicating if check for correctness should happen
*
* @return ans containing pointers to the slots of x.
*/
CHM_FR as_cholmod_factor3(CHM_FR ans, SEXP x, Rboolean do_check)
{
static const char *valid[] = { MATRIX_VALID_CHMfactor, ""};
int *type = INTEGER(GET_SLOT(x, install("type"))),
ctype = R_check_class_etc(x, valid);
SEXP tmp;
if (ctype < 0) error(_("invalid class of object to as_cholmod_factor"));
memset(ans, 0, sizeof(cholmod_factor)); /* zero the struct */
ans->itype = CHOLMOD_INT; /* characteristics of the system */
ans->dtype = CHOLMOD_DOUBLE;
ans->z = (void *) NULL;
ans->xtype = (ctype < 2) ? CHOLMOD_REAL : CHOLMOD_PATTERN;
ans->ordering = type[0]; /* unravel the type */
ans->is_ll = (type[1] ? 1 : 0);
ans->is_super = (type[2] ? 1 : 0);
ans->is_monotonic = (type[3] ? 1 : 0);
/* check for consistency */
if ((!(ans->is_ll)) && ans->is_super)
error(_("Supernodal LDL' decomposition not available"));
if ((!type[2]) ^ (ctype % 2))
error(_("Supernodal/simplicial class inconsistent with type flags"));
/* slots always present */
tmp = GET_SLOT(x, Matrix_permSym);
ans->minor = ans->n = LENGTH(tmp); ans->Perm = INTEGER(tmp);
ans->ColCount = INTEGER(GET_SLOT(x, install("colcount")));
ans->z = ans->x = (void *) NULL;
if (ctype < 2) {
tmp = GET_SLOT(x, Matrix_xSym);
ans->x = REAL(tmp);
}
if (ans->is_super) { /* supernodal factorization */
ans->xsize = LENGTH(tmp);
ans->maxcsize = type[4]; ans->maxesize = type[5];
ans->i = (int*)NULL;
tmp = GET_SLOT(x, install("super"));
ans->nsuper = LENGTH(tmp) - 1; ans->super = INTEGER(tmp);
/* Move these checks to the CHMfactor_validate function */
if (ans->nsuper < 1)
error(_("Number of supernodes must be positive when is_super is TRUE"));
tmp = GET_SLOT(x, install("pi"));
if (LENGTH(tmp) != ans->nsuper + 1)
error(_("Lengths of super and pi must be equal"));
ans->pi = INTEGER(tmp);
tmp = GET_SLOT(x, install("px"));
if (LENGTH(tmp) != ans->nsuper + 1)
error(_("Lengths of super and px must be equal"));
ans->px = INTEGER(tmp);
tmp = GET_SLOT(x, install("s"));
ans->ssize = LENGTH(tmp); ans->s = INTEGER(tmp);
} else {
ans->nzmax = LENGTH(tmp);
ans->p = INTEGER(GET_SLOT(x, Matrix_pSym));
ans->i = INTEGER(GET_SLOT(x, Matrix_iSym));
ans->nz = INTEGER(GET_SLOT(x, install("nz")));
ans->next = INTEGER(GET_SLOT(x, install("nxt")));
ans->prev = INTEGER(GET_SLOT(x, install("prv")));
}
if (do_check && !cholmod_check_factor(ans, &c))
error(_("failure in as_cholmod_factor"));
return ans;
}
