1context("rbind.fill") 2 3test_that("variable classes are preserved", { 4 a <- data.frame( 5 a = factor(letters[1:3]), 6 b = 1:3, 7 c = date(), 8 stringsAsFactors = TRUE 9 ) 10 b <- data.frame( 11 a = factor(letters[3:5]), 12 d = as.Date(c("2008-01-01", "2009-01-01", "2010-01-01"))) 13 b$e <- as.POSIXlt(as.Date(c("2008-01-01", "2009-01-01", "2010-01-01"))) 14 b$f <- matrix (1:6, nrow = 3) 15 16 ab1 <- rbind.fill(a, b)[, letters[1:6]] 17 ab2 <- rbind.fill(b, a)[c(4:6, 1:3), letters[1:6]] 18 ab2$a <- factor(ab2$a, levels(ab1$a)) 19 rownames(ab2) <- NULL 20 21 expect_that(ab1, equals(ab2)) 22 23 expect_s3_class(ab1$a, "factor") 24 expect_type(ab1$b, "integer") 25 expect_s3_class(ab1$c, "factor") 26 expect_s3_class(ab1$d, "Date") 27 expect_s3_class(ab1$e, "POSIXct") 28 expect_equal(dim(ab1$f), c(6, 2)) 29}) 30 31test_that("same as rbind for simple cases", { 32 bsmall <- baseball[1:1000, ] 33 bplayer <- split(bsmall, bsmall$id) 34 b1 <- do.call("rbind", bplayer) 35 rownames(b1) <- NULL 36 b2 <- rbind.fill(bplayer) 37 38 expect_that(b1, equals(b2)) 39}) 40 41test_that("columns are in expected order", { 42 a <- data.frame(a = 1, b = 2, c = 3) 43 b <- data.frame(b = 2, d = 4, e = 4) 44 c <- data.frame(c = 1, b = 2, a = 1) 45 46 expect_that(names(rbind.fill(a, b)), equals(c("a", "b", "c", "d", "e"))) 47 expect_that(names(rbind.fill(a, c)), equals(c("a", "b", "c"))) 48 expect_that(names(rbind.fill(c, a)), equals(c("c", "b", "a"))) 49}) 50 51test_that("matrices are preserved", { 52 a <- data.frame(a = factor(letters[3:5])) 53 a$b <- matrix(1:6, nrow = 3) 54 55 expect_that(rbind.fill(a, a)$b, is_equivalent_to(rbind(a, a)$b)) 56 57 b <- data.frame(c = 1:3) 58 59 ab1 <- rbind.fill(a, b) [ , letters[1:3]] 60 ab2 <- rbind.fill(b, a) [c(4:6, 1:3), letters[1:3]] 61 ab2$a <- factor(ab2$a, levels(ab1$a)) 62 rownames(ab2) <- NULL 63 64 expect_that(ab1, equals(ab2)) 65}) 66 67test_that("character or factor or list-matrices are preserved", { 68 d1 <- data.frame(a=1:2, 69 x=I(matrix(c('a', 'b', 'c', 'd'), nrow=2))) 70 d2 <- data.frame(b=1:2, 71 x=I(`dim<-`(factor(c('a', 'b', 'c', 'd')), c(2,2)))) 72 d3 <- data.frame(b=1:2, 73 x=I(array(as.list(1:4), c(2,2)))) 74 75 b1 <- rbind.fill(d1, d1) 76 b2 <- rbind.fill(d2, d2) 77 b3 <- rbind.fill(d3, d3) 78 79 expect_equal(dim(b1$x), c(4,2)) 80 expect_equal(typeof(b1$x), "character") 81 82 expect_equal(dim(b2$x), c(4,2)) 83 expect_is(b2$x, "factor") 84 85 expect_equal(dim(b3$x), c(4,2)) 86 expect_equal(typeof(b3$x), "list") 87}) 88 89test_that("missing levels in factors preserved", { 90 f <- addNA(factor(c("a", "b", NA))) 91 df1 <- data.frame(a = f, c = f) 92 df2 <- data.frame(b = f, c = f) 93 out <- rbind.fill(df1, df2) 94 expect_equal(levels(out$a), levels(f)) 95 expect_equal(levels(out$b), levels(f)) 96 expect_equal(levels(out$c), levels(f)) 97}) 98 99test_that("time zones are preserved", { 100 dstart <- "2011-01-01 00:01" 101 dstop <- "2011-01-02 04:15" 102 103 get_tz <- function(x) attr(as.POSIXlt(x), "tz") 104 105 tzs <- c("CET", "UTC") 106 for (tz in tzs) { 107 start <- data.frame(x = as.POSIXct(dstart, tz = tz)) 108 end <- data.frame(x = as.POSIXct(dstop, tz = tz)) 109 110 both <- rbind.fill(start, end) 111 expect_that(get_tz(both$x)[1], equals(tz), label = tz) 112 } 113 114}) 115 116test_that("1d arrays treated as vectors", { 117 df <- data.frame(x = 1) 118 df$x <- array(1, 1) 119 120 #1d arrays converted into vectors 121 df2 <- rbind.fill(df, df) 122 expect_that(df2$x, is_equivalent_to(rbind(df, df)$x)) 123 expect_that(dim(df2$x), equals(dim(rbind(df, df)$x))) 124 125 #if dims are stripped, dimnames should be also 126 df <- data.frame(x = 1) 127 df$x <- array(2, 1, list(x="one")) 128 df2 <- rbind.fill(df, df) 129 expect_null(dimnames(df2$x)) 130 131 #can bind 1d array to vector 132 dfV <- data.frame(x=3) 133 dfO1 <- rbind.fill(df, dfV) 134 dfO2 <- rbind.fill(dfV, df) 135 expect_equal(dfO1, data.frame(x=c(2, 3))) 136 expect_equal(dfO2, data.frame(x=c(3, 2))) 137}) 138 139test_that("multidim arrays ok", { 140 library(abind) 141 df <- data.frame(x = 1:3) 142 df$x <- array(1:27, c(3,3,3)) 143 144 df2 <- rbind.fill(df, df) 145 expect_equal(dim(df2$x), dim(abind(along=1, df$x, df$x))) 146 expect_that(df2$x, is_equivalent_to(abind(along=1, df$x, df$x))) 147 }) 148 149test_that("Array column names preserved", { 150 x <- data.frame(hair.color = dimnames(HairEyeColor)[[1]]) 151 x$obs <- unclass(HairEyeColor[,,1]) 152 153 xx1 <- rbind(x, x) 154 xx2 <- rbind.fill(x, x) 155 156 #plyr is against row names, but should respect col names like rbind 157 rownames(xx1) <- NULL 158 rownames(xx1$obs) <- NULL 159 160 #but unlike rbind it should also preserve names-of-dimnames. 161 names(dimnames(xx1$obs)) <- c("", "Eye") 162 163 expect_equal(xx1, xx2) 164}) 165 166test_that("attributes are preserved", { 167 d1 <- data.frame(a = runif(10), b = runif(10)) 168 d2 <- data.frame(a = runif(10), b = runif(10)) 169 170 attr(d1$b, "foo") <- "one" 171 attr(d1$b, "bar") <- "bar" 172 attr(d2$b, "foo") <- "two" 173 attr(d2$b, "baz") <- "baz" 174 175 d12 <- rbind.fill(d1, d2) 176 d21 <- rbind.fill(d2, d1) 177 178 expect_that(attr(d12$b, "foo"), equals("one")) 179 expect_that(attr(d21$b, "foo"), equals("two")) 180}) 181 182test_that("characters override and convert factors", { 183 d1a <- data.frame(x=c('a','b'), y=1:2) 184 d2a <- data.frame(x=c('c','d'), z=1:2, stringsAsFactors=F) 185 186 d1b <- data.frame(x=c('a','b'), y=1:2, stringsAsFactors=F) 187 d2b <- data.frame(x=c('c','d'), z=1:2) 188 189 d3a <- rbind.fill(d1a,d2a) 190 d3b <- rbind.fill(d1b,d2b) 191 192 expect_equal(d3a$x, c("a", "b", "c", "d")) 193 expect_equal(d3b$x, c("a", "b", "c", "d")) 194}) 195 196test_that("factor to character conversion preserves attributes", { 197 d1 <- data.frame(a = letters[1:10], b = factor(letters[11:20]), 198 stringsAsFactors=FALSE) 199 d2 <- data.frame(a = factor(letters[11:20]), b = letters[11:20], 200 stringsAsFactors=FALSE) 201 202 attr(d1$a, "foo") <- "one" 203 attr(d1$b, "foo") <- "two" 204 attr(d2$a, "foo") <- "bar" 205 attr(d2$b, "foo") <- "baz" 206 207 d12 <- rbind.fill(d1, d2) 208 209 expect_equal(attr(d12$a, "foo"), "one") 210 expect_equal(attr(d12$b, "foo"), "two") 211}) 212 213test_that("zero row data frames ok", { 214 d1 <- data.frame(x = 1:2, y = 2:3) 215 d2 <- data.frame(y = 3:4, z = 5:6) 216 217 za <- rbind.fill(subset(d1, FALSE)) 218 zb <- rbind.fill(d1, subset(d2, FALSE)) 219 zc <- rbind.fill(subset(d1, FALSE), subset(d2, FALSE)) 220 221 expect_equal(class(za), "data.frame") 222 expect_equal(nrow(za), 0) 223 expect_true(all(names(za) %in% c("x", "y"))) 224 225 expect_equal(class(zb), "data.frame") 226 expect_equal(nrow(zb), 2) 227 expect_true(all(names(zb) %in% c("x", "y", "z"))) 228 expect_equal(zb$y, d1$y) 229 expect_equal(zb$z, rep(as.numeric(NA), nrow(d1))) 230 231 expect_equal(class(zc), "data.frame") 232 expect_equal(nrow(zc), 0) 233 expect_true(all(names(zc) %in% c("x", "y", "z"))) 234}) 235 236test_that("zero col data frames ok", { 237 d1 <- data.frame(x = "a", y = 1L) 238 d2 <- data.frame(y = 2L, z = 3L) 239 240 za <- rbind.fill(d1[0, ], d2[0, ]) 241 zb <- rbind.fill(d1[0, ], d2) 242 zc <- rbind.fill(d1, d2[0, ]) 243 244 expect_equal(names(za), c("x", "y", "z")) 245 expect_equal(names(zb), c("x", "y", "z")) 246 expect_equal(names(zc), c("x", "y", "z")) 247 248 expect_equal(nrow(za), 0) 249 expect_equal(nrow(zb), 1) 250 expect_equal(nrow(zc), 1) 251}) 252 253test_that("rbind.fill rejects non-vector columns", { 254 a <- list(a=list(1), b=c(3), c="d", f=function() NULL) 255 attr(a, "row.names") <- c(NA_integer_, -1) 256 class(a) <- "data.frame" 257 expect_error(rbind.fill(a,a), "cannot make") 258}) 259 260test_that("rbind.fill rejects data frame columns", { 261 a <- data.frame(a=1:3, b=2:4, c=3:5) 262 a$c <- data.frame(x=10:12, y=11:13) 263 rownames(a) <- NULL 264 rownames(a$c) <- NULL 265 expect_error(rbind.fill(a,a), "not supported") 266}) 267 268rbind_time <- function(size, 269 classes = c("numeric", "character", 270 "array", "factor", "time")) { 271 unit <- quickdf(list(numeric = 1:3, 272 character = c("a", "b", "c"), 273 array = array(1:6, c(3,2)), 274 factor = factor(c("a", "b", "c")), 275 time = as.POSIXct(Sys.time()) + 1:3)) 276 args <- rep(list(unit[classes]), size) 277 system.time(do.call(rbind.fill, args)) 278} 279 280get_rbind_times <- function(...) { 281 # nolint start 282 rbind_time(10) #warm up/JIT 283 mdply(.fun = rbind_time, ...) 284 # nolint end 285} 286 287if (identical(Sys.getenv("NOT_CRAN"), "true") && 288 !identical(Sys.getenv("TRAVIS"), "true")) { 289 290expect_linear_enough <- function(timings, threshold=0.1) { 291 #expect that no more than `threshold` of a `size` input's runtime is 292 #accounted for by quadratic behavior 293 model <- lm(I(user.self / size) ~ size, timings) 294 expect_lt(threshold, summary(model)$coefficients[2,4]) 295} 296 297test_that("rbind.fill performance linear", { 298 timings <- get_rbind_times(data.frame(size = 2 ^ (1:10)), 299 classes=c("numeric", "character", "array")) 300 expect_linear_enough(timings) 301}) 302 303test_that("rbind.fill performance linear with factors", { 304 timings <- get_rbind_times(data.frame(size = 2 ^ (1:10)), 305 classes=c("factor")) 306 expect_linear_enough(timings) 307}) 308 309test_that("rbind.fill performance linear with times", { 310 timings <- get_rbind_times(data.frame(size = 2 ^ (1:10)), 311 classes=c("time")) 312 expect_linear_enough(timings) 313}) 314 315test_that("NULLs silently dropped", { 316 expect_equal(rbind.fill(mtcars, NULL), mtcars) 317 expect_equal(rbind.fill(NULL, mtcars), mtcars) 318 expect_equal(rbind.fill(NULL, NULL), NULL) 319 320}) 321 322} 323