Simplify conditions, use vctrs, use dev covr for test-coverage

.github/workflows/test-coverage.yaml

@@ -25,7 +25,7 @@ jobs:
 
       - uses: r-lib/actions/setup-r-dependencies@v2
         with:
-          extra-packages: any::covr, any::xml2
+          extra-packages: r-lib/covr, any::xml2
           needs: coverage
 
       - name: Test coverage

R/compile_scss.R

@@ -51,7 +51,7 @@ compile_scss <- function(data, id = NULL) {
   additional_css <- dt_options_get_value(data = data, option = "table_additional_css")
 
   # Determine if there are any additional CSS statements
-  has_additional_css <- any(nchar(additional_css) > 0)
+  has_additional_css <- any(nzchar(additional_css))
 
   # Combine any additional CSS statements and separate with `\n`
   if (has_additional_css) {

R/dt_heading.R

@@ -67,7 +67,7 @@ dt_heading_has_title <- function(data) {
 
   heading <- dt_heading_get(data = data)
 
-   length(heading) > 0 && !is.null(heading$title) && length(heading$title) > 0
+   length(heading) > 0 && length(heading$title) > 0
 }
 
 dt_heading_has_subtitle <- function(data) {

R/dt_stub_df.R

@@ -79,7 +79,6 @@ dt_stub_df_init <- function(
   # Handle column of data specified as the `groupname_col`
   #
   if (
-    !is.null(groupname_col) &&
     length(groupname_col) > 0L &&
     all(groupname_col %in% colnames(data_tbl))
   ) {

R/dt_summary.R

@@ -131,18 +131,13 @@ dt_summary_build <- function(data, context) {
 
       groups <- unique(stub_df$group_id)
 
-    } else if (
-      !is.null(groups) &&
-      is.character(groups) &&
-      length(groups) == 1 &&
-      groups == ":GRAND_SUMMARY:"
-    ) {
+    } else if (is_string(groups, ":GRAND_SUMMARY:")) {
 
       # If groups is given as ":GRAND_SUMMARY:" then use a
       # special group (`::GRAND_SUMMARY`)
       groups <- grand_summary_col
 
-    } else if (!is.null(groups) && is.character(groups)) {
+    } else if (is.character(groups)) {
 
       assert_rowgroups()
 

R/fmt.R

@@ -184,7 +184,7 @@ validate_locale <- function(locale, call = rlang::caller_env()) {
   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.",
@@ -252,7 +252,7 @@ get_locale_sep_mark <- function(
 
   # Get the correct `group_sep` value from the `gt:::locales` lookup table
   sep_mark <- locales$group[locales$locale == locale]
-  validate_length_one(sep_mark)
+  validate_length_one(sep_mark, "sep_mark")
   # Replace any `""` or "\u00a0" with `" "` since an empty string actually
   # signifies a space character, and, we want to normalize to a simple space
   if (sep_mark == "" || sep_mark == "\u00a0") sep_mark <- " "
@@ -291,7 +291,7 @@ get_locale_range_pattern <- function(locale = NULL) {
 
   # Get the correct `range_pattern` value from the `gt:::locales` lookup table
   range_pattern <- locales$range_pattern[locales$locale == locale]
-  validate_length_one(range_pattern)
+  validate_length_one(range_pattern, "range_pattern")
 
   range_pattern <- gsub("1", "2", range_pattern, fixed = TRUE)
   range_pattern <- gsub("0", "1", range_pattern, fixed = TRUE)
@@ -332,7 +332,7 @@ get_locale_idx_set <- function(locale = NULL) {
   }
 
   val <- locales$chr_index[locales$locale == locale]
-  validate_length_one(val)
+  validate_length_one(val, "locale")
   val
 }
 
@@ -388,7 +388,7 @@ get_locale_no_table_data_text <- function(locale = NULL) {
   # Get the correct `no_table_data_text` value from the
   # `gt:::locales` lookup table
   val <- locales$no_table_data_text[locales$locale == locale]
-  validate_length_one(val)
+  validate_length_one(val, "locale")
   val
 }
 

R/gt_group.R

@@ -796,7 +796,7 @@ grp_options <- function(
     dplyr::bind_rows(
       dplyr::inner_join(
         new_df,
-        dplyr::select(opts_df, -value),
+        dplyr::select(opts_df, -"value"),
         by = "parameter"
       ),
       dplyr::anti_join(opts_df, new_df, by = "parameter")

R/render_as_i_html.R

@@ -397,7 +397,7 @@ render_as_ihtml <- function(data, id) {
     # for defaultExpanded = TRUE
     expand_groupname_col <- TRUE
     # modify data_tbl to include
-    data_tbl <- dplyr::bind_cols(
+    data_tbl <- vctrs::vec_cbind(
       data_tbl,
       data_tbl0[ , groupname_col, drop = FALSE]
     )

R/resolver.R

@@ -153,13 +153,13 @@ resolve_cells_column_spanners <- function(
 
   spanners <- dt_spanners_get(data = data)
 
-  levels <- attr(object,"spanner_levels")
+  levels <- attr(object, "spanner_levels")
 
-  if(!is.null(levels)){
+  if (!is.null(levels)) {
     # check if there are wrong level expectations in the argument
 
     # must be numeric
-    if(!all(suppressWarnings(!is.na(as.numeric(levels))))){
+    if (!all(suppressWarnings(!is.na(as.numeric(levels))))) {
       cli::cli_warn(c(
         "All values of vector `levels` must be numeric.",
         "!" = "Please check wrong element{?/s}: [{levels[suppressWarnings(is.na(as.numeric(levels)))]}]."
@@ -170,7 +170,7 @@ resolve_cells_column_spanners <- function(
     # must actually exist
 
     wrong_levels <- setdiff(levels, unique(spanners$spanner_level))
-    if(length(wrong_levels) > 0){
+    if (length(wrong_levels) > 0) {
       cli::cli_warn(c(
         "All values of vector `levels` must exist in spanner definition.",
         "i" = "currently only the following level{?s} {?is/are} available: [{as.character(unique(spanners$spanner_level))}].",
@@ -261,9 +261,9 @@ resolve_cols_c <- function(
     ret <- names(dt_data_get(data))
     return(ret)
   }
-  
+
   null_means <- rlang::arg_match0(null_means, c("everything", "nothing"))
-  
+
   names(
     resolve_cols_i(
       expr = {{ expr }},
@@ -520,11 +520,11 @@ resolve_rows_i <- function(
       call = call
     )
 
-  if (!is.null(resolved_rows)) {
-    return(which(resolved_rows))
-  } else {
+  if (is.null(resolved_rows)) {
     return(NULL)
   }
+
+  which(resolved_rows)
 }
 
 resolve_vector_l <- function(
@@ -601,7 +601,7 @@ resolve_groups <- function(expr, vector) {
     resolved <- NULL
   }
 
-  if (length(resolved) < 1) {
+  if (length(resolved) == 0) {
     # Error if groups = everything() and no row groups. Return NULL otherwise.
     input <- tryCatch(rlang::as_label(quo), error = NULL)
     if (identical(input, "everything()")) {
@@ -624,7 +624,7 @@ resolve_groups <- function(expr, vector) {
 
     resolved <- base::intersect(resolved, vector)
 
-    if (length(resolved) < 1) {
+    if (length(resolved) == 0) {
       return(NULL)
     }
 

R/summary_rows.R

@@ -443,12 +443,7 @@ summary_rows <- function(
     data$`_data` <-
       dplyr::mutate(
         data$`_data`,
-        !!rowname_col_private := rep("", nrow(data$`_data`))
-      )
-    data$`_data` <-
-      dplyr::relocate(
-        data$`_data`,
-        dplyr::all_of(rowname_col_private),
+        !!rowname_col_private := rep("", nrow(data$`_data`)),
         .after = dplyr::last_col()
       )
 

R/tab_options.R

@@ -906,7 +906,7 @@ tab_options <- function(
     dplyr::bind_rows(
       dplyr::inner_join(
         new_df,
-        dplyr::select(opts_df, -value),
+        dplyr::select(opts_df, -"value"),
         by = "parameter"
       ),
       dplyr::anti_join(opts_df, new_df, by = "parameter")
@@ -946,9 +946,7 @@ tab_options <- function(
 dt_options_get_default_value <- function(option) {
 
   # Validate the provided `option` value
-  if (length(option) != 1) {
-    cli::cli_abort("A character vector of length one must be provided.")
-  }
+  check_string(option)
   if (!(option %in% dt_options_tbl$parameter)) {
     cli::cli_abort("The `option` provided is invalid.")
   }
@@ -1046,12 +1044,7 @@ set_super_options <- function(arg_vals) {
 
   if ("ihtml.selection_mode" %in% names(arg_vals)) {
     ihtml_selection_mode_val <- arg_vals$ihtml.selection_mode
-    if (
-        !(
-          rlang::is_scalar_character(ihtml_selection_mode_val) &&
-          ihtml_selection_mode_val %in% c("single", "multiple")
-        )
-    ) {
+    if (!rlang::is_string(ihtml_selection_mode_val, c("single", "multiple"))) {
       cli::cli_abort(c(
         "The chosen option for `ihtml.selection_mode` (`{ihtml_selection_mode_val}`) is invalid.",
         "*" = "We can use either \"single\" or \"multiple\"."

R/utils_render_grid.R

@@ -104,17 +104,17 @@ create_heading_component_g <- function(data) {
 
   title_styles <- NA_character_
   if ("title" %in% styles_tbl$locname) {
-    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
+    title_styles <- vctrs::vec_slice(styles_tbl$html_style, styles_tbl$locname == "title")
+    if (length(title_styles) == 0) {
+      title_styles <- NA_character_
     }
   }
 
   subtitle_styles <- NA_character_
   if (subtitle_defined && "subtitle" %in% styles_tbl$locname) {
-    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
+    subtitle_styles <- vctrs::vec_slice(styles_tbl$html_style, styles_tbl$locname == "subtitle")
+    if (length(subtitle_styles) == 0) {
+      subtitle_styles <- NA_character_
     }
   }
 

R/utils_render_html.R

@@ -190,7 +190,7 @@ styles_to_html <- function(styles) {
           style <- as.character(x)
         } else if (all(names(x) != "")) {
           x <- cell_style_to_html(x)
-          style <- gsub(";;", ";", paste0(names(x), ": ", x, ";", collapse = " "))
+          style <- gsub(";;", ";", paste0(names(x), ": ", x, ";", collapse = " "), fixed = TRUE)
         } else {
           style <- as.character(x)
         }
@@ -417,11 +417,11 @@ create_heading_component_h <- function(data) {
   # Get the style attrs for the title
   if ("title" %in% styles_tbl$locname) {
 
-    title_style_rows <- styles_tbl[styles_tbl$locname == "title", ]
-
-    if (nrow(title_style_rows) > 0) {
-      title_styles <- title_style_rows$html_style
-    } else {
+    title_styles <- vctrs::vec_slice(
+      styles_tbl$html_style,
+      styles_tbl$locname == "title"
+    )
+    if (length(title_styles) == 0) {
       title_styles <- NULL
     }
 
@@ -450,11 +450,12 @@ create_heading_component_h <- function(data) {
 
   # Get the style attrs for the subtitle
   if (subtitle_defined && "subtitle" %in% styles_tbl$locname) {
-    subtitle_style_rows <- styles_tbl[styles_tbl$locname == "subtitle", ]
+    subtitle_styles <- vctrs::vec_slice(
+      styles_tbl$html_style,
+      styles_tbl$locname == "subtitle"
+    )
 
-    if (nrow(subtitle_style_rows) > 0) {
-      subtitle_styles <- subtitle_style_rows$html_style
-    } else {
+    if (length(subtitle_styles) == 0) {
       subtitle_styles <- NULL
     }
 

R/utils_render_latex.R

@@ -46,10 +46,7 @@ footnote_mark_to_latex <- function(
   }
 
   spec <- get_footnote_spec_by_location(data = data, location = location)
-
-  if (is.null(spec)) {
-    spec <- "^i"
-  }
+  spec <- spec %||% "^i"
 
   if (grepl(".", spec, fixed = TRUE)) mark <- sprintf_unless_na("%s.", mark)
   if (grepl("b", spec, fixed = TRUE)) mark <- sprintf_unless_na("\\textbf{%s}", mark)
@@ -156,18 +153,18 @@ create_table_start_l <- function(data, colwidth_df) {
   if ("group_label" %in% stub_layout) {
     types <- c(types, "row_group")
   }
-  
+
   colwidth_df_visible <- colwidth_df[colwidth_df$type %in% types, ]
-  
-  # Ensure that the `colwidth_df_visible` df rows are sorted such that the 
+
+  # Ensure that the `colwidth_df_visible` df rows are sorted such that the
   # `"row_group"` row is first (only if it's located in the stub), then `"stub"`,
   # and then everything else
   if ("stub" %in% colwidth_df_visible[["type"]]) {
     stub_idx <- which(colwidth_df_visible$type == "stub")
     othr_idx <- base::setdiff(seq_len(nrow(colwidth_df_visible)), stub_idx)
     colwidth_df_visible <- vctrs::vec_slice(colwidth_df_visible, c(stub_idx, othr_idx))
   }
-  
+
   if ("row_group" %in% colwidth_df_visible[["type"]]) {
     row_group_idx <- which(colwidth_df_visible$type == "row_group")
     othr_idx <- base::setdiff(seq_len(nrow(colwidth_df_visible)), row_group_idx)
@@ -200,7 +197,7 @@ create_table_start_l <- function(data, colwidth_df) {
     col_defs <- NULL
 
     for (i in seq_len(nrow(colwidth_df_visible))) {
-      
+
       if (colwidth_df_visible$unspec[i] == 1L) {
         col_defs_i <- substr(colwidth_df_visible$column_align[i], 1, 1)
       } else {
@@ -228,7 +225,7 @@ create_table_start_l <- function(data, colwidth_df) {
     }
 
   } else {
-    
+
     col_defs <- substr(colwidth_df_visible$column_align, 1, 1)
   }
 
@@ -1710,7 +1707,7 @@ create_colwidth_df_l <- function(data) {
     pt = rep.int(0L, n),
     column_align = boxhead$column_align
   )
-  
+
   width_df$column_align[width_df$type %in% c("stub", "row_group")] <- "left"
 
   for (i in 1:n) {

R/z_utils_render_footnotes.R

@@ -236,7 +236,7 @@ resolve_footnotes_styles <- function(data, tbl_type) {
     # Re-combine `tbl_not_column_cells`
     # with `tbl_column_cells`
     tbl <-
-      dplyr::bind_rows(
+      vctrs::vec_rbind(
         tbl_not_column_cells,
         tbl_column_cells
       )

R/zzz.R

@@ -138,7 +138,7 @@ utils::globalVariables(
 #'
 #' **gt** uses the following [options()] to configure behavior:
 #'
-#' - `gt.locale`: A [locale][info_locales()] to yse by default in
+#' - `gt.locale`: A [locale][info_locales()] to use by default in
 #'  the [gt()] function.
 #' - `gt.row_group.sep`: A separator between groups for the row group label. By
 #' default this is `" - "`.
@@ -151,7 +151,7 @@ utils::globalVariables(
 #' - `gt.latex_packages`: A vector of LaTeX package names to use when generating
 #' tables in the LaTeX output context. The set of packages loaded is controlled
 #' by this default vector:
-#' `c("booktabs", "caption", "longtable", "colortbl", "array")`.
+#' `c("booktabs", "caption", "longtable", "colortbl", "array", "anyfontsize", "multirow")`.
 #'
 #' @keywords internal
 #' @name gt-options