diff --git a/R/screen.R b/R/screen.R
index 4ed4ee5b..029dd583 100644
--- a/R/screen.R
+++ b/R/screen.R
@@ -64,42 +64,18 @@ to_screen <- function(ht,
all_colnames <- colnames(ht)
last_ht_col <- orig_ncol <- ncol(ht)
if (ncol(ht) > 0 && nrow(ht) > 0) {
- charmat_data <- character_matrix(ht,
+ cm <- character_matrix(ht,
inner_border_h = 3, outer_border_h = 2, inner_border_v = 1, outer_border_v = 1,
min_width = min_width, max_width = max_width, color = color, markdown = FALSE
)
- charmat <- charmat_data$charmat
- border_rows <- charmat_data$border_rows
- border_cols <- charmat_data$border_cols
- last_ht_col <- charmat_data$last_ht_col
- width_mat <- charmat_data$width_mat
+ border_rows <- cm$border_rows
+ border_cols <- cm$border_cols
+ last_ht_col <- cm$last_ht_col
+ width_mat <- cm$width_mat
ht <- ht[, seq_len(last_ht_col)]
border_cols[-1] <- border_cols[-1] + 1 # middle of 3 for interior, last of 2 for last outer
- borders <- get_visible_borders(ht)
- border_mat <- matrix(1L, nrow = nrow(charmat), ncol = ncol(charmat))
- # converts a row/col number to a sequence of charmat row/col numbers for the relevant *column/row*
- index_rows <- lapply(seq_len(nrow(ht)), function(x) seq(border_rows[x], border_rows[x + 1] - 1))
- index_cols <- lapply(seq_len(ncol(ht)), function(x) seq(border_cols[x], border_cols[x + 1] - 1))
- # borders$vert is row, col+1; $horiz is row+1, col
- for (i in seq_len(nrow(ht) + 1)) {
- for (j in seq_len(ncol(ht) + 1)) {
- if (i <= nrow(ht)) {
- ir <- index_rows[[i]]
- # 1: has a line above:
- border_mat[ir, border_cols[j]] <- border_mat[ir, border_cols[j]] + 1L * (borders$vert[i, j] > 0)
- # 2: has a line below:
- border_mat[ir + 1, border_cols[j]] <- border_mat[ir + 1, border_cols[j]] + 2L * (borders$vert[i, j] > 0)
- }
- if (j <= ncol(ht)) {
- ic <- index_cols[[j]]
- # 4: a line on right:
- border_mat[border_rows[i], ic] <- border_mat[border_rows[i], ic] + 4L * (borders$horiz[i, j] > 0)
- # 8: a line on left:
- border_mat[border_rows[i], ic + 1] <- border_mat[border_rows[i], ic + 1] + 8L * (borders$horiz[i, j] > 0)
- }
- }
- }
+ border_mat <- build_border_mat(ht, cm)
pipe_chars <- c(
NA,
@@ -109,47 +85,22 @@ to_screen <- function(ht,
"\u252c", "\u2534", "\u253c"
)
border_mat[] <- pipe_chars[border_mat]
- charmat[!is.na(border_mat)] <- border_mat[!is.na(border_mat)]
+ cm$charmat[!is.na(border_mat)] <- border_mat[!is.na(border_mat)]
if (color) {
- bcolors <- collapsed_border_colors(ht)
- unique_cols <- unique(na.omit(unlist(bcolors)))
- col_funs <- lapply(unique_cols, crayon::make_style)
- names(col_funs) <- unique_cols
- for (i in seq_len(nrow(ht) + 1)) {
- for (j in seq_len(ncol(ht) + 1)) {
- if (i <= nrow(ht)) {
- # colour vertical borders:
- ir <- index_rows[[i]]
- color_fun <- col_funs[[bcolors$vert[i, j]]]
- if (!is.na(bcolors$vert[i, j])) charmat[ir, border_cols[j]] <- color_fun(charmat[ir, border_cols[j]])
- }
- if (j <= ncol(ht)) {
- # horizontal borders:
- ic <- c(index_cols[[j]], max(index_cols[[j]]) + 1) # rows extend a little bit to cover ends
- color_fun <- col_funs[[bcolors$horiz[i, j]]]
- if (!is.na(bcolors$horiz[i, j])) charmat[border_rows[i], ic] <- color_fun(charmat[border_rows[i], ic])
- }
- }
- }
+ cm$charmat <- colorize_borders(ht, cm)
}
if (compact) {
- empty_borders <- apply(charmat, 1, function(x) {
- all(grepl(" ", x, fixed = TRUE) | grepl("\u2502", x, fixed = TRUE))
- })
- empty_borders <- intersect(border_rows, which(empty_borders))
- # length statement necessary otherwise we end up doing charmat[ - integer(0), ] and getting nothing
- if (length(empty_borders) > 0) {
- charmat <- charmat[-empty_borders, , drop = FALSE]
- }
+ cm <- drop_empty_border_lines(cm)
}
+ charmat <- cm$charmat
result <- apply(charmat, 1, paste0, collapse = "")
# we can't use conventional string padding because of colour strings
# instead this horrible hack uses the uncoloured widths, and adds 1 for
# any borders we find.
- width_mat <- pmax(width_mat, 1)
+ width_mat <- pmax(cm$width_mat, 1)
width_mat[charmat == ""] <- 0
row_char_widths <- rowSums(width_mat)
pad_width <- min(max_width, getOption("width", 80))
@@ -207,8 +158,122 @@ to_screen <- function(ht,
}
-# calculate text column widths, wrap huxtable text accordingly, and return a
-# matrix of characters, without borders
+#' Build a border matrix for on-screen tables
+#'
+#' Computes an integer matrix encoding border positions using the visible
+#' borders and mappings from table rows and columns to character matrix
+#' positions.
+#'
+#' @param ht A huxtable.
+#' @param cm List returned by `character_matrix`.
+#' @noRd
+build_border_mat <- function(ht, cm) {
+ border_rows <- cm$border_rows
+ border_cols <- cm$border_cols
+ charmat <- cm$charmat
+ borders <- get_visible_borders(ht)
+ index_rows <- lapply(seq_len(nrow(ht)), function(x) seq(border_rows[x], border_rows[x + 1] - 1))
+ index_cols <- lapply(seq_len(ncol(ht)), function(x) seq(border_cols[x], border_cols[x + 1] - 1))
+ border_mat <- matrix(1L, nrow = nrow(charmat), ncol = ncol(charmat))
+ for (i in seq_len(nrow(ht) + 1)) {
+ for (j in seq_len(ncol(ht) + 1)) {
+ if (i <= nrow(ht)) {
+ ir <- index_rows[[i]]
+ border_mat[ir, border_cols[j]] <- border_mat[ir, border_cols[j]] +
+ 1L * (borders$vert[i, j] > 0)
+ border_mat[ir + 1, border_cols[j]] <- border_mat[ir + 1, border_cols[j]] +
+ 2L * (borders$vert[i, j] > 0)
+ }
+ if (j <= ncol(ht)) {
+ ic <- index_cols[[j]]
+ border_mat[border_rows[i], ic] <- border_mat[border_rows[i], ic] +
+ 4L * (borders$horiz[i, j] > 0)
+ border_mat[border_rows[i], ic + 1] <- border_mat[border_rows[i], ic + 1] +
+ 8L * (borders$horiz[i, j] > 0)
+ }
+ }
+ }
+ border_mat
+}
+
+#' Colour table borders
+#'
+#' Apply colour styles to border characters in `charmat` based on collapsed
+#' border colours.
+#'
+#' @param ht A huxtable.
+#' @param cm List returned by `character_matrix` containing updated `charmat`.
+#' @noRd
+colorize_borders <- function(ht, cm) {
+ border_rows <- cm$border_rows
+ border_cols <- cm$border_cols
+ charmat <- cm$charmat
+ bcolors <- collapsed_border_colors(ht)
+ index_rows <- lapply(seq_len(nrow(ht)), function(x) seq(border_rows[x], border_rows[x + 1] - 1))
+ index_cols <- lapply(seq_len(ncol(ht)), function(x) seq(border_cols[x], border_cols[x + 1] - 1))
+ unique_cols <- unique(na.omit(unlist(bcolors)))
+ col_funs <- lapply(unique_cols, crayon::make_style)
+ names(col_funs) <- unique_cols
+ for (i in seq_len(nrow(ht) + 1)) {
+ for (j in seq_len(ncol(ht) + 1)) {
+ if (i <= nrow(ht)) {
+ ir <- index_rows[[i]]
+ color_fun <- col_funs[[bcolors$vert[i, j]]]
+ if (!is.na(bcolors$vert[i, j])) {
+ charmat[ir, border_cols[j]] <- color_fun(charmat[ir, border_cols[j]])
+ }
+ }
+ if (j <= ncol(ht)) {
+ ic <- c(index_cols[[j]], max(index_cols[[j]]) + 1)
+ color_fun <- col_funs[[bcolors$horiz[i, j]]]
+ if (!is.na(bcolors$horiz[i, j])) {
+ charmat[border_rows[i], ic] <- color_fun(charmat[border_rows[i], ic])
+ }
+ }
+ }
+ }
+ charmat
+}
+
+#' Remove empty horizontal border rows
+#'
+#' Drop rows from the character matrix that contain no visible border
+#' characters, updating the corresponding width matrix.
+#'
+#' @param cm List returned by `character_matrix`.
+#' @return Modified list with updated `charmat` and `width_mat`.
+#' @noRd
+drop_empty_border_lines <- function(cm) {
+ charmat <- cm$charmat
+ empty_borders <- apply(charmat, 1, function(x) {
+ all(grepl(" ", x, fixed = TRUE) | grepl("\u2502", x, fixed = TRUE))
+ })
+ empty_borders <- intersect(cm$border_rows, which(empty_borders))
+ if (length(empty_borders) > 0) {
+ cm$charmat <- charmat[-empty_borders, , drop = FALSE]
+ cm$width_mat <- cm$width_mat[-empty_borders, , drop = FALSE]
+ }
+ cm
+}
+
+#' Build a character matrix for on-screen or markdown output
+#'
+#' Determines column and row sizes, wraps cell contents and returns a matrix of
+#' characters representing the table without borders. Used internally by
+#' `to_screen`.
+#'
+#' @param ht A huxtable.
+#' @param inner_border_h Width of inner horizontal borders.
+#' @param inner_border_v Height of inner vertical borders.
+#' @param outer_border_h Width of outer horizontal borders.
+#' @param outer_border_v Height of outer vertical borders.
+#' @param min_width Minimum allowed width in characters.
+#' @param max_width Maximum allowed width in characters.
+#' @param color Logical. Apply cell colouring styles.
+#' @param markdown Logical. Include markdown formatting markers.
+#' @return A list with the character matrix, width matrix, border positions and
+#' number of displayed columns.
+#' @noRd
character_matrix <- function(ht,
inner_border_h,
inner_border_v,
@@ -220,16 +285,19 @@ character_matrix <- function(ht,
markdown) {
if (ncol(ht) == 0) stop("Couldn't display any columns in less than max_width characters.")
+ # Work with display cells so that merged cells are expanded appropriately
dc <- display_cells(ht, all = FALSE)
dc <- dc[order(dc$colspan), ]
contents <- clean_contents(ht, output_type = if (markdown) "markdown" else "screen")
drow_mat <- as.matrix(dc[, c("display_row", "display_col")])
+ # Attach the cell contents to the display cell data frame
dc$contents <- contents[drow_mat]
cw <- col_width(ht)
if (!is.numeric(cw) || anyNA(cw)) cw <- rep(1, ncol(ht))
cw <- cw / sum(cw)
+ # Start with minimum column widths based on overall table width
min_widths <- ceiling(min_width * cw)
widths <- min_widths
@@ -244,11 +312,13 @@ character_matrix <- function(ht,
###########################################
# calculate widths to make room for content
for (r in seq_len(nrow(dc))) {
+ # choose either longest word or full content depending on wrap()
width <- if (wrap(ht)[dc$display_row[r], dc$display_col[r]]) {
max_word_widths[r]
} else {
content_widths[r]
}
+ # markdown markup adds characters
if (markdown && bold(ht)[dc$display_row[r], dc$display_col[r]]) {
width <- width + 4
}
@@ -256,7 +326,7 @@ character_matrix <- function(ht,
width <- width + 2
}
cols <- seq(dc$display_col[r], dc$end_col[r])
- # allows for width of interior borders if a cell spans multiple columns
+ # allow for interior borders when a cell spans multiple columns
if (sum(widths[cols]) + inner_border_h * (dc$colspan[r] - 1) < width) {
widths[cols] <- pmax(widths[cols], ceiling(width / dc$colspan[r]))
}
diff --git a/man/huxtable-news.Rd b/man/huxtable-news.Rd
index b068d929..7d16d576 100644
--- a/man/huxtable-news.Rd
+++ b/man/huxtable-news.Rd
@@ -20,11 +20,11 @@ object. AFAIK nobody has ever done this; if I’m wrong, please tell me.
\itemize{
\item HTML tables now wrap header rows in \verb{} (using \verb{} cells) and
body rows in \verb{