ctl_new_pillar_list()

NAMESPACE

@@ -3,6 +3,7 @@
 S3method(as_tbl,data.frame)
 S3method(ctl_new_compound_pillar,tbl)
 S3method(ctl_new_pillar,tbl)
+S3method(ctl_new_pillar_list,tbl)
 S3method(extra_cols,pillar_squeezed_colonnade)
 S3method(format,pillar)
 S3method(format,pillar_1e)
@@ -110,6 +111,7 @@ export(char)
 export(colonnade)
 export(ctl_new_compound_pillar)
 export(ctl_new_pillar)
+export(ctl_new_pillar_list)
 export(dim_desc)
 export(expect_known_display)
 export(extra_cols)

R/ctl_colonnade.R

@@ -22,7 +22,7 @@ ctl_colonnade <- function(x, has_row_id = TRUE, width = NULL, controller = new_t
   }
 
   tier_widths <- get_tier_widths(width, nc, rowid_width + 1L)
-  pillars <- new_packed_pillars(x, controller, tier_widths, title = NULL)
+  pillars <- new_data_frame_pillar_list(x, controller, tier_widths, title = NULL)
 
   if (length(pillars) == 0) {
     return(new_colonnade_body(list(), extra_cols = x))

R/ctl_compound.R

@@ -1,10 +1,10 @@
 new_data_frame_pillar <- function(x, controller, width, title) {
-  pillars <- new_packed_pillars(x, controller, width, title)
-  combine_pillars(pillars, extra = names(x)[-seq_along(pillars)])
+  pillars <- new_data_frame_pillar_list(x, controller, width, title)
+  combine_pillars(pillars, extra = attr(pillars, "extra"))
 }
 
-new_packed_pillars <- function(x, controller, width, title) {
-  "!!!!!DEBUG new_packed_pillars(`v(width)`, `v(title)`)"
+new_data_frame_pillar_list <- function(x, controller, width, title, first_pillar = NULL) {
+  "!!!!!DEBUG new_data_frame_pillar_list(`v(width)`, `v(title)`)"
 
   if (ncol(x) == 0) {
     return(compact(list(pillar_from_shaft(
@@ -25,26 +25,36 @@ new_packed_pillars <- function(x, controller, width, title) {
 
     # FIXME
     # sub_title <- c(title, ticked_names[[i]])
-    sub_title <- ticked_names[[i]]
-    if (!is.null(title)) {
-      if (i == 1) {
-        title[[length(title)]] <- paste0(title[[length(title)]], "$")
-      } else {
-        title[[length(title)]] <- "$"
+    if (i == 1 && !is.null(first_pillar)) {
+      pillar <- first_pillar
+    } else {
+      sub_title <- ticked_names[[i]]
+      if (!is.null(title)) {
+        if (i == 1) {
+          title[[length(title)]] <- paste0(title[[length(title)]], "$")
+        } else {
+          title[[length(title)]] <- "$"
+        }
+        sub_title <- c(title, sub_title)
       }
-      sub_title <- c(title, sub_title)
+
+      # Call ctl_new_compound_pillar() only for objects that can fit
+      pillar <- ctl_new_compound_pillar(
+        controller, x[[i]],
+        width = width,
+        title = sub_title
+      )
     }
 
-    # Call ctl_new_compound_pillar() only for objects that can fit
-    pillar <- ctl_new_compound_pillar(
-      controller, x[[i]], width,
-      title = sub_title
-    )
     if (is.null(pillar)) {
       # NULL return: doesn't fit
       break
     }
 
+    if (is.null(width)) {
+      return(list(pillar))
+    }
+
     # Compute remaining width
     width <- deduct_width(width, pillar_get_min_widths(pillar))
     if (is.null(width)) {
@@ -55,17 +65,24 @@ new_packed_pillars <- function(x, controller, width, title) {
     pillars[[i]] <- pillar
   }
 
-  compact(pillars)
+  pillars <- compact(pillars)
+
+  structure(pillars, extra = names(x)[-seq_along(pillars)])
 }
 
 new_matrix_pillar <- function(x, controller, width, title) {
+  pillars <- new_matrix_pillar_list(x, controller, width, title)
+  combine_pillars(pillars, extra = attr(pillars, "extra"))
+}
+
+new_matrix_pillar_list <- function(x, controller, width, title, first_pillar = NULL) {
   if (ncol(x) == 0) {
-    return(pillar_from_shaft(
+    return(list(pillar_from_shaft(
       new_pillar_title(prepare_title(title)),
       new_pillar_type(x),
       new_empty_shaft(nrow(x)),
       width
-    ))
+    )))
   }
 
   max_n_pillars <- sum(width %/% 2)
@@ -81,26 +98,36 @@ new_matrix_pillar <- function(x, controller, width, title) {
   ticked_names <- paste0("[,", idx, "]")
 
   for (i in seq_along(ticked_names)) {
-    # FIXME
-    # sub_title <- c(title, ticked_names[[i]])
-    sub_title <- ticked_names[[i]]
-    if (!is.null(title)) {
-      if (i > 1) {
-        title[[length(title)]] <- ""
+    if (i == 1 && !is.null(first_pillar)) {
+      pillar <- first_pillar
+    } else {
+      # FIXME
+      # sub_title <- c(title, ticked_names[[i]])
+      sub_title <- ticked_names[[i]]
+      if (!is.null(title)) {
+        if (i > 1) {
+          title[[length(title)]] <- ""
+        }
+        sub_title <- c(title, sub_title)
       }
-      sub_title <- c(title, sub_title)
+
+      # Call ctl_new_pillar() only for objects that can fit
+      pillar <- ctl_new_pillar(
+        controller, x[, i],
+        width = width,
+        title = prepare_title(sub_title)
+      )
     }
 
-    # Call ctl_new_pillar() only for objects that can fit
-    pillar <- ctl_new_pillar(
-      controller, x[, i], width,
-      title = prepare_title(sub_title)
-    )
     if (is.null(pillar)) {
       # NULL return: doesn't fit
       break
     }
 
+    if (is.null(width)) {
+      return(list(pillar))
+    }
+
     # Compute remaining width
     width <- deduct_width(width, pillar_get_min_widths(pillar))
     if (is.null(width)) {
@@ -111,26 +138,30 @@ new_matrix_pillar <- function(x, controller, width, title) {
     pillars[[i]] <- pillar
   }
 
-  compact_pillars <- compact(pillars)
-  if (length(compact_pillars) < ncol(x)) {
-    extra <- seq2(length(compact_pillars) + 1, ncol(x))
-  } else {
-    extra <- NULL
-  }
-  combine_pillars(compact_pillars, extra = extra)
+  pillars <- compact(pillars)
+  structure(pillars, extra = seq2(length(pillars) + 1, ncol(x)))
 }
 
 new_array_pillar <- function(x, controller, width, title) {
+  pillars <- new_array_pillar_list(x, controller, width, title)
+  pillars[[1]]
+}
+
+new_array_pillar_list <- function(x, controller, width, title, first_pillar = NULL) {
+  if (!is.null(first_pillar)) {
+    return(list(first_pillar))
+  }
+
   first_slice <- head(as.vector(x), vec_size(x))
 
   body <- pillar_shaft(first_slice)
 
-  pillar_from_shaft(
+  list(pillar_from_shaft(
     new_pillar_title(title),
     new_pillar_type(x),
     new_continuation_shaft(body),
     width
-  )
+  ))
 }
 
 combine_pillars <- function(pillars, extra = NULL) {

R/ctl_new_pillar.R

@@ -27,10 +27,11 @@
 #'
 #' @inheritParams ellipsis::dots_empty
 #' @param controller The object of class `"tbl"` currently printed.
-#' @param x A vector, can also be a data frame, array or matrix
-#'   in `ctl_new_compound_pillar()`
-#' @param width The available width, can be a vector for multiple tiers
-#' @param title The title, derived from the name of the column in the data
+#' @param x A vector, can also be a data frame, array or matrix.
+#'   in `ctl_new_compound_pillar()` and `ctl_new_pillar_list()`.
+#' @param width The available width, can be a vector for multiple tiers.
+#'   If `NULL`, compute only the first pillar.
+#' @param title The title, derived from the name of the column in the data.
 #'
 #' @export
 #' @examplesIf rlang::is_installed("palmerpenguins") && requireNamespace("tibble")
@@ -90,10 +91,6 @@ ctl_new_pillar <- function(controller, x, width, ..., title = NULL) {
 
   check_dots_empty()
 
-  if (length(width) == 0) {
-    return(NULL)
-  }
-
   UseMethod("ctl_new_pillar")
 }
 
@@ -119,10 +116,6 @@ ctl_new_compound_pillar <- function(controller, x, width, ..., title = NULL) {
 
   check_dots_empty()
 
-  if (length(width) == 0) {
-    return(NULL)
-  }
-
   UseMethod("ctl_new_compound_pillar")
 }
 
@@ -141,6 +134,36 @@ ctl_new_compound_pillar.tbl <- function(controller, x, width, ..., title = NULL)
   }
 }
 
+#' @param first_pillar Can be passed to this method if the first pillar
+#'   for a compound pillar (or the pillar itself for a simple pillar)
+#'   has been computed already.
+#' @rdname ctl_new_pillar
+#' @export
+ctl_new_pillar_list <- function(controller, x, width, ..., title = NULL, first_pillar = NULL) {
+  "!!!!DEBUG ctl_new_pillar_list(`v(width)`, `v(title)`)"
+
+  check_dots_empty()
+
+  UseMethod("ctl_new_pillar_list")
+}
+
+#' @export
+ctl_new_pillar_list.tbl <- function(controller, x, width, ..., title = NULL, first_pillar = NULL) {
+  "!!!!DEBUG ctl_new_pillar_list.tbl(`v(width)`, `v(title)`)"
+
+  if (is.data.frame(x)) {
+    new_data_frame_pillar_list(x, controller, width, title = title, first_pillar = first_pillar)
+  } else if (is.matrix(x)) {
+    new_matrix_pillar_list(x, controller, width, title = title, first_pillar = first_pillar)
+  } else if (is.array(x) && length(dim(x)) > 1) {
+    new_array_pillar_list(x, controller, width, title = title, first_pillar = first_pillar)
+  } else if (is.null(first_pillar)) {
+    list(ctl_new_pillar(controller, x, width, ..., title = prepare_title(title)))
+  } else {
+    list(first_pillar)
+  }
+}
+
 # FIXME: Keep vectorized titles later
 prepare_title <- function(title) {
   paste(title, collapse = "")