Frame flextable header column labels with an outer border only

NEWS.md

@@ -1,5 +1,7 @@
 # crane 0.3.3.9001
 
+* `theme_gtsummary_roche()` now frames the flextable column labels with an outer border only, removing the internal borders between header rows and the inconsistent missing right border. (#272)
+
 * Fixed minor typo in the DESCRIPTION file.
 
 * `tbl_hierarchical_incidence_rate()` gains an `overall_row` argument to control whether the overall summary row is included. (#264)

R/theme_gtsummary_roche.R

@@ -96,8 +96,13 @@ theme_gtsummary_roche <- function(font_size = NULL,
         ),
         valign = list( # valign only because it will append to to last commands
           rlang::expr(flextable::fontsize(size = !!((font_size %||% 8) - 1), part = "footer")), # second fontsize spectbl
-          rlang::expr(flextable::border_outer(part = "header", border = !!border)), # second command from border
-          rlang::expr(flextable::border_inner_h(part = "header", border = !!border)), # fix different line sizes
+          # outer box only. style = "none" (not width = 0) so docx doesn't draw
+          # a line between a spanner and the column labels.
+          rlang::expr(flextable::border_inner_h(
+            part = "header",
+            border = officer::fp_border(width = 0, style = "none")
+          )),
+          rlang::expr(flextable::border_outer(part = "header", border = !!border)),
           rlang::expr(flextable::valign(valign = "top", part = "all")),
           rlang::expr(flextable::font(fontname = "Arial", part = "all")),
           rlang::expr(flextable::padding(padding.top = 0, part = "all")),

tests/testthat/_snaps/theme_gtsummary_roche.md

@@ -26,11 +26,11 @@
       flextable::fontsize(size = 7, part = "footer")
 
       $user_added3[[2]]
-      flextable::border_outer(part = "header", border = list(width = 0.5, 
-          color = "#666666", style = "solid"))
+      flextable::border_inner_h(part = "header", border = officer::fp_border(width = 0, 
+          style = "none"))
 
       $user_added3[[3]]
-      flextable::border_inner_h(part = "header", border = list(width = 0.5, 
+      flextable::border_outer(part = "header", border = list(width = 0.5, 
           color = "#666666", style = "solid"))
 
       $user_added3[[4]]
@@ -52,4 +52,3 @@
       flextable::set_table_properties(layout = "autofit")
 
 
-

tests/testthat/test-theme_gtsummary_roche.R

@@ -119,8 +119,60 @@ test_that("theme pre-conversion modifies header not to be bold and border only 0
   # check no bold syntax in header
   expect_true(all(!grepl(tbl$header$dataset[1, -1], pattern = "\\*")))
 
-  # check border width is 0.5
-  expect_true(all(tbl$header$styles$cells$border.width.bottom$data == 0.5))
+  # Column labels are framed with an outer border only (width 0.5), so the
+  # outer edges carry the border while inner edges between header rows are 0.
+  n_hdr <- nrow(tbl$header$dataset)
+  bottom <- tbl$header$styles$cells$border.width.bottom$data
+  top <- tbl$header$styles$cells$border.width.top$data
+  expect_true(all(top[1, ] == 0.5)) # top of the block
+  expect_true(all(bottom[n_hdr, ] == 0.5)) # bottom of the block
+  if (n_hdr > 1) {
+    expect_true(all(bottom[-n_hdr, ] == 0)) # no internal horizontal borders
+    # The internal border must also be style "none": a width-0 solid border is
+    # still written as a visible single line in docx (regression with spanners).
+    style_bottom <- tbl$header$styles$cells$border.style.bottom$data
+    expect_true(all(style_bottom[-n_hdr, ] == "none"))
+  }
+})
+
+test_that("theme draws no internal horizontal line between spanner and column labels in docx", {
+  skip_if_not_installed("officer")
+  skip_if_not_installed("flextable")
+
+  tbl <- with_gtsummary_theme(
+    x = theme_gtsummary_roche(),
+    {
+      t1 <- gtsummary::trial |> gtsummary::tbl_summary(by = trt, include = age)
+      t2 <- gtsummary::trial |> gtsummary::tbl_summary(by = trt, include = grade)
+      gtsummary::tbl_merge(
+        list(t1, t2),
+        tab_spanner = c("**Group A**", "**Group B**")
+      ) |>
+        gtsummary::as_flex_table()
+    }
+  )
+
+  f <- withr::local_tempfile(fileext = ".docx")
+  flextable::save_as_docx(tbl, path = f)
+  d <- withr::local_tempdir()
+  utils::unzip(f, exdir = d)
+  xml <- paste(readLines(file.path(d, "word", "document.xml"), warn = FALSE), collapse = "")
+  rows <- regmatches(xml, gregexpr("<w:tr\\b.*?</w:tr>", xml))[[1]]
+
+  spanner <- rows[grepl("Group A", rows)][1]
+  labels <- rows[grepl("Characteristic", rows)][1]
+
+  border_val <- function(row, side) {
+    m <- regmatches(row, regexpr(sprintf('<w:%s w:val="[a-z]+"', side), row))
+    if (length(m)) sub('.*w:val="([a-z]+)".*', "\\1", m) else NA_character_
+  }
+
+  # No line between the spanner row and the column-label row.
+  expect_identical(border_val(spanner, "bottom"), "none")
+  expect_identical(border_val(labels, "top"), "none")
+  # Outer frame of the header block is kept.
+  expect_identical(border_val(spanner, "top"), "single")
+  expect_identical(border_val(labels, "bottom"), "single")
 })
 
 test_that("theme pre-conversion protects stat columns with non-breaking spaces", {