diff --git a/NAMESPACE b/NAMESPACE index 0e7088d..b9ad9ea 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 5f2860d..5c7834d 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 0000000..fd48bbc --- /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 483f4b6..d76d260 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 b43e898..6f243f3 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/_pkgdown.yml b/_pkgdown.yml index 4724cc0..223e99e 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" diff --git a/man/rtf_span_row.Rd b/man/rtf_span_row.Rd new file mode 100644 index 0000000..3287908 --- /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 0000000..fc81fd8 --- /dev/null +++ b/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)) +})