From 4bcde9d06196c6c7b7621d3add56c0f43e750118 Mon Sep 17 00:00:00 2001 From: langbr_merck Date: Fri, 29 May 2026 02:51:34 -0400 Subject: [PATCH 1/4] Add rtf_span_row() for native horizontal cell merging Introduces rtf_span_row() to mark body rows that should span all columns using RTF \clmgf/\clmrg merge keywords. This replaces manual RTF injection workarounds for full-width category/group header rows in clinical tables. - New exported function rtf_span_row(tbl, span_row) - Horizontal merge logic in rtf_table_content() - Attribute threading through rtf_subset() and as_rtf_table() - Developer tests covering unit, integration, and edge cases --- .gitignore | 1 + NAMESPACE | 1 + R/as_rtf_table.R | 4 + R/rtf_span_row.R | 69 ++++++++ R/rtf_subset.R | 4 + R/rtf_table_content.R | 36 +++- man/rtf_span_row.Rd | 42 +++++ .../test-developer-testing-rtf_span_row.R | 162 ++++++++++++++++++ 8 files changed, 315 insertions(+), 4 deletions(-) create mode 100644 R/rtf_span_row.R create mode 100644 man/rtf_span_row.Rd create mode 100644 tests/testthat/test-developer-testing-rtf_span_row.R diff --git a/.gitignore b/.gitignore index 30dde30a..e27c75f7 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,4 @@ r2rtf.Rcheck/ r2rtf*.tar.gz r2rtf*.tgz revdep/ +RESEARCH-*.md diff --git a/NAMESPACE b/NAMESPACE index 0e7088d0..b9ad9ea0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -14,6 +14,7 @@ export(rtf_read_figure) export(rtf_read_png) export(rtf_rich_text) export(rtf_source) +export(rtf_span_row) export(rtf_subline) export(rtf_title) export(utf8Tortf) diff --git a/R/as_rtf_table.R b/R/as_rtf_table.R index 5f2860df..5c7834d2 100644 --- a/R/as_rtf_table.R +++ b/R/as_rtf_table.R @@ -94,10 +94,14 @@ as_rtf_table <- function(tbl) { # Remove repeated records if group_by is not null if (!is.null(group_by)) { + saved_attrs <- attributes(cell_tbl) cell_tbl <- rtf_group_by_enhance(cell_tbl, group_by = group_by, page_index = page_dict$page ) + for (a in setdiff(names(saved_attrs), names(attributes(cell_tbl)))) { + attr(cell_tbl, a) <- saved_attrs[[a]] + } } # Add border type for first and last row diff --git a/R/rtf_span_row.R b/R/rtf_span_row.R new file mode 100644 index 00000000..fd48bbc2 --- /dev/null +++ b/R/rtf_span_row.R @@ -0,0 +1,69 @@ +# Copyright (c) 2022 Merck & Co., Inc., Rahway, NJ, USA and its affiliates. All rights reserved. +# +# This file is part of the r2rtf program. +# +# r2rtf is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . + +#' @title Add Horizontal Span Row Attributes to Table +#' +#' @param tbl A data frame. +#' @param span_row A logical vector of length \code{nrow(tbl)} indicating +#' which rows should span all columns, or an integer vector of row indices. +#' +#' @section Specification: +#' \if{latex}{ +#' \itemize{ +#' \item Validate that \code{tbl} has body attributes from \code{rtf_body()}. +#' \item Normalize \code{span_row} to a logical vector of length \code{nrow(tbl)}. +#' \item Set the \code{"rtf_span_row"} attribute on \code{tbl}. +#' \item Return \code{tbl}. +#' } +#' } +#' \if{html}{The contents of this section are shown in PDF user manual only.} +#' +#' @return the same data frame \code{tbl} with additional attributes for horizontal span rows +#' +#' @examples +#' library(dplyr) # required to run examples +#' data(r2rtf_tbl1) +#' r2rtf_tbl1 %>% +#' rtf_body() %>% +#' rtf_span_row(span_row = c(rep(TRUE, 2), rep(FALSE, nrow(r2rtf_tbl1) - 2))) %>% +#' attr("rtf_span_row") +#' +#' @export +rtf_span_row <- function(tbl, span_row) { + check_args(tbl, type = "data.frame") + + if (is.null(attr(tbl, "border_top"))) { + stop("rtf_span_row() must be called after rtf_body()") + } + + n_row <- nrow(tbl) + + if (is.numeric(span_row) || is.integer(span_row)) { + indices <- as.integer(span_row) + if (any(indices < 1L | indices > n_row)) { + stop("span_row indices must be between 1 and nrow(tbl)") + } + span_logical <- rep(FALSE, n_row) + span_logical[indices] <- TRUE + span_row <- span_logical + } + + check_args(span_row, type = "logical", length = n_row) + + attr(tbl, "rtf_span_row") <- span_row + tbl +} diff --git a/R/rtf_subset.R b/R/rtf_subset.R index 483f4b68..d76d2606 100644 --- a/R/rtf_subset.R +++ b/R/rtf_subset.R @@ -96,5 +96,9 @@ rtf_subset <- function(tbl, attr(tbl_sub, "col_rel_width") <- attr(tbl, "col_rel_width")[col] + if (!is.null(attr(tbl, "rtf_span_row"))) { + attr(tbl_sub, "rtf_span_row") <- attr(tbl, "rtf_span_row")[row] + } + tbl_sub } diff --git a/R/rtf_table_content.R b/R/rtf_table_content.R index b43e898c..6f243f3c 100644 --- a/R/rtf_table_content.R +++ b/R/rtf_table_content.R @@ -165,11 +165,29 @@ rtf_table_content <- function(tbl, cell_size <- cumsum(cell_width) cell_size <- foo(cell_size) + # Horizontal Merge (span rows) + span_row <- attr(tbl, "rtf_span_row") + if (!is.null(span_row) && any(span_row) && n_col > 1) { + cell_h_merge <- matrix("", nrow = n_row, ncol = n_col) + cell_h_merge[span_row, 1] <- "\\clmgf" + cell_h_merge[span_row, 2:n_col] <- "\\clmrg" + + # For span rows, the first cell (\clmgf) controls all visible borders. + # Copy the last cell's right border onto the first cell, then clear internals. + border_left_rtf <- matrix(border_left_rtf, nrow = n_row, ncol = n_col) + border_right_rtf <- matrix(border_right_rtf, nrow = n_row, ncol = n_col) + border_right_rtf[span_row, 1] <- border_right_rtf[span_row, n_col] + border_left_rtf[span_row, 2:n_col] <- "" + border_right_rtf[span_row, 2:n_col] <- "" + } else { + cell_h_merge <- "" + } + # Combine Cell Attributes of cell justification, cell border type, cell border width, cell border color, cell background color and cell size. - border_top_left <- matrix(paste0(border_left_rtf, border_top_rtf, text_background_color_rtf, cell_vertical_justification, "\\cellx", cell_size), nrow = n_row, ncol = n_col) - border_top_left_right <- matrix(paste0(border_left_rtf, border_top_rtf, border_right_rtf, text_background_color_rtf, cell_vertical_justification, "\\cellx", cell_size), nrow = n_row, ncol = n_col) - border_top_left_bottom <- matrix(paste0(border_left_rtf, border_top_rtf, border_bottom_rtf, text_background_color_rtf, cell_vertical_justification, "\\cellx", cell_size), nrow = n_row, ncol = n_col) - border_all <- matrix(paste0(border_left_rtf, border_top_rtf, border_right_rtf, border_bottom_rtf, text_background_color_rtf, cell_vertical_justification, "\\cellx", cell_size), nrow = n_row, ncol = n_col) + border_top_left <- matrix(paste0(border_left_rtf, border_top_rtf, text_background_color_rtf, cell_vertical_justification, cell_h_merge, "\\cellx", cell_size), nrow = n_row, ncol = n_col) + border_top_left_right <- matrix(paste0(border_left_rtf, border_top_rtf, border_right_rtf, text_background_color_rtf, cell_vertical_justification, cell_h_merge, "\\cellx", cell_size), nrow = n_row, ncol = n_col) + border_top_left_bottom <- matrix(paste0(border_left_rtf, border_top_rtf, border_bottom_rtf, text_background_color_rtf, cell_vertical_justification, cell_h_merge, "\\cellx", cell_size), nrow = n_row, ncol = n_col) + border_all <- matrix(paste0(border_left_rtf, border_top_rtf, border_right_rtf, border_bottom_rtf, text_background_color_rtf, cell_vertical_justification, cell_h_merge, "\\cellx", cell_size), nrow = n_row, ncol = n_col) if (use_border_bottom) { border_rtf <- border_top_left_bottom @@ -179,6 +197,11 @@ rtf_table_content <- function(tbl, border_rtf[, n_col] <- border_top_left_right[, n_col] } + # For span rows, first cell is the only visible cell — give it all 4 borders + if (!is.null(span_row) && any(span_row) && n_col > 1) { + border_rtf[span_row, 1] <- border_all[span_row, 1] + } + border_rtf <- t(border_rtf) # Encode RTF Text and Paragraph @@ -206,5 +229,10 @@ rtf_table_content <- function(tbl, cell = TRUE ) + # Clear continuation cell content for span rows + if (!is.null(span_row) && any(span_row) && n_col > 1) { + cell_rtf[span_row, 2:n_col] <- "\\pard\\cell" + } + rbind(row_begin, border_rtf, t(cell_rtf), row_end) } diff --git a/man/rtf_span_row.Rd b/man/rtf_span_row.Rd new file mode 100644 index 00000000..32879089 --- /dev/null +++ b/man/rtf_span_row.Rd @@ -0,0 +1,42 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rtf_span_row.R +\name{rtf_span_row} +\alias{rtf_span_row} +\title{Add Horizontal Span Row Attributes to Table} +\usage{ +rtf_span_row(tbl, span_row) +} +\arguments{ +\item{tbl}{A data frame.} + +\item{span_row}{A logical vector of length \code{nrow(tbl)} indicating +which rows should span all columns, or an integer vector of row indices.} +} +\value{ +the same data frame \code{tbl} with additional attributes for horizontal span rows +} +\description{ +Add Horizontal Span Row Attributes to Table +} +\section{Specification}{ + +\if{latex}{ + \itemize{ + \item Validate that \code{tbl} has body attributes from \code{rtf_body()}. + \item Normalize \code{span_row} to a logical vector of length \code{nrow(tbl)}. + \item Set the \code{"rtf_span_row"} attribute on \code{tbl}. + \item Return \code{tbl}. + } + } +\if{html}{The contents of this section are shown in PDF user manual only.} +} + +\examples{ +library(dplyr) # required to run examples +data(r2rtf_tbl1) +r2rtf_tbl1 \%>\% + rtf_body() \%>\% + rtf_span_row(span_row = c(rep(TRUE, 2), rep(FALSE, nrow(r2rtf_tbl1) - 2))) \%>\% + attr("rtf_span_row") + +} diff --git a/tests/testthat/test-developer-testing-rtf_span_row.R b/tests/testthat/test-developer-testing-rtf_span_row.R new file mode 100644 index 00000000..259ea76a --- /dev/null +++ b/tests/testthat/test-developer-testing-rtf_span_row.R @@ -0,0 +1,162 @@ +# ============================================================================= +# Unit tests for rtf_span_row +# ============================================================================= + +# --- rtf_span_row() function tests --- + +test_that("rtf_span_row sets attribute with logical vector", { + tbl <- iris[1:5, ] |> rtf_body() + result <- rtf_span_row(tbl, span_row = c(TRUE, FALSE, FALSE, TRUE, FALSE)) + expect_equal(attr(result, "rtf_span_row"), c(TRUE, FALSE, FALSE, TRUE, FALSE)) +}) + +test_that("rtf_span_row sets attribute with integer indices", { + tbl <- iris[1:5, ] |> rtf_body() + result <- rtf_span_row(tbl, span_row = c(1L, 4L)) + expect_equal(attr(result, "rtf_span_row"), c(TRUE, FALSE, FALSE, TRUE, FALSE)) +}) + +test_that("rtf_span_row errors on wrong length", { + tbl <- iris[1:5, ] |> rtf_body() + expect_error(rtf_span_row(tbl, span_row = c(TRUE, FALSE))) +}) + +test_that("rtf_span_row errors when called before rtf_body", { + expect_error(rtf_span_row(iris[1:5, ], span_row = c(TRUE, FALSE, FALSE, TRUE, FALSE))) +}) + +test_that("rtf_span_row errors on out-of-range indices", { + tbl <- iris[1:5, ] |> rtf_body() + expect_error(rtf_span_row(tbl, span_row = c(0L, 6L))) +}) + +test_that("rtf_span_row errors on non-logical non-integer input", { + + tbl <- iris[1:5, ] |> rtf_body() + expect_error(rtf_span_row(tbl, span_row = "row1")) +}) + + +# --- rtf_table_content() with span --- + +test_that("rtf_table_content emits clmgf and clmrg for span rows", { + tbl <- iris[1:3, ] |> rtf_body() |> rtf_span_row(span_row = c(TRUE, FALSE, FALSE)) + result <- rtf_table_content(tbl, use_border_bottom = TRUE) + + # result is a matrix; columns correspond to rows in the table + # Row 1 (column 1 of result) should have \\clmgf and \\clmrg + col1 <- paste(result[, 1], collapse = "\n") + expect_true(grepl("\\\\clmgf", col1)) + expect_true(grepl("\\\\clmrg", col1)) + + # Row 2 (column 2) should NOT have merge codes + + col2 <- paste(result[, 2], collapse = "\n") + expect_false(grepl("\\\\clmgf", col2)) + expect_false(grepl("\\\\clmrg", col2)) +}) + +test_that("rtf_table_content empties continuation cells for span rows", { + tbl <- iris[1:3, ] |> rtf_body() |> rtf_span_row(span_row = c(TRUE, FALSE, FALSE)) + result <- rtf_table_content(tbl, use_border_bottom = TRUE) + + # For span row (column 1 of result matrix), continuation cells should be \\pard\\cell + # The cell content rows start after row_begin + n_col border rows + n_col <- ncol(iris) + # Content for columns 2..n_col should be \\pard\\cell + content_rows <- result[(1 + n_col + 2):(1 + n_col + n_col), 1] + expect_true(all(content_rows == "\\pard\\cell")) +}) + +test_that("rtf_table_content first cell retains content for span rows", { + tbl <- iris[1:3, ] |> rtf_body() |> rtf_span_row(span_row = c(TRUE, FALSE, FALSE)) + result <- rtf_table_content(tbl, use_border_bottom = TRUE) + + # First cell content (row after borders) should NOT be just \\pard\\cell + n_col <- ncol(iris) + first_cell_content <- result[1 + n_col + 1, 1] + expect_false(first_cell_content == "\\pard\\cell") + expect_true(grepl("5.1", first_cell_content)) +}) + + +# --- as_rtf_table() with span + group_by --- + +test_that("as_rtf_table preserves span_row through group_by", { + tbl <- iris[1:4, 4:5] |> + rtf_body(group_by = "Species") |> + rtf_span_row(span_row = c(TRUE, FALSE, FALSE, FALSE)) + + result <- as_rtf_table(tbl) + expect_true(grepl("\\\\clmgf", result[1])) +}) + + +# --- rtf_subset() with span --- + +test_that("rtf_subset subsets rtf_span_row attribute", { + tbl <- iris[1:5, ] |> + rtf_body() |> + rtf_span_row(span_row = c(TRUE, FALSE, TRUE, FALSE, TRUE)) + + sub <- rtf_subset(tbl, row = 2:4, col = 1:3) + expect_equal(attr(sub, "rtf_span_row"), c(FALSE, TRUE, FALSE)) +}) + + +# --- End-to-end: rtf_encode with span --- + +test_that("rtf_encode produces valid RTF with span rows", { + tbl <- iris[1:3, ] |> + rtf_body() |> + rtf_span_row(span_row = c(TRUE, FALSE, FALSE)) |> + rtf_encode() + + rtf_text <- paste(unlist(tbl), collapse = "\n") + expect_true(grepl("\\\\clmgf", rtf_text)) + expect_true(grepl("\\\\clmrg", rtf_text)) +}) + +test_that("rtf_encode without span_row produces no merge codes", { + tbl <- iris[1:3, ] |> + rtf_body() |> + rtf_encode() + + rtf_text <- paste(unlist(tbl), collapse = "\n") + expect_false(grepl("\\\\clmgf", rtf_text)) + expect_false(grepl("\\\\clmrg", rtf_text)) +}) + + +# --- Edge cases --- + +test_that("single-column table with span_row does not error", { + tbl <- data.frame(x = 1:3) |> + rtf_body() |> + rtf_span_row(span_row = c(TRUE, FALSE, FALSE)) + + result <- rtf_table_content(tbl, use_border_bottom = TRUE) + # Should not contain merge codes (only 1 column, merge is no-op) + col1 <- paste(result[, 1], collapse = "\n") + expect_false(grepl("\\\\clmgf", col1)) +}) + +test_that("all rows as span rows works", { + tbl <- iris[1:3, ] |> + rtf_body() |> + rtf_span_row(span_row = c(TRUE, TRUE, TRUE)) |> + rtf_encode() + + rtf_text <- paste(unlist(tbl), collapse = "\n") + expect_true(grepl("\\\\clmgf", rtf_text)) +}) + +test_that("span_row on first and last rows works with border_first/last", { + tbl <- iris[1:5, ] |> + rtf_body(border_first = "single", border_last = "single") |> + rtf_span_row(span_row = c(TRUE, FALSE, FALSE, FALSE, TRUE)) |> + rtf_encode() + + rtf_text <- paste(unlist(tbl), collapse = "\n") + expect_true(grepl("\\\\clmgf", rtf_text)) +}) From 7e02dad66bb0d5c33c165d44359a1442d51055c0 Mon Sep 17 00:00:00 2001 From: BrianLang Date: Fri, 29 May 2026 07:02:02 +0000 Subject: [PATCH 2/4] Style code (GHA) --- .../testthat/test-developer-testing-rtf_span_row.R | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-developer-testing-rtf_span_row.R b/tests/testthat/test-developer-testing-rtf_span_row.R index 259ea76a..fc81fd85 100644 --- a/tests/testthat/test-developer-testing-rtf_span_row.R +++ b/tests/testthat/test-developer-testing-rtf_span_row.R @@ -31,7 +31,6 @@ test_that("rtf_span_row errors on out-of-range indices", { }) test_that("rtf_span_row errors on non-logical non-integer input", { - tbl <- iris[1:5, ] |> rtf_body() expect_error(rtf_span_row(tbl, span_row = "row1")) }) @@ -40,7 +39,9 @@ test_that("rtf_span_row errors on non-logical non-integer input", { # --- rtf_table_content() with span --- test_that("rtf_table_content emits clmgf and clmrg for span rows", { - tbl <- iris[1:3, ] |> rtf_body() |> rtf_span_row(span_row = c(TRUE, FALSE, FALSE)) + tbl <- iris[1:3, ] |> + rtf_body() |> + rtf_span_row(span_row = c(TRUE, FALSE, FALSE)) result <- rtf_table_content(tbl, use_border_bottom = TRUE) # result is a matrix; columns correspond to rows in the table @@ -57,7 +58,9 @@ test_that("rtf_table_content emits clmgf and clmrg for span rows", { }) test_that("rtf_table_content empties continuation cells for span rows", { - tbl <- iris[1:3, ] |> rtf_body() |> rtf_span_row(span_row = c(TRUE, FALSE, FALSE)) + tbl <- iris[1:3, ] |> + rtf_body() |> + rtf_span_row(span_row = c(TRUE, FALSE, FALSE)) result <- rtf_table_content(tbl, use_border_bottom = TRUE) # For span row (column 1 of result matrix), continuation cells should be \\pard\\cell @@ -69,7 +72,9 @@ test_that("rtf_table_content empties continuation cells for span rows", { }) test_that("rtf_table_content first cell retains content for span rows", { - tbl <- iris[1:3, ] |> rtf_body() |> rtf_span_row(span_row = c(TRUE, FALSE, FALSE)) + tbl <- iris[1:3, ] |> + rtf_body() |> + rtf_span_row(span_row = c(TRUE, FALSE, FALSE)) result <- rtf_table_content(tbl, use_border_bottom = TRUE) # First cell content (row after borders) should NOT be just \\pard\\cell From c02fba3aeae07f924fb2ca5a61fdb6d4af48443f Mon Sep 17 00:00:00 2001 From: langbr_merck Date: Fri, 29 May 2026 03:09:30 -0400 Subject: [PATCH 3/4] Add rtf_span_row to pkgdown reference section --- _pkgdown.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/_pkgdown.yml b/_pkgdown.yml index 4724cc0e..223e99e5 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -85,6 +85,7 @@ reference: - "rtf_subline" - "rtf_colheader" - "rtf_body" + - "rtf_span_row" - "rtf_footnote" - "rtf_source" - "rtf_encode" From ad4926098902edd55588150be21eaf9dfbb90e4b Mon Sep 17 00:00:00 2001 From: langbr_merck Date: Fri, 29 May 2026 03:11:35 -0400 Subject: [PATCH 4/4] Revert .gitignore change unrelated to feature --- .gitignore | 1 - 1 file changed, 1 deletion(-) diff --git a/.gitignore b/.gitignore index e27c75f7..30dde30a 100644 --- a/.gitignore +++ b/.gitignore @@ -9,4 +9,3 @@ r2rtf.Rcheck/ r2rtf*.tar.gz r2rtf*.tgz revdep/ -RESEARCH-*.md