Merged upstream/master into font-weight-heading

.Rbuildignore

@@ -180,4 +180,6 @@ tests/testthat/test-util_functions.R
 tests/testthat/test-utils_plots.R
 tests/testthat/test-utils_render_html.R
 tests/testthat/test-utils_units.R
+
+tests/testthat/_snaps/utils.md
 tests/testthat/test-utils.R

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)
@@ -44,6 +46,7 @@
 * Fixed an issue where `tab_spanner_delim()` would fail to resolve a duplicate id (@olivroy, #1821).
 
 * `tidyselect::where()`, `tidyselect::all_of()`, `tidyselect::any_of()` are now re-exported by gt.
+
 # gt 0.11.0
 
 ## New features

R/data_color.R

@@ -1493,7 +1493,7 @@ check_named_colors <- function(named_colors, call = rlang::caller_env()) {
       )
 
     cli::cli_abort(c(
-      "{one_several_invalid} used ({str_catalog(invalid_colors, conj = 'and')}).",
+      "{one_several_invalid} used ({.str {invalid_colors}}).",
       "*" = "Only R/X11 color names and CSS 3.0 color names can be used."
      ),
      call = call

R/modify_rows.R

@@ -100,7 +100,7 @@ row_group_order <- function(
     cli::cli_abort(c(
       "All values given as `groups` must correspond to `group_id` values.",
       "*" = "The following `group_id` values can be
-      used {str_catalog(arrange_groups)}."
+      used {.str {arrange_groups}}."
     ))
   }
 

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}]"
       ))

R/text_transform.R

@@ -110,7 +110,7 @@ text_replace <- function(
     data = data,
     locations = locations,
     fn = function(x) {
-      str_complete_replace(x, pattern = pattern, replacement = replacement)
+      gsub(pattern = pattern, replacement = replacement, x, perl = TRUE)
     }
   )
 }

R/utils_general_str_formatting.R

@@ -329,48 +329,6 @@ is_adjacent_separate <- function(group_1, group_2) {
   TRUE
 }
 
