239 lines
8.2 KiB
R
239 lines
8.2 KiB
R
## ----include = FALSE----------------------------------------------------------
|
|
knitr::opts_chunk$set(
|
|
collapse = TRUE,
|
|
eval = rlang::is_installed("tibble"),
|
|
comment = "#>"
|
|
)
|
|
|
|
pillar:::set_show_source_hooks()
|
|
|
|
## ----setup--------------------------------------------------------------------
|
|
library(pillar)
|
|
|
|
## ----echo = FALSE, error = TRUE-----------------------------------------------
|
|
try({
|
|
text <- paste(
|
|
readLines("format.mmd"),
|
|
collapse = "\n"
|
|
)
|
|
DiagrammeR::mermaid(text)
|
|
})
|
|
|
|
## -----------------------------------------------------------------------------
|
|
tbl <- tibble::tibble(a = 1:3, b = tibble::tibble(c = 4:6, d = 7:9), e = 10:12)
|
|
print(tbl, width = 23)
|
|
str(tbl)
|
|
|
|
## ----show_source = TRUE-------------------------------------------------------
|
|
# print.tbl <- function (x, width = NULL, ..., n = NULL, max_extra_cols = NULL,
|
|
# max_footer_lines = NULL)
|
|
# {
|
|
# print_tbl(x, width, ..., n = n, max_extra_cols = max_extra_cols,
|
|
# max_footer_lines = max_footer_lines)
|
|
# }
|
|
|
|
## ----show_source = TRUE-------------------------------------------------------
|
|
# format.tbl <- function (x, width = NULL, ..., n = NULL, max_extra_cols = NULL,
|
|
# max_footer_lines = NULL)
|
|
# {
|
|
# format_tbl(x, width, ..., n = n, max_extra_cols = max_extra_cols,
|
|
# max_footer_lines = max_footer_lines)
|
|
# }
|
|
|
|
## -----------------------------------------------------------------------------
|
|
setup <- tbl_format_setup(tbl, width = 24)
|
|
setup
|
|
|
|
## ----show_source = TRUE-------------------------------------------------------
|
|
# tbl_format_setup <- function (x, width = NULL, ..., setup = list(tbl_sum = tbl_sum(x)),
|
|
# n = NULL, max_extra_cols = NULL, max_footer_lines = NULL,
|
|
# focus = NULL)
|
|
# {
|
|
# "!!!!DEBUG tbl_format_setup()"
|
|
# width <- get_width_print(width)
|
|
# n <- get_n_print(n, tbl_nrow(x))
|
|
# max_extra_cols <- get_max_extra_cols(max_extra_cols)
|
|
# max_footer_lines <- get_max_footer_lines(max_footer_lines)
|
|
# out <- tbl_format_setup_dispatch(x, width, ..., setup = setup,
|
|
# n = n, max_extra_cols = max_extra_cols, max_footer_lines = max_footer_lines,
|
|
# focus = focus)
|
|
# return(out)
|
|
# UseMethod("tbl_format_setup")
|
|
# }
|
|
|
|
## ----show_source = TRUE-------------------------------------------------------
|
|
# tbl_format_setup.tbl <- function (x, width, ..., setup, n, max_extra_cols, max_footer_lines,
|
|
# focus)
|
|
# {
|
|
# "!!!!DEBUG tbl_format_setup.tbl()"
|
|
# if (is.null(setup)) {
|
|
# tbl_sum <- tbl_sum(x)
|
|
# return(new_tbl_format_setup(width, tbl_sum, rows_total = NA))
|
|
# }
|
|
# else {
|
|
# tbl_sum <- setup$tbl_sum
|
|
# }
|
|
# rows <- tbl_nrow(x)
|
|
# lazy <- is.na(rows)
|
|
# if (lazy) {
|
|
# df <- as.data.frame(head(x, n + 1))
|
|
# if (nrow(df) <= n) {
|
|
# rows <- nrow(df)
|
|
# }
|
|
# else {
|
|
# df <- vec_head(df, n)
|
|
# }
|
|
# }
|
|
# else {
|
|
# df <- df_head(x, n)
|
|
# }
|
|
# if (is.na(rows)) {
|
|
# needs_dots <- (nrow(df) >= n)
|
|
# }
|
|
# else {
|
|
# needs_dots <- (rows > n)
|
|
# }
|
|
# if (needs_dots) {
|
|
# rows_missing <- rows - n
|
|
# }
|
|
# else {
|
|
# rows_missing <- 0
|
|
# }
|
|
# rownames(df) <- NULL
|
|
# colonnade <- ctl_colonnade(df, has_row_id = if (!lazy &&
|
|
# .row_names_info(x) > 0)
|
|
# "*"
|
|
# else TRUE, width = width, controller = x, focus = focus)
|
|
# body <- colonnade$body
|
|
# extra_cols <- colonnade$extra_cols
|
|
# extra_cols_total <- length(extra_cols)
|
|
# if (extra_cols_total > max_extra_cols) {
|
|
# length(extra_cols) <- max_extra_cols
|
|
# }
|
|
# abbrev_cols <- colonnade$abbrev_cols
|
|
# new_tbl_format_setup(x = x, df = df, width = width, tbl_sum = tbl_sum,
|
|
# body = body, rows_missing = rows_missing, rows_total = rows,
|
|
# extra_cols = extra_cols, extra_cols_total = extra_cols_total,
|
|
# max_footer_lines = max_footer_lines, abbrev_cols = abbrev_cols)
|
|
# }
|
|
|
|
## -----------------------------------------------------------------------------
|
|
tbl_format_header(tbl, setup)
|
|
tbl_format_body(tbl, setup)
|
|
tbl_format_footer(tbl, setup)
|
|
|
|
## -----------------------------------------------------------------------------
|
|
class(tbl_format_body(tbl, setup))
|
|
typeof(tbl_format_body(tbl, setup))
|
|
|
|
## ----show_source = TRUE-------------------------------------------------------
|
|
# tbl_format_header.tbl <- function (x, setup, ...)
|
|
# {
|
|
# named_header <- setup$tbl_sum
|
|
# focus <- attr(x, "pillar_focus")
|
|
# if (!is.null(focus)) {
|
|
# named_header <- c(named_header, `Focus columns` = collapse(tick_if_needed(focus)))
|
|
# }
|
|
# if (all(names2(named_header) == "")) {
|
|
# header <- named_header
|
|
# }
|
|
# else {
|
|
# header <- paste0(align(paste0(names2(named_header), ":"),
|
|
# space = NBSP), " ", named_header)
|
|
# }
|
|
# style_subtle(format_comment(header, width = setup$width))
|
|
# }
|
|
|
|
## ----show_source = TRUE-------------------------------------------------------
|
|
# tbl_format_body.tbl <- function (x, setup, ...)
|
|
# {
|
|
# force(setup)
|
|
# setup$body
|
|
# }
|
|
|
|
## ----show_source = TRUE-------------------------------------------------------
|
|
# tbl_format_footer.tbl <- function (x, setup, ...)
|
|
# {
|
|
# footer <- format_footer(x, setup)
|
|
# footer_comment <- wrap_footer_bullet(footer, setup)
|
|
# footer_advice <- format_footer_advice(x, setup)
|
|
# footer_advice_comment <- wrap_footer_bullet(footer_advice,
|
|
# setup, lines = 1, ellipsis = FALSE, bullet = symbol$info)
|
|
# style_subtle(c(footer_comment, footer_advice_comment))
|
|
# }
|
|
|
|
## -----------------------------------------------------------------------------
|
|
ctl_new_pillar_list(tbl, tbl$a, width = 20)
|
|
ctl_new_pillar_list(tbl, tbl$b, width = 20)
|
|
|
|
## ----show_source = TRUE-------------------------------------------------------
|
|
# 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) && !inherits(x, c("Surv", "Surv2"))) {
|
|
# new_matrix_pillar_list(x, controller, width, title = title,
|
|
# first_pillar = first_pillar)
|
|
# }
|
|
# else if (is.array(x) && length(dim(x)) > 2) {
|
|
# new_array_pillar_list(x, controller, width, title = title,
|
|
# first_pillar = first_pillar)
|
|
# }
|
|
# else {
|
|
# if (is.null(first_pillar)) {
|
|
# first_pillar <- ctl_new_pillar(controller, x, width,
|
|
# ..., title = prepare_title(title))
|
|
# }
|
|
# new_single_pillar_list(first_pillar, width)
|
|
# }
|
|
# }
|
|
|
|
## -----------------------------------------------------------------------------
|
|
ctl_new_pillar(tbl, tbl$a, width = 20)
|
|
|
|
## ----show_source = TRUE-------------------------------------------------------
|
|
# ctl_new_pillar.tbl <- function (controller, x, width, ..., title = NULL)
|
|
# {
|
|
# "!!!!DEBUG ctl_new_pillar.tbl(`v(width)`, `v(title)`)"
|
|
# pillar(x, title, if (!is.null(width))
|
|
# max0(width))
|
|
# }
|
|
|
|
## ----show_source = TRUE-------------------------------------------------------
|
|
# pillar <- function (x, title = NULL, width = NULL, ...)
|
|
# {
|
|
# "!!!!DEBUG pillar(`v(class(x))`, `v(title)`, `v(width)`)"
|
|
# pillar_from_shaft(new_pillar_title(title), new_pillar_type(x),
|
|
# pillar_shaft(x, ...), width)
|
|
# }
|
|
|
|
## ----show_source = TRUE-------------------------------------------------------
|
|
# new_pillar <- function (components, ..., width = NULL, class = NULL, extra = deprecated())
|
|
# {
|
|
# "!!!!DEBUG new_pillar(`v(width)`, `v(class)`)"
|
|
# if (is_present(extra)) {
|
|
# deprecate_warn("1.7.0", "pillar::new_pillar(extra = )")
|
|
# }
|
|
# check_dots_empty()
|
|
# if (length(components) > 0 && !is_named(components)) {
|
|
# abort("All components must have names.")
|
|
# }
|
|
# structure(components, width = width, class = c(class, "pillar"))
|
|
# }
|
|
|
|
## ----show_source = TRUE-------------------------------------------------------
|
|
# format.pillar <- function (x, width = NULL, ...)
|
|
# {
|
|
# if (is.null(width)) {
|
|
# width <- get_width(x)
|
|
# }
|
|
# if (is.null(width)) {
|
|
# width <- pillar_get_width(x)
|
|
# }
|
|
# as_glue(pillar_format_parts_2(x, width)$aligned)
|
|
# }
|
|
|