Merge pull request #444 from r-lib/f-365-extra-nested

- If some but not all sub-columns of a data frame or matrix column are shown, the names and types of the remaining columns are displayed in the footer (#365, #444).

R/ctl_colonnade.R

@@ -55,12 +55,25 @@ ctl_colonnade <- function(x, has_row_id = TRUE, width = NULL,
   on_extra_cols <- function(my_extra_cols) {
     # print(extra_cols)
 
-    # FIXME: Show for all levels
-    is_top_level <- map_lgl(my_extra_cols$x, identical, x)
-    if (any(is_top_level)) {
-      extra_cols <<- as.list(x)[my_extra_cols$cols[is_top_level][[1]]]
-      names(extra_cols) <<- tick_if_needed(names(extra_cols))
-    }
+    out <- pmap(my_extra_cols, function(x, title, cols) {
+      out <- as.list(x)[cols]
+      if (is.null(title)) {
+        return(out)
+      }
+
+      if (length(out) > 1) {
+        title_empty <- rep_along(title, "")
+        new_names <- paste0(paste0(title_empty, "$", collapse = ""), names(out))
+        new_names[[1]] <- paste0(paste0(title, "$", collapse = ""), names(out)[[1]])
+        names(out) <- new_names
+      } else {
+        # Also account for the case of packed matrices here
+        names(out) <- prepare_title(c(title, names(out)))
+      }
+      out
+    })
+
+    extra_cols <<- unlist(out, recursive = FALSE)
   }
 
   cb <- new_emit_tiers_callbacks(
@@ -69,10 +82,6 @@ ctl_colonnade <- function(x, has_row_id = TRUE, width = NULL,
   )
   do_emit_tiers(x_focus, tier_widths, length(focus), cb)
 
-  if (length(extra_cols) == 0) {
-    extra_cols <- list()
-  }
-
   new_colonnade_body(formatted_tiers, split_after = split_after, extra_cols = extra_cols)
 }
 
@@ -156,9 +165,11 @@ do_emit_tiers <- function(x, tier_widths, n_focus, cb) {
     # message("extra_cols()")
     # print(title)
     # print(cols)
-    extra_cols <<- vec_rbind(extra_cols, data_frame(
+    new_extra_cols <- data_frame(
       x = list(x), title = list(title), cols = list(cols)
-    ))
+    )
+    # Add to the front, because top-level columns are emitted first:
+    extra_cols <<- vec_rbind(new_extra_cols, extra_cols)
   }
 
   cb_pillars <- new_emit_pillars_callbacks(
@@ -192,16 +203,36 @@ new_emit_pillars_callbacks <- function(controller,
   )
 }
 
-do_emit_pillars <- function(x, tier_widths, cb, title = NULL, first_pillar = NULL, parent_col_idx = 1L) {
+do_emit_pillars <- function(x, tier_widths, cb, title = NULL, first_pillar = NULL, parent_col_idx = NULL) {
   top_level <- is.null(first_pillar)
 
-  pillar_list <- ctl_new_pillar_list(cb$controller, x, width = tier_widths, title = title, first_pillar = first_pillar)
+  # Only tweaking sub-title, because full title is needed for extra-cols
+  sub_title <- title
+  if (!is.null(sub_title)) {
+    sub_title[-length(sub_title)][parent_col_idx[-1] != 1] <- ""
+  }
+
+  pillar_list <- ctl_new_pillar_list(cb$controller, x, width = tier_widths, title = sub_title, first_pillar = first_pillar)
 
   # Extra columns are known early on, and remain fixed
   extra <- attr(pillar_list, "extra")
 
+  # We emit early, this means that top-level columns are emitted before
+  # nested columns. We reverse in the callback.
   if (length(extra) > 0) {
-    cb$on_extra_cols(x, title, extra)
+    if (is.numeric(extra)) {
+      if (length(extra) == 1) {
+        extra <- paste0("[", extra, "]")
+      } else {
+        extra <- paste0("[", min(extra), ":", max(extra), "]")
+      }
+      x_extra <- set_names(list(x[1, ]), extra)
+    } else {
+      extra <- tick_if_needed(extra)
+      x_extra <- tick_names_if_needed(x)
+    }
+
+    cb$on_extra_cols(x_extra, title, extra)
   }
 
   if (length(pillar_list) == 0) {
@@ -252,16 +283,6 @@ do_emit_pillars <- function(x, tier_widths, cb, title = NULL, first_pillar = NUL
   x_pos <- 0L
   tier_pos <- 1L
 
-  # FIXME: Replace with title vector
-  sub_title <- title
-  if (!is.null(sub_title)) {
-    if (parent_col_idx >= 2) {
-      sub_title[[length(sub_title)]] <- "$"
-    } else {
-      sub_title[[length(sub_title)]] <- paste0(sub_title[[length(sub_title)]], "$")
-    }
-  }
-
   # Advance column by column
   for (col in seq_along(pillar_list)) {
     target_tier <- rev$tier[[col]]
@@ -286,9 +307,9 @@ do_emit_pillars <- function(x, tier_widths, cb, title = NULL, first_pillar = NUL
       x[[col]],
       sub_tier_widths,
       cb,
-      c(sub_title, tick_if_needed(names(x)[[col]])),
+      c(title, tick_if_needed(names(x)[[col]])),
       pillar_list[[col]],
-      col
+      c(parent_col_idx, if (!is.null(names(x))) col)
     )
     "!!!!!DEBUG used"
 

R/ctl_compound.R

@@ -18,27 +18,15 @@ new_data_frame_pillar_list <- function(x, controller, width, title, first_pillar
   for (i in seq_along(x)) {
     "!!!!!DEBUG i = `i`, width = `width`"
 
-    # FIXME
-    # sub_title <- c(title, ticked_names[[i]])
     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)
-      }
-
       # Call ctl_new_pillar_list(), return only the first sub-pillar
       # thanks to width = NULL
       new_pillars <- ctl_new_pillar_list(
         controller, x[[i]],
         width = NULL,
-        title = sub_title
+        title = c(title, ticked_names[[i]])
       )
 
       # Safety check:
@@ -67,6 +55,10 @@ new_data_frame_pillar_list <- function(x, controller, width, title, first_pillar
     }
 
     pillars[[i]] <- pillar
+
+    if (!is.null(title)) {
+      title[] <- ""
+    }
   }
 
   pillars <- compact(pillars)

R/ctl_new_pillar.R

@@ -147,7 +147,13 @@ ctl_new_pillar_list.tbl <- function(controller, x, width, ..., title = NULL, fir
   }
 }
 
-# FIXME: Keep vectorized titles later
 prepare_title <- function(title) {
-  paste(title, collapse = "")
+  n_title <- length(title)
+  if (n_title == 0) {
+    title
+  } else if (grepl("^[[]", title[[n_title]])) {
+    paste0(paste(title[-n_title], collapse = "$"), title[[n_title]])
+  } else {
+    paste(title, collapse = "$")
+  }
 }

R/tick.R

@@ -22,13 +22,26 @@ format_title <- function(x, width) {
   out
 }
 
+tick_names_if_needed <- function(x) {
+  names(x) <- tick_if_needed(names(x))
+  x
+}
+
 tick_if_needed <- function(x) {
+  # Compatibility with R 3.4
+  if (is.null(x)) {
+    return(NULL)
+  }
   needs_ticks <- !is_syntactic(x)
   x[needs_ticks] <- tick(x[needs_ticks])
   x
 }
 
 is_syntactic <- function(x) {
+  # Compatibility with R 3.4
+  if (is.null(x)) {
+    return(logical())
+  }
   ret <- make.names(x) == x
   ret[is.na(x)] <- FALSE
   ret