Merge pull request #429 from GSK-Biostatistics/bug-width-postspace

Make post space width fill optional

DESCRIPTION

@@ -36,7 +36,7 @@ License: Apache License (>= 2)
 Encoding: UTF-8
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.1
 Suggests: 
     covr,
     testthat (>= 3.0.0),

NAMESPACE

@@ -20,8 +20,15 @@ S3method(as_json,quosure)
 S3method(as_json,quosures)
 S3method(as_json,span_structure)
 S3method(as_json,tfrmt)
+S3method(as_length_one_quo,character)
+S3method(as_length_one_quo,quosure)
+S3method(as_length_one_quo,quosures)
+S3method(as_vars,character)
+S3method(as_vars,quosure)
+S3method(as_vars,quosures)
 S3method(cleaned_data_to_gt,default)
 S3method(cleaned_data_to_gt,list)
+S3method(format,body_plan)
 S3method(format,frmt)
 S3method(format,frmt_combine)
 S3method(format,frmt_structure)

NEWS.md

@@ -2,6 +2,8 @@
 
 Bug fixes
 * Fixed issue where `frmt_combine` couldn't process variable names surrounded by backticks
+* Fixed issue where `row_grp_plan` post space did not respect `col_style_plan` widths by adding new `fill` argument to `element_block`. The `fill` argument controls whether post space values should be recycled for the cell's data width. For example, a cell width of 3 will be respected by the post space with the following syntax: `element_block(post_space = "---", fill = FALSE)`. 
+* Remove unused `border` argument in `element_block`. 
 * Fixed bug where `row_grp_plan` splits on all grouping variables, even if not mentioned. Instead, the logic has been updated to split on those explicitly mentioned, similar to `page_plan`
 
 # tfrmt 0.1.0

R/apply_row_grp_plan.R

@@ -165,9 +165,11 @@ apply_grp_block <- function(.data, group, element_block, widths){
       slice(n()) %>%
       mutate(across(c(-map_chr(group, as_name), -vars_select_helpers$where(is.numeric)),
                     ~replace(.x, value = fill_post_space(post_space = element_block$post_space,
-                                                           width = widths[[cur_column()]]))),
+                                                         fill = element_block$fill,
+                                                         width = widths[[cur_column()]]))),
              TEMP_row = .data$TEMP_row + 0.1)
 
+
     # combine with original data
     bind_rows(.data, grp_row_add) %>%
       fill(!!!group)
