Second try for rowids

NAMESPACE

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

R/ctl_colonnade.R

@@ -15,13 +15,18 @@ ctl_colonnade <- function(x, has_row_id = TRUE, width = NULL,
     return(new_colonnade_body(list(), extra_cols = x, abbrev_cols = character(), abbrev_col_idxs = numeric()))
   }
 
-  # Reserve space for rowid column in each tier
-  if (!is_false(has_row_id)) {
-    rowid <- rif_shaft(n)
-    rowid_width <- get_width(rowid)
-  } else {
+  if (is_false(has_row_id)) {
     rowid <- NULL
+  } else {
+    rowid <- ctl_new_rowid_pillar(controller, x, width, title = NULL,
+      type = if (isTRUE(has_row_id)) NULL else has_row_id)
+  }
+
+  # Reserve space for rowid column in each tier
+  if (is.null(rowid)) {
     rowid_width <- 0L
+  } else {
+    rowid_width <- get_width(rowid)
   }
 
   has_star <- identical(has_row_id, "*")
@@ -111,8 +116,7 @@ do_emit_tiers <- function(x, tier_widths, n_focus, cb, focus) {
     # message("on_end_tier()")
     if (length(formatted_list) > 0) {
       if (!is.null(cb$rowid)) {
-        rowid_pillar <- rowidformat2(cb$rowid, formatted_list[[1]]$components, has_star = cb$has_star)
-        formatted_list <- c(list(pillar_format_parts_2(rowid_pillar, cb$rowid_width)), formatted_list)
+        formatted_list <- c(list(pillar_format_parts_2(cb$rowid, cb$rowid_width)), formatted_list)
       }
 
       aligned <- map(formatted_list, `[[`, "aligned")

R/ctl_new_pillar.R

@@ -16,6 +16,8 @@
 #' implementation.
 #' Override this method to completely change the appearance of the pillars.
 #' Components are created with [new_pillar_component()] or [pillar_component()].
+#' In order to customize printing of row IDs, a method can be supplied for the
+#' `ctl_new_rowid_pillar()` generic.
 #'
 #' All components must be of the same height.
 #' This restriction may be levied in the future.
@@ -59,7 +61,7 @@
 #'   paste(rep(x, width), collapse = "")
 #' }
 #'
-#' ctl_new_pillar.line_tbl <- function(controller, x, width, ..., title = NULL) {
+#' ctl_new_pillar.line_tbl <- function(controller, x, width, ...) {
 #'   out <- NextMethod()
 #'   new_pillar(list(
 #'     title = out$title,
@@ -69,10 +71,48 @@
 #'   ))
 #' }
 #'
+#' ctl_new_rowid_pillar.line_tbl <- function(controller, x, width, ...) {
+#'   out <- NextMethod()
+#'   new_pillar(
+#'     list(
+#'       title = out$title,
+#'       type = out$type,
+#'       lines = new_pillar_component(list(lines("=")), width = 1),
+#'       data = out$data
+#'     ),
+#'     width = as.integer(floor(log10(max(nrow(x), 1))) + 1)
+#'   )
+#' }
+#'
 #' vctrs::new_data_frame(
 #'   list(a = 1:3, b = letters[1:3]),
 #'   class = c("line_tbl", "tbl")
 #' )
+#'
+#' ctl_new_rowid_pillar.roman_tbl <- function(controller, x, width, ...) {
+#'   out <- NextMethod()
+#'   rowid <- utils::as.roman(seq_len(nrow(x)))
+#'   width <- max(nchar(as.character(rowid)))
+#'   new_pillar(
+#'     list(
+#'       title = out$title,
+#'       type = out$type,
+#'       data = pillar_component(
+#'         new_pillar_shaft(list(row_ids = rowid),
+#'           width = width,
+#'           class = "pillar_rif_shaft"
+#'         )
+#'       )
+#'     ),
+#'     width = width
+#'   )
+#' }
+#'
+#' vctrs::new_data_frame(
+#'   list(a = 1:3, b = letters[1:3]),
+#'   class = c("roman_tbl", "tbl")
+#' )
+#'
 ctl_new_pillar <- function(controller, x, width, ..., title = NULL) {
   "!!!!DEBUG ctl_new_pillar(`v(width)`, `v(title)`)"
 
@@ -88,6 +128,47 @@ ctl_new_pillar.tbl <- function(controller, x, width, ..., title = NULL) {
   pillar(x, title, if (!is.null(width)) max0(width))
 }
 
+#' @param type String for specifying a row ID type. Current values in use are
+#' `NULL` and `"*"`.
+#' @rdname ctl_new_pillar
+#' @export
+ctl_new_rowid_pillar <- function(controller, x, width, ..., title = NULL, type = NULL) {
+  "!!!!DEBUG ctl_new_rowid_pillar(`v(width)`, `v(title)`)"
+
+  check_dots_empty()
+
+  if (length(width) == 0) {
+    return(NULL)
+  }
+
+  UseMethod("ctl_new_rowid_pillar")
+}
+
+#' @export
+ctl_new_rowid_pillar.tbl <- function(controller, x, width, ..., title = NULL, type = NULL) {
+  "!!!!DEBUG ctl_new_rowid_pillar.tbl(`v(width)`, `v(title)`)"
+
+  template <- names(ctl_new_pillar(controller, vector(), width, title = title))
+
+  if (!length(template)) {
+    return(NULL)
+  }
+
+  data <- rif_shaft(nrow(x))
+
+  out <- map(set_names(template), function(.x) "")
+
+  if ("type" %in% template) {
+    out$type <- pillar_component(rif_type(identical(type, "*")))
+  }
+
+  if ("data" %in% template) {
+    out$data <- pillar_component(data)
+  }
+
+  new_pillar(out, width = get_width(data))
+}
+
 max0 <- function(x) {
   if (length(x) > 0) {
     max(x)

R/ctl_pillar.R

@@ -109,21 +109,6 @@ pillar_from_shaft <- function(title, type, data, width) {
   )
 }
 
-rowidformat2 <- function(data, names, has_star) {
-  empty_component <- pillar_component(set_width("", 0))
-  out <- map(set_names(names), function(.x) empty_component)
-
-  if ("type" %in% names) {
-    out$type <- pillar_component(rif_type(has_star))
-  }
-
-  if ("data" %in% names) {
-    out$data <- pillar_component(data)
-  }
-
-  new_pillar(out, width = get_width(data))
-}
-
 #' Construct a custom pillar object
 #'
 #' @description

R/rowid-data.R

@@ -3,7 +3,7 @@ style_rowid <- function(x) {
 }
 
 rif_shaft <- function(n, ...) {
-  new_pillar_shaft(list(n = n),
+  new_pillar_shaft(list(row_ids = seq_len(n)),
     width = as.integer(floor(log10(max(n, 1))) + 1),
     class = "pillar_rif_shaft"
   )
@@ -12,7 +12,7 @@ rif_shaft <- function(n, ...) {
 #' @export
 format.pillar_rif_shaft <- function(x, width, ...) {
   new_ornament(
-    style_rowid(format(seq_len(x$n), width = width)),
+    style_rowid(format(x$row_ids, width = width)),
     width = width,
     align = "right"
   )

tests/testthat/_snaps/rowid.md

@@ -0,0 +1,27 @@
+# rowids for line-style
+
+    Code
+      vctrs::new_data_frame(list(a = 1:3, b = letters[1:3]), class = c("line_tbl",
+        "tbl"))
+    Output
+      # A data frame: 3 x 2
+            a b    
+        <int> <chr>
+      =     = =    
+      1     1 a    
+      2     2 b    
+      3     3 c    
+
+# roman rowids
+
+    Code
+      vctrs::new_data_frame(list(a = 1:3, b = letters[1:3]), class = c("roman_tbl",
+        "tbl"))
+    Output
+      # A data frame: 3 x 2
+              a b    
+          <int> <chr>
+      I       1 a    
+      II      2 b    
+      III     3 c    
+