make alply dim outputs non-optional, stronger test, NEWS

NEWS

@@ -5,6 +5,8 @@ NEW FEATURES AND FUNCTIONS
 
 * `**ply` gain a `.inform` argument (previously only available in `llply`) - this gives more useful debugging information at the cost of some speed. (Thanks to Brian Diggs, #57)
 
+* `alply`'s output gains dimensions and dimnames, similar to `apply`. Sequential indexing of a list produced by `alply` should be unaffected. (Peter Meilstrup)
+
 * `colwise`, `numcolwise` and `catcolwise` now all accept additional arguments in .... (Thanks to Stavros Macrakis, #62)
 
 * `here` makes it possible to use `**ply` + a function that uses non-standard evaluation (e.g. `summarise`, `mutate`, `subset`, `arrange`) inside a function.  (Thanks to Peter Meilstrup, #3)
@@ -44,7 +46,7 @@ PERFORMANCE IMPROVEMENTS
 
 BUG FIXES
 
-* `*aply` functions now bind list mode results into a list-array (Peter Meilstrup)
+* `*aply` functions now bind list mode results into a list-array. (Peter Meilstrup).
 
 * `*aply` now accepts 0-dimension arrays as inputs. (#88)
 

R/alply.r

@@ -3,14 +3,16 @@
 #' For each slice of an array, apply function then combine results into a
 #' list.
 #'
+#' The list will have "dims" and "dimnames" corresponding to the
+#' margins given. For instance \code{llply(x, c(3,2))} where \code{x}
+#' has dims \code{c(4,3,2)} will give a result with dims \code{c(2,3)}.
+#'
 #' \code{alply} is somewhat similar to \code{\link{apply}} for cases
 #' where the results are not atomic.
 #'
 #' @template ply
 #' @template a-
 #' @template -l
-#' @param .dims If TRUE, the result will be a list-array with
-#' dimensions determined by the margins.
 #' @export
 #' @examples
 #' alply(ozone, 3, quantile)
@@ -24,13 +26,10 @@ alply <- function(.data, .margins, .fun = NULL, ..., .expand = TRUE,
     .progress = .progress, .inform = .inform,
     .parallel = .parallel, .paropts = .paropts)
 
-  if (.dims) {
-    labels <- attr(pieces, "split_labels")
-    res_labels <- lapply(labels,
-      function(x) if(is.factor(x)) levels(x) else sort(unique(x)))
-    res_dim <- sapply(res_labels, length)
-    dim(res) <-  res_dim
-    dimnames(res) <- res_labels
-  }
+  labels <- attr(pieces, "split_labels")
+  res_labels <- lapply(labels, function(x) as.character(unique(x)))
+  res_dim <- sapply(res_labels, length)
+  dim(res) <-  res_dim
+  dimnames(res) <- res_labels
   res
 }

inst/tests/test-array.r

@@ -73,7 +73,10 @@ test_that("idempotent function equivalent to permutation",  {
   x <- array(1:24, 4:2,
     dimnames = list(LETTERS[1:4], letters[24:26], letters[1:2]))
 
-  perms <- unique(alply(as.matrix(subset(expand.grid(x=0:3,y=0:3,z=0:3), (x+y+z)>0 & !any(duplicated(setdiff(c(x,y,z), 0))))), 1, function(x) setdiff(x, 0)))
+  perms <- unique(alply(as.matrix(subset(expand.grid(x=0:3,y=0:3,z=0:3),
+                                         (x+y+z)>0 & !any(duplicated(setdiff(c(x,y,z), 0))))),
+                        1,
+                        function(x) setdiff(x, 0)))
 
   aperms <- llply(perms, function(perm) aperm(x, unique(c(perm, 1:3))))
   aaplys <- llply(perms, function(perm) aaply(x, perm, identity))
@@ -88,15 +91,30 @@ test_that("idempotent function equivalent to permutation",  {
 
 })
 
-test_that("alply optionally sets dims and dimnames attribute", {
+test_that("alply sets dims and dimnames, equivalence to permutation", {
   x <- array(1:24, 4:2,
-             dimnames = list(LETTERS[1:4], letters[24:26], letters[1:2]))
-  perms <- unique(alply(as.matrix(subset(expand.grid(x=0:3,y=0:3,z=0:3), (x+y+z)>0 & !any(duplicated(setdiff(c(x,y,z), 0))))), 1, function(x) setdiff(x, 0)))
-
-  alplys <- lapply(perms, alply, .data=x, identity, .dims=TRUE)
-  m_ply(cbind(perm=perms, ply=alplys), function(perm, ply) {
-    expect_that(dim(ply), is_equivalent_to(dim(x)[perm]))
-    expect_that(dimnames(ply), is_equivalent_to(dimnames(x)[perm]))
+             dimnames = list(dim1=LETTERS[1:4], dim2=letters[c(24,26,25)], dim3=NULL))
+  #unlisting an alply should leave elements the the same order as
+  #an aperm with the unused dimensions shifted to the front.
+  #check against all ways to split this array
+  p_alply <- unique(alply(as.matrix(subset(expand.grid(x=0:3,y=0:3,z=0:3),
+                                         (x+y+z)>0 & !any(duplicated(setdiff(c(x,y,z), 0))))),
+                        1, function(x) setdiff(x, 0)))
+  p_aperm <- llply(p_alply, function(x) union(setdiff(1:3, x), x))
+  alplys <- lapply(p_alply, alply, .data=x, identity, .dims=TRUE)
+  #alply will fill in dimnames on a dim that has none, so match that here
+  dimnames(x)[[3]] <- c("1", "2")
+  aperms <- llply(p_aperm, .fun=aperm, a=x)
+
+  m_ply(cbind(x_perm=p_alply, x_ply=alplys, x_aperm=aperms),
+        function(x_perm, x_ply, x_aperm) {
+          expect_equivalent(dim(x_ply),
+                            dim(x)[x_perm])
+          expect_equivalent(dimnames(x_ply),
+                            dimnames(x)[x_perm])
+          expect_equivalent(dim(x_ply),
+                            dim(x_aperm)[(length(dim(x)) - length(x_perm) + 1):(length(dim(x)))])
+          expect_equivalent(as.vector(unlist(x_ply)), as.vector(x_aperm))
   })
 })