WIP: custom row-metadata (#260)

NAMESPACE

@@ -3,6 +3,7 @@
 S3method(as_tbl,data.frame)
 S3method(ctl_new_compound_pillar,tbl)
 S3method(ctl_new_pillar,tbl)
+S3method(ctl_new_rowid_pillar,tbl)
 S3method(extra_cols,pillar_squeezed_colonnade)
 S3method(format,pillar)
 S3method(format,pillar_1e)
@@ -25,6 +26,7 @@ S3method(format,pillar_tbl_format_setup)
 S3method(format,pillar_title)
 S3method(format,pillar_type)
 S3method(format,tbl)
+S3method(format,tbl_rif_shaft)
 S3method(format_glimpse,character)
 S3method(format_glimpse,default)
 S3method(format_glimpse,factor)
@@ -111,6 +113,7 @@ export(char)
 export(colonnade)
 export(ctl_new_compound_pillar)
 export(ctl_new_pillar)
+export(ctl_new_rowid_pillar)
 export(dim_desc)
 export(expect_known_display)
 export(extra_cols)

R/ctl_colonnade.R

@@ -12,13 +12,13 @@ ctl_colonnade <- function(x, has_row_id = TRUE, width = NULL, controller = new_t
     return(new_colonnade_body(list(), extra_cols = x))
   }
 
+  rowid <- ctl_new_rowid_pillar(controller, x, width, has_row_id, title = NULL)
+
   # Reserve space for rowid column in each tier
-  if (!is_false(has_row_id)) {
-    rowid <- rif_shaft(n)
-    rowid_width <- get_cell_widths(rowid)
-  } else {
-    rowid <- NULL
+  if (is.null(rowid)) {
     rowid_width <- 0L
+  } else {
+    rowid_width <- get_cell_widths(rowid)
   }
 
   tier_widths <- get_tier_widths(width, nc, rowid_width + 1L)
@@ -32,13 +32,12 @@ ctl_colonnade <- function(x, has_row_id = TRUE, width = NULL, controller = new_t
   col_widths <- colonnade_get_width_2(compound_pillar, tier_widths)
 
   if (!is.null(rowid)) {
-    rowid_pillar <- rowidformat2(rowid, names(pillars[[1]]), has_star = identical(has_row_id, "*"))
 
     col_widths_rowid <- as_tbl(data_frame(
       tier = unique(col_widths$tier),
       id = 0L,
       width = rowid_width,
-      pillar = list(rowid_pillar)
+      pillar = list(rowid)
     ))
 
     col_widths <- vec_rbind(col_widths_rowid, col_widths)

R/ctl_new_pillar.R

@@ -84,6 +84,49 @@
 #'   list(a = 1:3, b = letters[1:3]),
 #'   class = c("line_tbl", "tbl")
 #' )
+#'
+#' ctl_new_rowid_pillar.line_tbl <- function(controller, x, width, has_row_id, ..., title = NULL) {
+#'   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, has_row_id, ..., title = NULL) {
+#'   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 = c("tbl_rif_shaft", "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)`)"
 
@@ -110,6 +153,26 @@ ctl_new_compound_pillar <- function(controller, x, width, ..., title = NULL) {
   UseMethod("ctl_new_compound_pillar")
 }
 
+#' @param has_row_id Logical flag indicating whether to construct a row ID
+#' pillar
+#' @rdname ctl_new_pillar
+#' @export
+ctl_new_rowid_pillar <- function(controller, x, width, has_row_id, ..., title = NULL) {
+  "!!!!DEBUG ctl_new_rowid_pillar(`v(width)`, `v(title)`)"
+
+  check_dots_empty()
+
+  if (length(width) == 0) {
+    return(NULL)
+  }
+
+  if (is_false(has_row_id)) {
+    return(NULL)
+  }
+
+  UseMethod("ctl_new_rowid_pillar")
+}
+
 #' @export
 ctl_new_compound_pillar.tbl <- function(controller, x, width, ..., title = NULL) {
   "!!!!DEBUG ctl_new_compound_pillar.tbl(`v(width)`, `v(title)`)"
@@ -132,6 +195,33 @@ ctl_new_pillar.tbl <- function(controller, x, width, ..., title = NULL) {
   pillar(x, title, if (!is.null(width)) max0(width))
 }
 
+#' @export
+ctl_new_rowid_pillar.tbl <- function(controller, x, width, has_row_id, ..., title = 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(has_row_id, "*")))
+  }
+
+  if ("data" %in% template) {
+    out$data <- pillar_component(data)
+  }
+
+  new_pillar(out, width = get_cell_widths(data))
+}
+
 max0 <- function(x) {
   if (length(x) > 0) {
     max(x)

R/ctl_pillar.R

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

R/rowid-data.R

@@ -3,16 +3,22 @@ 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"
+    class = c("tbl_rif_shaft", "pillar_rif_shaft")
   )
 }
 
+#' @export
+format.tbl_rif_shaft <- function(x, width, ...) {
+  x <- format(x$row_ids, width = width)
+  NextMethod()
+}
+
 #' @export
 format.pillar_rif_shaft <- function(x, width, ...) {
   new_ornament(
-    style_rowid(format(seq_len(x$n), width = width)),
+    style_rowid(x),
     width = width,
     align = "right"
   )