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