From 92eb087c984fcaf43ac5a5f8d1027ee5c9e438d6 Mon Sep 17 00:00:00 2001
From: n-kall <n-kall@github.com>
Date: Fri, 15 Mar 2024 13:10:30 +0200
Subject: [PATCH 1/3] modify summarise_draws internals not to coerce values to
 same type

---
 R/misc.R            | 25 +++++++++++++++++++++++++
 R/summarise_draws.R | 19 +++++--------------
 2 files changed, 30 insertions(+), 14 deletions(-)

diff --git a/R/misc.R b/R/misc.R
index c1bce76c..5332f675 100644
--- a/R/misc.R
+++ b/R/misc.R
@@ -14,6 +14,31 @@ named_list <- function(names, values = NULL) {
   setNames(values, names)
 }
 
+
+# flatten a list that may contain vectors into a single level list
+unnest <- function(x) {
+
+  out <- list()
+
+  for (i in seq_along(x)) {
+    name_i <- names(x[i])
+    if (length(x[[i]]) > 1) {
+      if (rlang::is_named(x[[i]])) {
+        name_j <- names(x[[i]])
+      } else {
+        name_j <- paste0(name_i, ".", c(1:length(x[[i]])))
+      }
+      for (j in seq_along(x[[i]])) {
+        out[[name_j[j]]] <- x[[i]][[j]]
+      }
+    } else {
+      out[[name_i]] <- x[[i]]
+    }
+  }
+  out
+}
+
+
 # unlist lapply output
 ulapply <- function(X, FUN, ..., recursive = TRUE, use.names = TRUE) {
   unlist(lapply(X, FUN, ...), recursive, use.names)
diff --git a/R/summarise_draws.R b/R/summarise_draws.R
index 6f13755a..16aaad37 100644
--- a/R/summarise_draws.R
+++ b/R/summarise_draws.R
@@ -341,30 +341,21 @@ summarise_draws_helper <- function(x, funs, .args) {
   variables_x <- variables(x)
   # get length and output names, calculated on the first variable
   out_1 <- create_summary_list(x, variables_x[1], funs, .args)
-  the_names <- vector(mode = "list", length = length(funs))
-  for (i in seq_along(out_1)){
-    if (rlang::is_named(out_1[[i]])) {
-      the_names[[i]] <- names(out_1[[i]])
-    } else if (length(out_1[[i]]) > 1) {
-      the_names[[i]] <- paste0(names(out_1)[i], ".", c(1:length(out_1[[i]])))
-    } else {
-      the_names[[i]] <- names(out_1)[i]
-    }
-  }
-  the_names <- unlist(the_names)
+  out_1 <- unnest(out_1)
+  the_names <- names(out_1)
   # Check for naming issues prior do doing lengthy computation
   if ("variable" %in% the_names) {
     stop_no_call("Name 'variable' is reserved in 'summarise_draws'.")
   }
   # Pre-allocate matrix to store output
-  out <- matrix(NA, nrow = length(variables_x), ncol = length(the_names))
+  out <- data.frame(matrix(NA, nrow = length(variables_x), ncol = length(the_names)))
   colnames(out) <- the_names
-  out[1, ] <- unlist(out_1)
+  out[1, ] <- out_1
   # Do the computation for all remaining variables
   if (length(variables_x) > 1L) {
     for (v_ind in 2:length(variables_x)) {
       out_v <- create_summary_list(x, variables_x[v_ind], funs, .args)
-      out[v_ind, ] <- unlist(out_v)
+      out[v_ind, ] <- unnest(out_v)
     }
   }
   out <- tibble::as_tibble(out)

From 2a8ae5e90dc5f784fac18d9c4fa593ccd5224280 Mon Sep 17 00:00:00 2001
From: n-kall <n-kall@github.com>
Date: Fri, 15 Mar 2024 14:06:56 +0200
Subject: [PATCH 2/3] minor tweaks to unnest

---
 R/misc.R | 10 +++++-----
 1 file changed, 5 insertions(+), 5 deletions(-)

diff --git a/R/misc.R b/R/misc.R
index 5332f675..c8c725a8 100644
--- a/R/misc.R
+++ b/R/misc.R
@@ -20,19 +20,19 @@ unnest <- function(x) {
 
   out <- list()
 
+  names_x <- names(x)
   for (i in seq_along(x)) {
-    name_i <- names(x[i])
     if (length(x[[i]]) > 1) {
       if (rlang::is_named(x[[i]])) {
-        name_j <- names(x[[i]])
+        names_i <- names(x[[i]])
       } else {
-        name_j <- paste0(name_i, ".", c(1:length(x[[i]])))
+        names_i <- paste0(names_x[[i]], ".", c(1:length(x[[i]])))
       }
       for (j in seq_along(x[[i]])) {
-        out[[name_j[j]]] <- x[[i]][[j]]
+        out[[names_i[j]]] <- x[[i]][[j]]
       }
     } else {
-      out[[name_i]] <- x[[i]]
+      out[[names_x[[i]]]] <- x[[i]]
     }
   }
   out

From ded8b04474a7d5530227f413661ef0c31cf53668 Mon Sep 17 00:00:00 2001
From: n-kall <n-kall@github.com>
Date: Fri, 15 Mar 2024 14:28:46 +0200
Subject: [PATCH 3/3] add test for summarise draws

---
 tests/testthat/test-summarise_draws.R | 8 ++++++++
 1 file changed, 8 insertions(+)

diff --git a/tests/testthat/test-summarise_draws.R b/tests/testthat/test-summarise_draws.R
index 80ed971e..d5e7a20c 100644
--- a/tests/testthat/test-summarise_draws.R
+++ b/tests/testthat/test-summarise_draws.R
@@ -19,6 +19,14 @@ test_that("summarise_draws works correctly", {
   sum_x <- summarise_draws(x)
   expect_true(is.na(sum_x[1, "q5"]))
   expect_true(all(c("q5", "q95") %in% names(sum_x)))
+
+  sum_x <- summarise_draws(x, quantile2 = ~quantile2(.x, names = FALSE))
+  expect_true(all(c("quantile2.1", "quantile2.2") %in% names(sum_x)))
+
+  sum_x <- summarise_draws(x, mean, char = function(x) "char")
+  expect_double(sum_x[["mean"]])
+  expect_character(sum_x[["char"]])
+
 })
 
 test_that("aliases of summarise_draws work", {