Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

apply-like output for alply

  • Loading branch information...
commit 3e45a4a85fa6f84ee929088cdd2cb322c7a28d5e 1 parent ac9fc5d
Peter Meilstrup crowding authored
Showing with 26 additions and 2 deletions.
  1. +14 −2 R/alply.r
  2. +12 −0 inst/tests/test-array.r
16 R/alply.r
View
@@ -9,16 +9,28 @@
#' @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)
#' alply(ozone, 3, function(x) table(round(x)))
alply <- function(.data, .margins, .fun = NULL, ..., .expand = TRUE,
.progress = "none", .inform = FALSE, .parallel = FALSE,
- .paropts = NULL) {
+ .paropts = NULL, .dims=FALSE) {
pieces <- splitter_a(.data, .margins, .expand)
- llply(.data = pieces, .fun = .fun, ...,
+ res <- llply(.data = pieces, .fun = .fun, ...,
.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
+ }
+ res
}
12 inst/tests/test-array.r
View
@@ -88,6 +88,18 @@ test_that("idempotent function equivalent to permutation", {
})
+test_that("alply optionally sets dims and dimnames attribute", {
+ 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]))
+ })
+})
+
# Test contributed by Baptiste Auguie
test_that("single column data frames work when treated as an array", {
foo <- function(a="a", b="b", c="c", ...){
Please sign in to comment.
Something went wrong with that request. Please try again.