fix for CRAN and ggplot2 v4

Author: jthomasmock

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: gtExtras
 Title: Extending 'gt' for Beautiful HTML Tables
-Version: 0.6.0
+Version: 0.6.1
 Authors@R: c(
     person("Thomas", "Mock", , "j.thomasmock@gmail.com", role = c("aut", "cre", "cph")),
     person("Daniel D.", "Sjoberg", , "danield.sjoberg@gmail.com", role = "ctb", comment = c(ORCID = "0000-0003-0862-2018"))

NEWS.md

@@ -52,18 +52,22 @@
 #' @family Themes
 #' @section Function ID:
 #' 3-10
-gt_plt_conf_int <- function(gt_object,
-                            column,
-                            ci_columns,
-                            ci = 0.9,
-                            ref_line = NULL,
-                            palette = c("black", "grey", "white", "black"),
-                            width = 45,
-                            text_args = list(accuracy = 1),
-                            text_size = 1.5) {
+gt_plt_conf_int <- function(
+  gt_object,
+  column,
+  ci_columns,
+  ci = 0.9,
+  ref_line = NULL,
+  palette = c("black", "grey", "white", "black"),
+  width = 45,
+  text_args = list(accuracy = 1),
+  text_size = 1.5
+) {
   all_vals <- gt_index(gt_object, {{ column }}, as_vector = FALSE)
 
-  stopifnot("Confidence level must be between 0 and 1" = dplyr::between(ci, 0, 1))
+  stopifnot(
+    "Confidence level must be between 0 and 1" = dplyr::between(ci, 0, 1)
+  )
   # convert desired confidence interval from percentage
   # to a two-tailed level to be used in confint() function
   level <- 1 - ((1 - ci) * 2)
@@ -86,8 +90,10 @@ gt_plt_conf_int <- function(gt_object,
 
   if ("none" %in% ci_val1) {
     stopifnot(
-      "Must provide list column if no defined Confidence Intervals" =
-        (class(column_vals) %in% c("list"))
+      "Must provide list column if no defined Confidence Intervals" = (class(
+        column_vals
+      ) %in%
+        c("list"))
     )
 
     # create a list of dataframes with
@@ -106,8 +112,10 @@ gt_plt_conf_int <- function(gt_object,
     })
   } else {
     stopifnot(
-      "Must provide single values per row if defining Confidence Intervals" =
-        !(class(column_vals) %in% "list")
+      "Must provide single values per row if defining Confidence Intervals" = !(class(
+        column_vals
+      ) %in%
+        "list")
     )
 
     data_in <- dplyr::tibble(mean = column_vals, y = "1a") %>%
@@ -158,7 +166,6 @@ gt_plt_conf_int <- function(gt_object,
 }
 
 
-
 #' Add a confidence interval plot inside a specific row
 #'
 #' @param data_in A dataframe of length 1
@@ -170,13 +177,15 @@ gt_plt_conf_int <- function(gt_object,
 #' @noRd
 #'
 #' @return SVG/HTML
-add_ci_plot <- function(data_in,
-                        pal_vals,
-                        width,
-                        ext_range,
-                        text_args = list(scale_cut = cut_short_scale()),
-                        text_size,
-                        ref_line) {
+add_ci_plot <- function(
+  data_in,
+  pal_vals,
+  width,
+  ext_range,
+  text_args = list(scale_cut = cut_short_scale()),
+  text_size,
+  ref_line
+) {
   if (NA %in% unlist(data_in)) {
     return("&nbsp;")
   }
@@ -232,12 +241,15 @@ add_ci_plot <- function(data_in,
       position = position_nudge(y = 0.25),
       family = "mono",
       fontface = "bold",
-      label.size = unit(0, "lines"),
+      label.size = 0,
       label.padding = unit(0.05, "lines"),
       label.r = unit(0, "lines")
     ) +
     geom_label(
-      aes(x = .data$ci1, label = do.call(scales::label_number, text_args)(.data$ci1)),
+      aes(
+        x = .data$ci1,
+        label = do.call(scales::label_number, text_args)(.data$ci1)
+      ),
       position = position_nudge(y = 0.25),
       color = pal_vals[4],
       hjust = -0.1,
@@ -246,7 +258,7 @@ add_ci_plot <- function(data_in,
       fill = "transparent",
       family = "mono",
       fontface = "bold",
-      label.size = unit(0, "lines"),
+      label.size = 0,
       label.padding = unit(0.05, "lines"),
       label.r = unit(0, "lines")
     ) +

R/gt_plt_conf_int.R

@@ -1,7 +1,6 @@
 ## Submission details
 
 - This is an update to solve a few bugs as indicated by users and CRAN maintainers.
-- Fixed the version of package to be stable and not release version (0.6.0)
 
 ## R CMD check results
 
@@ -12,14 +11,19 @@ Checked against automated test environments, RHub, MacBuilder, and WinBuilder (o
 ## Automated Test environments
 
 on Github Actions:
+
 - ubuntu (devel, release, oldrel)
 - windows (release)
 - macOS (release)
 
 on R-universe
+
 - Windows (devel, release, oldrel)
 - MacOS (release, oldrel)
 
 ## R CMD check results
 
-0 errors | 0 warnings | 0 note
+── R CMD check results ─────── gtExtras 0.6.1 ────
+Duration: 42.7s
+
+0 errors ✔ | 0 warnings ✔ | 0 notes ✔

cran-comments.md

@@ -45,6 +45,7 @@
 
 test_that("gt_pct_bar SVG is created and has specific palette", {
   check_suggests()
+  testthat::skip_on_cran()
 
   ex_df <- dplyr::tibble(
     x = c(
@@ -76,7 +77,10 @@ test_that("gt_pct_bar SVG is created and has specific palette", {
 
   ex_tab <- tab_df %>%
     gt::gt() %>%
-    gt_plt_bar_stack(column = list_data, labels = c("Lab 1", "Lab 2")) %>%
+    gtExtras::gt_plt_bar_stack(
+      column = list_data,
+      labels = c("Lab 1", "Lab 2")
+    ) %>%
     gt::as_raw_html() %>%
     rvest::read_html()
 
@@ -86,13 +90,15 @@ test_that("gt_pct_bar SVG is created and has specific palette", {
     as.double()
 
   bar_colors <- ex_tab %>%
-    rvest::html_nodes("svg > g > g > rect") %>%
+    rvest::html_nodes(
+      "svg > g > g > rect:nth-child(2), svg > g > g > rect:nth-child(3)"
+    ) %>%
     rvest::html_attr("style") %>%
     gsub(x = ., pattern = ".*fill: #", "")
 
   expect_equal(
     round(bar_vals, 2),
-    c(0.00, 119.06, 0.00, 124.02, 0.00, 85.04, 0.00, 85.04)
+    c(0.00, 0, 119.06, 0.00, 0, 124.02, 0.00, 0, 85.04, 0.00, 0, 85.04)
   )
   expect_equal(
     bar_colors,

tests/testthat/test-gt_pct_bar.R

@@ -33,11 +33,11 @@ test_that("gt_plt_bar svg is created and has specific values", {
   # SVG has specific points ----
 
   bar_vals <- bar_tbl %>%
-    rvest::html_nodes("svg > g > g > rect") %>%
+    rvest::html_nodes("svg > g > g > rect:nth-child(2)") %>%
     rvest::html_attr("width")
 
   bar_neg_vals <- bar_tbl_neg %>%
-    rvest::html_nodes("svg > g > g > rect") %>%
+    rvest::html_nodes("svg > g > g > rect:nth-child(2)") %>%
     rvest::html_attr("width")
 
   expect_equal(

tests/testthat/test-gt_plt_bar.R

@@ -0,0 +1,149 @@
+# R
+
+test_that("gt_pct_bar SVG structure, positions, and default palette are correct", {
+  check_suggests()
+  testthat::skip_on_cran()
+
+  # Helpers
+  get_bar_rect_nodes <- function(doc) {
+    nodes <- rvest::html_nodes(doc, "svg > g > g > rect")
+    if (length(nodes) == 0) {
+      nodes <- rvest::html_nodes(doc, "svg > g > rect")
+    }
+    nodes
+  }
+  normalize_colors <- function(styles) {
+    # Extract hex after 'fill: #' and remove trailing ';', make uppercase
+    cols <- gsub(".*fill:\\s*#([0-9a-fA-F]{6}).*", "\\1", styles, perl = TRUE)
+    toupper(cols)
+  }
+
+  # Data
+  ex_df <- dplyr::tibble(
+    x = c(
+      "Example 1",
+      "Example 1",
+      "Example 2",
+      "Example 2",
+      "Example 3",
+      "Example 3",
+      "Example 4",
+      "Example 4"
+    ),
+    measure = c(
+      "Measure 1",
+      "Measure 2",
+      "Measure 1",
+      "Measure 2",
+      "Measure 1",
+      "Measure 2",
+      "Measure 1",
+      "Measure 2"
+    ),
+    data = c(30, 20, 50, 30, 30, 40, 30, 40)
+  )
+
+  tab_df <- ex_df %>%
+    dplyr::group_by(x) %>%
+    dplyr::summarise(list_data = list(data), .groups = "drop")
+
+  ex_tab <- tab_df %>%
+    gt::gt() %>%
+    gt_plt_bar_stack(column = list_data, labels = c("Lab 1", "Lab 2")) %>%
+    gt::as_raw_html() %>%
+    rvest::read_html()
+
+  rect_nodes <- get_bar_rect_nodes(ex_tab)
+  expect_gt(length(rect_nodes), 0L)
+
+  # Extract attributes
+  bar_x <- ex_tab %>%
+    rvest::html_nodes(
+      "svg > g > g > text:nth-child(4), svg > g > g > text:nth-child(5)"
+    ) %>%
+    rvest::html_attr("x") %>%
+    as.double()
+
+  styles <- ex_tab %>%
+    rvest::html_nodes(
+      "svg > g > g > text:nth-child(4), svg > g > g > text:nth-child(5)"
+    ) %>%
+    rvest::html_attr("style")
+
+  # There should be 4 rows * 2 segments
+  expect_length(bar_x, 8L)
+  expect_length(styles, 8L)
+})
+
+test_that("gt_pct_bar respects a custom two-color palette", {
+  check_suggests()
+  testthat::skip_on_cran()
+
+  # Helpers
+  get_bar_rect_nodes <- function(doc) {
+    nodes <- rvest::html_nodes(doc, "svg > g > g > rect")
+    if (length(nodes) == 0) {
+      nodes <- rvest::html_nodes(doc, "svg > g > rect")
+    }
+    nodes
+  }
+  normalize_colors <- function(styles) {
+    cols <- gsub(".*fill:\\s*#([0-9a-fA-F]{6}).*", "\\1", styles, perl = TRUE)
+    toupper(cols)
+  }
+
+  pal <- c("#112233", "#8899AA")
+
+  ex_df <- dplyr::tibble(
+    x = c(
+      "Example 1",
+      "Example 1",
+      "Example 2",
+      "Example 2",
+      "Example 3",
+      "Example 3",
+      "Example 4",
+      "Example 4"
+    ),
+    measure = c(
+      "Measure 1",
+      "Measure 2",
+      "Measure 1",
+      "Measure 2",
+      "Measure 1",
+      "Measure 2",
+      "Measure 1",
+      "Measure 2"
+    ),
+    data = c(30, 20, 50, 30, 30, 40, 30, 40)
+  )
+
+  tab_df <- ex_df %>%
+    dplyr::group_by(x) %>%
+    dplyr::summarise(list_data = list(data), .groups = "drop")
+
+  ex_tab <- tab_df %>%
+    gt::gt() %>%
+    gt_plt_bar_stack(column = list_data, palette = pal) %>%
+    gt::as_raw_html() %>%
+    rvest::read_html()
+
+  rect_nodes <- ex_tab %>%
+    rvest::html_nodes(
+      "svg > g > g > text:nth-child(4), svg > g > g > text:nth-child(5)"
+    ) %>%
+    rvest::html_attr("x") %>%
+    as.double()
+  expect_gt(length(rect_nodes), 0L)
+
+  # Extract attributes
+
+  styles <- ex_tab %>%
+    rvest::html_nodes(
+      "svg > g > g > text:nth-child(4), svg > g > g > text:nth-child(5)"
+    ) %>%
+    rvest::html_attr("style")
+
+  cols <- normalize_colors(styles)
+  expect_length(cols, 8L)
+})