Merge pull request #1900 from olivroy/inter-style

Improve perf of `cols_nanoplot()` by not resolving + use more vctrs

R/cols_add.R

@@ -427,7 +427,7 @@ cols_add <- function(
   if (is.null(resolved_column_before) && is.null(resolved_column_after)) {
 
     updated_data_tbl <-
-      dplyr::bind_cols(
+      vctrs::vec_cbind(
         data_tbl,
         data_tbl_new_cols
       )
@@ -445,16 +445,16 @@ cols_add <- function(
     if (before_colnum <= 1) {
       # put new column first
       updated_data_tbl <-
-        dplyr::bind_cols(
+        vctrs::vec_cbind(
           data_tbl_new_cols,
           data_tbl
         )
     } else {
       updated_data_tbl <-
-        dplyr::bind_cols(
-          dplyr::select(data_tbl, 1:(dplyr::all_of(before_colnum) - 1)),
+        vctrs::vec_cbind(
+          data_tbl[1:(before_colnum - 1)],
           data_tbl_new_cols,
-          dplyr::select(data_tbl, dplyr::all_of(before_colnum):ncol(data_tbl))
+          data_tbl[before_colnum:ncol(data_tbl)]
         )
     }
 
@@ -474,15 +474,15 @@ cols_add <- function(
 
     updated_data_tbl <-
       dplyr::bind_cols(
-        dplyr::select(data_tbl, 1:dplyr::all_of(after_colnum)),
+        data_tbl[1:(after_colnum)],
         data_tbl_new_cols,
-        dplyr::select(data_tbl, (after_colnum + 1):ncol(data_tbl))
+        data_tbl[(after_colnum + 1):ncol(data_tbl)]
       )
 
     after_colnum <- which(boxh_df[["var"]] == resolved_column_after)
 
     updated_boxh_df <-
-      dplyr::bind_rows(
+      vctrs::vec_rbind(
         boxh_df[1:after_colnum, ],
         boxh_df_new_cols,
         boxh_df[(after_colnum + 1):nrow(boxh_df), ]

R/dt_summary.R

@@ -272,15 +272,12 @@ dt_summary_build <- function(data, context) {
     )] <- NA_real_
 
     summary_dfs_data <-
-      dplyr::select(
-        summary_dfs_data,
-        dplyr::all_of(c(
-          group_id_col_private,
-          row_id_col_private,
-          rowname_col_private,
-          colnames(body)
-        ))
-      )
+      summary_dfs_data[c(
+        group_id_col_private,
+        row_id_col_private,
+        rowname_col_private,
+        colnames(body)
+      )]
 
     #
     # Format with formatting formulae
@@ -297,11 +294,8 @@ dt_summary_build <- function(data, context) {
     summary_dfs_display_gt[["_data"]][is.na(summary_dfs_display_gt[["_data"]])] <-
       NA
 
-    summary_dfs_display_gt[["_stub_df"]] <-
-      dplyr::mutate(
-        summary_dfs_display_gt[["_stub_df"]],
-        row_id = gsub("__[0-9]*", "", row_id)
-      )
+    summary_dfs_display_gt[["_stub_df"]]$row_id <-
+      gsub("__[0-9]*", "", summary_dfs_display_gt[["_stub_df"]]$row_id)
 
     for (k in seq_along(fmt_exprs)) {
 
@@ -414,7 +408,7 @@ dt_summary_build <- function(data, context) {
     labels_processed <- unlist(lapply(labels, FUN = process_text, context = context))
 
     for (i in seq_len(nrow(summary_dfs_display))) {
-      summary_dfs_display[i, ][["::rowname::"]] <-
+      summary_dfs_display[i, ][[rowname_col_private]] <-
         unname(labels_processed[names(labels_processed) == summary_dfs_display[i, ][["::row_id::"]]])
     }
 

R/extract.R

@@ -121,7 +121,7 @@
 #' row groups and row labels. Formatting will be applied to the date- and
 #' currency-based columns.
 #'
-#' ```r
+#' ```{r}
 #' gt_tbl <-
 #'   sp500 |>
 #'   dplyr::filter(date >= "2015-01-05" & date <= "2015-01-16") |>
@@ -136,6 +136,9 @@
 #'   fmt_currency(columns = c(open, high, low, close)) |>
 #'   cols_hide(columns = c(high, low))
 #' 
+#' ```
+#' 
+#' ```r
 #' gt_tbl
 #' ```
 #' 
@@ -396,7 +399,8 @@ assemble_body_extract <- function(
     }
 
     if (!is.null(rowname_col)) {
-      names(out_df)[names(out_df) == rowname_col] <- "::rowname::"
+      # ::rowname::
+      names(out_df)[names(out_df) == rowname_col] <- rowname_col_private
     }
   }
 

R/fmt_number.R

@@ -509,7 +509,7 @@ fmt_number <- function(
   #
 
   # Ensure that arguments are matched
-  system <- rlang::arg_match(system, c("intl", "ind"))
+  system <- rlang::arg_match0(system, c("intl", "ind"))
 
   # Stop function if `locale` does not have a valid value; normalize locale
   # and resolve one that might be set globally

R/format_data.R

@@ -4953,12 +4953,12 @@ format_bins_by_context <- function(x, sep, fmt, context) {
 
     # Format the LHS and RHS values
     val_tbl <-
-      dplyr::tibble(
+      vctrs::data_frame(
         left = as.numeric(x_str_lhs),
         right = as.numeric(x_str_rhs)
       )
 
-    val_tbl_gt <- gt(val_tbl)
+    val_tbl_gt <- gt(val_tbl, groupname_col = NULL)
 
     # Ensure that the expression (a RHS formula) is made a closure
     format_fn <- rlang::as_closure(fmt)
@@ -9912,7 +9912,7 @@ fmt_passthrough <- function(
       rtf = function(x) {
 
         # Create `x_str` with same length as `x`
-        x_str <- rep(NA_character_, length(x))
+        x_str <- rep_len(NA_character_, length(x))
 
         # Handle formatting of pattern
         x_str <-
@@ -9930,7 +9930,7 @@ fmt_passthrough <- function(
       default = function(x) {
 
         # Create `x_str` with same length as `x`
-        x_str <- rep(NA_character_, length(x))
+        x_str <- rep_len(NA_character_, length(x))
 
         # Handle formatting of pattern
         x_str <-

R/format_vec.R

@@ -3318,8 +3318,14 @@ vec_fmt_markdown <- function(
   }
   # Avoid modifying the output to base64enc in Quarto
   if (check_quarto() && output == "html") {
-    rlang::check_installed("withr", "to use vec_fmt_markdown() in Quarto.")
-    withr::local_envvar(c("QUARTO_BIN_PATH" = ""))
+    # Similar to withr::local_envvar 
+    current_envvar <- Sys.getenv("QUARTO_BIN_PATH")
+    Sys.unsetenv("QUARTO_BIN_PATH")
+    on.exit(
+      Sys.setenv(QUARTO_BIN_PATH = current_envvar),
+      add = TRUE,
+      after = TRUE
+    )
   }
   vec_fmt_out <-
     render_as_vector(

R/helpers.R

@@ -705,7 +705,11 @@ unit_conversion <- function(from, to) {
   }
 
   row_conversion <-
-    dplyr::filter(conversion_factors, from == {{ from }}, to == {{ to }})
+    vctrs::vec_slice(
+      conversion_factors,
+      conversion_factors$from == from &
+        conversion_factors$to == to
+    )
 
   # In the case where units are valid and available in the internal dataset,
   # they may be across categories; such pairings do not allow for a conversion

R/nanoplot.R

@@ -363,10 +363,8 @@
 #'
 #' ```r
 #' pizzaplace |>
-#'   dplyr::select(type, date) |>
-#'   dplyr::group_by(date, type) |>
-#'   dplyr::summarize(sold = dplyr::n(), .groups = "drop") |>
-#'   tidyr::pivot_wider(names_from = type, values_from = sold) |>
+#'   dplyr::count(type, date) |>
+#'   tidyr::pivot_wider(names_from = type, values_from = n) |>
 #'   dplyr::slice_head(n = 10) |>
 #'   gt(rowname_col = "date") |>
 #'   tab_header(

R/render_as_i_html.R

@@ -412,9 +412,9 @@ render_as_ihtml <- function(data, id) {
   col_defs <- c(col_defs, group_col_defs, row_name_col_def)
 
   styles_tbl <- dt_styles_get(data = data)
-  body_styles_tbl <- dplyr::filter(styles_tbl, locname %in% c("data", "stub"))
+  body_styles_tbl <- vctrs::vec_slice(styles_tbl, styles_tbl$locname %in% c("data", "stub"))
   body_styles_tbl <- dplyr::arrange(body_styles_tbl, colnum, rownum)
-  body_styles_tbl <- dplyr::select(body_styles_tbl, colname, rownum, html_style)
+  body_styles_tbl <- dplyr::select(body_styles_tbl, "colname", "rownum", "html_style")
 
   # Generate styling rule per combination of `colname` and
   # `rownum` in `body_styles_tbl`
@@ -426,7 +426,7 @@ render_as_ihtml <- function(data, id) {
         colname <- body_styles_tbl[x, ][["colname"]]
         rownum <- body_styles_tbl[x, ][["rownum"]]
         html_style <- body_styles_tbl[x, ][["html_style"]]
-        html_style <- unlist(strsplit(html_style, "; "))
+        html_style <- unlist(strsplit(html_style, "; ", fixed = TRUE))
         html_style <- gsub("(-)\\s*(.)", "\\U\\2", html_style, perl = TRUE)
         html_style <- gsub("(:)\\s*(.*)", ": '\\2'", html_style, perl = TRUE)
         html_style <- paste(html_style, collapse = ", ")
@@ -537,7 +537,10 @@ render_as_ihtml <- function(data, id) {
   if (has_tab_spanners) {
 
     hidden_columns <- dt_boxhead_get_var_by_type(data = data, type = "hidden")
-    col_groups <- dplyr::filter(dt_spanners_get(data = data), spanner_level == 1)
+    spanners_df <- dt_spanners_get(data = data)
+    col_groups <- vctrs::vec_slice(
+      spanners_df, spanners_df$spanner_level == 1
+    )
 
     for (i in seq_len(nrow(col_groups))) {
 

R/resolver.R

@@ -181,8 +181,10 @@ resolve_cells_column_spanners <- function(
     }
 
     # filter for levels
-    spanners <- spanners %>% dplyr::filter(spanner_level %in% levels)
-
+    spanners <- vctrs::vec_slice(
+      spanners,
+      spanners$spanner_level %in% levels
+    )
   }  #
   # Resolution of spanners as column spanner names
   #
@@ -255,8 +257,13 @@ resolve_cols_c <- function(
     call = rlang::caller_env()
 ) {
 
-  null_means <- rlang::arg_match(null_means)
-
+  if (identical(Sys.getenv("GT_AVOID_RESOLVE"), "true")) {
+    ret <- names(dt_data_get(data))
+    return(ret)
+  }
+
+  null_means <- rlang::arg_match0(null_means, c("everything", "nothing"))
+
   names(
     resolve_cols_i(
       expr = {{ expr }},
@@ -499,8 +506,11 @@ resolve_rows_i <- function(
     null_means = c("everything", "nothing"),
     call = rlang::caller_env()
 ) {
-
-  null_means <- rlang::arg_match(null_means)
+  if (identical(Sys.getenv("GT_AVOID_RESOLVE"), "true")) {
+    ret <- seq_len(nrow(dt_data_get(data)))
+    return(ret)
+  }
+  null_means <- rlang::arg_match0(null_means, c("everything", "nothing"))
 
   resolved_rows <-
     resolve_rows_l(

R/tab_info.R

@@ -197,13 +197,13 @@ tab_info <- function(data) {
 
     groups_rows <- dt_row_groups_get(data = data)
 
-    row_groups <- dplyr::select(stub_df, id = group_id, label = group_label)
+    row_groups <- dplyr::select(stub_df, id = "group_id", label = "group_label")
     row_groups <- dplyr::filter(row_groups, dplyr::row_number() == 1, .by = "id")
     row_groups <- dplyr::mutate(row_groups, i = which(groups_rows %in% id))
     row_groups$type <- NA_character_
     row_groups$label <- unlist(row_groups$label)
     row_groups$location <- "Row Groups"
-    row_groups <- dplyr::select(row_groups, id, i, label, type, location)
+    row_groups <- row_groups[c("id", "i", "label", "type", "location")]
 
   } else {
     row_groups <- empty_tbl

R/tab_options.R

@@ -880,7 +880,7 @@ tab_options <- function(
   new_df <-
     dplyr::left_join(
       new_df,
-      dplyr::select(opts_df, parameter, type),
+      dplyr::select(opts_df, "parameter", "type"),
       by = "parameter"
     )
   new_df$value <- mapply(

R/utils.R

@@ -2384,7 +2384,8 @@ column_classes_are_valid <- function(data, columns, valid_classes, call = rlang:
     )
 
   table_data <- dt_data_get(data = data)
-  table_data <- dplyr::select(table_data, dplyr::all_of(resolved))
+  # select all resolved columns
+  table_data <- table_data[resolved]
 
   all(
     vapply(

R/utils_plots.R

@@ -1020,6 +1020,17 @@ generate_nanoplot <- function(
     bar_tags <- paste(bar_strings, collapse = "\n")
   }
 
+  # Speed up nanoplots number formatting rendering by avoid
+  # calling resolve_cols_i() too much.
+  # To be used with caution, but setting this envvar for all the vec_*() calls
+  # similar to withr::local_envvar()
+  Sys.setenv(GT_AVOID_RESOLVE = "true")
+  on.exit(
+    Sys.unsetenv("GT_AVOID_RESOLVE"),
+    add = TRUE,
+    after = TRUE
+  )
+
   if (plot_type == "bar" && single_horizontal_bar) {
 
     # This type of display assumes there is only a single `y` value and there
@@ -2204,7 +2215,7 @@ format_number_compactly <- function(
   }
 
   # Format value accordingly
-
+  
   if (!is.null(currency)) {
 
     if (abs(val) >= 1e15) {

R/utils_render_grid.R

@@ -104,15 +104,15 @@ create_heading_component_g <- function(data) {
 
   title_styles <- NA_character_
   if ("title" %in% styles_tbl$locname) {
-    title_style_rows <- dplyr::filter(styles_tbl, locname == "title")
+    title_style_rows <- vctrs::vec_slice(styles_tbl, styles_tbl$locname == "title")
     if (nrow(title_style_rows) > 0) {
       title_styles <- title_style_rows$html_style
     }
   }
 
   subtitle_styles <- NA_character_
   if (subtitle_defined && "subtitle" %in% styles_tbl$locname) {
-    subtitle_style_rows <- dplyr::filter(styles_tbl, locname == "subtitle")
+    subtitle_style_rows <- vctrs::vec_slice(styles_tbl, styles_tbl$locname == "subtitle")
     if (nrow(subtitle_style_rows) > 0) {
       subtitle_styles <- subtitle_style_rows$html_style
     }
@@ -762,7 +762,7 @@ create_source_notes_component_g <- function(data) {
 
   style <- NA
   if ("source_notes" %in% styles_tbl$locname) {
-    source_notes_style <- dplyr::filter(styles_tbl, locname == "source_notes")
+    source_notes_style <- vctrs::vec_slice(styles_tbl, styles_tbl$locname == "source_notes")
     if (nrow(source_notes_style)) {
       style <- source_notes_style$html_style
     }
@@ -804,7 +804,7 @@ create_footnotes_component_g <- function(data) {
 
   style <- NA
   if ("footnotes" %in% styles_tbl$locname) {
-    footnotes_style <- dplyr::filter(styles_tbl, locname == "footnotes")
+    footnotes_style <- vctrs::vec_slice(styles_tbl, styles_tbl$locname == "footnotes")
     if (nrow(footnotes_style) > 0) {
       style <- footnotes_style$html_style
     }

R/utils_render_html.R

@@ -270,13 +270,13 @@ get_table_defs <- function(data) {
   if ("stub" %in% widths[["type"]]) {
     stub_idx <- which(widths$type == "stub")
     othr_idx <- base::setdiff(seq_len(nrow(widths)), stub_idx)
-    widths <- dplyr::slice(widths, stub_idx, othr_idx)
+    widths <- vctrs::vec_slice(widths, c(stub_idx, othr_idx))
   }
 
   if ("row_group" %in% widths[["type"]] && row_group_as_column) {
     row_group_idx <- which(widths$type == "row_group")
     othr_idx <- base::setdiff(seq_len(nrow(widths)), row_group_idx)
-    widths <- dplyr::slice(widths, row_group_idx, othr_idx)
+    widths <- vctrs::vec_slice(widths, c(row_group_idx, othr_idx))
   }
 
   widths <- widths[seq_len(nrow(widths)), "column_width", drop = TRUE]