Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

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

  • Loading branch information...
commit 8606a7228d767d567a29f6f2abb390e105dcaa57 1 parent 3e45a4a
@crowding crowding authored
Showing with 39 additions and 20 deletions.
  1. +3 −1 NEWS
  2. +9 −10 R/alply.r
  3. +27 −9 inst/tests/test-array.r
View
4 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)
View
19 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
}
View
36 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))
})
})
Please sign in to comment.
Something went wrong with that request. Please try again.