grid styles

vincentarelbundock · Nov 4, 2024 · fdb7789 · fdb7789
1 parent 61101e1
commit fdb7789
Show file tree

Hide file tree

Showing 4 changed files with 60 additions and 40 deletions.
diff --git a/R/build_tt.R b/R/build_tt.R
@@ -73,7 +73,7 @@ build_tt <- function(x, output = NULL) {
 
   # markdown styles need to be applied before creating the table, otherwise there's annoying parsing, etc.
   if (x@output %in% c("markdown", "gfm", "dataframe")) {
-        # TODO
+    x <- style_eval(x)
   }
 
   # draw the table

diff --git a/R/style_grid.R b/R/style_grid.R
@@ -1,55 +1,67 @@
 #' tinytable S4 method
 #' 
 #' @keywords internal
-style_grid_internal <- function(x,
-                                i = NULL,
-                                j = NULL,
-                                bold = FALSE,
-                                italic = FALSE,
-                                monospace = FALSE,
-                                underline = FALSE,
-                                strikeout = FALSE,
-                                rowspan = NULL,
-                                colspan = NULL,
-                                ...) {
+style_eval_grid <- function(x,
+                            i = NULL,
+                            j = NULL,
+                            bold = FALSE,
+                            italic = FALSE,
+                            monospace = FALSE,
+                            underline = FALSE,
+                            strikeout = FALSE,
+                            rowspan = NULL,
+                            colspan = NULL,
+                            ...) {
+
 
   out <- x@table_dataframe
+  sty <- x@style
+
+  all_i <- seq_len(nrow(x))
+  idx_g <- x@group_i_idx + cumsum(rep(1, length(x@group_i_idx))) - 1
+  idx_d <- setdiff(all_i, idx_g)
 
-  # i is a logical matrix mask
-  if (is.matrix(i) && is.logical(i) && nrow(i) == nrow(x) && ncol(i) == ncol(x)) {
-    assert_null(j)
-    settings <- which(i == TRUE, arr.ind = TRUE)
-    settings <- stats::setNames(data.frame(settings), c("i", "j"))
-  } else {
-    jval <- sanitize_j(j, x)
-    ival <- sanitize_i(i, x, lazy = FALSE)
-    settings <- expand.grid(i = ival, j = jval)
+  # expand i to full rows
+  if (any(is.na(sty$i))) {
+    alli <- data.frame(i = seq_len(nrow(x)))
+    alli <- merge(alli, sty[is.na(sty$i), colnames(sty) != "i"], all = TRUE)
+    sty <- rbind(sty, alli)
+    sty <- sty[!is.na(sty$i),]
+    sty <- sty[order(sty$i, sty$j),]
+  }
+
+  last <- function(k) {
+    if (all(is.na(k))) return(NA)
+    if (is.logical(k)) return(as.logical(max(k, na.rm = TRUE)))
+    return(utils::tail(stats::na.omit(k), 1))
   }
+  sty <- do.call(rbind, by(sty, list(sty$i, sty$j), function(k) {
+    data.frame(lapply(k, last))
+  }))
 
-  # we only format the body, not headers
-  settings <- settings[settings$i > 0,]
+  # TODO: style groups
+  sty <- sty[which(!sty$i %in% idx_g),]
 
-  # Unlike other formats, Markdown inserts `group_tt()` row labels after styling. This aligns the `i` index to the full columns.
-  gr <- x@lazy_group
-  gr <- Filter(function(k) !is.null(k$i), gr)
-  # do not style spanning row labels
-  lab_idx <- drop(unlist(lapply(gr, function(k) k$i)))
-  lab_idx <- lab_idx + cumsum(rep(1, length(lab_idx))) - 1
-  settings <- settings[!settings$i %in% lab_idx,]
-  for (g in gr) {
-    for (lab in g$i) {
-      settings$i[settings$i > lab - 1] <- settings$i[settings$i > lab - 1] - 1
-    }
-    lab_idx <- c(lab_idx, g$i)
+  if (nrow(sty) == 0) return(x)
+
+  # user-supplied indices are post-groups
+  # adjust indices to match original data rows since we only operate on those 
+  for (g in rev(idx_g)) {
+    sty[sty$i > g, "i"] <- sty[sty$i > g, "i"] - 1
   }
 
   for (col in seq_along(out)) {
     out[[col]] <- as.character(out[[col]])
   }
 
-  for (idx in seq_len(nrow(settings))) {
-    row <- settings[idx, "i"]
-    col <- settings[idx, "j"]
+  for (idx in seq_len(nrow(sty))) {
+    row <- sty[idx, "i"]
+    col <- sty[idx, "j"]
+    bold <- sty[which(sty$i == row & sty$j == col), "bold"]
+    italic <- sty[which(sty$i == row & sty$j == col), "italic"]
+    strikeout <- sty[which(sty$i == row & sty$j == col), "strikeout"]
+    rowspan <- sty[which(sty$i == row & sty$j == col), "rowspan"]
+    colspan <- sty[which(sty$i == row & sty$j == col), "colspan"]
     if (isTRUE(bold)) {
       out[row, col] <- sprintf("**%s**", out[row, col])
     }
@@ -87,5 +99,5 @@ style_grid_internal <- function(x,
 setMethod(
           f = "style_eval",
           signature = "tinytable_grid",
-          definition = identity
+          definition = style_eval_grid
 )
diff --git a/R/style_grid_dataframe.R b/R/style_grid_dataframe.R
@@ -3,7 +3,7 @@
 #' @keywords internal
 setMethod(f = "style_eval",
           signature = "tinytable_dataframe",
-          definition = identity
+          definition = style_eval_grid
 )
 
 

diff --git a/sandbox/typst.qmd b/sandbox/typst.qmd
@@ -11,6 +11,14 @@ options(tinytable_quarto_figure = TRUE)
 options(tinytable_print_output = "typst")
 ```
 
+```{r}
+dat <- data.frame(
+  a = c("a", "aa", "aaa"),
+  b = c("b", "bb", "bbb"),
+  c = c("c", "cc", "ccc"))
+tt(dat) |> style_tt(j = 1:3, align = "lcr")
+```
+
 ```{r}
 # Semi-complicated
 tab <- tt(mtcars[1:4, 1:5], caption = "Hello World") |>