SCM

SCM Repository

[matrix] Annotation of /pkg/src/dgTMatrix.c
ViewVC logotype

Annotation of /pkg/src/dgTMatrix.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2203 - (view) (download) (as text)

1 : mmaechler 2203 #include <Rinternals.h>
2 :     /* for R_LEN... */
3 :    
4 : bates 478 #include "dgTMatrix.h"
5 : bates 10
6 : bates 922 #include "chm_common.h"
7 :     #include "Tsparse.h"
8 :    
9 : maechler 1661 SEXP xTMatrix_validate(SEXP x)
10 : bates 10 {
11 : maechler 1661 /* Almost everything now in Tsparse_validate ( ./Tsparse.c )
12 :     * *but* the checking of the 'x' slot : */
13 :     if (LENGTH(GET_SLOT(x, Matrix_iSym)) !=
14 :     LENGTH(GET_SLOT(x, Matrix_xSym)))
15 : bates 922 return mkString(_("lengths of slots i and x must match"));
16 : bates 10 return ScalarLogical(1);
17 :     }
18 : bates 70
19 : bates 390 static void
20 : maechler 1747 d_insert_triplets_in_array(int m, int n, int nnz,
21 :     const int xi[], const int xj[],
22 :     const double xx[], double vx[])
23 : bates 390 {
24 :     int i;
25 :     memset(vx, 0, sizeof(double) * m * n);
26 :     for (i = 0; i < nnz; i++) {
27 :     vx[xi[i] + xj[i] * m] += xx[i]; /* allow redundant entries in x */
28 :     }
29 : maechler 534 }
30 :    
31 : maechler 1747 static void
32 :     l_insert_triplets_in_array(int m, int n, int nnz,
33 :     const int xi[], const int xj[],
34 :     const int xx[], int vx[])
35 : bates 70 {
36 : maechler 1747 int i;
37 :     memset(vx, 0, sizeof(int) * m * n);
38 :     for (i = 0; i < nnz; i++) {
39 :     vx[xi[i] + xj[i] * m] += xx[i]; /* allow redundant entries in x */
40 :     }
41 :     }
42 : maechler 534
43 : maechler 1747 #define MAKE_gTMatrix_to_geMatrix(_t1_, _SEXPTYPE_, _SEXP_) \
44 :     SEXP _t1_ ## gTMatrix_to_ ## _t1_ ## geMatrix(SEXP x) \
45 :     { \
46 :     SEXP dd = GET_SLOT(x, Matrix_DimSym), \
47 :     islot = GET_SLOT(x, Matrix_iSym), \
48 :     ans = PROTECT(NEW_OBJECT(MAKE_CLASS(#_t1_ "geMatrix"))); \
49 :     \
50 :     int *dims = INTEGER(dd), \
51 :     m = dims[0], \
52 :     n = dims[1]; \
53 : mmaechler 2203 double len = m * (double)n; \
54 : maechler 1747 \
55 : mmaechler 2203 if (len > R_LEN_T_MAX) \
56 :     error(_("Cannot coerce to too large *geMatrix with %.0f entries"), \
57 :     len); \
58 :     \
59 : maechler 1747 SET_SLOT(ans, Matrix_factorSym, allocVector(VECSXP, 0)); \
60 :     SET_SLOT(ans, Matrix_DimSym, duplicate(dd)); \
61 :     SET_DimNames(ans, x); \
62 : mmaechler 2203 SET_SLOT(ans, Matrix_xSym, allocVector(_SEXPTYPE_, (R_len_t)len)); \
63 : maechler 1747 _t1_ ## _insert_triplets_in_array(m, n, length(islot), \
64 :     INTEGER(islot), \
65 :     INTEGER(GET_SLOT(x, Matrix_jSym)),\
66 :     _SEXP_(GET_SLOT(x, Matrix_xSym)), \
67 :     _SEXP_(GET_SLOT(ans, Matrix_xSym))); \
68 :     UNPROTECT(1); \
69 :     return ans; \
70 : bates 70 }
71 :    
72 : maechler 1747 MAKE_gTMatrix_to_geMatrix(d, REALSXP, REAL)
73 :    
74 :     MAKE_gTMatrix_to_geMatrix(l, LGLSXP, LOGICAL)
75 :    
76 :     #undef MAKE_gTMatrix_to_geMatrix
77 :    
78 :     #define MAKE_gTMatrix_to_matrix(_t1_, _SEXPTYPE_, _SEXP_) \
79 :     SEXP _t1_ ## gTMatrix_to_matrix(SEXP x) \
80 :     { \
81 :     SEXP dd = GET_SLOT(x, Matrix_DimSym), \
82 :     dn = GET_SLOT(x, Matrix_DimNamesSym), \
83 :     islot = GET_SLOT(x, Matrix_iSym); \
84 :     int m = INTEGER(dd)[0], \
85 :     n = INTEGER(dd)[1]; \
86 :     SEXP ans = PROTECT(allocMatrix(_SEXPTYPE_, m, n)); \
87 :     if(VECTOR_ELT(dn, 0) != R_NilValue || VECTOR_ELT(dn, 1) != R_NilValue) \
88 :     /* matrix() with non-trivial dimnames */ \
89 :     setAttrib(ans, R_DimNamesSymbol, duplicate(dn)); \
90 :     _t1_ ## _insert_triplets_in_array(m, n, length(islot), \
91 :     INTEGER(islot), \
92 :     INTEGER(GET_SLOT(x, Matrix_jSym)),\
93 :     _SEXP_(GET_SLOT(x, Matrix_xSym)), \
94 :     _SEXP_(ans)); \
95 :     UNPROTECT(1); \
96 :     return ans; \
97 : bates 390 }
98 : bates 862
99 : maechler 1747 MAKE_gTMatrix_to_matrix(d, REALSXP, REAL)
100 :    
101 :     MAKE_gTMatrix_to_matrix(l, LGLSXP, LOGICAL)
102 :    
103 :     #undef MAKE_gTMatrix_to_matrix
104 :    
105 :    
106 : maechler 1271 #ifdef _valid_only_for_old_graph_package
107 : maechler 874 SEXP graphNEL_as_dgTMatrix(SEXP x, SEXP symmetric)
108 : bates 862 {
109 : bates 876 int sym = asLogical(symmetric);
110 : bates 862 SEXP nodes = GET_SLOT(x, install("nodes")),
111 :     edgeL = GET_SLOT(x, install("edgeL")),
112 : bates 876 ans = PROTECT(NEW_OBJECT(MAKE_CLASS(sym
113 : maechler 874 ? "dsTMatrix"
114 :     : "dgTMatrix")));
115 : bates 862 int *ii, *jj, *dims, i, j, nnd = LENGTH(nodes), pos, totl;
116 :     double *xx;
117 : maechler 874
118 : bates 862 totl = 0;
119 :     for (i = 0; i < nnd; i++)
120 :     totl += LENGTH(Matrix_getElement(VECTOR_ELT(edgeL, i), "edges"));
121 :     dims = INTEGER(ALLOC_SLOT(ans, Matrix_DimSym, INTSXP, 2));
122 :     dims[0] = dims[1] = nnd;
123 :     if (isString(nodes)) {
124 :     SEXP dnms = ALLOC_SLOT(ans, Matrix_DimNamesSym, VECSXP, 2);
125 :     SET_VECTOR_ELT(dnms, 0, duplicate(nodes));
126 :     SET_VECTOR_ELT(dnms, 1, duplicate(nodes));
127 :     }
128 : maechler 1960 ii = Alloca(totl, int);
129 :     jj = Alloca(totl, int);
130 :     xx = Alloca(totl, double);
131 :     R_CheckStack();
132 : bates 862 pos = 0;
133 :     for (i = 0; i < nnd; i++) {
134 :     SEXP edg = VECTOR_ELT(edgeL, i);
135 :     SEXP edges = Matrix_getElement(edg, "edges"),
136 :     weights = Matrix_getElement(edg, "weights");
137 : bates 876 int *edgs = INTEGER(PROTECT(coerceVector(edges, INTSXP))),
138 :     nedg = LENGTH(edges);
139 : bates 862 double *wts = REAL(weights);
140 : maechler 874
141 : bates 862 for (j = 0; j < nedg; j++) {
142 : bates 876 int j1 = edgs[j] - 1;
143 :     /* symmetric case stores upper triangle only */
144 :     if ((!sym) || i <= j1) {
145 :     ii[pos] = i;
146 :     jj[pos] = j1;
147 :     xx[pos] = wts[j];
148 :     pos++;
149 :     }
150 : bates 862 }
151 : bates 876 UNPROTECT(1);
152 : bates 862 }
153 : bates 876 Memcpy(INTEGER(ALLOC_SLOT(ans, Matrix_iSym, INTSXP, pos)), ii, pos);
154 :     Memcpy(INTEGER(ALLOC_SLOT(ans, Matrix_jSym, INTSXP, pos)), jj, pos);
155 :     Memcpy(REAL(ALLOC_SLOT(ans, Matrix_xSym, REALSXP, pos)), xx, pos);
156 :    
157 : bates 862 UNPROTECT(1);
158 :     return ans;
159 :     }
160 : maechler 1271 #endif

root@r-forge.r-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business Powered By FusionForge