Re-implement plyr::split_labels

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)

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)) {

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)))
+})