Matrix r4655
Loading...
Searching...
No Matches
bind.c
Go to the documentation of this file.
1#include "Mdefines.h"
2#include "coerce.h"
3#include "bind.h"
4
5static const char *valid[] = { VALID_NONVIRTUAL_MATRIX, "" };
6
7static SEXP tagWasVector = NULL;
8
9static
10void scanArgs(SEXP args, SEXP exprs, int margin, int level,
11 int *rdim, int *rdimnames, char *kind, char *repr)
12{
13 SEXP a, e, s, tmp;
14 int nS4 = 0, nDense = 0,
15 anyCsparse = 0, anyRsparse = 0, anyTsparse = 0, anyDiagonal = 0,
16 anyN = 0, anyL = 0, anyI = 0, anyD = 0, anyZ = 0,
17 i, ivalid, *sdim;
18 R_xlen_t slen;
19 const char *scl;
20
21 rdim[!margin] = -1;
22 rdim[ margin] = 0;
23 rdimnames[0] = rdimnames[1] = 0;
24
25 for (a = args; a != R_NilValue; a = CDR(a)) {
26 s = CAR(a);
27 if (s == R_NilValue)
28 continue;
29 if (TYPEOF(s) == S4SXP) {
30 ++nS4;
31 ivalid = R_check_class_etc(s, valid);
32 if (ivalid < 0) {
33 if (margin)
34 ERROR_INVALID_CLASS(s, "cbind.Matrix");
35 else
36 ERROR_INVALID_CLASS(s, "rbind.Matrix");
37 }
38 scl = valid[ivalid + VALID_NONVIRTUAL_SHIFT(ivalid, 1)];
39
40 tmp = GET_SLOT(s, Matrix_DimSym);
41 sdim = INTEGER(tmp);
42 if (rdim[!margin] < 0)
43 rdim[!margin] = sdim[!margin];
44 else if (sdim[!margin] != rdim[!margin]) {
45 if (margin)
46 error(_("number of rows of matrices must match"));
47 else
48 error(_("number of columns of matrices must match"));
49 }
50 if (sdim[margin] > INT_MAX - rdim[margin])
51 error(_("dimensions cannot exceed %s"), "2^31-1");
52 rdim[margin] += sdim[margin];
53
54 if (!rdimnames[0] || !rdimnames[1]) {
55 tmp = GET_SLOT(s, Matrix_DimNamesSym);
56 if (scl[1] == 's') {
57 if (VECTOR_ELT(tmp, 0) != R_NilValue ||
58 VECTOR_ELT(tmp, 1) != R_NilValue)
59 rdimnames[0] = rdimnames[1] = 1;
60 } else
61 for (i = 0; i < 2; ++i)
62 if (!rdimnames[i] &&
63 VECTOR_ELT(tmp, i) != R_NilValue)
64 rdimnames[i] = 1;
65 }
66
67 switch (scl[0]) {
68 case 'n':
69 anyN = 1;
70 break;
71 case 'l':
72 anyL = 1;
73 break;
74 case 'i':
75 if (scl[2] != 'd')
76 anyI = 1;
77 break;
78 case 'd':
79 anyD = 1;
80 break;
81 case 'z':
82 anyZ = 1;
83 break;
84 default:
85 break;
86 }
87
88 switch (scl[2]) {
89 case 'e':
90 case 'y':
91 case 'r':
92 case 'p':
93 ++nDense;
94 break;
95 case 'C':
96 anyCsparse = 1;
97 break;
98 case 'R':
99 anyRsparse = 1;
100 break;
101 case 'T':
102 {
103 /* defined in ./sparse.c : */
104 SEXP Tsparse_aggregate(SEXP);
105 SETCAR(a, Tsparse_aggregate(s));
106 anyTsparse = 1;
107 break;
108 }
109 case 'i':
110 anyDiagonal = 1;
111 break;
112 case 'd':
113 if (INTEGER(GET_SLOT(s, Matrix_marginSym))[0] - 1 != margin) {
114 anyN = 1;
115 if (margin)
116 anyCsparse = 1;
117 else
118 anyRsparse = 1;
119 }
120 break;
121 default:
122 break;
123 }
124 } else {
125 switch (TYPEOF(s)) {
126 case LGLSXP:
127 anyL = 1;
128 break;
129 case INTSXP:
130 anyI = 1;
131 break;
132 case REALSXP:
133 anyD = 1;
134 break;
135 case CPLXSXP:
136 anyZ = 1;
137 break;
138 default:
139 if (margin)
140 ERROR_INVALID_TYPE(s, "cbind.Matrix");
141 else
142 ERROR_INVALID_TYPE(s, "rbind.Matrix");
143 break;
144 }
145
146 tmp = getAttrib(s, R_DimSymbol);
147 if (TYPEOF(tmp) == INTSXP && LENGTH(tmp) == 2) {
148 sdim = INTEGER(tmp);
149 if (rdim[!margin] < 0)
150 rdim[!margin] = sdim[!margin];
151 else if (rdim[!margin] != sdim[!margin]) {
152 if (margin)
153 error(_("number of rows of matrices must match"));
154 else
155 error(_("number of columns of matrices must match"));
156 }
157 if (sdim[margin] > INT_MAX - rdim[margin])
158 error(_("dimensions cannot exceed %s"), "2^31-1");
159 rdim[margin] += sdim[margin];
160
161 if (!rdimnames[0] || !rdimnames[1]) {
162 tmp = getAttrib(s, R_DimNamesSymbol);
163 if (tmp != R_NilValue)
164 for (i = 0; i < 2; ++i)
165 if (!rdimnames[i] &&
166 VECTOR_ELT(tmp, i) != R_NilValue)
167 rdimnames[i] = 1;
168 }
169 }
170 }
171 }
172
173 if (rdim[!margin] < 0) {
174 /* Arguments are all vectors or NULL */
175 R_xlen_t maxlen = -1;
176 for (a = args; a != R_NilValue; a = CDR(a)) {
177 s = CAR(a);
178 if (s == R_NilValue)
179 continue;
180 slen = XLENGTH(s);
181 if (slen > INT_MAX)
182 error(_("dimensions cannot exceed %s"), "2^31-1");
183 else if (slen > maxlen)
184 maxlen = slen;
185 }
186 if (maxlen < 0)
187 /* Arguments are all NULL */
188 return;
189 rdim[!margin] = (int) maxlen;
190 }
191
192 for (a = args, e = exprs; a != R_NilValue; a = CDR(a), e = CDR(e)) {
193 s = CAR(a);
194 if ((s == R_NilValue && rdim[!margin] > 0) || TYPEOF(s) == S4SXP)
195 continue;
196 if (s == R_NilValue)
197 rdim[margin] += 1;
198 else {
199 tmp = getAttrib(s, R_DimSymbol);
200 if (TYPEOF(tmp) == INTSXP && LENGTH(tmp) == 2)
201 continue;
202 slen = XLENGTH(s);
203 if (slen == 0 && rdim[!margin] > 0)
204 continue;
205 if (rdim[margin] == INT_MAX)
206 error(_("dimensions cannot exceed %s"), "2^31-1");
207 rdim[margin] += 1;
208 if (slen > rdim[!margin] || rdim[!margin] % (int) slen) {
209 if (margin)
210 warning(_("number of rows of result is not a multiple of vector length"));
211 else
212 warning(_("number of columns of result is not a multiple of vector length"));
213 }
214 if (!rdimnames[!margin] && slen == rdim[!margin]) {
215 tmp = getAttrib(s, R_NamesSymbol);
216 if (tmp != R_NilValue)
217 rdimnames[!margin] = 1;
218 }
219 }
220 if (!rdimnames[margin]) {
221 if (TAG(a) != R_NilValue ||
222 level == 2 || (level == 1 && TYPEOF(CAR(e)) == SYMSXP))
223 rdimnames[margin] = 1;
224 }
225 }
226
227 if (anyZ)
228 *kind = 'z';
229#ifndef MATRIX_ENABLE_IMATRIX
230 else if (anyD || anyI)
231 *kind = 'd';
232#else
233 else if (anyD)
234 *kind = 'd';
235 else if (anyI)
236 *kind = 'i';
237#endif
238 else if (anyL)
239 *kind = 'l';
240 else if (anyN)
241 *kind = 'n';
242 else
243 *kind = '\0';
244
245 if (nDense == nS4)
246 *repr = 'e';
247 else if (nDense == 0) {
248 if (anyCsparse && anyRsparse)
249 *repr = (margin) ? 'C' : 'R';
250 else if (anyCsparse)
251 *repr = 'C';
252 else if (anyRsparse)
253 *repr = 'R';
254 else if (anyTsparse)
255 *repr = 'T';
256 else if (anyDiagonal)
257 *repr = (margin) ? 'C' : 'R';
258 else
259 *repr = '\0';
260 } else {
261 /* The length of the result is at most INT_MAX * INT_MAX,
262 which cannot overflow Matrix_int_fast64_t as long as R
263 builds require sizeof(int) equal to 4
264 */
265 Matrix_int_fast64_t nnz = 0, len = 0, snnz = 0, slen = 0;
266 for (a = args; a != R_NilValue && nnz < INT_MAX; a = CDR(a)) {
267 s = CAR(a);
268 if (TYPEOF(s) != S4SXP)
269 continue;
270 ivalid = R_check_class_etc(s, valid);
271 scl = valid[ivalid + VALID_NONVIRTUAL_SHIFT(ivalid, 1)];
272
273 PROTECT(tmp = GET_SLOT(s, Matrix_DimSym));
274 sdim = INTEGER(tmp);
275 slen = (Matrix_int_fast64_t) sdim[0] * sdim[1];
276
277 switch (scl[2]) {
278 case 'e':
279 case 'y':
280 case 'r':
281 case 'p':
282 snnz = (scl[1] != 't') ? slen : ((slen + sdim[0]) / 2);
283 break;
284 case 'C':
285 case 'R':
286 {
287 SEXP p = PROTECT(GET_SLOT(s, Matrix_pSym));
288 int *pp = INTEGER(p), n = sdim[(scl[2] == 'C') ? 1 : 0];
289 snnz = pp[n];
290 if (scl[1] == 's') {
291 SEXP iSym = (scl[2] == 'C') ? Matrix_iSym : Matrix_jSym,
292 i = PROTECT(GET_SLOT(s, iSym));
293 int *pi = INTEGER(i), j;
294 snnz *= 2;
295 if (*CHAR(STRING_ELT(GET_SLOT(s, Matrix_uploSym), 0)) == 'U') {
296 for (j = 0; j < n; ++j)
297 if (pp[j] < pp[j + 1] && pi[pp[j + 1] - 1] == j)
298 --snnz;
299 } else {
300 for (j = 0; j < n; ++j)
301 if (pp[j] < pp[j + 1] && pi[pp[j]] == j)
302 --snnz;
303 }
304 UNPROTECT(1);
305 } else if (scl[1] == 't' && *CHAR(STRING_ELT(GET_SLOT(s, Matrix_diagSym), 0)) != 'N')
306 snnz += sdim[0];
307 UNPROTECT(1);
308 break;
309 }
310 case 'T':
311 {
312 SEXP i = PROTECT(GET_SLOT(s, Matrix_iSym));
313 snnz = XLENGTH(i);
314 if (scl[1] == 's') {
315 SEXP j = PROTECT(GET_SLOT(s, Matrix_jSym));
316 int *pi = INTEGER(i), *pj = INTEGER(j);
317 R_xlen_t k = XLENGTH(i);
318 snnz *= 2;
319 while (k--)
320 if (*(pi++) == *(pj++))
321 --snnz;
322 UNPROTECT(1);
323 } else if (scl[1] == 't' && *CHAR(STRING_ELT(GET_SLOT(s, Matrix_diagSym), 0)) != 'N')
324 snnz += sdim[0];
325 UNPROTECT(1);
326 break;
327 }
328 case 'i':
329 snnz = sdim[0];
330 break;
331 case 'd':
332 snnz = XLENGTH(GET_SLOT(s, Matrix_permSym));
333 break;
334 default:
335 break;
336 }
337
338 nnz += snnz;
339 len += slen;
340 UNPROTECT(1);
341 }
342
343 if (nnz > INT_MAX || nnz > len / 2)
344 *repr = 'e';
345 else if (anyCsparse && anyRsparse)
346 *repr = (margin) ? 'C' : 'R';
347 else if (anyCsparse)
348 *repr = 'C';
349 else if (anyRsparse)
350 *repr = 'R';
351 else if (anyTsparse)
352 *repr = 'T';
353 else
354 *repr = (margin) ? 'C' : 'R';
355 }
356
357 return;
358}
359
360static
361void coerceArgs(SEXP args, int margin,
362 int *rdim, char kind, char repr)
363{
364 SEXP a, s, t, tmp;
365 int ivalid, isM;
366 char scl_[] = "...Matrix";
367 const char *scl;
368
369 for (a = args; a != R_NilValue; a = CDR(a)) {
370 s = CAR(a);
371 t = TAG(a);
372 SET_TAG(a, R_NilValue); /* to be replaced only if 's' is a vector */
373 if (s == R_NilValue)
374 continue;
375 PROTECT_INDEX pid;
376 PROTECT_WITH_INDEX(s, &pid);
377 if (TYPEOF(s) == S4SXP) {
378 ivalid = R_check_class_etc(s, valid);
379 scl = valid[ivalid + VALID_NONVIRTUAL_SHIFT(ivalid, 1)];
380 switch (scl[2]) {
381 case 'e':
382 case 'y':
383 case 'r':
384 case 'p':
385 switch (repr) {
386 case 'e':
387 REPROTECT(s = dense_as_kind(s, scl, kind, 0), pid);
388 scl_[0] = kind; scl_[1] = scl[1]; scl_[2] = scl[2];
389 REPROTECT(s = dense_as_general(
390 s, scl_, kindToType(kind) == kindToType(scl[0])), pid);
391 break;
392 case 'C':
393 case 'R':
394 case 'T':
395 REPROTECT(s = dense_as_sparse(s, scl, repr), pid);
396 scl_[0] = scl[0]; scl_[1] = scl[1]; scl_[2] = repr;
397 REPROTECT(s = sparse_as_kind(s, scl_, kind), pid);
398 scl_[0] = kind;
399 REPROTECT(s = sparse_as_general(s, scl_), pid);
400 break;
401 default:
402 break;
403 }
404 break;
405 case 'C':
406 case 'R':
407 case 'T':
408 REPROTECT(s = sparse_as_kind(s, scl, kind), pid);
409 scl_[0] = kind; scl_[1] = scl[1]; scl_[2] = scl[2];
410 REPROTECT(s = sparse_as_general(s, scl_), pid);
411 scl_[1] = 'g';
412 switch (repr) {
413 case 'e':
414 REPROTECT(s = sparse_as_dense(s, scl_, 0), pid);
415 break;
416 case 'C':
417 REPROTECT(s = sparse_as_Csparse(s, scl_), pid);
418 break;
419 case 'R':
420 REPROTECT(s = sparse_as_Rsparse(s, scl_), pid);
421 break;
422 case 'T':
423 REPROTECT(s = sparse_as_Tsparse(s, scl_), pid);
424 break;
425 default:
426 break;
427 }
428 break;
429 case 'i':
430 switch (repr) {
431 case 'e':
432 REPROTECT(s = diagonal_as_dense(s, scl_, kind, 'g', 0, '\0'), pid);
433 break;
434 case 'C':
435 case 'R':
436 case 'T':
437 REPROTECT(s = diagonal_as_sparse(s, scl_, kind, 'g', repr, '\0'), pid);
438 break;
439 default:
440 break;
441 }
442 break;
443 case 'd':
444 switch (repr) {
445 case 'e':
446 REPROTECT(s = index_as_dense(s, scl, kind), pid);
447 break;
448 case 'C':
449 case 'R':
450 case 'T':
451 REPROTECT(s = index_as_sparse(s, scl, kind, repr), pid);
452 break;
453 default:
454 break;
455 }
456 break;
457 default:
458 break;
459 }
460 } else {
461 tmp = getAttrib(s, R_DimSymbol);
462 isM = TYPEOF(tmp) == INTSXP && LENGTH(tmp) == 2;
463 if (!isM) {
464 if (rdim[!margin] > 0 && XLENGTH(s) == 0) {
465 UNPROTECT(1);
466 continue;
467 }
468 SET_TAG(a, (t != R_NilValue) ? t : tagWasVector);
469 }
470 if (TYPEOF(s) != kindToType(kind))
471 REPROTECT(s = coerceVector(s, kindToType(kind)), pid);
472 if (repr != 'e') {
473 if (!isM && XLENGTH(s) != rdim[!margin]) {
474 static SEXP replen = NULL;
475 if (!replen)
476 replen = install("rep_len");
477 SEXP lengthout = PROTECT(ScalarInteger(rdim[!margin])),
478 call = PROTECT(lang3(replen, s, lengthout));
479 REPROTECT(s = eval(call, R_GlobalEnv), pid);
480 UNPROTECT(2);
481 }
482 scl_[1] = 'g';
483 scl_[2] = repr;
484 REPROTECT(s = matrix_as_sparse(s, scl_, '\0', '\0', !margin), pid);
485 }
486 }
487 SETCAR(a, s);
488 UNPROTECT(1);
489 }
490
491 return;
492}
493
494static
495void bindArgs(SEXP args, int margin, SEXP res,
496 int *rdim, char kind, char repr)
497{
498 SEXP a, s;
499
500#define BIND_CASES(_BIND_) \
501 do { \
502 switch (kind) { \
503 case 'l': \
504 _BIND_(int, LOGICAL, SHOW); \
505 break; \
506 case 'i': \
507 _BIND_(int, INTEGER, SHOW); \
508 break; \
509 case 'd': \
510 _BIND_(double, REAL, SHOW); \
511 break; \
512 case 'z': \
513 _BIND_(Rcomplex, COMPLEX, SHOW); \
514 break; \
515 default: \
516 break; \
517 } \
518 } while (0)
519
520 if (repr == 'e') {
521
522 if (rdim[0] == 0 || rdim[1] == 0)
523 return;
524
525 int k, m = rdim[0], n = rdim[1];
526 R_xlen_t mn = (R_xlen_t) m * n;
527 SEXP x = PROTECT(allocVector(kindToType(kind), mn)), tmp;
528 SET_SLOT(res, Matrix_xSym, x);
529
530#define BIND_E(_CTYPE_, _PTR_, _MASK_) \
531 do { \
532 _CTYPE_ *px = _PTR_(x), *ps; \
533 for (a = args; a != R_NilValue; a = CDR(a)) { \
534 s = CAR(a); \
535 if (s == R_NilValue) \
536 continue; \
537 if (TYPEOF(s) != S4SXP) \
538 tmp = getAttrib(s, R_DimSymbol); \
539 else { \
540 s = GET_SLOT(s, Matrix_xSym); \
541 tmp = NULL; \
542 } \
543 mn = XLENGTH(s); \
544 ps = _PTR_(s); \
545 if (margin) { \
546 if (!tmp || (TYPEOF(tmp) == INTSXP && LENGTH(tmp) == 2)) { \
547 Matrix_memcpy(px, ps, mn, sizeof(_CTYPE_)); \
548 px += mn; \
549 } else if (mn >= m) { \
550 Matrix_memcpy(px, ps, m , sizeof(_CTYPE_)); \
551 px += m; \
552 } else if (mn == 1) { \
553 _CTYPE_ v = ps[0]; \
554 for (k = 0; k < m; ++k) \
555 *(px++) = v; \
556 } else { \
557 int mn_ = (int) mn; \
558 for (k = 0; k < rdim[0]; ++k) \
559 *(px++) = ps[k % mn_]; \
560 } \
561 } else { \
562 _CTYPE_ *py = px; \
563 if (!tmp || (TYPEOF(tmp) == INTSXP && LENGTH(tmp) == 2)) { \
564 m = (int) (mn / n); \
565 for (k = 0; k < n; ++k) { \
566 Matrix_memcpy(py, ps, m, sizeof(_CTYPE_)); \
567 py += rdim[0]; \
568 ps += m; \
569 } \
570 px += m; \
571 } else if (mn >= n) { \
572 for (k = 0; k < n; ++k) { \
573 *py = *ps; \
574 py += rdim[0]; \
575 ps += 1; \
576 } \
577 px += 1; \
578 } else if (mn == 1) { \
579 _CTYPE_ v = ps[0]; \
580 for (k = 0; k < n; ++k) { \
581 *py = v; \
582 py += rdim[0]; \
583 } \
584 px += 1; \
585 } else { \
586 int mn_ = (int) mn; \
587 for (k = 0; k < n; ++k) { \
588 *py = ps[k % mn_]; \
589 py += rdim[0]; \
590 } \
591 px += 1; \
592 } \
593 } \
594 } \
595 } while (0)
596
597 if (kind == 'n')
598 BIND_E(int, LOGICAL, SHOW);
599 else
600 BIND_CASES(BIND_E);
601 UNPROTECT(1);
602
603 } else if ((repr == 'C' && margin) || (repr == 'R' && !margin)) {
604
605 SEXP p = PROTECT(allocVector(INTSXP, (R_xlen_t) rdim[margin] + 1));
606 int *pp = INTEGER(p);
607 SET_SLOT(res, Matrix_pSym, p);
608
609 if (rdim[0] == 0 || rdim[1] == 0) {
610 Matrix_memset(pp, 0, (R_xlen_t) rdim[margin] + 1, sizeof(int));
611 UNPROTECT(1);
612 return;
613 }
614
615 SEXP sp;
616 int *psp, j, n, nnz = 0;
617 *(pp++) = nnz = 0;
618 for (a = args; a != R_NilValue; a = CDR(a)) {
619 s = CAR(a);
620 if (s == R_NilValue)
621 continue;
622 sp = GET_SLOT(s, Matrix_pSym);
623 psp = INTEGER(sp);
624 n = (int) (XLENGTH(sp) - 1);
625 if (psp[n] > INT_MAX - nnz)
626 error(_("%s cannot exceed %s"), "p[length(p)]", "2^31-1");
627 for (j = 0; j < n; ++j)
628 *(pp++) = nnz = nnz + (psp[j + 1] - psp[j]);
629 }
630
631 SEXP i = PROTECT(allocVector(INTSXP, nnz)), si,
632 iSym = (repr == 'C') ? Matrix_iSym : Matrix_jSym;
633 int *pi = INTEGER(i), *psi;
634 SET_SLOT(res, iSym, i);
635
636#define BIND_C1R0(_CTYPE_, _PTR_, _MASK_) \
637 do { \
638 _MASK_(_CTYPE_ *px = _PTR_(x), *psx); \
639 for (a = args; a != R_NilValue; a = CDR(a)) { \
640 s = CAR(a); \
641 if (s == R_NilValue) \
642 continue; \
643 PROTECT(sp = GET_SLOT(s, Matrix_pSym)); \
644 PROTECT(si = GET_SLOT(s, iSym)); \
645 _MASK_(PROTECT(sx = GET_SLOT(s, Matrix_xSym))); \
646 psp = INTEGER(sp); \
647 psi = INTEGER(si); \
648 _MASK_(psx = _PTR_(sx)); \
649 n = (int) (XLENGTH(sp) - 1); \
650 Matrix_memcpy(pi, psi, psp[n], sizeof(int)); \
651 _MASK_(Matrix_memcpy(px, psx, psp[n], sizeof(_CTYPE_))); \
652 pi += psp[n]; \
653 _MASK_(px += psp[n]); \
654 _MASK_(UNPROTECT(1)); \
655 UNPROTECT(2); \
656 } \
657 } while (0)
658
659 if (kind == 'n')
660 BIND_C1R0(int, LOGICAL, HIDE);
661 else {
662 SEXP x = PROTECT(allocVector(kindToType(kind), nnz)), sx;
663 SET_SLOT(res, Matrix_xSym, x);
664 BIND_CASES(BIND_C1R0);
665 UNPROTECT(1);
666 }
667 UNPROTECT(2);
668
669 } else if ((repr == 'C' && !margin) || (repr == 'R' && margin)) {
670
671 SEXP p = PROTECT(allocVector(INTSXP, (R_xlen_t) rdim[!margin] + 1));
672 int *pp = INTEGER(p);
673 SET_SLOT(res, Matrix_pSym, p);
674 Matrix_memset(pp, 0, (R_xlen_t) rdim[!margin] + 1, sizeof(int));
675
676 if (rdim[0] == 0 || rdim[1] == 0) {
677 UNPROTECT(1);
678 return;
679 }
680
681 SEXP sp;
682 int *psp, j, n = rdim[!margin];
683 ++pp;
684 for (a = args; a != R_NilValue; a = CDR(a)) {
685 s = CAR(a);
686 if (s == R_NilValue)
687 continue;
688 sp = GET_SLOT(s, Matrix_pSym);
689 psp = INTEGER(sp) + 1;
690 if (n > 0 && psp[n - 1] > INT_MAX - pp[n - 1])
691 error(_("%s cannot exceed %s"), "p[length(p)]", "2^31-1");
692 for (j = 0; j < n; ++j)
693 pp[j] += psp[j];
694 }
695 --pp;
696
697 int nnz = pp[n];
698 SEXP i = PROTECT(allocVector(INTSXP, nnz)), si,
699 iSym = (repr == 'C') ? Matrix_iSym : Matrix_jSym;
700 int *pi = INTEGER(i), *psi, *work, k, kend, pos = 0;
701 SET_SLOT(res, iSym, i);
702 Matrix_Calloc(work, n, int);
703 Matrix_memcpy(work, pp, n, sizeof(int));
704
705#define BIND_C0R1(_CTYPE_, _PTR_, _MASK_) \
706 do { \
707 _MASK_(_CTYPE_ *px = _PTR_(x), *psx); \
708 for (a = args; a != R_NilValue; a = CDR(a)) { \
709 s = CAR(a); \
710 if (s == R_NilValue) \
711 continue; \
712 PROTECT(sp = GET_SLOT(s, Matrix_pSym)); \
713 PROTECT(si = GET_SLOT(s, iSym)); \
714 _MASK_(PROTECT(sx = GET_SLOT(s, Matrix_xSym))); \
715 psp = INTEGER(sp); \
716 psi = INTEGER(si); \
717 _MASK_(psx = _PTR_(sx)); \
718 for (j = 0, k = 0; j < n; ++j) { \
719 kend = psp[j + 1]; \
720 while (k < kend) { \
721 pi[work[j]] = *(psi++) + pos; \
722 _MASK_(px[work[j]] = *(psx++)); \
723 work[j]++; \
724 ++k; \
725 } \
726 } \
727 _MASK_(UNPROTECT(1)); \
728 UNPROTECT(2); \
729 pos += INTEGER(GET_SLOT(s, Matrix_DimSym))[margin]; \
730 } \
731 } while (0)
732
733 if (kind == 'n')
734 BIND_C0R1(int, LOGICAL, HIDE);
735 else {
736 SEXP x = PROTECT(allocVector(kindToType(kind), nnz)), sx;
737 SET_SLOT(res, Matrix_xSym, x);
738 BIND_CASES(BIND_C0R1);
739 UNPROTECT(1);
740 }
741 UNPROTECT(2);
742 Matrix_Free(work, n);
743
744 } else if (repr == 'T') {
745
746 if (rdim[0] == 0 || rdim[1] == 0)
747 return;
748
749 R_xlen_t k, nnz = 0;
750 for (a = args; a != R_NilValue; a = CDR(a)) {
751 s = CAR(a);
752 if (s == R_NilValue)
753 continue;
754 k = XLENGTH(GET_SLOT(s, Matrix_iSym));
755 if (k > R_XLEN_T_MAX - nnz)
756 error(_("attempt to allocate vector of length exceeding %s"),
757 "R_XLEN_T_MAX");
758 nnz += k;
759 }
760
761 SEXP si, sj,
762 i = PROTECT(allocVector(INTSXP, nnz)),
763 j = PROTECT(allocVector(INTSXP, nnz));
764 int *psi, *psj, *pi = INTEGER(i), *pj = INTEGER(j), pos = 0;
765 SET_SLOT(res, Matrix_iSym, i);
766 SET_SLOT(res, Matrix_jSym, j);
767
768#define BIND_T(_CTYPE_, _PTR_, _MASK_) \
769 do { \
770 _MASK_(_CTYPE_ *px = _PTR_(x), *psx); \
771 for (a = args; a != R_NilValue; a = CDR(a)) { \
772 s = CAR(a); \
773 if (s == R_NilValue) \
774 continue; \
775 PROTECT(si = GET_SLOT(s, Matrix_iSym)); \
776 PROTECT(sj = GET_SLOT(s, Matrix_jSym)); \
777 _MASK_(PROTECT(sx = GET_SLOT(s, Matrix_xSym))); \
778 psi = INTEGER(si); \
779 psj = INTEGER(sj); \
780 _MASK_(psx = _PTR_(sx)); \
781 k = XLENGTH(si); \
782 if (margin) { \
783 while (k--) { \
784 *(pi++) = *(psi++); \
785 *(pj++) = *(psj++) + pos; \
786 _MASK_(*(px++) = *(psx++)); \
787 } \
788 } else { \
789 while (k--) { \
790 *(pi++) = *(psi++) + pos; \
791 *(pj++) = *(psj++); \
792 _MASK_(*(px++) = *(psx++)); \
793 } \
794 } \
795 _MASK_(UNPROTECT(1)); \
796 UNPROTECT(2); \
797 pos += INTEGER(GET_SLOT(s, Matrix_DimSym))[margin]; \
798 } \
799 } while (0)
800
801 if (kind == 'n')
802 BIND_T(int, LOGICAL, HIDE);
803 else {
804 SEXP x = PROTECT(allocVector(kindToType(kind), nnz)), sx;
805 SET_SLOT(res, Matrix_xSym, x);
806 BIND_CASES(BIND_T);
807 UNPROTECT(1);
808 }
809 UNPROTECT(2);
810
811 } else {
812
813 SEXP p = PROTECT(allocVector(INTSXP, rdim[margin])), sp;
814 int *pp = INTEGER(p);
815 for (a = args; a != R_NilValue; a = CDR(a)) {
816 s = CAR(a);
817 if (s == R_NilValue)
818 continue;
819 sp = GET_SLOT(s, Matrix_permSym);
820 Matrix_memcpy(pp, INTEGER(sp), LENGTH(sp), sizeof(int));
821 pp += LENGTH(sp);
822 }
823 SET_SLOT(res, Matrix_permSym, p);
824 UNPROTECT(1);
825 if (margin)
826 INTEGER(GET_SLOT(res, Matrix_marginSym))[0] = 2;
827
828 }
829
830#undef BIND_CASES
831#undef BIND_E
832#undef BIND_C1R0
833#undef BIND_C0R1
834#undef BIND_T
835
836 return;
837}
838
839static
840SEXP bind(SEXP args, SEXP exprs, int margin, int level)
841{
842 if (!tagWasVector)
843 tagWasVector = install(".__WAS_VECTOR__."); /* for now, a hack */
844
845 int rdim[2], rdimnames[2];
846 char kind = '\0', repr = '\0';
847 scanArgs(args, exprs, margin, level,
848 rdim, rdimnames, &kind, &repr);
849 if (rdim[!margin] < 0)
850 /* Arguments are all NULL */
851 return R_NilValue;
852 if (repr == 'e' && (Matrix_int_fast64_t) rdim[0] * rdim[1] > R_XLEN_T_MAX)
853 error(_("attempt to allocate vector of length exceeding %s"),
854 "R_XLEN_T_MAX");
855 char rcl[] = "...Matrix";
856 if (kind == '\0' || repr == '\0') {
857 if (kind != repr)
858 error(_("should never happen ..."));
859 rcl[0] = 'i';
860 rcl[1] = 'n';
861 rcl[2] = 'd';
862 } else {
863 rcl[0] = kind;
864 rcl[1] = 'g';
865 rcl[2] = repr;
866 coerceArgs(args, margin, rdim, kind, repr);
867 }
868 SEXP res = PROTECT(newObject(rcl));
869 bindArgs(args, margin, res, rdim, kind, repr);
870
871 SEXP dim = PROTECT(GET_SLOT(res, Matrix_DimSym));
872 INTEGER(dim)[0] = rdim[0];
873 INTEGER(dim)[1] = rdim[1];
874 UNPROTECT(1);
875
876 if (rdimnames[0] || rdimnames[1]) {
877 SEXP dimnames = PROTECT(GET_SLOT(res, Matrix_DimNamesSym)),
878 marnames = R_NilValue, nms[2], nms_, a, e, s, tmp;
879 int i, ivalid, r = -1, pos = 0, nprotect = 1;
880 const char *scl;
881 if (rdimnames[margin]) {
882 PROTECT(marnames = allocVector(STRSXP, rdim[margin]));
883 ++nprotect;
884 SET_VECTOR_ELT(dimnames, margin, marnames);
885 }
886 for (a = args, e = exprs; a != R_NilValue; a = CDR(a), e = CDR(e)) {
887 s = CAR(a);
888 if (s == R_NilValue && rdim[!margin] > 0)
889 continue;
890 nms[0] = nms[1] = R_NilValue;
891 if (TYPEOF(s) == S4SXP) {
892 ivalid = R_check_class_etc(s, valid);
893 scl = valid[ivalid + VALID_NONVIRTUAL_SHIFT(ivalid, 1)];
894 tmp = GET_SLOT(s, Matrix_DimSym);
895 r = INTEGER(tmp)[margin];
896 tmp = GET_SLOT(s, Matrix_DimNamesSym);
897 if (scl[1] == 's') {
898 if ((nms_ = VECTOR_ELT(tmp, 1)) != R_NilValue ||
899 (nms_ = VECTOR_ELT(tmp, 0)) != R_NilValue)
900 nms[0] = nms[1] = nms_;
901 } else
902 for (i = 0; i < 2; ++i)
903 nms[i] = VECTOR_ELT(tmp, i);
904 } else {
905 tmp = getAttrib(s, R_DimSymbol);
906 if (TYPEOF(tmp) == INTSXP && LENGTH(tmp) == 2) {
907 r = INTEGER(tmp)[margin];
908 tmp = getAttrib(s, R_DimNamesSymbol);
909 if (tmp != R_NilValue)
910 for (i = 0; i < 2; ++i)
911 nms[i] = VECTOR_ELT(tmp, i);
912 } else if (rdim[!margin] == 0 || XLENGTH(s) > 0) {
913 r = 1;
914 if (rdim[!margin] > 0 && XLENGTH(s) == rdim[!margin])
915 nms[!margin] = getAttrib(s, R_NamesSymbol);
916 }
917 }
918 if (TAG(a) != R_NilValue) { /* only if 's' is or was a vector */
919 if (TAG(a) != tagWasVector)
920 nms[margin] = coerceVector(TAG(a), STRSXP);
921 else if (level == 2) {
922 PROTECT(nms_ = allocVector(EXPRSXP, 1));
923 SET_VECTOR_ELT(nms_, 0, CAR(e));
924 nms[margin] = coerceVector(nms_, STRSXP);
925 UNPROTECT(1);
926 } else if (level == 1 && TYPEOF(CAR(e)) == SYMSXP)
927 nms[margin] = coerceVector(CAR(e), STRSXP);
928 }
929 if (rdimnames[!margin] && nms[!margin] != R_NilValue) {
930 SET_VECTOR_ELT(dimnames, !margin, nms[!margin]);
931 rdimnames[!margin] = 0;
932 if (!rdimnames[margin])
933 break;
934 }
935 if (rdimnames[ margin] && nms[ margin] != R_NilValue)
936 for (i = 0; i < r; ++i)
937 SET_STRING_ELT(marnames, pos + i,
938 STRING_ELT(nms[margin], i));
939 pos += r;
940 }
941 UNPROTECT(nprotect);
942 }
943
944 UNPROTECT(1);
945 return res;
946}
947
948SEXP R_bind(SEXP args)
949{
950 SEXP level, margin, exprs;
951 args = CDR(args); level = CAR(args);
952 args = CDR(args); margin = CAR(args);
953 args = CDR(args); exprs = CAR(args);
954 return bind(CDR(args), CDR(exprs), asInteger(margin), asInteger(level));
955}
Matrix_int_fast64_t
long long Matrix_int_fast64_t
Definition Mdefines.h:27
ERROR_INVALID_CLASS
#define ERROR_INVALID_CLASS(_X_, _FUNC_)
Definition Mdefines.h:208
_
#define _(String)
Definition Mdefines.h:44
VALID_NONVIRTUAL_MATRIX
#define VALID_NONVIRTUAL_MATRIX
Definition Mdefines.h:220
kindToType
SEXPTYPE kindToType(char)
Definition objects.c:28
HIDE
#define HIDE(...)
Definition Mdefines.h:202
ERROR_INVALID_TYPE
#define ERROR_INVALID_TYPE(_X_, _FUNC_)
Definition Mdefines.h:204
SHOW
#define SHOW(...)
Definition Mdefines.h:201
Matrix_Free
#define Matrix_Free(_VAR_, _N_)
Definition Mdefines.h:77
SET_SLOT
#define SET_SLOT(x, what, value)
Definition Mdefines.h:86
GET_SLOT
#define GET_SLOT(x, what)
Definition Mdefines.h:85
Matrix_Calloc
#define Matrix_Calloc(_VAR_, _N_, _CTYPE_)
Definition Mdefines.h:66
newObject
SEXP newObject(const char *)
Definition objects.c:4
VALID_NONVIRTUAL_SHIFT
#define VALID_NONVIRTUAL_SHIFT(i, pToInd)
Definition Mdefines.h:247
Matrix_permSym
SEXP Matrix_permSym
Definition Msymbols.h:18
Matrix_DimSym
SEXP Matrix_DimSym
Definition Msymbols.h:3
Matrix_marginSym
SEXP Matrix_marginSym
Definition Msymbols.h:16
Matrix_xSym
SEXP Matrix_xSym
Definition Msymbols.h:22
Matrix_iSym
SEXP Matrix_iSym
Definition Msymbols.h:13
Matrix_jSym
SEXP Matrix_jSym
Definition Msymbols.h:14
Matrix_DimNamesSym
SEXP Matrix_DimNamesSym
Definition Msymbols.h:2
Matrix_diagSym
SEXP Matrix_diagSym
Definition Msymbols.h:11
Matrix_uploSym
SEXP Matrix_uploSym
Definition Msymbols.h:21
Matrix_pSym
SEXP Matrix_pSym
Definition Msymbols.h:17
coerceArgs
static void coerceArgs(SEXP args, int margin, int *rdim, char kind, char repr)
Definition bind.c:361
BIND_C0R1
#define BIND_C0R1(_CTYPE_, _PTR_, _MASK_)
valid
static const char * valid[]
Definition bind.c:5
R_bind
SEXP R_bind(SEXP args)
Definition bind.c:948
BIND_CASES
#define BIND_CASES(_BIND_)
tagWasVector
static SEXP tagWasVector
Definition bind.c:7
BIND_E
#define BIND_E(_CTYPE_, _PTR_, _MASK_)
BIND_T
#define BIND_T(_CTYPE_, _PTR_, _MASK_)
BIND_C1R0
#define BIND_C1R0(_CTYPE_, _PTR_, _MASK_)
bindArgs
static void bindArgs(SEXP args, int margin, SEXP res, int *rdim, char kind, char repr)
Definition bind.c:495
scanArgs
static void scanArgs(SEXP args, SEXP exprs, int margin, int level, int *rdim, int *rdimnames, char *kind, char *repr)
Definition bind.c:10
bind
static SEXP bind(SEXP args, SEXP exprs, int margin, int level)
Definition bind.c:840
sparse_as_Csparse
SEXP sparse_as_Csparse(SEXP from, const char *class)
Definition coerce.c:3721
sparse_as_Rsparse
SEXP sparse_as_Rsparse(SEXP from, const char *class)
Definition coerce.c:3820
diagonal_as_sparse
SEXP diagonal_as_sparse(SEXP from, const char *class, char kind, char shape, char repr, char ul)
Definition coerce.c:2066
sparse_as_dense
SEXP sparse_as_dense(SEXP from, const char *class, int packed)
Definition coerce.c:501
dense_as_sparse
SEXP dense_as_sparse(SEXP from, const char *class, char repr)
Definition coerce.c:1647
sparse_as_kind
SEXP sparse_as_kind(SEXP from, const char *class, char kind)
Definition coerce.c:2499
dense_as_kind
SEXP dense_as_kind(SEXP from, const char *class, char kind, int new)
Definition coerce.c:2409
index_as_dense
SEXP index_as_dense(SEXP from, const char *class, char kind)
Definition coerce.c:931
sparse_as_Tsparse
SEXP sparse_as_Tsparse(SEXP from, const char *class)
Definition coerce.c:3919
matrix_as_sparse
SEXP matrix_as_sparse(SEXP from, const char *zzz, char ul, char di, int trans)
Definition coerce.c:1580
dense_as_general
SEXP dense_as_general(SEXP from, const char *class, int new)
Definition coerce.c:2734
sparse_as_general
SEXP sparse_as_general(SEXP from, const char *class)
Definition coerce.c:2831
diagonal_as_dense
SEXP diagonal_as_dense(SEXP from, const char *class, char kind, char shape, int packed, char ul)
Definition coerce.c:798
index_as_sparse
SEXP index_as_sparse(SEXP from, const char *class, char kind, char repr)
Definition coerce.c:2281
Tsparse_aggregate
SEXP Tsparse_aggregate(SEXP from)
Definition sparse.c:3672
Matrix_memset
void * Matrix_memset(void *dest, int ch, R_xlen_t length, size_t size)
Definition utils.c:8
Matrix_memcpy
void * Matrix_memcpy(void *dest, const void *src, R_xlen_t length, size_t size)
Definition utils.c:70
Generated by doxygen 1.9.8