Skip to content
Browse files

rbind.fill multiway arrays

  • Loading branch information...
1 parent d48cdd1 commit 2d79ebd77ee23d6ec2490a71fa1ac856d9ccd93b @crowding crowding committed Aug 25, 2013
Showing with 33 additions and 17 deletions.
  1. +22 −16 R/rbind-fill.r
  2. +11 −1 inst/tests/test-rbind.r
View
38 R/rbind-fill.r
@@ -99,27 +99,43 @@ allocate_column <- function(example, nrows, dfs, var) {
#next modification.
type <- typeof(example)
handler <- type
+
+ #this statement may be altered below
+ assignment <- quote(column[rows] <<- what)
+
if (inherits(example, "POSIXt")) {
#this should get folded in to general attribute handling as well...
tzone <- attr(example, "tzone")
column <- structure(as.POSIXct(rep(NA, nrows)), tzone=tzone)
} else {
+
a <- attributes(example)
a$names <- NULL
isList <- is.recursive(example)
+
if (is.array(example)) {
+
+ a$dimnames <- NULL #todo: check if rbind handles these
+
# Check that all other args have consistent dims
df_has <- vapply(dfs, function(df) var %in% names(df), FALSE)
dims <- unique(lapply(dfs[df_has], function(df) dim(df[[var]])[-1]))
if (length(dims) > 1)
stop("Array variable ", var, " has inconsistent dims")
+
+ # add empty args
+ assignment[[2]] <- as.call(
+ c(as.list(assignment[[2]]),
+ rep(list(quote(expr = )), length(dims[[1]]))))
+
if (length(dims[[1]]) == 0) { #is dropping dims necessary for 1d arrays?
a$dim <- NULL
} else {
a$dim <- c(nrows, dim(example)[-1])
}
- a$dimnames <- NULL
+
length <- prod(a$dim)
+
} else {
length <- nrows
}
@@ -128,6 +144,7 @@ allocate_column <- function(example, nrows, dfs, var) {
df_has <- vapply(dfs, function(df) var %in% names(df), FALSE)
isfactor <- vapply(dfs[df_has], function(df) is.factor(df[[var]]), FALSE)
if (!all(isfactor)) {
+ #fall back on character
type <- "character"
handler <- "character"
a$class <- NULL
@@ -156,27 +173,16 @@ allocate_column <- function(example, nrows, dfs, var) {
handler,
character = function(rows, what) {
if (nargs() == 0) return(column)
- if (is.matrix(column)) {
- column[rows, ] <<- as.character(what)
- } else {
- column[rows] <<- as.character(what)
- }
+ what <- as.character(what)
+ eval(assignment)
},
factor = function(rows, what) {
if(nargs() == 0) return(column)
- if (is.matrix(column)) {
- column[rows, ] <<- as.character(what)
- } else {
- column[rows] <<- as.character(what)
- }
+ eval(assignment)
},
function(rows, what) {
if(nargs() == 0) return(column)
- if (is.matrix(column)) {
- column[rows, ] <<- what
- } else {
- column[rows] <<- what
- }
+ eval(assignment)
}
)
}
View
12 inst/tests/test-rbind.r
@@ -101,7 +101,7 @@ test_that("time zones are preserved", {
})
-test_that("arrays are ok", { #is this necessary?
+test_that("arrays are ok", {
df <- data.frame(x = 1)
df$x <- array(1, 1)
@@ -112,6 +112,16 @@ test_that("arrays are ok", { #is this necessary?
#expect_that(df2$x, is_equivalent_to(rbind(array(1,1), array(1,1))))
})
+test_that("multidim arrays ok", {
+ library(abind)
+ df <- data.frame(x = 1:3)
+ df$x <- array(1:27, c(3,3,3))
+
+ df2 <- rbind.fill(df, df)
+ expect_equal(dim(df2$x), dim(abind(along=1, df$x, df$x)))
+ expect_that(df2$x, is_equivalent_to(abind(along=1, df$x, df$x)))
+ })
+
test_that("attributes are preserved", {
d1 <- data.frame(a = runif(10), b = runif(10))
d2 <- data.frame(a = runif(10), b = runif(10))

0 comments on commit 2d79ebd

Please sign in to comment.
Something went wrong with that request. Please try again.