Merge pull request #1829 from olivroy/stubhead-spanner

Support `tab_style()` + `cells_stubhead()` in `opt_interactive()` + add visual test

NEWS.md

@@ -17,6 +17,8 @@
 
 * `opt_interactive()` now works when columns are substituted with `sub_*()` (@olivroy, #1759). 
 
+* More support for `cells_stubhead()` styling in interactive tables.
+
 ## Bug fixes
 
 * Improved error messages for the `text_transform()` function if `locations` couldn't be resolved. (@olivroy, #1774)

R/render_as_i_html.R

@@ -63,6 +63,18 @@ render_as_ihtml <- function(data, id) {
   if (identical(column_groups, NA_character_)) {
     column_groups <- NULL
   }
+
+  # Derive styling for the stubhead
+  stubhead_style <-  dt_styles_get(data)
+  if (!is.null(stubhead_style)) {
+    stubhead_style <- stubhead_style[stubhead_style$locname == "stubhead"]
+    if (nrow(stubhead_style) == 0) {
+      stubhead_style <- NULL
+    } else {
+      stubhead_style <- stubhead_style$html_style
+    }
+  }
+
   rownames_to_stub <- stub_rownames_has_column(data)
   # value to use for rowname_col or groupname_col title
   # Will use it for rowname_col only if groupname_col is undefined.
@@ -81,6 +93,15 @@ render_as_ihtml <- function(data, id) {
     groupname_label <- NULL
   }
 
+  # Apply the stubhead styling to row group heading
+  if (is.null(column_groups)) {
+    rowname_header_style <- stubhead_style
+    rwo_group_header_style <- NULL
+  } else {
+    # Since row names don't appear under the row group column, style it (even if it is different in non-intereactive)
+    rowname_header_style   <- stubhead_style
+    row_group_header_style <- stubhead_style
+  }
 
   # Obtain the underlying data table (including group rows)
   data_tbl0 <- dt_data_get(data = data)
@@ -223,7 +244,9 @@ render_as_ihtml <- function(data, id) {
       name = rowname_label,
       style = list(
         fontWeight = stub_font_weight
-      )
+      ),
+      # part of the stubhead
+      headerStyle = rowname_header_style
       # TODO pass on other attributes of row names column if necessary.
     ))
     names(row_name_col_def) <- ".rownames"
