Matrix  $Rev: 3071 $ at $LastChangedDate: 2015-03-26 15:35:47 +0100 (Thu, 26 Mar 2015) $
TMatrix_as.c
Go to the documentation of this file.
1  /* Sparse symmetric matrices in triplet format */
2 #include "TMatrix_as.h"
3 
4 #define MAYBE_DECLARE_AND_GET_X_SLOT(__T__, __S__) \
5  DECLARE_AND_GET_X_SLOT(__T__, __S__)
6 
7 #define Matrix_T_as_DENSE(_C_TYPE_, _SEXP_, _SEXPTYPE_, _SYMM_) \
8  SEXP dimP = GET_SLOT(x, Matrix_DimSym), \
9  xiP = GET_SLOT(x, Matrix_iSym); \
10  int k, n = INTEGER(dimP)[0], nnz = length(xiP); \
11  int *xi = INTEGER(xiP), *xj = INTEGER(GET_SLOT(x, Matrix_jSym)), \
12  sz = n * n; \
13  _C_TYPE_ *tx = _SEXP_(ALLOC_SLOT(val, Matrix_xSym, _SEXPTYPE_, sz)); \
14  MAYBE_DECLARE_AND_GET_X_SLOT(_C_TYPE_, _SEXP_); \
15  \
16  SET_SLOT(val, Matrix_DimSym, duplicate(dimP)); \
17  if(_SYMM_) \
18  SET_DimNames_symm(val, x); \
19  else \
20  SET_DimNames(val, x); \
21  slot_dup(val, x, Matrix_uploSym)
22 
23 #define Matrix_T_as_DENSE_FINISH(_X_k_) \
24  AZERO(tx, sz); \
25  for (k = 0; k < nnz; k++) \
26  tx[xi[k] + xj[k] * n] = _X_k_; \
27  UNPROTECT(1); \
28  return val
29 
30 
32 {
33  SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dsyMatrix")));
34 
35  Matrix_T_as_DENSE(double, REAL, REALSXP, FALSE);
37 }
38 
40 {
41  SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("lsyMatrix")));
42 
43  Matrix_T_as_DENSE(int, LOGICAL, LGLSXP, FALSE);
45 }
46 
47 /* ---- Now the triangular ones -- have an extra 'diag' slot : ------ */
48 
50 {
51  SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dtrMatrix")));
52 
53  Matrix_T_as_DENSE(double, REAL, REALSXP, FALSE);
54  slot_dup(val, x, Matrix_diagSym);
56 }
57 
59 {
60  SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("ltrMatrix")));
61 
62  Matrix_T_as_DENSE(int, LOGICAL, LGLSXP, FALSE);
63  slot_dup(val, x, Matrix_diagSym);
65 }
66 
67 /*===================== Coercion to gTMatrix ================================*/
68 
69 #undef MAYBE_DECLARE_AND_GET_X_SLOT
70 #define MAYBE_DECLARE_AND_GET_X_SLOT(__T__, __S__) \
71  DECLARE_AND_GET_X_SLOT(__T__, __S__), *vx
72 
73 #define ALLOC_val_x_SLOT(__SEXP__, __S_TYPE__) \
74  vx = __SEXP__(ALLOC_SLOT(val, Matrix_xSym,__S_TYPE__, nv))
75 
76 #define MAYBE_ALLOC_val_x_SLOT(_S1_, _S2_) \
77  ALLOC_val_x_SLOT(_S1_, _S2_)
78 
79 #define MEMCPY_x_SLOT Memcpy(&vx[nv], xx, nnz)
80 #define MAYBE_MEMCPY_x_SLOT MEMCPY_x_SLOT
81 
82 #define SET_x_SLOT vx[nv] = xx[i]
83 #define MAYBE_SET_x_SLOT SET_x_SLOT
84 
85 #define Matrix_sT_as_GENERAL(_C_TYPE_, _SEXP_, _SEXPTYPE_) \
86  SEXP xiP = GET_SLOT(x, Matrix_iSym); \
87  /* , uplo = GET_SLOT(x, Matrix_uploSym); */ \
88  int i, nnz = length(xiP), n0d, nv, \
89  *xi = INTEGER(xiP), \
90  *xj = INTEGER(GET_SLOT(x, Matrix_jSym)), \
91  *vi, *vj; \
92  MAYBE_DECLARE_AND_GET_X_SLOT(_C_TYPE_, _SEXP_); \
93  \
94  /* Find *length* of result slots: */ \
95  /* = 2 * nnz - n0d; n0d := #{non-0 diagonals} :*/ \
96  for(i = 0, n0d = 0; i < nnz; i++) \
97  if(xi[i] == xj[i]) n0d++ ; \
98  nv = 2 * nnz - n0d; \
99  \
100  vi = INTEGER(ALLOC_SLOT(val, Matrix_iSym, INTSXP, nv)); \
101  vj = INTEGER(ALLOC_SLOT(val, Matrix_jSym, INTSXP, nv)); \
102  MAYBE_ALLOC_val_x_SLOT(_SEXP_, _SEXPTYPE_); \
103  \
104  slot_dup(val, x, Matrix_DimSym); \
105  SET_DimNames_symm(val, x); \
106  /* copy the upper/lower triangle (including the diagonal)*/ \
107  /* "at end" ([nv]): */ \
108  nv = nnz - n0d; \
109  Memcpy(&vi[nv], xi, nnz); \
110  Memcpy(&vj[nv], xj, nnz); \
111  MAYBE_MEMCPY_x_SLOT; \
112  \
113  for(i = 0, nv = 0; i < nnz; i++) { /* copy the other triangle */ \
114  if(xi[i] != xj[i]) { /* but not the diagonal */ \
115  vi[nv] = xj[i]; \
116  vj[nv] = xi[i]; \
117  MAYBE_SET_x_SLOT; \
118  nv++; \
119  } \
120  } \
121  \
122  UNPROTECT(1); \
123  return val
124 
125 
126 /* this corresponds to changing 'stype' of a cholmod_triplet;
127  * seems not available there */
129 {
130  SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgTMatrix")));
131  Matrix_sT_as_GENERAL(double, REAL, REALSXP);
132 }
133 
134 
136 {
137  SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("lgTMatrix")));
138  Matrix_sT_as_GENERAL(int, LOGICAL, LGLSXP);
139 }
140 
141 /* Now the 'nsparseMatrix' ones where input has no 'x' slot : ---------------*/
142 
143 #undef MAYBE_DECLARE_AND_GET_X_SLOT
144 #define MAYBE_DECLARE_AND_GET_X_SLOT(__T__, __S__)
145 #undef MAYBE_ALLOC_val_x_SLOT
146 #define MAYBE_ALLOC_val_x_SLOT(_S1_, _S2_)
147 #undef MAYBE_MEMCPY_x_SLOT
148 #define MAYBE_MEMCPY_x_SLOT
149 #undef MAYBE_SET_x_SLOT
150 #define MAYBE_SET_x_SLOT
151 
153 {
154  SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("nsyMatrix")));
155 
156  Matrix_T_as_DENSE(int, LOGICAL, LGLSXP, FALSE);
158 }
159 
161 {
162  SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("ntrMatrix")));
163 
164  Matrix_T_as_DENSE(int, LOGICAL, LGLSXP, FALSE);
165  slot_dup(val, x, Matrix_diagSym);
167 }
168 
170 {
171  SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("ngTMatrix")));
172  Matrix_sT_as_GENERAL(int, LOGICAL, LGLSXP);
173 }
SEXP lsTMatrix_as_lgTMatrix(SEXP x)
Definition: TMatrix_as.c:135
#define slot_dup(dest, src, sym)
Definition: Mutils.h:149
SEXP ntTMatrix_as_ntrMatrix(SEXP x)
Definition: TMatrix_as.c:160
#define Matrix_sT_as_GENERAL(_C_TYPE_, _SEXP_, _SEXPTYPE_)
Definition: TMatrix_as.c:85
SEXP ltTMatrix_as_ltrMatrix(SEXP x)
Definition: TMatrix_as.c:58
SEXP lsTMatrix_as_lsyMatrix(SEXP x)
Definition: TMatrix_as.c:39
SEXP nsTMatrix_as_nsyMatrix(SEXP x)
Definition: TMatrix_as.c:152
SEXP nsTMatrix_as_ngTMatrix(SEXP x)
Definition: TMatrix_as.c:169
#define Matrix_T_as_DENSE(_C_TYPE_, _SEXP_, _SEXPTYPE_, _SYMM_)
Definition: TMatrix_as.c:7
SEXP dsTMatrix_as_dgTMatrix(SEXP x)
Definition: TMatrix_as.c:128
SEXP Matrix_diagSym
Definition: Syms.h:2
SEXP dsTMatrix_as_dsyMatrix(SEXP x)
Definition: TMatrix_as.c:31
#define Matrix_T_as_DENSE_FINISH(_X_k_)
Definition: TMatrix_as.c:23
SEXP dtTMatrix_as_dtrMatrix(SEXP x)
Definition: TMatrix_as.c:49