Merge branch 'main' into 2032_tbl_hierarchical_digits

R/import-standalone-stringr.R

@@ -5,7 +5,7 @@
 # ---
 # repo: insightsengineering/standalone
 # file: standalone-stringr.R
-# last-updated: 2024-06-05
+# last-updated: 2024-11-01
 # license: https://unlicense.org
 # imports: rlang
 # ---
@@ -15,6 +15,8 @@
 # of programming.
 #
 # ## Changelog
+# 2024-11-01
+#   - `str_pad()` was updated to use `strrep()` instead of `sprintf()` (accommodates escape characters).
 #
 # nocov start
 # styler: off
@@ -108,21 +110,27 @@ str_sub_all <- function(string, start = 1L, end = -1L) {
 }
 
 str_pad <- function(string, width, side = c("left", "right", "both"), pad = " ", use_width = TRUE) {
-  side <- match.arg(side, c("left", "right", "both"))
-
-  if (side == "both") {
-    pad_left <- (width - nchar(string)) %/% 2
-    pad_right <- width - nchar(string) - pad_left
-    padded_string <- paste0(strrep(pad, pad_left), string, strrep(pad, pad_right))
-  } else {
-    format_string <- ifelse(side == "right", paste0("%-", width, "s"),
-                            ifelse(side == "left", paste0("%", width, "s"),
-                                   paste0("%", width, "s")))
-
-    padded_string <- sprintf(format_string, string)
-  }
-
-  return(padded_string)
+  side <- match.arg(side)
+
+  # allow vectorized input
+  padded_strings <- sapply(string, function(s) {
+    current_length <- nchar(s)
+    pad_length <- width - current_length
+
+    if (side == "both") {
+      pad_left <- pad_length %/% 2
+      pad_right <- pad_length - pad_left
+      padded_string <- paste0(strrep(pad, pad_left), s, strrep(pad, pad_right))
+    } else if (side == "right") {
+      padded_string <- paste0(s, strrep(pad, pad_length))
+    } else { # side == "left"
+      padded_string <- paste0(strrep(pad, pad_length), s)
+    }
+
+    return(padded_string)
+  })
+
+  return(unname(padded_strings))
 }
 
 str_split <- function(string, pattern, n = Inf, fixed = FALSE, perl = !fixed) {

tests/testthat/_snaps/show_header_names.md

@@ -86,3 +86,18 @@
       * These values may be dynamically placed into headers (and other locations).
       i Review the `modify_header()` (`?gtsummary::modify_header()`) help for examples.
 
+# show_header_names() has all values aligned
+
+    Code
+      show_header_names(test_table)
+    Output
+      Column Name   Header                                                                            level*                       N*          n*         p*             
+      label         "**Primary System Organ Class**  \n    **Reported Term for the Adverse Event**"                                254 <int>                             
+      stat_1        "**Placebo**  \nN = 86"                                                                        Placebo <chr>   254 <int>   86 <int>   0.339 <dbl>    
+      stat_2        "**Xanomeline High Dose**  \nN = 84"                                              Xanomeline High Dose <chr>   254 <int>   84 <int>   0.331 <dbl>    
+      stat_3        "**Xanomeline Low Dose**  \nN = 84"                                                Xanomeline Low Dose <chr>   254 <int>   84 <int>   0.331 <dbl>    
+      
+    Message
+      * These values may be dynamically placed into headers (and other locations).
+      i Review the `modify_header()` (`?gtsummary::modify()`) help for examples.
+

tests/testthat/test-show_header_names.R

@@ -63,3 +63,19 @@ test_that("show_header_names() returns single class value", {
     test_table |> show_header_names()
   )
 })
+
+
+test_that("show_header_names() has all values aligned", {
+  withr::local_options(list(width = 120))
+    test_table <- tbl_hierarchical(
+      data = cards::ADAE,
+      variables = c(AESOC, AETERM),
+      by = TRTA,
+      denominator = cards::ADSL |> mutate(TRTA = ARM),
+      id = USUBJID
+    )
+
+    expect_snapshot(
+      test_table |> show_header_names()
+    )
+})