| 1534 |
bates |
1 |
/* Sparse triangular logical matrices */
|
|
|
2 |
#include "ltCMatrix.h"
|
|
|
3 |
|
|
|
4 |
/**
|
|
|
5 |
* Check the validity of the slots of an ltCMatrix object
|
|
|
6 |
*
|
|
|
7 |
* @param x Pointer to an ltCMatrix object
|
|
|
8 |
*
|
|
|
9 |
* @return an SEXP that is either TRUE or a character string
|
|
|
10 |
* describing the way in which the object failed the validity check
|
|
|
11 |
*/
|
|
|
12 |
SEXP ltCMatrix_validate(SEXP x)
|
|
|
13 |
{
|
|
|
14 |
SEXP val = check_scalar_string(GET_SLOT(x, Matrix_uploSym),
|
|
|
15 |
"LU", "uplo");
|
|
|
16 |
int *Dim = INTEGER(GET_SLOT(x, Matrix_DimSym));
|
|
|
17 |
|
|
|
18 |
if (isString(val)) return val;
|
|
|
19 |
if (isString(val = check_scalar_string(GET_SLOT(x, Matrix_diagSym),
|
|
|
20 |
"NU", "diag"))) return val;
|
|
|
21 |
if (Dim[0] != Dim[1])
|
|
|
22 |
return mkString(_("Symmetric matrix must be square"));
|
|
|
23 |
csc_check_column_sorting(x);
|
|
|
24 |
return ScalarLogical(1);
|
|
|
25 |
}
|
|
|
26 |
|
|
|
27 |
/**
|
|
|
28 |
* Transpose an ltCMatrix
|
|
|
29 |
*
|
|
|
30 |
* @param x Pointer to an ltCMatrix object
|
|
|
31 |
*
|
|
|
32 |
* @return the transpose of x. It represents the same matrix but is
|
|
|
33 |
* stored in the opposite triangle.
|
|
|
34 |
*/
|
|
|
35 |
SEXP ltCMatrix_trans(SEXP x)
|
|
|
36 |
{
|
|
|
37 |
SEXP Xi = GET_SLOT(x, Matrix_iSym),
|
|
|
38 |
ans = PROTECT(NEW_OBJECT(MAKE_CLASS("ltCMatrix"))),
|
|
|
39 |
xdn = GET_SLOT(x, Matrix_DimNamesSym);
|
|
|
40 |
SEXP adn = ALLOC_SLOT(ans, Matrix_DimNamesSym, VECSXP, 2);
|
|
|
41 |
int *adims = INTEGER(ALLOC_SLOT(ans, Matrix_DimSym, INTSXP, 2)),
|
|
|
42 |
*xdims = INTEGER(GET_SLOT(x, Matrix_DimSym)),
|
|
|
43 |
up = CHAR(asChar(GET_SLOT(x, Matrix_uploSym)))[0] == 'U';
|
|
|
44 |
int m = xdims[0], n = xdims[1], nz = length(Xi);
|
|
|
45 |
int *xj = expand_cmprPt(n, INTEGER(GET_SLOT(x, Matrix_pSym)),
|
|
|
46 |
Calloc(nz, int));
|
|
|
47 |
|
|
|
48 |
adims[0] = n; adims[1] = m;
|
|
|
49 |
SET_VECTOR_ELT(adn, 0, VECTOR_ELT(xdn, 1));
|
|
|
50 |
SET_VECTOR_ELT(adn, 1, VECTOR_ELT(xdn, 0));
|
|
|
51 |
SET_SLOT(ans, Matrix_uploSym, mkString(up ? "L" : "U"));
|
|
|
52 |
SET_SLOT(ans, Matrix_diagSym, duplicate(GET_SLOT(x, Matrix_diagSym)));
|
|
|
53 |
triplet_to_col(n, m, nz, xj, INTEGER(Xi), (double *) NULL,
|
|
|
54 |
INTEGER(ALLOC_SLOT(ans, Matrix_pSym, INTSXP, m + 1)),
|
|
|
55 |
INTEGER(ALLOC_SLOT(ans, Matrix_iSym, INTSXP, nz)),
|
|
|
56 |
(double *) NULL);
|
|
|
57 |
Free(xj);
|
|
|
58 |
UNPROTECT(1);
|
|
|
59 |
return ans;
|
|
|
60 |
}
|
|
|
61 |
|
|
|
62 |
/**
|
|
|
63 |
* Solve one of the matrix equations op(A)*C = B, or
|
|
|
64 |
* C*op(A) = B where A is a square ltCMatrix and B and C are lgCMatrix
|
|
|
65 |
* objects.
|
|
|
66 |
*
|
|
|
67 |
* @param side LFT or RGT
|
|
|
68 |
* @param transa TRN or NTR
|
|
|
69 |
* @param A pointer to an ltCMatrix object
|
|
|
70 |
* @param B pointer to an lgCMatrix object
|
|
|
71 |
* @param C pointer to an lgCMatrix object
|
|
|
72 |
*/
|
|
|
73 |
void
|
|
|
74 |
ltClgCsm(enum CBLAS_SIDE side, enum CBLAS_TRANSPOSE transa,
|
|
|
75 |
SEXP A, SEXP B, SEXP C)
|
|
|
76 |
{
|
|
|
77 |
error(_("code not yet written"));
|
|
|
78 |
}
|
The R Project SVN
R-packages