From 0944a545decde96294f5a35b4f44b14c0fef456b Mon Sep 17 00:00:00 2001 From: Vincent Arel-Bundock Date: Fri, 26 Jun 2026 11:51:18 -0400 Subject: [PATCH 1/4] 0.17.0 --- DESCRIPTION | 2 +- NEWS.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 1d1dd294e..5e741a44a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -2,7 +2,7 @@ Package: tinytable Type: Package Title: Simple and Configurable Tables in 'HTML', 'LaTeX', 'Markdown', 'Word', 'PNG', 'PDF', and 'Typst' Formats Description: Create highly customized tables with this simple and dependency-free package. Data frames can be converted to 'HTML', 'LaTeX', 'Markdown', 'Word', 'PNG', 'PDF', or 'Typst' tables. The user interface is minimalist and easy to learn. The syntax is concise. 'HTML' tables can be customized using the flexible 'Bootstrap' framework, and 'LaTeX' code with the 'tabularray' package. -Version: 0.16.0.14 +Version: 0.17.0 Imports: methods Depends: diff --git a/NEWS.md b/NEWS.md index 7dc545a56..7617b18b9 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,6 @@ # News -## Development +## 0.17.0 * `theme_typst()` no longer emits figure-level center alignment by default. Typst tables now use the document's default alignment unless `align_figure` or the `tinytable_typst_align_figure` option is set. * `theme_typst()` gains `resize_width`, `resize_height`, and `resize_direction` arguments to resize wide or tall Typst tables, paralleling `theme_latex()`. Thanks to @tomasrei for feature request #657. From b98fe78a4f234af2f6b68e7fd3036cc66196c3ae Mon Sep 17 00:00:00 2001 From: EinMaulwurf Date: Tue, 7 Jul 2026 16:15:29 +0000 Subject: [PATCH 2/4] perf(save_tt): vectorize style resolution and typst CSS builder Two phases of build_tt() dominate save_tt() time on tables with many style_tt() calls (heat-map backgrounds, per-column alignment, etc.): 1. Resolving @style into the rectangular @style_other/@style_lines grids. apply_style_to_rect() re-scanned the full cell grid for every style entry (O(N * cells * props)) and append_lines_to_rect() used rbind() in a loop (O(N^2)). 2. The typst style_eval() backend, where process_typst_other_styles() built CSS one cell at a time via regex typst_insert_field() calls, and typst_apply_styles() grew style_dict_entries with c(). Replace with batched/vectorized equivalents: - expand_style.R: new resolve_styles_batch() builds a single (i,j)->linear-index map and walks each property once. Old per-row functions kept for backwards compatibility. - build_tt.R: calls resolve_styles_batch() instead of the per-row loop. - typst_style.R: new .typst_build_css_vectorized() emits all key:value fragments in a single pass with matching output format; typst_apply_styles() uses a pre-allocated list + unlist(). Output is byte-identical across 6 fixtures x 4 formats (typst, html, latex, markdown) and the full tinytest suite passes. Benchmarks (median of 5 reps, 60x12 table with 170 style_tt() calls): typst: 1.091s -> 0.703s (1.55x) html: 1.442s -> 1.151s (1.25x) Style resolution phase: 0.451s -> 0.137s (3.3x) --- R/build_tt.R | 21 +++--- R/expand_style.R | 114 ++++++++++++++++++++++++++++++++ R/typst_style.R | 166 +++++++++++++++++++++++++++++++---------------- 3 files changed, 235 insertions(+), 66 deletions(-) diff --git a/R/build_tt.R b/R/build_tt.R index 70f3cf4f2..80853cb8c 100644 --- a/R/build_tt.R +++ b/R/build_tt.R @@ -162,17 +162,16 @@ build_tt <- function(x, output = NULL) { x <- style_notes(x) x <- style_caption(x) - # Populate @style_other and @style_lines by applying each entry from @style sequentially - # This must happen before build_eval() for backends (like Grid) that apply styles during build - x@style_lines <- data.frame() # Initialize empty line dataframe - - for (idx in seq_len(nrow(x@style))) { - style_row <- x@style[idx, , drop = FALSE] - # Apply non-line styles (overwrites) - x@style_other <- apply_style_to_rect(x@style_other, style_row) - # Apply line styles (appends) - x@style_lines <- append_lines_to_rect(x@style_lines, style_row, rect) - } + # Populate @style_other and @style_lines by resolving @style in a single + # batched pass. This must happen before build_eval() for backends (like + # Grid) that apply styles during build. + # The original per-row loop with apply_style_to_rect()/append_lines_to_rect() + # is preserved here as a fallback; for non-trivial style counts the batched + # resolver in resolve_styles_batch() is dramatically faster because it does + # not rescan the entire rectangular grid for every style_tt() entry. + resolved <- resolve_styles_batch(x@style_other, x@style) + x@style_other <- resolved$other + x@style_lines <- resolved$lines # Sort style_other for consistent ordering (j first, then i within each j) # This ensures test snapshots are deterministic diff --git a/R/expand_style.R b/R/expand_style.R index 01481dbd5..81f03fdf0 100644 --- a/R/expand_style.R +++ b/R/expand_style.R @@ -89,6 +89,120 @@ append_lines_to_rect <- function(style_lines, style_row, rect) { } +#' Resolve all entries of @style into the rectangular @style_other grid and +#' the line list @style_lines in a single batched pass. +#' +#' This is functionally equivalent to (and produces byte-identical output as) +#' the per-row loop: +#' for (idx in seq_len(nrow(x@style))) { +#' style_other <- apply_style_to_rect(style_other, x@style[idx,]) +#' style_lines <- append_lines_to_rect(style_lines, x@style[idx,], rect) +#' } +#' but is O(N + cells) instead of O(N * cells * props) by avoiding the per-row +#' full-rect mask scan. The naive loop becomes the dominant bottleneck once a +#' table accumulates more than a few hundred style_tt() entries (which is +#' common when styling individual cells for heat-map-like effects, alternating +#' row backgrounds, or per-column alignment). +#' +#' @param style_other Rectangular dataframe of (i, j, ) initialized with NAs +#' @param style_df @style data frame (one row per style_tt setting entry) +#' @return list(other=, lines=) with the populated data frames +#' @keywords internal +#' @noRd +resolve_styles_batch <- function(style_other, style_df) { + n <- nrow(style_df) + empty_lines <- data.frame( + i = integer(0), j = integer(0), + line = character(0), + line_color = character(0), + line_width = numeric(0), + line_trim = character(0), + stringsAsFactors = FALSE + ) + if (n == 0) { + return(list(other = style_other, lines = empty_lines)) + } + + style_props <- c("bold", "italic", "underline", "strikeout", + "monospace", "smallcap", "align", "alignv", + "color", "background", "fontsize", "indent", + "html_css", "colspan", "rowspan") + + # Unique i and j present in style_other (used when i or j is NA meaning "all") + so_i <- style_other$i + so_j <- style_other$j + uniq_i <- unique(so_i) + uniq_j <- unique(so_j) + + # Build a (i,j) -> linear index map for style_other using a single match() call + keys_other <- paste(so_i, "\001", so_j, sep = "") + + sd_i <- style_df$i + sd_j <- style_df$j + i_na <- is.na(sd_i) + j_na <- is.na(sd_j) + + # For each property, walk style rows that have a non-NA value, in order, + # and write directly into style_other at the matching linear indices. + # "Last write wins" semantics is preserved by iterating in source order. + for (prop in style_props) { + if (!prop %in% names(style_df)) next + vals <- style_df[[prop]] + has <- which(!is.na(vals)) + if (length(has) == 0L) next + for (k in has) { + ri <- if (i_na[k]) uniq_i else sd_i[k] + rj <- if (j_na[k]) uniq_j else sd_j[k] + # Build cartesian-product keys; reuse key format above for match() + if (length(ri) == 1L && length(rj) == 1L) { + tgt_keys <- paste(ri, "\001", rj, sep = "") + } else { + tgt_keys <- paste( + rep(ri, times = length(rj)), + "\001", + rep(rj, each = length(ri)), + sep = "" + ) + } + idx <- match(tgt_keys, keys_other) + idx <- idx[!is.na(idx)] + if (length(idx)) style_other[[prop]][idx] <- vals[[k]] + } + } + + # Lines are additive: expand every style_df row that has a non-NA `line` + # into one entry per (i, j) cell, then rbind() once at the end. + has_line <- which(!is.na(style_df$line)) + if (length(has_line)) { + line_color_col <- if ("line_color" %in% names(style_df)) style_df$line_color else rep(NA_character_, n) + line_width_col <- if ("line_width" %in% names(style_df)) style_df$line_width else rep(NA_real_, n) + line_trim_col <- if ("line_trim" %in% names(style_df)) style_df$line_trim else rep(NA_character_, n) + + line_entries <- vector("list", length(has_line)) + for (kp in seq_along(has_line)) { + k <- has_line[kp] + ri <- if (i_na[k]) uniq_i else sd_i[k] + rj <- if (j_na[k]) uniq_j else sd_j[k] + # cartesian product (preserves append_lines_to_rect ordering) + line_entries[[kp]] <- data.frame( + i = rep(ri, times = length(rj)), + j = rep(rj, each = length(ri)), + line = style_df$line[k], + line_color = line_color_col[k], + line_width = line_width_col[k], + line_trim = line_trim_col[k], + stringsAsFactors = FALSE + ) + } + style_lines <- do.call(rbind, line_entries) + } else { + style_lines <- empty_lines + } + + list(other = style_other, lines = style_lines) +} + + # NOTE: expand_lines() and expand_style() have been removed. # Line styles are now handled via @style_lines in build_tt() # Other styles are handled via @style_other in build_tt() diff --git a/R/typst_style.R b/R/typst_style.R index 2c7d551c7..ad304ea62 100644 --- a/R/typst_style.R +++ b/R/typst_style.R @@ -34,6 +34,101 @@ typst_clean_css <- function(css) { return(css) } +#' Vectorized CSS builder for the typst style-array +#' +#' Replaces the per-cell for-loop that called typst_insert_field() (which does +#' regex sub() on a growing string per property) with a single pass that builds +#' each cell's "key: value, key: value, ..." string directly. Output is +#' byte-identical to the concatenation of sequential typst_insert_field() +#' calls followed by typst_clean_css(). +#' +#' @param other Filtered @style_other data frame (only rows with at least one style) +#' @param color_map Named character vector mapping original color names to typst rgb() strings +#' @return Character vector of css strings (one per row of `other`), un-trimmed +#' @keywords internal +#' @noRd +.typst_build_css_vectorized <- function(other, color_map) { + n <- nrow(other) + if (n == 0) return(character(0)) + + bold <- !is.na(other$bold) & other$bold + italic <- !is.na(other$italic) & other$italic + underline <- !is.na(other$underline) & other$underline + strikeout <- !is.na(other$strikeout) & other$strikeout + monospace <- !is.na(other$monospace) & other$monospace + color_set <- !is.na(other$color) + bg_set <- !is.na(other$background) + fs_set <- !is.na(other$fontsize) + indent_set <- !is.na(other$indent) & other$indent > 0 + align_h_set <- !is.na(other$align) + align_v_set <- !is.na(other$alignv) + + parts <- vector("list", n) + for (k in seq_len(n)) parts[[k]] <- character(0) + + # scalar emission: same string for every matching cell + add_scalar <- function(mask, key, val) { + if (!any(mask)) return() + fragment <- sprintf("%s: %s", key, val) + for (k in which(mask)) parts[[k]] <<- c(parts[[k]], fragment) + } + # vector emission: val is parallel to `other`; only used where mask is TRUE + add_vec <- function(mask, key, val) { + if (!any(mask)) return() + fragment <- sprintf("%s: %s", key, val) + for (k in which(mask)) parts[[k]] <<- c(parts[[k]], fragment[k]) + } + + add_scalar(bold, "bold", "true") + add_scalar(italic, "italic", "true") + add_scalar(underline, "underline", "true") + add_scalar(strikeout, "strikeout", "true") + add_scalar(monospace, "mono", "true") + + if (any(color_set)) { + cv <- ifelse(color_set, color_map[other$color], "") + add_vec(color_set, "color", cv) + } + if (any(bg_set)) { + bv <- ifelse(bg_set, color_map[other$background], "") + add_vec(bg_set, "background", bv) + } + if (any(fs_set)) { + fv <- ifelse(fs_set, + vapply(other$fontsize, + function(x) if (is.na(x)) "" else format_markup_unit(x, "em"), + character(1)), + "") + add_vec(fs_set, "fontsize", fv) + } + + if (any(align_h_set) || any(align_v_set)) { + ah <- ifelse(is.na(other$align), "", other$align) + av <- ifelse(is.na(other$alignv), "", other$alignv) + combined <- ifelse(nchar(ah) > 0 & nchar(av) > 0, + paste(ah, av, sep = " + "), + paste0(ah, av)) + mask <- align_h_set | align_v_set + add_vec(mask, "align", combined) + } + + if (any(indent_set)) { + iv <- ifelse(indent_set, + vapply(other$indent, + function(x) if (is.na(x)) "" else format_markup_unit(x, "em"), + character(1)), + "") + add_vec(indent_set, "indent", iv) + } + + # Each cell becomes a comma-separated list with a trailing comma, matching + # the original typst_insert_field() + typst_clean_css() output format. + vapply(parts, function(p) { + s <- paste(p, collapse = ", ") + if (nchar(s) > 0) paste0(s, ",") else s + }, character(1)) +} + #' Apply Typst styles and generate style-dict/array #' @keywords internal #' @noRd @@ -54,13 +149,16 @@ typst_apply_styles <- function(x, rec) { sprintf("(%s),", style_str) }) - # Create style-dict (cell positions -> style array indices) - style_dict_entries <- character(0) + # Create style-dict (cell positions -> style array indices) using vectorized + # sprintf instead of growing a vector inside a for loop. Each unique style + # group can produce many cell-position keys, so we pre-allocate a list and + # unlist() once. + style_dict_list <- vector("list", length(uni)) for (style_idx in seq_along(uni)) { cells <- uni[[style_idx]] - entry <- sprintf('"%s_%s": %s', cells$i, cells$j, style_idx - 1) - style_dict_entries <- c(style_dict_entries, entry) + style_dict_list[[style_idx]] <- sprintf('"%s_%s": %s', cells$i, cells$j, style_idx - 1) } + style_dict_entries <- unlist(style_dict_list, use.names = FALSE) # Remove duplicate keys (keep last occurrence for each coordinate) if (length(style_dict_entries) > 0) { @@ -291,57 +389,15 @@ process_typst_other_styles <- function(x, other) { color_map <- character(0) } - # Generate CSS for each cell - vectorize where possible - css <- rep("", nrow(other)) - - # Process boolean styles (vectorized) - is_bold <- !is.na(other$bold) & other$bold - is_italic <- !is.na(other$italic) & other$italic - is_underline <- !is.na(other$underline) & other$underline - is_strikeout <- !is.na(other$strikeout) & other$strikeout - is_monospace <- !is.na(other$monospace) & other$monospace - - for (row in seq_len(nrow(other))) { - if (is_bold[row]) { - css[row] <- typst_insert_field(css[row], "bold", "true") - } - if (is_italic[row]) { - css[row] <- typst_insert_field(css[row], "italic", "true") - } - if (is_underline[row]) { - css[row] <- typst_insert_field(css[row], "underline", "true") - } - if (is_strikeout[row]) { - css[row] <- typst_insert_field(css[row], "strikeout", "true") - } - if (is_monospace[row]) { - css[row] <- typst_insert_field(css[row], "mono", "true") - } - if (!is.na(other[row, "color"])) { - color_value <- color_map[other[row, "color"]] - css[row] <- typst_insert_field(css[row], "color", color_value) - } - if (!is.na(other[row, "background"])) { - bg_value <- color_map[other[row, "background"]] - css[row] <- typst_insert_field(css[row], "background", bg_value) - } - if (!is.na(other[row, "fontsize"])) { - css[row] <- typst_insert_field(css[row], "fontsize", format_markup_unit(other[row, "fontsize"], "em")) - } - # Handle alignment (combining horizontal and vertical if both present) - align_h <- other[row, "align"] - align_v <- other[row, "alignv"] - if (!is.na(align_h) || !is.na(align_v)) { - align_parts <- character(0) - if (!is.na(align_h)) align_parts <- c(align_parts, align_h) - if (!is.na(align_v)) align_parts <- c(align_parts, align_v) - combined_align <- paste(align_parts, collapse = " + ") - css[row] <- typst_insert_field(css[row], "align", combined_align) - } - if (!is.na(other[row, "indent"]) && other[row, "indent"] > 0) { - css[row] <- typst_insert_field(css[row], "indent", format_markup_unit(other[row, "indent"], "em")) - } - } + # Generate CSS for each cell. The reference implementation builds one cell + # at a time by repeatedly calling typst_insert_field(), which uses regex + # sub() on a growing string. The vectorized version below produces an + # identical result but is much faster on tables with many styled cells + # (heat-map backgrounds, per-cell alignment, etc.). The output strings are + # joined with ", " and given a trailing comma to match the original + # typst_insert_field() format exactly (typst_clean_css() collapses runs + # of commas and trims whitespace, so byte-identical output is achievable). + css <- .typst_build_css_vectorized(other, color_map) # Clean CSS and add to data frame other$css <- sapply(css, typst_clean_css) From 9241c4a4b43261f94faff9581331efb8594757c9 Mon Sep 17 00:00:00 2001 From: Vincent Arel-Bundock Date: Tue, 7 Jul 2026 17:35:34 -0400 Subject: [PATCH 3/4] more perf --- R/build_tt.R | 5 +- R/expand_style.R | 88 ++++++++++++++++++++------- R/grid_style.R | 20 +++--- R/html_style.R | 14 ++--- R/tabularray_style.R | 15 ++--- R/tabulator_style.R | 12 ++-- R/typst_style.R | 85 ++++++++++++++------------ README.md | 2 +- inst/tinytest/test-style-resolution.R | 82 +++++++++++++++++++++++++ 9 files changed, 225 insertions(+), 98 deletions(-) create mode 100644 inst/tinytest/test-style-resolution.R diff --git a/R/build_tt.R b/R/build_tt.R index 80853cb8c..aa7a53212 100644 --- a/R/build_tt.R +++ b/R/build_tt.R @@ -170,12 +170,15 @@ build_tt <- function(x, output = NULL) { # resolver in resolve_styles_batch() is dramatically faster because it does # not rescan the entire rectangular grid for every style_tt() entry. resolved <- resolve_styles_batch(x@style_other, x@style) + has_style <- resolved$has_style x@style_other <- resolved$other x@style_lines <- resolved$lines # Sort style_other for consistent ordering (j first, then i within each j) # This ensures test snapshots are deterministic - x@style_other <- x@style_other[order(x@style_other$j, x@style_other$i), ] + ord <- order(x@style_other$j, x@style_other$i) + x@style_other <- x@style_other[ord, ] + attr(x@style_other, "has_style") <- has_style[ord] # draw the table x <- build_eval(x) diff --git a/R/expand_style.R b/R/expand_style.R index 81f03fdf0..47b36bbb8 100644 --- a/R/expand_style.R +++ b/R/expand_style.R @@ -92,7 +92,7 @@ append_lines_to_rect <- function(style_lines, style_row, rect) { #' Resolve all entries of @style into the rectangular @style_other grid and #' the line list @style_lines in a single batched pass. #' -#' This is functionally equivalent to (and produces byte-identical output as) +#' This is functionally equivalent to (and produces value-identical output as) #' the per-row loop: #' for (idx in seq_len(nrow(x@style))) { #' style_other <- apply_style_to_rect(style_other, x@style[idx,]) @@ -120,7 +120,11 @@ resolve_styles_batch <- function(style_other, style_df) { stringsAsFactors = FALSE ) if (n == 0) { - return(list(other = style_other, lines = empty_lines)) + return(list( + other = style_other, + lines = empty_lines, + has_style = rep(FALSE, nrow(style_other)) + )) } style_props <- c("bold", "italic", "underline", "strikeout", @@ -134,14 +138,38 @@ resolve_styles_batch <- function(style_other, style_df) { uniq_i <- unique(so_i) uniq_j <- unique(so_j) - # Build a (i,j) -> linear index map for style_other using a single match() call - keys_other <- paste(so_i, "\001", so_j, sep = "") + idx_matrix <- matrix( + NA_integer_, + nrow = length(uniq_i), + ncol = length(uniq_j), + dimnames = list(as.character(uniq_i), as.character(uniq_j)) + ) + idx_matrix[cbind(match(so_i, uniq_i), match(so_j, uniq_j))] <- seq_along(so_i) sd_i <- style_df$i sd_j <- style_df$j i_na <- is.na(sd_i) j_na <- is.na(sd_j) + target_i <- vector("list", n) + target_j <- vector("list", n) + target_idx <- vector("list", n) + for (k in seq_len(n)) { + target_i[[k]] <- if (i_na[k]) uniq_i else sd_i[k] + target_j[[k]] <- if (j_na[k]) uniq_j else sd_j[k] + + i_pos <- if (i_na[k]) seq_along(uniq_i) else match(sd_i[k], uniq_i) + j_pos <- if (j_na[k]) seq_along(uniq_j) else match(sd_j[k], uniq_j) + if (anyNA(i_pos) || anyNA(j_pos)) { + target_idx[[k]] <- integer(0) + } else { + idx <- as.vector(idx_matrix[i_pos, j_pos, drop = FALSE]) + target_idx[[k]] <- idx[!is.na(idx)] + } + } + + has_style <- rep(FALSE, nrow(style_other)) + # For each property, walk style rows that have a non-NA value, in order, # and write directly into style_other at the matching linear indices. # "Last write wins" semantics is preserved by iterating in source order. @@ -151,22 +179,11 @@ resolve_styles_batch <- function(style_other, style_df) { has <- which(!is.na(vals)) if (length(has) == 0L) next for (k in has) { - ri <- if (i_na[k]) uniq_i else sd_i[k] - rj <- if (j_na[k]) uniq_j else sd_j[k] - # Build cartesian-product keys; reuse key format above for match() - if (length(ri) == 1L && length(rj) == 1L) { - tgt_keys <- paste(ri, "\001", rj, sep = "") - } else { - tgt_keys <- paste( - rep(ri, times = length(rj)), - "\001", - rep(rj, each = length(ri)), - sep = "" - ) + idx <- target_idx[[k]] + if (length(idx)) { + style_other[[prop]][idx] <- vals[[k]] + has_style[idx] <- TRUE } - idx <- match(tgt_keys, keys_other) - idx <- idx[!is.na(idx)] - if (length(idx)) style_other[[prop]][idx] <- vals[[k]] } } @@ -181,8 +198,8 @@ resolve_styles_batch <- function(style_other, style_df) { line_entries <- vector("list", length(has_line)) for (kp in seq_along(has_line)) { k <- has_line[kp] - ri <- if (i_na[k]) uniq_i else sd_i[k] - rj <- if (j_na[k]) uniq_j else sd_j[k] + ri <- target_i[[k]] + rj <- target_j[[k]] # cartesian product (preserves append_lines_to_rect ordering) line_entries[[kp]] <- data.frame( i = rep(ri, times = length(rj)), @@ -199,7 +216,34 @@ resolve_styles_batch <- function(style_other, style_df) { style_lines <- empty_lines } - list(other = style_other, lines = style_lines) + list(other = style_other, lines = style_lines, has_style = has_style) +} + + +#' Filter a rectangular @style_other grid to rows relevant for a backend +#' @keywords internal +#' @noRd +filter_style_other <- function(style_other, style_cols) { + if (is.null(style_other) || nrow(style_other) == 0) { + return(style_other) + } + + style_cols <- intersect(style_cols, names(style_other)) + if (length(style_cols) == 0L) { + return(style_other[0, , drop = FALSE]) + } + + has_style <- attr(style_other, "has_style", exact = TRUE) + if (!is.null(has_style) && length(has_style) == nrow(style_other)) { + style_other <- style_other[has_style, , drop = FALSE] + } + + if (nrow(style_other) == 0) { + return(style_other) + } + + has_backend_style <- rowSums(!is.na(style_other[, style_cols, drop = FALSE])) > 0 + style_other[has_backend_style, , drop = FALSE] } diff --git a/R/grid_style.R b/R/grid_style.R index 100d045f8..71a59f8f9 100644 --- a/R/grid_style.R +++ b/R/grid_style.R @@ -14,10 +14,7 @@ prepare_grid_style <- function(x) { return(sty) } - # Select only the columns needed for grid styling - sty <- sty[, c( - "i", - "j", + style_cols <- c( "bold", "italic", "strikeout", @@ -28,13 +25,16 @@ prepare_grid_style <- function(x) { "background", "colspan", "rowspan" - ), drop = FALSE] + ) + + sty <- filter_style_other(sty, style_cols) - # Filter to only cells that have actual styles - has_style <- rowSums(!is.na(sty[, c("bold", "italic", "strikeout", "underline", - "smallcap", "indent", "color", "background", - "colspan", "rowspan"), drop = FALSE])) > 0 - sty <- sty[has_style, , drop = FALSE] + # Select only the columns needed for grid styling + sty <- sty[, c( + "i", + "j", + style_cols + ), drop = FALSE] return(sty) } diff --git a/R/html_style.R b/R/html_style.R index 203335364..532ce0c07 100644 --- a/R/html_style.R +++ b/R/html_style.R @@ -185,14 +185,12 @@ setMethod( # Use populated @style_other from build_tt() other <- x@style_other - # Filter to only cells that have actual styles (at least one non-NA value) - if (nrow(other) > 0) { - has_style <- rowSums(!is.na(other[, c("bold", "italic", "underline", "strikeout", - "monospace", "smallcap", "align", "alignv", - "color", "background", "fontsize", "indent", - "html_css", "colspan", "rowspan"), drop = FALSE])) > 0 - other <- other[has_style, , drop = FALSE] - } + other <- filter_style_other(other, c( + "bold", "italic", "underline", "strikeout", + "monospace", "smallcap", "align", "alignv", + "color", "background", "fontsize", "indent", + "html_css", "colspan", "rowspan" + )) # Use populated @style_lines from build_tt() lines <- x@style_lines diff --git a/R/tabularray_style.R b/R/tabularray_style.R index 3d1d00bba..dfe612958 100644 --- a/R/tabularray_style.R +++ b/R/tabularray_style.R @@ -677,15 +677,12 @@ setMethod( # Use populated @style_other from build_tt() other <- x@style_other - # Filter to only cells that have actual styles - if (nrow(other) > 0) { - has_style <- rowSums(!is.na(other[, c( - "bold", "italic", "underline", "strikeout", - "monospace", "smallcap", "align", "alignv", - "color", "background", "fontsize", "indent", - "colspan", "rowspan"), drop = FALSE])) > 0 - other <- other[has_style, , drop = FALSE] - } + other <- filter_style_other(other, c( + "bold", "italic", "underline", "strikeout", + "monospace", "smallcap", "align", "alignv", + "color", "background", "fontsize", "indent", + "colspan", "rowspan" + )) # Use populated @style_lines from build_tt() lines <- x@style_lines diff --git a/R/tabulator_style.R b/R/tabulator_style.R index e9b9c1c46..e76a1bac9 100644 --- a/R/tabulator_style.R +++ b/R/tabulator_style.R @@ -41,13 +41,11 @@ tabulator_apply_styles <- function(x) { # Use populated @style_other from build_tt() other <- x@style_other - # Filter to only cells that have actual styles - if (nrow(other) > 0) { - has_style <- rowSums(!is.na(other[, c("bold", "italic", "underline", "strikeout", - "monospace", "smallcap", "align", "alignv", - "color", "background", "fontsize", "indent"), drop = FALSE])) > 0 - other <- other[has_style, , drop = FALSE] - } + other <- filter_style_other(other, c( + "bold", "italic", "underline", "strikeout", + "monospace", "smallcap", "align", "alignv", + "color", "background", "fontsize", "indent" + )) # Precompute field names once (dots/spaces -> underscores) field_names <- tabulator_clean_column_name(x@names) diff --git a/R/typst_style.R b/R/typst_style.R index ad304ea62..53bcf98f0 100644 --- a/R/typst_style.R +++ b/R/typst_style.R @@ -63,20 +63,23 @@ typst_clean_css <- function(css) { align_h_set <- !is.na(other$align) align_v_set <- !is.na(other$alignv) - parts <- vector("list", n) - for (k in seq_len(n)) parts[[k]] <- character(0) + css <- character(n) # scalar emission: same string for every matching cell add_scalar <- function(mask, key, val) { if (!any(mask)) return() + idx <- which(mask) fragment <- sprintf("%s: %s", key, val) - for (k in which(mask)) parts[[k]] <<- c(parts[[k]], fragment) + sep <- ifelse(nzchar(css[idx]), ", ", "") + css[idx] <<- paste0(css[idx], sep, fragment) } # vector emission: val is parallel to `other`; only used where mask is TRUE add_vec <- function(mask, key, val) { if (!any(mask)) return() - fragment <- sprintf("%s: %s", key, val) - for (k in which(mask)) parts[[k]] <<- c(parts[[k]], fragment[k]) + idx <- which(mask) + fragment <- sprintf("%s: %s", key, val[idx]) + sep <- ifelse(nzchar(css[idx]), ", ", "") + css[idx] <<- paste0(css[idx], sep, fragment) } add_scalar(bold, "bold", "true") @@ -86,19 +89,23 @@ typst_clean_css <- function(css) { add_scalar(monospace, "mono", "true") if (any(color_set)) { - cv <- ifelse(color_set, color_map[other$color], "") + cv <- character(n) + cv[color_set] <- color_map[other$color[color_set]] add_vec(color_set, "color", cv) } if (any(bg_set)) { - bv <- ifelse(bg_set, color_map[other$background], "") + bv <- character(n) + bv[bg_set] <- color_map[other$background[bg_set]] add_vec(bg_set, "background", bv) } if (any(fs_set)) { - fv <- ifelse(fs_set, - vapply(other$fontsize, - function(x) if (is.na(x)) "" else format_markup_unit(x, "em"), - character(1)), - "") + fv <- character(n) + fv[fs_set] <- vapply( + other$fontsize[fs_set], + format_markup_unit, + character(1), + "em" + ) add_vec(fs_set, "fontsize", fv) } @@ -113,20 +120,19 @@ typst_clean_css <- function(css) { } if (any(indent_set)) { - iv <- ifelse(indent_set, - vapply(other$indent, - function(x) if (is.na(x)) "" else format_markup_unit(x, "em"), - character(1)), - "") + iv <- character(n) + iv[indent_set] <- vapply( + other$indent[indent_set], + format_markup_unit, + character(1), + "em" + ) add_vec(indent_set, "indent", iv) } # Each cell becomes a comma-separated list with a trailing comma, matching # the original typst_insert_field() + typst_clean_css() output format. - vapply(parts, function(p) { - s <- paste(p, collapse = ", ") - if (nchar(s) > 0) paste0(s, ",") else s - }, character(1)) + ifelse(nzchar(css), paste0(css, ","), css) } #' Apply Typst styles and generate style-dict/array @@ -140,30 +146,31 @@ typst_apply_styles <- function(x, rec) { return(x) } - # Get unique styles - uni <- split(rec, rec$css) + # Get unique styles. split(rec, rec$css) sorted by CSS value; preserve that + # order without copying one data frame per style group. + style_keys <- sort(unique(rec$css)) + style_idx <- match(rec$css, style_keys) # Create style-array (unique styles) - style_array_entries <- sapply(uni, function(x) { - style_str <- x$css[1] - sprintf("(%s),", style_str) - }) + style_array_entries <- sprintf("(%s),", style_keys) # Create style-dict (cell positions -> style array indices) using vectorized # sprintf instead of growing a vector inside a for loop. Each unique style # group can produce many cell-position keys, so we pre-allocate a list and # unlist() once. - style_dict_list <- vector("list", length(uni)) - for (style_idx in seq_along(uni)) { - cells <- uni[[style_idx]] - style_dict_list[[style_idx]] <- sprintf('"%s_%s": %s', cells$i, cells$j, style_idx - 1) + style_dict_list <- vector("list", length(style_keys)) + style_key_list <- vector("list", length(style_keys)) + for (idx in seq_along(style_keys)) { + rows <- which(style_idx == idx) + style_key_list[[idx]] <- sprintf("%s_%s", rec$i[rows], rec$j[rows]) + style_dict_list[[idx]] <- sprintf('"%s_%s": %s', rec$i[rows], rec$j[rows], idx - 1) } style_dict_entries <- unlist(style_dict_list, use.names = FALSE) + style_dict_keys <- unlist(style_key_list, use.names = FALSE) # Remove duplicate keys (keep last occurrence for each coordinate) if (length(style_dict_entries) > 0) { - keys <- gsub('"([^"]+)":\\s*\\d+', '\\1', style_dict_entries) - style_dict_entries <- style_dict_entries[!duplicated(keys, fromLast = TRUE)] + style_dict_entries <- style_dict_entries[!duplicated(style_dict_keys, fromLast = TRUE)] } # Insert style-dict entries as single line @@ -520,13 +527,11 @@ setMethod( # Use populated @style_other from build_tt() other <- x@style_other - # Filter to only cells that have actual styles - if (nrow(other) > 0) { - has_style <- rowSums(!is.na(other[, c("bold", "italic", "underline", "strikeout", - "monospace", "smallcap", "align", "alignv", - "color", "background", "fontsize", "indent"), drop = FALSE])) > 0 - other <- other[has_style, , drop = FALSE] - } + other <- filter_style_other(other, c( + "bold", "italic", "underline", "strikeout", + "monospace", "smallcap", "align", "alignv", + "color", "background", "fontsize", "indent" + )) # Use populated @style_lines from build_tt() lines <- x@style_lines diff --git a/README.md b/README.md index 5ae8562e9..108d69a19 100644 --- a/README.md +++ b/README.md @@ -135,7 +135,7 @@ tt(x, ## Tutorial -The `tinytable` 0.16.0.13 tutorial will take you much further. It is +The `tinytable` 0.16.0.14 tutorial will take you much further. It is available in HTML and PDF formats at: diff --git a/inst/tinytest/test-style-resolution.R b/inst/tinytest/test-style-resolution.R new file mode 100644 index 000000000..5c98d2e4e --- /dev/null +++ b/inst/tinytest/test-style-resolution.R @@ -0,0 +1,82 @@ +source("helpers.R") + +style_resolution_props <- c( + "bold", "italic", "underline", "strikeout", "monospace", "smallcap", + "align", "alignv", "color", "background", "fontsize", "indent", + "html_css", "colspan", "rowspan" +) + +make_style_rect <- function() { + rect <- expand.grid(i = c(0L, 1L, 2L), j = 1:3) + for (col in style_resolution_props) { + rect[[col]] <- NA + } + rect +} + +make_style_settings <- function() { + data.frame( + i = c(NA, 1, 2, NA, 1, 2), + j = c(1, NA, 2, NA, 3, 3), + bold = c(TRUE, NA, FALSE, NA, TRUE, NA), + italic = c(NA, TRUE, NA, NA, FALSE, NA), + underline = NA, + strikeout = NA, + monospace = NA, + smallcap = NA, + align = c(NA, "l", NA, NA, NA, NA), + alignv = NA, + color = c("red", NA, "blue", NA, "green", NA), + background = c(NA, "yellow", NA, NA, NA, NA), + fontsize = c(NA, 1.2, NA, NA, 0.9, NA), + indent = c(NA, NA, 2, NA, NA, NA), + html_css = c(NA, NA, NA, NA, NA, "font-feature-settings: 'tnum'"), + colspan = NA, + rowspan = NA, + line = c(NA, "b", "t", "b", "l", NA), + line_color = c(NA, "red", "blue", "gray", "black", NA), + line_width = c(NA, 0.1, 0.2, 0.4, 0.3, NA), + line_trim = c(NA, "lr", NA, NA, NA, NA), + stringsAsFactors = FALSE + ) +} + +resolve_styles_reference <- function(rect, settings) { + other <- rect + lines <- data.frame() + for (idx in seq_len(nrow(settings))) { + row <- settings[idx, , drop = FALSE] + other <- tinytable:::apply_style_to_rect(other, row) + lines <- tinytable:::append_lines_to_rect(lines, row, rect) + } + list(other = other, lines = lines) +} + +rect <- make_style_rect() +settings <- make_style_settings() +reference <- resolve_styles_reference(rect, settings) +resolved <- tinytable:::resolve_styles_batch(rect, settings) + +expect_true(isTRUE(all.equal(reference$other, resolved$other, check.attributes = FALSE))) +expect_true(isTRUE(all.equal(reference$lines, resolved$lines, check.attributes = FALSE))) + +expected_has_style <- rowSums(!is.na(reference$other[, style_resolution_props, drop = FALSE])) > 0 +expect_identical(resolved$has_style, expected_has_style) + +expect_true(exists("filter_style_other", envir = asNamespace("tinytable"), inherits = FALSE)) +if (exists("filter_style_other", envir = asNamespace("tinytable"), inherits = FALSE)) { + attr(resolved$other, "has_style") <- resolved$has_style + compact <- tinytable:::filter_style_other(resolved$other, style_resolution_props) + expected <- reference$other[expected_has_style, , drop = FALSE] + + expect_true(nrow(compact) < nrow(resolved$other)) + expect_true(isTRUE(all.equal(expected, compact, check.attributes = FALSE))) +} + +empty_resolved <- tinytable:::resolve_styles_batch(rect, data.frame()) +expect_identical(empty_resolved$has_style, rep(FALSE, nrow(rect))) +attr(empty_resolved$other, "has_style") <- empty_resolved$has_style +expect_identical( + tinytable:::filter_style_other(empty_resolved$other, style_resolution_props), + empty_resolved$other[0, , drop = FALSE] +) From b849f2ef34fe17ca53c428fe17ed66c757d2b950 Mon Sep 17 00:00:00 2001 From: Vincent Arel-Bundock Date: Tue, 7 Jul 2026 17:37:29 -0400 Subject: [PATCH 4/4] version bump + news --- DESCRIPTION | 2 +- NEWS.md | 4 ++++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 5e741a44a..e0f84551a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -2,7 +2,7 @@ Package: tinytable Type: Package Title: Simple and Configurable Tables in 'HTML', 'LaTeX', 'Markdown', 'Word', 'PNG', 'PDF', and 'Typst' Formats Description: Create highly customized tables with this simple and dependency-free package. Data frames can be converted to 'HTML', 'LaTeX', 'Markdown', 'Word', 'PNG', 'PDF', or 'Typst' tables. The user interface is minimalist and easy to learn. The syntax is concise. 'HTML' tables can be customized using the flexible 'Bootstrap' framework, and 'LaTeX' code with the 'tabularray' package. -Version: 0.17.0 +Version: 0.17.0.1 Imports: methods Depends: diff --git a/NEWS.md b/NEWS.md index 7617b18b9..8daa9353d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,9 @@ # News +## Development + +* Performance improvements to `style_tt()`. Thanks to @EinMaulwurf for PR #663. + ## 0.17.0 * `theme_typst()` no longer emits figure-level center alignment by default. Typst tables now use the document's default alignment unless `align_figure` or the `tinytable_typst_align_figure` option is set.