diff --git a/NAMESPACE b/NAMESPACE index 7472f90..793f932 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -21,7 +21,6 @@ importFrom(plyr,eval.quoted) importFrom(plyr,id) importFrom(plyr,llply) importFrom(plyr,rbind.fill) -importFrom(plyr,split_labels) importFrom(plyr,vaggregate) importFrom(stats,setNames) importFrom(utils,type.convert) diff --git a/R/cast.r b/R/cast.r index b77c301..ff49a3c 100644 --- a/R/cast.r +++ b/R/cast.r @@ -41,7 +41,7 @@ #' @param value.var name of column which stores values, see #' \code{\link{guess_value}} for default strategies to figure this out. #' @seealso \code{\link{melt}}, \url{http://had.co.nz/reshape/} -#' @importFrom plyr alply amv_dimnames as.quoted eval.quoted id llply rbind.fill split_labels vaggregate +#' @importFrom plyr alply amv_dimnames as.quoted eval.quoted id llply rbind.fill vaggregate #' @import stringr #' @examples #' #Air quality example @@ -92,6 +92,42 @@ #' @name cast NULL +split_labels <- function(splits, drop, id = id(splits, drop = TRUE)) { + if (length(splits) == 0) return(data.frame()) + + if (drop) { + n <- attr(id, "n") + if (n == 0) { + grid <- data.frame(lapply(splits, function(x) x[0]), stringsAsFactors = FALSE) + } else { + # find the first index of each unique id + idx <- match(seq_len(n), id) + grid <- data.frame(lapply(splits, function(x) x[idx]), stringsAsFactors = FALSE) + } + } else { + # Generate the full grid + unique_vals <- lapply(splits, function(x) { + if (is.factor(x)) { + factor(levels(x), levels = levels(x), ordered = is.ordered(x)) + } else { + sort(unique(x), na.last = TRUE) + } + }) + + # expand.grid varies the FIRST argument fastest + # But id(drop=FALSE) varies the LAST argument fastest + # So we expand.grid(rev(unique_vals)), then reverse the columns + grid <- expand.grid(rev(unique_vals), KEEP.OUT.ATTRS = FALSE, stringsAsFactors = FALSE) + grid <- grid[rev(seq_along(grid))] + } + + if (!is.null(names(splits))) { + names(grid) <- names(splits) + } + + grid +} + cast <- function(data, formula, fun.aggregate = NULL, ..., subset = NULL, fill = NULL, drop = TRUE, value.var = guess_value(data), value_var) { if (!missing(value_var)) { diff --git a/tests/testthat/test-cast.r b/tests/testthat/test-cast.r index 0aae1d7..7371598 100644 --- a/tests/testthat/test-cast.r +++ b/tests/testthat/test-cast.r @@ -211,3 +211,47 @@ test_that("useful error message if value.var doesn't exist", { expect_error(dcast(airquality, month ~ day, value.var = "test"), "value.var (test) not found in input", fixed = TRUE) }) + +test_that("split_labels constructs empty data.frame for empty input", { + expect_equal(split_labels(list(), drop = TRUE), data.frame()) + expect_equal(split_labels(list(), drop = FALSE), data.frame()) +}) + +test_that("split_labels with drop=TRUE extracts active combinations", { + x <- c("a", "b", "a") + y <- c(1, 2, 1) + vars <- list(x = x, y = y) + ids <- id(vars, drop = TRUE) + + labels <- split_labels(vars, drop = TRUE, id = ids) + + expect_equal(nrow(labels), 2) + expect_equal(labels$x, c("a", "b")) + expect_equal(labels$y, c(1, 2)) +}) + +test_that("split_labels with drop=FALSE constructs full Cartesian grid where last varies fastest", { + x <- factor(c("a", "b")) + y <- c(1, 2) + vars <- list(x = x, y = y) + + labels <- split_labels(vars, drop = FALSE) + + # Total combinations = 4 + expect_equal(nrow(labels), 4) + + # Last varies fastest means y is 1, 2, 1, 2 and x is a, a, b, b + expect_equal(labels$x, factor(c("a", "a", "b", "b"))) + expect_equal(labels$y, c(1, 2, 1, 2)) +}) + +test_that("split_labels handles NA values correctly", { + x <- c("a", NA) + y <- factor(c("b", "c")) + vars <- list(x = x, y = y) + + # drop = FALSE should still include NA as a level + labels_f <- split_labels(vars, drop = FALSE) + expect_equal(nrow(labels_f), 4) + expect_true(any(is.na(labels_f$x))) +})