Rework simplification

R/list-simplify.R

@@ -0,0 +1,40 @@
+list_simplify <- function(x, simplify = NA, ptype = NULL) {
+  vec_assert(x, list())
+  if (length(simplify) > 1 || !is.logical(simplify)) {
+    abort("`simplify` must be `TRUE`, `FALSE`, or `NA`")
+  }
+  if (!is.null(ptype) && isFALSE(simplify)) {
+    abort("Must not specify `ptype` when `simplify = FALSE`")
+  }
+
+  if (isFALSE(simplify)) {
+    return(x)
+  }
+  strict <- !is.na(simplify)
+
+  # We choose not to simply data frames to preserve length invariants
+  can_simplify <- every(x, ~ vec_is(.x, size = 1) && !is.data.frame(.x))
+
+  if (can_simplify) {
+    if (!is.null(ptype)) {
+      vec_unchop(x, ptype = ptype)
+    } else {
+      tryCatch(
+        vec_unchop(x),
+        vctrs_error_incompatible_type = function(err) {
+          if (strict) {
+            abort("Failed to simplify", parent = err)
+          } else {
+            x
+          }
+        }
+      )
+    }
+  } else {
+    if (strict) {
+      abort("Failed to simplify: not all elements vectors of length 1")
+    } else {
+      x
+    }
+  }
+}

R/list-transpose.R

@@ -0,0 +1,66 @@
+#' @examples
+#' # list_tranpose() is useful in conjunction with safely()
+#' x <- list("a", 1, 2)
+#' y <- x %>% map(safely(log))
+#' y %>% str()
+#' y %>% list_transpose() %>% str()
+#' y %>% list_transpose(default = list(result = NA)) %>% str()
+#'
+#' # list_tranpose() will try to simplify by default:
+#' x <- list(list(a = 1, b = 2), list(a = 3, b = 4), list(a = 5, b = 6))
+#' x %>% list_transpose()
+#' # use simplify = FALSE to always return lists:
+#' x %>% list_transpose(simplify = FALSE) |> str()
+#'
+#' # Provide explicit component names to prevent loss of those that don't
+#' # appear in first component
+#' ll <- list(
+#'   list(x = 1, y = "one"),
+#'   list(z = "deux", x = 2)
+#' )
+#' ll %>% list_transpose()
+#' ll %>% list_transpose(c("x", "y", "z"))
+#'
+#' # And specify default if you want to simplify
+#' ll %>% list_transpose(c("x", "y", "z"), default = NA)
+list_transpose <- function(x, template = NULL, simplify = NA, ptype = NULL, default = NULL) {
+  vec_assert(x, list())
+  if (length(x) == 0) {
+    return(list())
+  }
+
+  template <- template %||%
+    names(x[[1]]) %||%
+    cli::cli_abort("First element of {.arg x} is unnamed, please supply `template.")
+  if (!is.character(template)) {
+    cli::cli_abort("{.arg template} must be a character vector")
+  }
+
+  simplify <- match_template(simplify, template)
+  default <- match_template(default, template)
+  ptype <- match_template(ptype, template)
+
+  out <- rep_named(template, list())
+  for (nm in template) {
+    res <- map(x, nm, .default = default[[nm]])
+    res <- list_simplify(res, simplify = simplify[[nm]], ptype = ptype[[nm]])
+    out[[nm]] <- res
+  }
+
+  out
+}
+
+match_template <- function(x, template, error_arg = caller_arg(x), error_call = caller_env()) {
+  if (is_bare_list(x) && is_named(x)) {
+    extra_names <- setdiff(names(x), template)
+    if (length(extra_names)) {
+      cli::cli_abort(
+        "{.arg {error_arg}} contains unknown names: {.str extra_names}",
+        call = error_call
+      )
+    }
+    x
+  } else {
+    rep_named(template, list(x))
+  }
+}

R/reduce.R