@@ -338,9 +361,11 @@ render_as_ihtml <- function(data, id) {
       if (i == 1) {
         # Use the stubhead label for the first group
         group_label <- groupname_label
+        row_group_header_style <- stubhead_style
       } else {
         # by default, don't name groupname_col for consistency with non-interactive
         group_label <- ""
+        row_group_header_style <- stubhead_style
       }
 
       group_col_defs[[i]] <-
@@ -349,6 +374,7 @@ render_as_ihtml <- function(data, id) {
           style = list(
             `font-weight` = row_group_font_weight
           ),
+          headerStyle = row_group_header_style,
           # The total number of rows is wrong in colGroup, possibly due to the JS fn
           grouped = grp_fn,
           # FIXME Should groups be sticky? (or provide a way to do this)
@@ -520,7 +546,7 @@ render_as_ihtml <- function(data, id) {
       first_colgroups <- base::paste0(col_groups$built, collapse = "|")
 
       cli::cli_warn(c(
-        "When displaying an interactive gt table, there must not be more than 1 level of column groups (tab_spanners)",
+        "Interactive tables support a single spanner level.",
         "*" = "Currently there are {max(dt_spanners_get(data = data)$spanner_level)} levels of tab spanners.",
         "i" = "Only the first level will be used for the interactive table, that is: [{first_colgroups}]"
       ))

pkgdown/assets/gt-latex.tex

@@ -202,7 +202,7 @@
 
 \title{LaTeX Quarto test}
 \author{}
-\date{2024-07-19}
+\date{2024-08-14}
 
 \begin{document}
 \maketitle
@@ -284,6 +284,62 @@
 
 \end{table}%
 
+\begin{Shaded}
+\begin{Highlighting}[]
+\NormalTok{tab }\OtherTok{\textless{}{-}}\NormalTok{ exibble }\SpecialCharTok{\%\textgreater{}\%}
+  \FunctionTok{gt}\NormalTok{(}\AttributeTok{rowname\_col =} \StringTok{"row"}\NormalTok{, }\AttributeTok{groupname\_col =} \StringTok{"group"}\NormalTok{, }\AttributeTok{row\_group\_as\_column =} \ConstantTok{TRUE}\NormalTok{) }\SpecialCharTok{|\textgreater{}}
+  \FunctionTok{tab\_spanner}\NormalTok{(}\StringTok{"spanners"}\NormalTok{, }\FunctionTok{c}\NormalTok{(char, num)) }\SpecialCharTok{\%\textgreater{}\%}
+  \FunctionTok{tab\_spanner}\NormalTok{(}\StringTok{"Second level spanners"}\NormalTok{, }\FunctionTok{c}\NormalTok{(char, num, fctr)) }\SpecialCharTok{\%\textgreater{}\%}
+  \FunctionTok{tab\_stubhead}\NormalTok{(}\StringTok{"Stubhead label"}\NormalTok{) }\SpecialCharTok{\%\textgreater{}\%}
+  \FunctionTok{tab\_style}\NormalTok{(}
+    \AttributeTok{style =} \FunctionTok{list}\NormalTok{(}\FunctionTok{cell\_fill}\NormalTok{(}\StringTok{"\#f0f0f0"}\NormalTok{), }\FunctionTok{cell\_text}\NormalTok{(}\AttributeTok{weight =} \StringTok{"bold"}\NormalTok{)),}
+    \FunctionTok{cells\_stubhead}\NormalTok{()}
+\NormalTok{  ) }\SpecialCharTok{\%\textgreater{}\%} 
+  \FunctionTok{tab\_header}\NormalTok{(}\AttributeTok{title =} \StringTok{"Stubhead styling and multiple spanner levels"}\NormalTok{)}
+\end{Highlighting}
+\end{Shaded}
+
+\begin{table}
+
+\centering{
+
+\caption*{
+{\large Stubhead styling and multiple spanner levels}
+} 
+\fontsize{12.0pt}{14.4pt}\selectfont
+\begin{tabular*}{\linewidth}{@{\extracolsep{\fill}}l|l|lrcrrrr}
+\toprule
+\multicolumn{2}{l}{} & \multicolumn{3}{c}{Second level spanners} &  &  &  &  \\ 
+\cmidrule(lr){3-5}
+\multicolumn{2}{l}{} & \multicolumn{2}{c}{spanners} &  &  &  &  &  \\ 
+\cmidrule(lr){3-4}
+\multicolumn{2}{c}{{\bfseries \cellcolor[HTML]{F0F0F0}{Stubhead label}}} & char & num & fctr & date & time & datetime & currency \\ 
+\midrule\addlinespace[2.5pt]
+\multirow{4}{*}{grp\_a} & row\_1 & apricot & 1.111e-01 & one & 2015-01-15 & 13:35 & 2018-01-01 02:22 & 49.950 \\ 
+ & row\_2 & banana & 2.222e+00 & two & 2015-02-15 & 14:40 & 2018-02-02 14:33 & 17.950 \\ 
+ & row\_3 & coconut & 3.333e+01 & three & 2015-03-15 & 15:45 & 2018-03-03 03:44 & 1.390 \\ 
+ & row\_4 & durian & 4.444e+02 & four & 2015-04-15 & 16:50 & 2018-04-04 15:55 & 65100.000 \\ 
+\midrule\addlinespace[2.5pt]
+\multirow{4}{*}{grp\_b} & row\_5 & NA & 5.550e+03 & five & 2015-05-15 & 17:55 & 2018-05-05 04:00 & 1325.810 \\ 
+ & row\_6 & fig & NA & six & 2015-06-15 & NA & 2018-06-06 16:11 & 13.255 \\ 
+ & row\_7 & grapefruit & 7.770e+05 & seven & NA & 19:10 & 2018-07-07 05:22 & NA \\ 
+ & row\_8 & honeydew & 8.880e+06 & eight & 2015-08-15 & 20:20 & NA & 0.440 \\ 
+\bottomrule
+\end{tabular*}
+
+}
+
+\caption{\label{tbl-spanner-stub}Stubhead styling and multiple spanner
+levels}
+
+\end{table}%
+
+\begin{Shaded}
+\begin{Highlighting}[]
+\CommentTok{\# }\AlertTok{FIXME}\CommentTok{ Borders known not to be exact}
+\end{Highlighting}
+\end{Shaded}
+
 \begin{Shaded}
 \begin{Highlighting}[]
 \NormalTok{tab }\OtherTok{\textless{}{-}}\NormalTok{ pizzaplace }\SpecialCharTok{\%\textgreater{}\%}

scripts/visual-tests-latex.R

@@ -58,8 +58,8 @@ header_latex <- c(
 
   if (length(table_titles) != n_chunks) {
     cli::cli_abort(c(
-      "The structure is not respected. We have {n_chunks} examples, but {length(table_titles)}.",
-      "Each table should be labelled with #| label: and have a tab_header(title = \"\") title"
+      "The structure is not respected. We have {n_chunks} examples, but {length(table_titles)} actually detected.",
+      i = "Each table should be labelled with #| label: and have a tab_header(title = \"<title>\") title"
     ))
   }
 

tests/testthat/test-i_html.R

@@ -104,6 +104,16 @@ test_that("Interactive tables won't fail when using different options", {
     gt() %>%
     sub_missing(rows = 1:7) %>%
     opt_interactive()
+  # Styling with `cells_stubhead()` works
+  tbl_gt_i_30 <- exibble %>%
+    gt::gt(rowname_col = "row", groupname_col = "group", row_group_as_column = TRUE) |>
+    tab_spanner("spanners", c(char, num)) %>%
+    tab_stubhead("Stub row") %>%
+    tab_style(
+      style = list(cell_fill("#f0f0f0"), cell_text(weight = "bold")),
+      cells_stubhead()
+    ) %>% opt_interactive()
+
 
   capture_output(expect_no_error(tbl_gt_i_01))
   capture_output(expect_no_error(tbl_gt_i_02))
@@ -134,5 +144,6 @@ test_that("Interactive tables won't fail when using different options", {
   capture_output(expect_no_error(tbl_gt_i_27))
   capture_output(expect_no_error(tbl_gt_i_28))
   capture_output(expect_no_error(tbl_gt_i_29))
+  capture_output(expect_no_error(tbl_gt_i_30))
 
 })

vignettes/gt-visual.qmd

@@ -50,7 +50,45 @@ tab <- exibble |>
   ) |>
   tab_spanner(c(num, char), label = "A spanner") |>
   tab_header(title = "background color")
+```
+
+::: panel-tabset
+### html
 
+```{r}
+#| echo: false
+tab
+```
+
+### interactive
+
+```{r}
+#| echo: false
+opt_interactive(tab)
+```
+
+### plot
+
+```{r}
+#| echo: false
+plot(tab)
+```
+:::
+
+## Spanner and Stubhead {#sec-spanners-stub}
+
+```{r}
+#| label: spanner-stub
+tab <- exibble %>%
+  gt(rowname_col = "row", groupname_col = "group", row_group_as_column = TRUE) |>
+  tab_spanner("spanners", c(char, num)) %>%
+  tab_spanner("Second level spanners", c(char, num, fctr)) %>%
+  tab_stubhead("Stubhead label") %>%
+  tab_style(
+    style = list(cell_fill("#f0f0f0"), cell_text(weight = "bold")),
+    cells_stubhead()
+  ) %>% 
+  tab_header(title = "Stubhead styling and multiple spanner levels")
 ```
 
 ::: panel-tabset
@@ -59,19 +97,22 @@ tab <- exibble |>
 ```{r}
 #| echo: false
 tab
+# FIXME #1827
 ```
 
 ### interactive
 
 ```{r}
 #| echo: false
+#| warning: false
 opt_interactive(tab)
+# FIXME Borders known not to be exact
 ```
 
 ### plot
 
 ```{r}
-#| echo: false  
+#| echo: false
 plot(tab)
 ```
 :::
@@ -141,7 +182,7 @@ opt_interactive(tab)
 ### plot
 
 ```{r}
-#| echo: false  
+#| echo: false
 plot(tab)
 ```
 :::