4 |
|
|
5 |
SEXP Csparse_validate(SEXP x) |
SEXP Csparse_validate(SEXP x) |
6 |
{ |
{ |
7 |
|
/* NB: we do *NOT* check a potential 'x' slot here, at all */ |
8 |
SEXP pslot = GET_SLOT(x, Matrix_pSym), |
SEXP pslot = GET_SLOT(x, Matrix_pSym), |
9 |
islot = GET_SLOT(x, Matrix_iSym); |
islot = GET_SLOT(x, Matrix_iSym); |
10 |
int j, ncol = length(pslot) - 1, |
int j, k, ncol, nrow, sorted, |
11 |
*dims = INTEGER(GET_SLOT(x, Matrix_DimSym)), |
*dims = INTEGER(GET_SLOT(x, Matrix_DimSym)), |
12 |
nrow, *xp = INTEGER(pslot), |
*xp = INTEGER(pslot), |
13 |
*xi = INTEGER(islot); |
*xi = INTEGER(islot); |
14 |
|
|
15 |
nrow = dims[0]; |
nrow = dims[0]; |
16 |
if (length(pslot) <= 0) |
ncol = dims[1]; |
17 |
return mkString(_("slot p must have length > 0")); |
if (length(pslot) != dims[1] + 1) |
18 |
|
return mkString(_("slot p must have length = ncol(.) + 1")); |
19 |
if (xp[0] != 0) |
if (xp[0] != 0) |
20 |
return mkString(_("first element of slot p must be zero")); |
return mkString(_("first element of slot p must be zero")); |
21 |
if (length(islot) != xp[ncol]) |
if (length(islot) != xp[ncol]) |
22 |
return mkString(_("last element of slot p must match length of slots i and x")); |
return |
23 |
|
mkString(_("last element of slot p must match length of slots i and x")); |
24 |
|
for (j = 0; j < length(islot); j++) { |
25 |
|
if (xi[j] < 0 || xi[j] >= nrow) |
26 |
|
return mkString(_("all row indices must be between 0 and nrow-1")); |
27 |
|
} |
28 |
|
sorted = TRUE; |
29 |
for (j = 0; j < ncol; j++) { |
for (j = 0; j < ncol; j++) { |
30 |
if (xp[j] > xp[j+1]) |
if (xp[j] > xp[j+1]) |
31 |
return mkString(_("slot p must be non-decreasing")); |
return mkString(_("slot p must be non-decreasing")); |
32 |
|
for (k = xp[j] + 1; k < xp[j + 1]; k++) |
33 |
|
if (xi[k] < xi[k - 1]) sorted = FALSE; |
34 |
} |
} |
35 |
for (j = 0; j < length(islot); j++) { |
if (!sorted) { |
36 |
if (xi[j] < 0 || xi[j] >= nrow) |
cholmod_sparse *chx = as_cholmod_sparse(x); |
37 |
return mkString(_("all row indices must be between 0 and nrow-1")); |
cholmod_sort(chx, &c); |
38 |
|
Free(chx); |
39 |
} |
} |
40 |
return ScalarLogical(1); |
return ScalarLogical(1); |
41 |
} |
} |
108 |
GET_SLOT(x, Matrix_DimNamesSym)); |
GET_SLOT(x, Matrix_DimNamesSym)); |
109 |
} |
} |
110 |
|
|
111 |
|
SEXP Csparse_general_to_symmetric(SEXP x, SEXP uplo) |
112 |
|
{ |
113 |
|
cholmod_sparse *chx = as_cholmod_sparse(x), *chgx; |
114 |
|
int uploT = (*CHAR(asChar(uplo)) == 'U') ? -1 : 1; |
115 |
|
int Rkind = (chx->xtype == CHOLMOD_REAL) ? Real_kind(x) : 0; |
116 |
|
|
117 |
|
chgx = cholmod_copy(chx, /* stype: */ uploT, chx->xtype, &c); |
118 |
|
/* xtype: pattern, "real", complex or .. */ |
119 |
|
Free(chx); |
120 |
|
return chm_sparse_to_SEXP(chgx, 1, 0, Rkind, "", |
121 |
|
GET_SLOT(x, Matrix_DimNamesSym)); |
122 |
|
} |
123 |
|
|
124 |
SEXP Csparse_transpose(SEXP x, SEXP tri) |
SEXP Csparse_transpose(SEXP x, SEXP tri) |
125 |
{ |
{ |
126 |
cholmod_sparse *chx = as_cholmod_sparse(x); |
cholmod_sparse *chx = as_cholmod_sparse(x); |
127 |
|
int Rkind = (chx->xtype == CHOLMOD_REAL) ? Real_kind(x) : 0; |
128 |
cholmod_sparse *chxt = cholmod_transpose(chx, (int) chx->xtype, &c); |
cholmod_sparse *chxt = cholmod_transpose(chx, (int) chx->xtype, &c); |
129 |
SEXP dn = PROTECT(duplicate(GET_SLOT(x, Matrix_DimNamesSym))), tmp; |
SEXP dn = PROTECT(duplicate(GET_SLOT(x, Matrix_DimNamesSym))), tmp; |
130 |
int uploT = 0; char *diag = ""; |
int uploT = 0; char *diag = ""; |
|
int Rkind = (chx->xtype == CHOLMOD_REAL) ? Real_kind(x) : 0; |
|
131 |
|
|
132 |
Free(chx); |
Free(chx); |
133 |
tmp = VECTOR_ELT(dn, 0); /* swap the dimnames */ |
tmp = VECTOR_ELT(dn, 0); /* swap the dimnames */ |
156 |
return chm_sparse_to_SEXP(chc, 1, 0, 0, "", dn); |
return chm_sparse_to_SEXP(chc, 1, 0, 0, "", dn); |
157 |
} |
} |
158 |
|
|
159 |
|
SEXP Csparse_Csparse_crossprod(SEXP a, SEXP b) |
160 |
|
{ |
161 |
|
cholmod_sparse *cha = as_cholmod_sparse(a), |
162 |
|
*chb = as_cholmod_sparse(b); |
163 |
|
cholmod_sparse *chta = cholmod_transpose(cha, 1, &c); |
164 |
|
cholmod_sparse *chc = cholmod_ssmult(chta, chb, 0, cha->xtype, 1, &c); |
165 |
|
SEXP dn = allocVector(VECSXP, 2); |
166 |
|
|
167 |
|
Free(cha); Free(chb); cholmod_free_sparse(&chta, &c); |
168 |
|
SET_VECTOR_ELT(dn, 0, /* establish dimnames */ |
169 |
|
duplicate(VECTOR_ELT(GET_SLOT(a, Matrix_DimNamesSym), 1))); |
170 |
|
SET_VECTOR_ELT(dn, 1, |
171 |
|
duplicate(VECTOR_ELT(GET_SLOT(b, Matrix_DimNamesSym), 1))); |
172 |
|
return chm_sparse_to_SEXP(chc, 1, 0, 0, "", dn); |
173 |
|
} |
174 |
|
|
175 |
SEXP Csparse_dense_prod(SEXP a, SEXP b) |
SEXP Csparse_dense_prod(SEXP a, SEXP b) |
176 |
{ |
{ |
177 |
cholmod_sparse *cha = as_cholmod_sparse(a); |
cholmod_sparse *cha = as_cholmod_sparse(a); |
215 |
chxt = cholmod_transpose(chx, chx->xtype, &c); |
chxt = cholmod_transpose(chx, chx->xtype, &c); |
216 |
chcp = cholmod_aat((!tr) ? chxt : chx, (int *) NULL, 0, chx->xtype, &c); |
chcp = cholmod_aat((!tr) ? chxt : chx, (int *) NULL, 0, chx->xtype, &c); |
217 |
if(!chcp) |
if(!chcp) |
218 |
error("Csparse_crossprod(): error return from cholmod_aat()"); |
error(_("Csparse_crossprod(): error return from cholmod_aat()")); |
219 |
cholmod_band_inplace(0, chcp->ncol, chcp->xtype, chcp, &c); |
cholmod_band_inplace(0, chcp->ncol, chcp->xtype, chcp, &c); |
220 |
chcp->stype = 1; |
chcp->stype = 1; |
221 |
if (trip) { |
if (trip) { |
234 |
return chm_sparse_to_SEXP(chcp, 1, 0, 0, "", dn); |
return chm_sparse_to_SEXP(chcp, 1, 0, 0, "", dn); |
235 |
} |
} |
236 |
|
|
237 |
|
SEXP Csparse_drop(SEXP x, SEXP tol) |
238 |
|
{ |
239 |
|
cholmod_sparse *chx = as_cholmod_sparse(x), |
240 |
|
*ans = cholmod_copy(chx, chx->stype, chx->xtype, &c); |
241 |
|
double dtol = asReal(tol); |
242 |
|
int Rkind = (chx->xtype == CHOLMOD_REAL) ? Real_kind(x) : 0; |
243 |
|
|
244 |
|
if(!cholmod_drop(dtol, ans, &c)) |
245 |
|
error(_("cholmod_drop() failed")); |
246 |
|
Free(chx); |
247 |
|
/* FIXME: currently drops dimnames */ |
248 |
|
return chm_sparse_to_SEXP(ans, 1, 0, Rkind, "", R_NilValue); |
249 |
|
} |
250 |
|
|
251 |
|
|
252 |
SEXP Csparse_horzcat(SEXP x, SEXP y) |
SEXP Csparse_horzcat(SEXP x, SEXP y) |
253 |
{ |
{ |
254 |
cholmod_sparse *chx = as_cholmod_sparse(x), |
cholmod_sparse *chx = as_cholmod_sparse(x), |