diff --git a/DESCRIPTION b/DESCRIPTION index 1d1dd294e..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.16.0.14 +Version: 0.17.0.1 Imports: methods Depends: diff --git a/NEWS.md b/NEWS.md index 7dc545a56..8daa9353d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,10 @@ ## 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. * `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. * `theme_typst(portable = TRUE)` embeds local images directly in generated Typst code using base64 data, avoiding external image paths. Thanks to @jnnkB for the suggestion in Issue #652. diff --git a/R/build_tt.R b/R/build_tt.R index 70f3cf4f2..aa7a53212 100644 --- a/R/build_tt.R +++ b/R/build_tt.R @@ -162,21 +162,23 @@ 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) + 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 01481dbd5..47b36bbb8 100644 --- a/R/expand_style.R +++ b/R/expand_style.R @@ -89,6 +89,164 @@ 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 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,]) +#' 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, + has_style = rep(FALSE, nrow(style_other)) + )) + } + + 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) + + 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. + 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) { + idx <- target_idx[[k]] + if (length(idx)) { + style_other[[prop]][idx] <- vals[[k]] + has_style[idx] <- TRUE + } + } + } + + # 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 <- 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)), + 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, 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] +} + + # 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/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 2c7d551c7..53bcf98f0 100644 --- a/R/typst_style.R +++ b/R/typst_style.R @@ -34,6 +34,107 @@ 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) + + 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) + 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() + 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") + 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 <- character(n) + cv[color_set] <- color_map[other$color[color_set]] + add_vec(color_set, "color", cv) + } + if (any(bg_set)) { + bv <- character(n) + bv[bg_set] <- color_map[other$background[bg_set]] + add_vec(bg_set, "background", bv) + } + if (any(fs_set)) { + fv <- character(n) + fv[fs_set] <- vapply( + other$fontsize[fs_set], + format_markup_unit, + character(1), + "em" + ) + 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 <- 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. + ifelse(nzchar(css), paste0(css, ","), css) +} + #' Apply Typst styles and generate style-dict/array #' @keywords internal #' @noRd @@ -45,27 +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) - }) - - # Create style-dict (cell positions -> style array indices) - style_dict_entries <- character(0) - 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_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(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 @@ -291,57 +396,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) @@ -464,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] +)