Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Break out simplify functions into own file. Document

  • Loading branch information...
commit 1cc9b9db43a83200f5862dbea12d1248e4575ec4 1 parent a64b601
@hadley hadley authored
Showing with 98 additions and 84 deletions.
  1. +0 −55 R/ply-array.r
  2. +0 −29 R/ply-data-frame.r
  3. +98 −0 R/simplify.r
View
55 R/ply-array.r
@@ -42,61 +42,6 @@ laply <- function(.data, .fun = NULL, ..., .progress = "none", .drop = TRUE) {
list_to_array(res, attr(.data, "split_labels"), .drop)
}
-list_to_array <- function(res, labels, .drop) {
- if (length(res) == 0) return(vector())
- n <- length(res)
-
- atomic <- sapply(res, is.atomic)
- if (all(atomic)) {
- # Atomics need to be same size
- dlength <- unique.default(llply(res, dims))
- if (length(dlength) != 1) stop("Results must have the same number of dimensions.")
-
- dims <- unique(do.call("rbind", llply(res, amv_dim)))
- if (nrow(dims) != 1) stop("Results must have the same dimensions.")
-
- res_dim <- amv_dim(res[[1]])
- res_labels <- amv_dimnames(res[[1]])
- res_index <- expand.grid(res_labels)
-
- res <- unlist(res)
- } else {
- # Lists are degenerate case where every element is a singleton
- res_index <- as.data.frame(matrix(0, 1, 0))
- res_dim <- numeric()
- res_labels <- NULL
-
- attr(res, "split_type") <- NULL
- attr(res, "split_labels") <- NULL
- class(res) <- class(res)[2]
- }
-
- if (is.null(labels)) {
- labels <- data.frame(X = seq_len(n))
- in_labels <- list(NULL)
- in_dim <- n
- } else {
- in_labels <- lapply(labels, unique)
- in_dim <- sapply(in_labels, length)
- }
-
- index <- cbind(
- labels[rep(seq_len(nrow(labels)), each = nrow(res_index)), , drop = FALSE],
- res_index[rep(seq_len(nrow(res_index)), nrow(labels)), , drop = FALSE]
- )
-
- out_dim <- unname(c(in_dim, res_dim))
- out_labels <- c(in_labels, res_labels)
- n <- prod(out_dim)
-
- overall <- order(ninteraction(index))
- if (length(overall) < n) overall <- match(1:n, overall, nomatch = NA)
-
- out_array <- res[overall]
- dim(out_array) <- out_dim
- dimnames(out_array) <- out_labels
- if (.drop) reduce(out_array) else out_array
-}
# Split data frame, apply function, and return results in an array
# For each subset of data frame, apply function then combine results into an array
View
29 R/ply-data-frame.r
@@ -33,35 +33,6 @@ ldply <- function(.data, .fun = NULL, ..., .progress = "none") {
list_to_dataframe(res, attr(.data, "split_labels"))
}
-list_to_dataframe <- function(res, labels) {
- if (length(res) == 0) return(data.frame())
-
- atomic <- unlist(llply(res, is.atomic))
- if (all(atomic)) {
- ulength <- unique(unlist(llply(res, length)))
- if (length(ulength) != 1) stop("Results are not equal lengths")
-
- if (length(res) > 1) {
- resdf <- as.data.frame(do.call("rbind", res))
- } else {
- resdf <- data.frame(res[[1]])
- }
- rows <- rep(1, length(res))
- } else {
- l_ply(res, function(x) if(!is.null(x) & !is.data.frame(x)) stop("Not a data.frame!"))
-
- resdf <- do.call("rbind.fill", res)
- rows <- laply(res, function(x) if(is.null(x)) 0 else nrow(x))
- }
-
- if (!is.null(labels) && nrow(labels) == length(res)) {
- cols <- setdiff(names(labels), names(resdf))
- resdf <- cbind(labels[rep(1:nrow(labels), rows), cols, drop=FALSE], resdf)
- }
-
- unrowname(resdf)
-}
-
# Split data frame, apply function, and return results in a data frame
# For each subset of a data frame, apply function then combine results into a data frame
#
View
98 R/simplify.r
@@ -0,0 +1,98 @@
+# List to data frame
+# Reduce/simplify a list of homogenous objects to a data frame
+#
+# @arguments list of input data
+# @arguments a data frame of labels, one row for each element of res
+# @keywords internal
+list_to_dataframe <- function(res, labels = NULLS) {
+ if (length(res) == 0) return(data.frame())
+
+ atomic <- unlist(llply(res, is.atomic))
+ if (all(atomic)) {
+ ulength <- unique(unlist(llply(res, length)))
+ if (length(ulength) != 1) stop("Results are not equal lengths")
+
+ if (length(res) > 1) {
+ resdf <- as.data.frame(do.call("rbind", res))
+ } else {
+ resdf <- data.frame(res[[1]])
+ }
+ rows <- rep(1, length(res))
+ } else {
+ l_ply(res, function(x) if(!is.null(x) & !is.data.frame(x)) stop("Not a data.frame!"))
+
+ resdf <- do.call("rbind.fill", res)
+ rows <- laply(res, function(x) if(is.null(x)) 0 else nrow(x))
+ }
+
+ if (!is.null(labels) && nrow(labels) == length(res)) {
+ cols <- setdiff(names(labels), names(resdf))
+ resdf <- cbind(labels[rep(1:nrow(labels), rows), cols, drop=FALSE], resdf)
+ }
+
+ unrowname(resdf)
+}
+
+
+# List to array
+# Reduce/simplify a list of homogenous objects to an array
+#
+# @arguments list of input data
+# @arguments a data frame of labels, one row for each element of res
+# @arguments should extra dimensions be dropped (TRUE) or preserved (FALSE)
+# @keywords internal
+list_to_array <- function(res, labels = NULL, .drop = FALSE) {
+ if (length(res) == 0) return(vector())
+ n <- length(res)
+
+ atomic <- sapply(res, is.atomic)
+ if (all(atomic)) {
+ # Atomics need to be same size
+ dlength <- unique.default(llply(res, dims))
+ if (length(dlength) != 1) stop("Results must have the same number of dimensions.")
+
+ dims <- unique(do.call("rbind", llply(res, amv_dim)))
+ if (nrow(dims) != 1) stop("Results must have the same dimensions.")
+
+ res_dim <- amv_dim(res[[1]])
+ res_labels <- amv_dimnames(res[[1]])
+ res_index <- expand.grid(res_labels)
+
+ res <- unlist(res)
+ } else {
+ # Lists are degenerate case where every element is a singleton
+ res_index <- as.data.frame(matrix(0, 1, 0))
+ res_dim <- numeric()
+ res_labels <- NULL
+
+ attr(res, "split_type") <- NULL
+ attr(res, "split_labels") <- NULL
+ class(res) <- class(res)[2]
+ }
+
+ if (is.null(labels)) {
+ labels <- data.frame(X = seq_len(n))
+ in_labels <- list(NULL)
+ in_dim <- n
+ } else {
+ in_labels <- lapply(labels, unique)
+ in_dim <- sapply(in_labels, length)
+ }
+
+ index <- cbind(
+ labels[rep(seq_len(nrow(labels)), each = nrow(res_index)), , drop = FALSE],
+ res_index[rep(seq_len(nrow(res_index)), nrow(labels)), , drop = FALSE]
+ )
+
+ out_dim <- unname(c(in_dim, res_dim))
+ out_labels <- c(in_labels, res_labels)
+ n <- prod(out_dim)
+
+ overall <- order(ninteraction(index))
+ if (length(overall) < n) overall <- match(1:n, overall, nomatch = NA)
+
+ out_array <- res[overall]
+ dim(out_array) <- out_dim
+ dimnames(out_array) <- out_labels
+ if (.drop) reduce(out_array) else out_array
+}
Please sign in to comment.
Something went wrong with that request. Please try again.