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{} when header rows are at the top of the table. -\item HTML output now uses CSS classes with a shared \verb{