Merge pull request #1893 from olivroy/perform

Performance of vec_fmt_*() by avoiding checking of compatibility + coercion to tibble
rstudio · Sep 27, 2024 · 7e265f7 · 7e265f7 · github-actions · Sep 27, 2024
2 parents a6c8c57 + 53b1e44
commit 7e265f7
Show file tree

Hide file tree

Showing 15 changed files with 198 additions and 119 deletions.
diff --git a/NEWS.md b/NEWS.md
@@ -63,6 +63,8 @@
 
 * `vec_fmt_*()` (and incidentally `cols_nanoplot()`) should be faster now (@olivroy, #1888, #1891).
 
+* `cols_add()` works in more cases (#1893).
+
 # gt 0.11.0
 
 ## New features

diff --git a/R/build_data.R b/R/build_data.R
@@ -40,7 +40,7 @@ build_data <- function(data, context) {
   # Reassemble the rows and columns of `body` in
   # the correct order
   data <- dt_body_build(data = data)
-  data <- render_formats(data = data, context = context)
+  data <- render_formats(data = data, skip_compat_check = FALSE, context = context)
   data <- render_substitutions(data = data, context = context)
   data <- migrate_unformatted_to_output(data = data, context = context)
   data <- perform_col_merge(data = data, context = context)
@@ -96,7 +96,7 @@ build_data <- function(data, context) {
 build_data_body <- function(data, context) {
 
   data <- dt_body_build(data = data)
-  data <- render_formats(data = data, context = context)
+  data <- render_formats(data = data, skip_compat_check = TRUE, context = context)
   data <- migrate_unformatted_to_output(data = data, context = context)
 
   data

diff --git a/R/cols_add.R b/R/cols_add.R
@@ -242,7 +242,7 @@ cols_add <- function(
   # columns
   #
 
-  if (nrow(data_tbl) < 1 && ncol(data_tbl) < 1) {
+  if (nrow(data_tbl) == 0L && ncol(data_tbl) == 0L) {
 
     # Generate boxhead rows that correspond to the new columns
     updated_boxh_df <-
@@ -279,7 +279,7 @@ cols_add <- function(
   # however, the number of rows should be consistent across the supplied columns
   #
 
-  if (nrow(data_tbl) < 1 && ncol(data_tbl) > 0) {
+  if (nrow(data_tbl) == 0L && ncol(data_tbl) > 0) {
 
     # Generate boxhead rows that correspond to the new columns
     updated_boxh_df <-
@@ -380,18 +380,9 @@ cols_add <- function(
       null_means = "nothing"
     )
 
-  if (length(resolved_column_before) < 1) {
+  if (length(resolved_column_before) == 0) {
     resolved_column_before <- NULL
-  }
-
-  if (
-    !is.null(resolved_column_before) &&
-    length(resolved_column_before) != 1
-  ) {
-
-    if (length(resolved_column_before) < 1) {
-      cli::cli_abort("The expression used for `.before` did not resolve a column.")
-    }
+  } else if (length(resolved_column_before) != 1) {
 
     if (length(resolved_column_before) > 1) {
       cli::cli_abort("The expression used for `.before` resolved multiple columns.")
@@ -405,23 +396,19 @@ cols_add <- function(
       null_means = "nothing"
     )
 
-  if (length(resolved_column_after) < 1) {
+  if (length(resolved_column_after) == 0L) {
     resolved_column_after <- NULL
-  }
-
-  if (
-    !is.null(resolved_column_after) &&
-    length(resolved_column_after) != 1
-  ) {
-
-    if (length(resolved_column_after) < 1) {
-      cli::cli_abort("The expression used for `.after` did not resolve a column.")
-    }
+  } else if (length(resolved_column_after) != 1) {
 
     if (length(resolved_column_after) > 1) {
       cli::cli_abort("The expression used for `.after` resolved multiple columns.")
     }
   }
+
+  if (length(resolved_column_after) == 1 && resolved_column_after == colnames(data_tbl)[NCOL(data_tbl)]) {
+    # if requesting the last column to add after, use NULL instead.
+    resolved_column_after <- NULL
+  } 
 
   # Stop function if expressions are given to both `.before` and `.after`
   if (!is.null(resolved_column_before) && !is.null(resolved_column_after)) {
@@ -454,59 +441,52 @@ cols_add <- function(
   } else if (!is.null(resolved_column_before) && is.null(resolved_column_after)) {
 
     before_colnum <- which(colnames(data_tbl) == resolved_column_before)
+
+    if (before_colnum <= 1) {
+      # put new column first
+      updated_data_tbl <-
+        dplyr::bind_cols(
+          data_tbl_new_cols,
+          data_tbl
+        )
+    } else {
+      updated_data_tbl <-
+        dplyr::bind_cols(
+          dplyr::select(data_tbl, 1:(dplyr::all_of(before_colnum) - 1)),
+          data_tbl_new_cols,
+          dplyr::select(data_tbl, dplyr::all_of(before_colnum):ncol(data_tbl))
+        )
+    }
 
-    updated_data_tbl <-
-      dplyr::bind_cols(
-        dplyr::select(data_tbl, 1:(before_colnum - 1)),
-        data_tbl_new_cols,
-        dplyr::select(data_tbl, before_colnum:ncol(data_tbl))
-      )
 
     before_colnum <- which(boxh_df[["var"]] == resolved_column_before)
 
     updated_boxh_df <-
-      dplyr::bind_rows(
+      vctrs::vec_rbind(
         boxh_df[(1:before_colnum) - 1, ],
         boxh_df_new_cols,
         boxh_df[before_colnum:nrow(boxh_df), ]
       )
 
   } else if (is.null(resolved_column_before) && !is.null(resolved_column_after)) {
 
-    if (resolved_column_after == nrow(data_tbl)) {
+    after_colnum <- which(colnames(data_tbl) == resolved_column_after)
 
-      updated_data_tbl <-
-        dplyr::bind_cols(
-          data_tbl,
-          data_tbl_new_cols
-        )
-
-      updated_boxh_df <-
-        dplyr::bind_rows(
-          boxh_df,
-          boxh_df_new_cols
-        )
-
-    } else {
-
-      after_colnum <- which(colnames(data_tbl) == resolved_column_after)
-
-      updated_data_tbl <-
-        dplyr::bind_cols(
-          dplyr::select(data_tbl, 1:after_colnum),
-          data_tbl_new_cols,
-          dplyr::select(data_tbl, (after_colnum + 1):ncol(data_tbl))
-        )
-
-      after_colnum <- which(boxh_df[["var"]] == resolved_column_after)
+    updated_data_tbl <-
+      dplyr::bind_cols(
+        dplyr::select(data_tbl, 1:dplyr::all_of(after_colnum)),
+        data_tbl_new_cols,
+        dplyr::select(data_tbl, (after_colnum + 1):ncol(data_tbl))
+      )
 
-      updated_boxh_df <-
-        dplyr::bind_rows(
-          boxh_df[1:after_colnum, ],
-          boxh_df_new_cols,
-          boxh_df[(after_colnum + 1):nrow(boxh_df), ]
-        )
-    }
+    after_colnum <- which(boxh_df[["var"]] == resolved_column_after)
+
+    updated_boxh_df <-
+      dplyr::bind_rows(
+        boxh_df[1:after_colnum, ],
+        boxh_df_new_cols,
+        boxh_df[(after_colnum + 1):nrow(boxh_df), ]
+      )
   }
 
   # Modify the internal datasets

diff --git a/R/cols_align_decimal.R b/R/cols_align_decimal.R
@@ -148,7 +148,7 @@ cols_align_decimal <- function(
 
   # If the subsetting of columns finally results in no columns, return
   # the data unchanged
-  if (length(columns) < 1) {
+  if (length(columns) == 0L) {
     return(data)
   }
 

diff --git a/R/dt_body.R b/R/dt_body.R
@@ -36,12 +36,12 @@ dt_body_get <- function(data) {
 }
 
 dt_body_set <- function(data, body) {
-  dt__set(data, .dt_body_key, dplyr::as_tibble(body))
+  dt__set(data, .dt_body_key, body)
 }
 
 dt_body_build_init <- function(data) {
 
-  body <- dt_data_get(data = data)[, dt_boxhead_get_vars(data = data)]
+  body <- dt_data_get(data = data)[dt_boxhead_get_vars(data = data)]
 
   if (NROW(body) > 0) {
     body[] <- NA_character_

diff --git a/R/fmt.R b/R/fmt.R
@@ -176,22 +176,22 @@ normalize_locale <- function(locale = NULL) {
 #'   functions. This is expected as `NULL` if not supplied by the user.
 #' @noRd
 validate_locale <- function(locale, call = rlang::caller_env()) {
+  if (is.null(locale)) {
+    return(NULL)
+  }
 
-  # Stop function if the `locale` provided
-  # isn't a valid one
-  if (
-    !is.null(locale) &&
-    !(gsub("_", "-", locale, fixed = TRUE) %in% locales[["locale"]]) &&
-    !(gsub("_", "-", locale, fixed = TRUE) %in% default_locales[["default_locale"]])
-  ) {
-
-    cli::cli_abort(c(
-      "The supplied `locale` is not available in the list of supported locales.",
-      "i" = "Use {.run [info_locales()](gt::info_locales())} to see which locales can be used."
+  locale <- gsub("_", "-", locale, fixed = TRUE)
+  if (locale %in% c(locales[["locale"]], default_locales[["default_locale"]])) {
+    return(locale)
+  }
+
+  # Stop function if the `locale` provided is invalid
+  cli::cli_abort(c(
+    "The supplied `locale` is not available in the list of supported locales.",
+    "i" = "Use {.run [info_locales()](gt::info_locales())} to see which locales can be used."
     ),
     call = call
-    )
-  }
+  )
 }
 
 #' Validate the user-supplied `currency` value
@@ -293,8 +293,8 @@ get_locale_range_pattern <- function(locale = NULL) {
   range_pattern <- locales$range_pattern[locales$locale == locale]
   validate_length_one(range_pattern)
 
-  range_pattern <- gsub("1", "2", range_pattern)
-  range_pattern <- gsub("0", "1", range_pattern)
+  range_pattern <- gsub("1", "2", range_pattern, fixed = TRUE)
+  range_pattern <- gsub("0", "1", range_pattern, fixed = TRUE)
   range_pattern
 }
 
@@ -1284,7 +1284,7 @@ create_suffix_df <- function(
 
   suffix_fn <- if (system == "intl") num_suffix else num_suffix_ind
 
-  # Create a tibble with scaled values for `x` and the
+  # Create a data frame with scaled values for `x` and the
   # suffix labels to use for character formatting
   suffix_fn(
     round(x, decimals),
@@ -1344,7 +1344,7 @@ num_fmt_factory <- function(
   function(x) {
 
     # Create `x_str` with the same length as `x`
-    x_str <- rep(NA_character_, length(x))
+    x_str <- rep_len(NA_character_, length(x))
 
     # Determine which of `x` are not NA
     non_na_x <- !is.na(x)

diff --git a/R/nanoplot.R b/R/nanoplot.R
@@ -894,8 +894,8 @@ cols_nanoplot <- function(
     cols_add(
       .data = data,
       nanoplots,
-      .before = before,
-      .after = after
+      .before = dplyr::all_of(before),
+      .after = dplyr::all_of(after)
     )
 
   if (!is.null(new_col_name)) {
@@ -923,7 +923,7 @@ cols_nanoplot <- function(
     data <-
       fmt_passthrough(
         data = data,
-        columns = validated_new_col_name,
+        columns = dplyr::all_of(validated_new_col_name),
         escape = FALSE
       )
 
@@ -974,23 +974,23 @@ cols_nanoplot <- function(
         "vertical-align: middle; ",
         "overflow-x: visible;"
       ),
-      locations = cells_body(columns = validated_new_col_name)
+      locations = cells_body(columns = dplyr::all_of(validated_new_col_name))
     )
 
   if (isTRUE(autohide)) {
 
     data <-
       cols_hide(
         data = data,
-        columns = resolved_columns
+        columns = dplyr::all_of(resolved_columns)
       )
 
     if (length(resolved_columns_x) > 0) {
 
       data <-
         cols_hide(
           data = data,
-          columns = resolved_columns_x
+          columns = dplyr::all_of(resolved_columns_x)
         )
     }
   }
@@ -1387,7 +1387,7 @@ generate_data_vals_list <- function(
 
     } else {
 
-      data_vals_i <- dplyr::select(data_tbl, dplyr::all_of(resolved_columns))
+      data_vals_i <- data_tbl[resolved_columns]
 
       data_vals_i <- as.vector(data_vals_i[i, ])
 
@@ -1419,7 +1419,7 @@ generate_data_vals_list <- function(
 
 
         } else {
-          data_vals_j <- c(data_vals_j, unname(unlist(data_vals_i[j][[1]])))
+          data_vals_j <- c(data_vals_j, unlist(data_vals_i[j][[1]], use.names = FALSE))
         }
       }
 

diff --git a/R/tab_create_modify.R b/R/tab_create_modify.R
@@ -1736,7 +1736,8 @@ tab_row_group <- function(
 
   # Set the `_row_groups` vector here with the group id; new groups will
   # be placed at the front, pushing down `NA` (the 'Others' group)
-  arrange_groups_vars <- c(id, stats::na.omit(arrange_groups_vars))
+  arrange_groups_vars <- arrange_groups_vars[!is.na(arrange_groups_vars)]
+  arrange_groups_vars <- c(id, arrange_groups_vars)
   arrange_groups_vars <- unique(arrange_groups_vars)
   arrange_groups_vars <- arrange_groups_vars[arrange_groups_vars %in% stub_df$group_id]