@@ -343,11 +343,15 @@ seq_len2 <- function(start, end) {
 #'   the accumulation, rather than using `.x[[1]]`. This is useful if
 #'   you want to ensure that `reduce` returns a correct value when `.x`
 #'   is empty. If missing, and `.x` is empty, will throw an error.
-#'
 #' @param .dir The direction of accumulation as a string, one of
 #'   `"forward"` (the default) or `"backward"`. See the section about
 #'   direction below.
-#'
+#' @param .simplify If `NA`, the default, the accumulated list of
+#'   results is simplified to an atomic vector if possible.
+#'   If `TRUE`, the result is simplified, erroring if not possible.
+#'   If `FALSE`, the result is not simplified, always returning a list.
+#' @param .ptype If `simplify` is `TRUE`, optionally supply a vector prototype
+#'   to enforce the output types.
 #' @return A vector the same length of `.x` with the same names as `.x`.
 #'
 #'   If `.init` is supplied, the length is extended by 1. If `.x` has
@@ -454,26 +458,22 @@ seq_len2 <- function(start, end) {
 #'     ggtitle("Simulations of a random walk with drift")
 #' }
 #' @export
-accumulate <- function(.x, .f, ..., .init, .dir = c("forward", "backward")) {
+accumulate <- function(.x, .f, ..., .init, .dir = c("forward", "backward"), .simplify = NA, .ptype = NULL) {
   .dir <- arg_match(.dir, c("forward", "backward"))
   .f <- as_mapper(.f, ...)
 
   res <- reduce_impl(.x, .f, ..., .init = .init, .dir = .dir, .acc = TRUE)
   names(res) <- accumulate_names(names(.x), .init, .dir)
 
-  # It would be unappropriate to simplify the result rowwise with
-  # `accumulate()` because it has invariants defined in terms of
-  # `length()` rather than `vec_size()`
-  if (some(res, is.data.frame)) {
-    res
-  } else {
-    vec_simplify(res)
-  }
+  res <- list_simplify(res, .simplify, .ptype)
+  res
 }
 #' @rdname accumulate
 #' @export
-accumulate2 <- function(.x, .y, .f, ..., .init) {
-  reduce2_impl(.x, .y, .f, ..., .init = .init, .acc = TRUE)
+accumulate2 <- function(.x, .y, .f, ..., .init, .simplify = NA, .ptype = NULL) {
+  res <- reduce2_impl(.x, .y, .f, ..., .init = .init, .acc = TRUE)
+  res <- list_simplify(res, .simplify, .ptype)
+  res
 }
 
 accumulate_names <- function(nms, init, dir) {

R/utils.R

@@ -280,21 +280,6 @@ quo_invert <- function(call) {
 quo_is_constant <- function(quo) {
   is_reference(quo_get_env(quo), empty_env())
 }
-
-vec_simplify <- function(x) {
-  if (!vctrs::vec_is_list(x)) {
-    return(x)
-  }
-  if (!every(x, ~ vctrs::vec_is(.x) && vctrs::vec_size(.x) == 1L)) {
-    return(x)
-  }
-
-  tryCatch(
-    vctrs_error_incompatible_type = function(...) x,
-    vctrs::vec_c(!!!x)
-  )
-}
-
 quo_is_same_env <- function(x, env) {
   quo_env <- quo_get_env(x)
   is_reference(quo_env, env) || is_reference(quo_env, empty_env())

tests/testthat/_snaps/list-simplify.md

@@ -0,0 +1,17 @@
+# ptype is checked
+
+    Code
+      list_simplify(list(1, 2), ptype = character())
+    Condition
+      Error:
+      ! Can't convert <double> to <character>.
+
+# x must be a list
+
+    Code
+      list_simplify(1:5)
+    Condition
+      Error in `list_simplify()`:
+      ! `x` must be a vector with type <list>.
+      Instead, it has type <integer>.
+

tests/testthat/test-list-simplify.R

@@ -0,0 +1,30 @@
+test_that("simplification requires vectors", {
+  expect_equal(list_simplify(list(mean)), list(mean))
+})
+
+test_that("simplification requires length 1 inputs", {
+  expect_equal(list_simplify(list(1, 2:3)), list(1, 2:3))
+  expect_equal(list_simplify(list(1, 2, 3)), c(1, 2, 3))
+})
+
+test_that("simplification requires common type", {
+  expect_equal(list_simplify(list(1, 2)), c(1, 2))
+  expect_equal(list_simplify(list(1, "a")), list(1, "a"))
+})
+
+test_that("never simplifies data frames", {
+  x <- list(data.frame(x = 1), data.frame(y = 1))
+  expect_equal(list_simplify(x), x)
+})
+
+test_that("ptype is checked", {
+  expect_equal(list_simplify(list(1, 2), ptype = double()), c(1, 2))
+  expect_snapshot(list_simplify(list(1, 2), ptype = character()), error = TRUE)
+})
+
+
+# argument checking -------------------------------------------------------
+
+test_that("x must be a list", {
+  expect_snapshot(list_simplify(1:5), error = TRUE)
+})

tests/testthat/test-reduce.R

@@ -162,8 +162,8 @@ test_that("basic accumulate2() works", {
   paste2 <- function(x, y, sep) paste(x, y, sep = sep)
 
   x <- c("a", "b", "c")
-  expect_equal(accumulate2(x, c("-", "."), paste2), list("a", "a-b", "a-b.c"))
-  expect_equal(accumulate2(x, c(".", "-", "."), paste2, .init = "x"), list("x", "x.a", "x.a-b", "x.a-b.c"))
+  expect_equal(accumulate2(x, c("-", "."), paste2), c("a", "a-b", "a-b.c"))
+  expect_equal(accumulate2(x, c(".", "-", "."), paste2, .init = "x"), c("x", "x.a", "x.a-b", "x.a-b.c"))
 })
 
 test_that("can terminate accumulate2() early", {
@@ -177,8 +177,8 @@ test_that("can terminate accumulate2() early", {
   }
 
   x <- c("a", "b", "c")
-  expect_equal(accumulate2(x, c("-", "."), paste2), list("a", "a-b"))
-  expect_equal(accumulate2(x, c(".", "-", "."), paste2, .init = "x"), list("x", "x.a", "x.a-b"))
+  expect_equal(accumulate2(x, c("-", "."), paste2), c("a", "a-b"))
+  expect_equal(accumulate2(x, c(".", "-", "."), paste2, .init = "x"), c("x", "x.a", "x.a-b"))
 })
 
 test_that("accumulate2() forces arguments (#643)", {

tests/testthat/test-utils.R

@@ -74,30 +74,6 @@ test_that("quo_invert() unwraps constants", {
   expect_identical(quo_invert(call), new_quosure(quote(foo(foo, NULL)), quo_get_env(foo)))
 })
 
-test_that("vec_simplify() coerces atomic inputs", {
-  expect_identical(
-    vec_simplify(list(1, TRUE)),
-    c(1, 1)
-  )
-  expect_identical(
-    vec_simplify(list("foo", factor("bar"))),
-    c("foo", "bar")
-  )
-  expect_identical(
-    vec_simplify(list(data.frame(x = FALSE), data.frame(x = 1L))),
-    data.frame(x = 0:1)
-  )
-})
-
-test_that("vec_simplify() ignores complex inputs", {
-  expect_identical(vec_simplify(list(1L, 2:3)), list(1L, 2:3))
-  expect_identical(vec_simplify(list(1, "a")), list(1, "a"))
-  expect_identical(vec_simplify(1:3), 1:3)
-  expect_identical(vec_simplify(list(identity)), list(identity))
-  expect_identical(vec_simplify(mtcars), mtcars)
-})
-
-
 # Lifecycle ---------------------------------------------------------------
 
 test_that("%@% is an infix attribute accessor", {