@@ -181,22 +183,28 @@ apply_grp_block <- function(.data, group, element_block, widths){
 #' Fill the cell value with post space character
 #'
 #' @param post_space Character value for post space
+#' @param fill Whether to recycle value in `post_space` to match data width
 #' @param width width to make the post_space value in order to fill the cell
 #'
 #' @return character value containing post space value modified to fill cell
 #' @noRd
 #'
 #' @importFrom stringr str_sub
-fill_post_space <- function(post_space, width){
+fill_post_space <- function(post_space, fill, width){
 
   ## if only white space, no need to make wider for visuals
   if(grepl("^\\s*$", post_space)){
     return(" ")
   }
 
   length_post_space <- nchar(post_space)
-  reps <- ceiling(width/length_post_space)
-  fill_val <- strrep(post_space, reps) %>% str_sub(1, width)
+
+  if (fill) {
+    reps <- ceiling(width/length_post_space)
+    fill_val <- strrep(post_space, reps) %>% str_sub(1, width)
+  } else {
+    fill_val <- str_sub(post_space, 1, width) # truncate to data width if needed
+  }
 
   return(fill_val)
 

R/frmt_utils.R

@@ -176,7 +176,8 @@ print.frmt_structure <- function(x, ...){
   cat(format(x, ...), sep = "\n")
 }
 
-
+#' @export
+#' @keywords internal
 format.body_plan <- function(x,...){
 
   table_body_plan_str <- c(

R/tfrmt.R

@@ -423,10 +423,14 @@ as_length_one_quo <- function(x, ...){
   UseMethod("as_length_one_quo",x)
 }
 
+#' @export
+#' @keywords internal
 as_length_one_quo.quosure <- function(x, ...){
   x
 }
 
+#' @export
+#' @keywords internal
 #' @importFrom rlang warn
 as_length_one_quo.quosures <- function(x, ..., arg = NULL){
   if(length(x) == 0){
@@ -446,6 +450,8 @@ as_length_one_quo.quosures <- function(x, ..., arg = NULL){
   }
 }
 
+#' @export
+#' @keywords internal
 as_length_one_quo.character <- function(x, ...){
   quo(!!sym(x))
 }
@@ -454,14 +460,20 @@ as_vars <-  function(x){
   UseMethod("as_vars",x)
 }
 
+#' @export
+#' @keywords internal
 as_vars.quosures <- function(x){
   x
 }
 
+#' @export
+#' @keywords internal
 as_vars.quosure <- function(x){
   vars(!!x)
 }
 
+#' @export
+#' @keywords internal
 as_vars.character <- function(x){
   do.call(vars,lapply(x,function(x){ quo(!!sym(x))}))
 }

R/theme_element.R

@@ -57,8 +57,8 @@ is_element_row_grp_loc <- function(x){
 
 #' Element block
 #'
-#' @param post_space Option to create a new line after group block; specified characters will fill the cells
-#' @param border Option to add a solid border to group block (rectangle or just bottom border)
+#' @param post_space Values to show in a new line created after the group block
+#' @param fill Whether to recycle the value of `post_space` to match width of the data. Defaults to `TRUE`
 #'
 #' @return element block object
 #'
@@ -84,9 +84,9 @@ is_element_row_grp_loc <- function(x){
 #'   )
 #' )
 element_block <- function(post_space = c(NULL, " ", "-"),
-                          border = c(NULL, "outline", "bottom")){
+                          fill = TRUE){
   structure(
-    list(post_space = post_space, border = border),
+    list(post_space = post_space, fill = fill),
     class = c("element_block", "element")
   )
 

tests/testthat/_snaps/JSON.md

@@ -56,14 +56,14 @@
               "group_val": ["A", "C"],
               "block_to_apply": {
                 "post_space": ["---"],
-                "border": ["outline", "bottom"]
+                "fill": [true]
               }
             },
             {
               "group_val": ["B"],
               "block_to_apply": {
                 "post_space": [" "],
-                "border": ["outline", "bottom"]
+                "fill": [true]
               }
             }
           ],
@@ -94,7 +94,7 @@
               },
               "block_to_apply": {
                 "post_space": [" "],
-                "border": ["outline", "bottom"]
+                "fill": [true]
               }
             }
           ],

tests/testthat/test-apply_row_grp_plan.R

@@ -272,6 +272,35 @@ test_that("post space is truncated to data width",{
       "D",  "--------", "--------",  "--------"))
 })
 
+
+test_that("do not recycle the post space for full width",{
+
+  df <- tibble(
+    grp1 = c("A","B","C","D"),
+    trtA = rep("xx (xx%)", 4),
+    trtB = rep("xx (xx%)", 4),
+    trtC = rep("xx (xx%)", 4),
+  )
+
+  sample_grp_plan <- row_grp_plan(
+    row_grp_structure(group_val = ".default", element_block(post_space ="--", fill = FALSE)),
+    label_loc =element_row_grp_loc(location = "spanning")
+  )
+
+  expect_equal(
+    apply_row_grp_struct(df, sample_grp_plan$struct_list, vars(grp1)),
+    tibble::tribble(
+      ~grp1, ~trtA,      ~trtB,      ~trtC,
+      "A",  "xx (xx%)", "xx (xx%)",  "xx (xx%)",
+      "A",  "--"      , "--"      ,  "--"      ,
+      "B",  "xx (xx%)", "xx (xx%)",  "xx (xx%)",
+      "B",  "--"      , "--"      ,  "--"      ,
+      "C",  "xx (xx%)", "xx (xx%)",  "xx (xx%)",
+      "C",  "--"      , "--"      ,  "--"      ,
+      "D",  "xx (xx%)", "xx (xx%)",  "xx (xx%)",
+      "D",  "--"      , "--"      ,  "--"      ))
+})
+
 test_that("post space works when data contains NAs",{
 
   df <- tibble(