1# File src/library/methods/R/rbind.R 2# Part of the R package, https://www.R-project.org 3# 4# Copyright (C) 1995-2018 The R Core Team 5# 6# This program is free software; you can redistribute it and/or modify 7# it under the terms of the GNU General Public License as published by 8# the Free Software Foundation; either version 2 of the License, or 9# (at your option) any later version. 10# 11# This program is distributed in the hope that it will be useful, 12# but WITHOUT ANY WARRANTY; without even the implied warranty of 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14# GNU General Public License for more details. 15# 16# A copy of the GNU General Public License is available at 17# https://www.R-project.org/Licenses/ 18 19#### S4-ized rbind() --- this is entirely parallel to ./cbind() --- KEEP IN SYNC! 20### -------------------- built by 21## s/cbind/rbind/ ; s/nrow/N_COL/; s/column/row/; s/colnam/rownam/; 22## s/ncol/nrow/ ; s/N_COL/ncol/; s/d[2L]/d[1L]/ 23 24rbind <- function(..., deparse.level = 1) 25{ 26 has.dl <- !missing(deparse.level) 27 deparse.level <- as.integer(deparse.level) 28 if(identical(deparse.level, -1L)) deparse.level <- 0L # our hack 29 stopifnot(0 <= deparse.level, deparse.level <= 2) 30 31 argl <- list(...) 32 ## remove trailing 'NULL's: 33 na <- nargs() - has.dl 34 while(na > 0L && is.null(argl[[na]])) { argl <- argl[-na]; na <- na - 1L } 35 if(na == 0) return(NULL) 36 symarg <- as.list(substitute(list(...)))[-1L] # symbolic argument (names) 37 nmsym <- names(symarg) 38 ## Give *names* depending on deparse.level {for non-matrix}: 39 nm <- c( ## 0: 40 function(i) NULL, 41 ## 1: 42 function(i) if(is.symbol(s <- symarg[[i]])) deparse(s) else NULL, 43 ## 2: 44 function(i) deparse(symarg[[i]])[[1L]])[[ 1L + deparse.level ]] 45 Nms <- function(i) { if(!is.null(s <- nmsym[i]) && nzchar(s)) s else nm(i) } 46 if(na == 1) { 47 if(isS4(..1)) { 48 r <- rbind2(..1) 49 if(length(dim(..1)) < 2L && length(dim(r)) == 2L) 50 rownames(r) <- Nms(1) 51 return(r) 52 } 53 else return(base::rbind(..., deparse.level = deparse.level)) 54 } 55 56 ## else : na >= 2 57 58 if(na == 2) { 59 fix.na <- FALSE 60 } 61 else { ## na >= 3 arguments 62 ## determine ncol(<result>) for e.g., rbind(diag(2), 1, 2) 63 ## only when the last two argument have *no* dim attribute: 64 nrs <- unname(lapply(argl, ncol)) # of length na 65 iV <- vapply(nrs, is.null, NA)# is 'vector' 66 fix.na <- identical(nrs[(na-1L):na], list(NULL,NULL)) 67 if(fix.na) { 68 ## "fix" last argument, using 1-row `matrix' of proper ncol(): 69 nr <- max(if(all(iV)) lengths(argl) else unlist(nrs[!iV])) 70 argl[[na]] <- rbind(rep(argl[[na]], length.out = nr), 71 deparse.level = 0) 72 ## and since it's a 'matrix' now, rbind() below may not name it 73 } 74 ## if(deparse.level) { 75 if(fix.na) 76 fix.na <- !is.null(Nna <- Nms(na)) 77 ## } 78 } 79 80 Nrow <- function(x) { 81 d <- dim(x); if(length(d) == 2L) d[1L] else as.integer(length(x) > 0L) } 82 setN <- function(i, nams) 83 rownames(r)[i] <<- if(is.null(nams)) "" else nams 84 85 r <- argl[[na]] 86 for(i in (na-1L):1L) { 87 d2 <- dim(r) 88 r <- rbind2(argl[[i]], r) 89 ## if(deparse.level == 0) 90 ## if(i == 1L) return(r) else next 91 ism1 <- !is.null(d1 <- dim(argl[[i]])) && length(d1) == 2L 92 ism2 <- !is.null(d2) && length(d2) == 2L 93 if(ism1 && ism2) ## two matrices 94 next 95 96 ## else -- Setting rownames correctly 97 ## when one was not a matrix [needs some diligence!] 98 nn1 <- !is.null(N1 <- if( (l1 <- Nrow(argl[[i]])) && !ism1) Nms(i)) # else NULL 99 nn2 <- !is.null(N2 <- if(i == na-1L && Nrow(argl[[na]]) && !ism2) Nms(na)) 100 if(nn1 || nn2) { 101 if(is.null(rownames(r))) 102 rownames(r) <- rep.int("", nrow(r)) 103 if(nn1) setN(1, N1) 104 if(nn2) setN(1+l1, N2) 105 } 106 } 107 108 if(fix.na) { 109 if(is.null(rownames(r))) 110 rownames(r) <- rep.int("", nrow(r)) 111 setN(nrow(r), Nna) 112 } 113 r 114} 115