Add rtf_span_row() for horizontal cell merging

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)

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

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 <http://www.gnu.org/licenses/>.
+
+#' @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
+}

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
 }

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)
 }

_pkgdown.yml

@@ -85,6 +85,7 @@ reference:
   - "rtf_subline"
   - "rtf_colheader"
   - "rtf_body"
+  - "rtf_span_row"
   - "rtf_footnote"
   - "rtf_source"
   - "rtf_encode"

tests/testthat/test-developer-testing-rtf_span_row.R

@@ -0,0 +1,167 @@
+# =============================================================================
+# 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))
+})