-str_catalog <- function(
-    item_vector,
-    conj = "and",
-    surround = c("\"", "`"),
-    sep = ",",
-    oxford = TRUE
-) {
-
-  item_count <- length(item_vector)
-
-  surround_str_1 <- paste(rev(surround), collapse = "")
-  surround_str_2 <- paste(surround, collapse = "")
-
-  cat_str <- paste0(surround_str_1, item_vector, surround_str_2)
-
-  if (item_count == 1) {
-
-    return(cat_str)
-
-  } else if (item_count == 2) {
-
-    return(paste(cat_str[1], conj, cat_str[2]))
-
-  } else {
-
-    separators <- rep(paste_right(sep, " "), item_count - 1)
-
-    if (!oxford) {
-      separators[length(separators)] <- ""
-    }
-
-    separators[length(separators)] <-
-      paste_right(paste_right(separators[length(separators)], conj), " ")
-
-    separators[length(separators) + 1] <- ""
-
-    cat_str <- paste(paste0(cat_str, separators), collapse = "")
-
-    return(cat_str)
-  }
-}
-
 str_title_case <- function(x) {
 
   title_case_i <- function(y) {
@@ -393,30 +351,17 @@ str_substitute <- function(string, start = 1L, end = -1L) {
     end <- start[, 2L]
     start <- start[, 1L]
   }
-
-  start <- recycler(start, string)
-  end <- recycler(end, string)
-
+  # Error if start or end is incorrect.
+  vec <- vctrs::vec_recycle_common(start = start, end = end, .size = length(string))
+  start <- vec$start
+  end <- vec$end
   n <- nchar(string)
   start <- ifelse(start < 0, start + n + 1, start)
   end <- ifelse(end < 0, end + n + 1, end)
 
   substr(string, start, end)
 }
 
-recycler <- function(x, to, arg = deparse(substitute(x))) {
-
-  if (length(x) == length(to)) {
-    return(x)
-  }
-
-  if (length(x) != 1) {
-    stop("Can't recycle `", arg, "` to length ", length(to), call. = FALSE)
-  }
-
-  rep(x, length(to))
-}
-
 str_complete_locate <- function(string, pattern) {
   out <- gregexpr(pattern, string, perl = TRUE)
   lapply(out, location, all = TRUE)
@@ -427,14 +372,6 @@ str_single_locate <- function(string, pattern) {
   location(out)
 }
 
-str_complete_replace <- function(string, pattern, replacement) {
-  gsub(pattern, replacement, string, perl = TRUE)
-}
-
-str_single_replace <- function(string, pattern, replacement) {
-  sub(pattern, replacement, string, perl = TRUE)
-}
-
 location <- function(x, all = FALSE) {
 
   start <- as.vector(x)

R/utils_render_grid.R

@@ -949,9 +949,12 @@ render_grid_svg <- function(label, style, margin) {
 
   # Try if any height is declared in style attribute
   if (any(grepl("^height:", svg_style))) {
-    height <- gsub("^height:", "", svg_style[grep("^height:", svg_style)]) %>%
-      parse_fontsize(style$text_gp$fontsize) %>%
-      grid::unit(.grid_unit)
+    height <- gsub("^height:", "", svg_style[grep("^height:", svg_style)])
+    height <-
+      grid::unit(
+        parse_fontsize(height, style$text_gp$fontsize),
+        .grid_unit
+      )
   }
 
   # Try if any width is declared in style attribute
@@ -1022,9 +1025,8 @@ render_grid_svg <- function(label, style, margin) {
 
   raster <- try_fetch(
     {
-      svg_string %>%
         # charToRaw("") return character(0)
-        charToRaw() %>%
+        charToRaw(svg_string) %>%
         rsvg::rsvg_nativeraster(width = w) %>%
         grid::rasterGrob(
           width = width, height = height,

R/utils_render_rtf.R

@@ -403,8 +403,7 @@ parse_length_str <- function(
 
     cli::cli_abort(c(
       "Some of the values supplied cannot be interpreted.",
-      "*" = "Problem values are:
-      {str_catalog(bad_values, surround = c('\"'))}.",
+      "*" = "Problem values are: {.str {bad_values}}",
       "*" = "Use either of: `px`, `pt`, `in`, `cm`, `mm`, or `tw`
       (e.g., \"12px\")"
     ))
@@ -1019,8 +1018,7 @@ create_heading_component_rtf <- function(data) {
 
   # Obtain widths for each visible column label
   col_widths <-
-    boxh %>%
-    dplyr::filter(type %in% c("default", "stub")) %>%
+    dplyr::filter(boxh, type %in% c("default", "stub")) %>%
     dplyr::arrange(dplyr::desc(type)) %>%
     dplyr::pull(column_width) %>%
     unlist()

R/z_utils_render_footnotes.R

@@ -144,8 +144,9 @@ resolve_footnotes_styles <- function(data, tbl_type) {
     cond <- tbl$locname != "row_groups"
     tbl_not_row_groups <- tbl[cond, ]
 
-    tbl_row_groups <- tbl[!cond, ] %>%
+    tbl_row_groups <-
       dplyr::inner_join(
+        tbl[!cond, ],
         groups_rows_df,
         by = c("grpname" = "group_id")
       )
@@ -411,9 +412,16 @@ set_footnote_marks_columns <- function(data, context = "html") {
     if (nrow(footnotes_columns_groups_tbl) > 0) {
 
       footnotes_columns_group_marks <-
-        footnotes_columns_groups_tbl %>%
-        dplyr::mutate(fs_id_coalesced = paste(fs_id, collapse = ","), .by = "grpname") %>%
-        dplyr::distinct(grpname, fs_id_coalesced)
+        dplyr::mutate(
+          footnotes_columns_groups_tbl,
+          fs_id_coalesced = paste(fs_id, collapse = ","),
+          .by = "grpname"
+        )
+      footnotes_columns_group_marks <-
+        dplyr::distinct(
+          footnotes_columns_group_marks,
+          grpname, fs_id_coalesced
+        )
 
       for (i in seq_len(nrow(footnotes_columns_group_marks))) {
 
@@ -464,10 +472,21 @@ set_footnote_marks_columns <- function(data, context = "html") {
     if (nrow(footnotes_columns_columns_tbl) > 0) {
 
       footnotes_columns_column_marks <-
-        footnotes_columns_columns_tbl %>%
-        dplyr::filter(locname == "columns_columns") %>%
-        dplyr::mutate(fs_id_coalesced = paste(fs_id, collapse = ","), .by = "colname") %>%
-        dplyr::distinct(colname, fs_id_coalesced)
+        vctrs::vec_slice(
+          footnotes_columns_columns_tbl,
+          !is.na(footnotes_columns_columns_tbl$locname) &
+            footnotes_columns_columns_tbl$locname == "columns_columns"
+        )
+      footnotes_columns_column_marks <-
+        dplyr::mutate(
+          footnotes_columns_column_marks,
+          fs_id_coalesced = paste(fs_id, collapse = ","),
+          .by = "colname"
+        )
+      footnotes_columns_column_marks <-
+        dplyr::distinct(
+          footnotes_columns_column_marks, colname, fs_id_coalesced
+        )
 
       for (i in seq_len(nrow(footnotes_columns_column_marks))) {
 
@@ -515,11 +534,14 @@ set_footnote_marks_stubhead <- function(data, context = "html") {
     if (nrow(footnotes_tbl) > 0) {
 
       footnotes_stubhead_marks <-
-        footnotes_tbl %>%
-        dplyr::mutate(fs_id_coalesced = paste(fs_id, collapse = ","), .by = "grpname") %>%
-        dplyr::distinct(grpname, fs_id_coalesced) %>%
-        dplyr::pull(fs_id_coalesced)
-
+        dplyr::mutate(
+          footnotes_tbl,
+          fs_id_coalesced = paste(fs_id, collapse = ","),
+          .by = "grpname"
+        )
+      footnotes_stubhead_marks <-
+        dplyr::distinct(footnotes_stubhead_marks, grpname, fs_id_coalesced)
+      footnotes_stubhead_marks <- footnotes_stubhead_marks$fs_id_coalesced
 
       label <-
         paste0(