Issues #325 and #328

DESCRIPTION

@@ -23,7 +23,7 @@ Description: Contains functions to create regulatory-style statistical reports.
     and automatic page numbering.
 License: CC0
 Encoding: UTF-8
-URL: https://reporter.r-sassy.org
+URL: https://reporter.r-sassy.org, https://github.com/dbosak01/reporter
 BugReports: https://github.com/dbosak01/reporter/issues
 Depends: R (>= 3.6), 
          common (>= 1.1.0)
@@ -53,5 +53,5 @@ Imports: fmtr(>= 1.5.8),
          zip, 
          withr,
          glue
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.1
 VignetteBuilder: knitr

R/create_table_rtf.R

@@ -273,7 +273,7 @@ create_table_rtf <- function(rs, ts, pi, content_blank_row, wrap_flag,
   # rs, ts, widths,  algns, halgns, talgn
   rws <- get_table_body_rtf(rs, pi$data, pi$col_width, 
                             pi$col_align, pi$table_align, ts$borders, 
-                            ts$first_row_blank, ts$continuous, styles)
+                            ts$first_row_blank, ts$continuous, styles, pgind)
 
   # Default to content width
   ls <- rs$content_size[["width"]]
@@ -892,7 +892,7 @@ get_spanning_header_rtf <- function(rs, ts, pi) {
 #' of lines on this particular page.
 #' @noRd
 get_table_body_rtf <- function(rs, tbl, widths, algns, talgn, tbrdrs, 
-                               frb, continuous = FALSE, styles) {
+                               frb, continuous = FALSE, styles, pgind) {
 
   if ("..blank" %in% names(tbl))
     flgs <- tbl$..blank
@@ -917,6 +917,17 @@ get_table_body_rtf <- function(rs, tbl, widths, algns, talgn, tbrdrs,
   if (all(tbrdrs == "body"))
     brdrs <- c("top", "bottom", "left", "right")
 
+  # Deal with outside borders on continuous tables
+  if (continuous & "outside" %in% brdrs) {
+    if ("first" %in% pgind & !"last" %in% pgind) {
+      brdrs <- c("top", "left", "right") 
+    } else if (!"first" %in% pgind & "last" %in% pgind) {
+      brdrs <- c("bottom", "left", "right") 
+    } else if (!"first" %in% pgind & !"last" %in% pgind) {
+      brdrs <- c("left", "right") 
+    }
+  }
+
   # Get line height.  Don't want to leave editor default.
   rh <- rs$row_height
   conv <- rs$twip_conversion

R/reporter.R

@@ -99,12 +99,11 @@
 #'   colors, and some font sizing and bolding.   
 #' }
 #' 
-#' @docType package
 #' @import common
 #' @aliases reporter-package
 #' @keywords internal
 #' @name reporter
-NULL
+"_PACKAGE"
 
 #' @title Notes on PDF output type
 #' @description 

R/write_report_docx.R

@@ -272,6 +272,9 @@ paginate_content_docx <- function(rs, ls) {
 
       } 
     }
+
+    if (cntnt$page_break == TRUE | last_page_lines >= rs$body_line_count)
+      last_page_lines <- 0
 
     ls[[i]]$pages[[length(pgs)]] <- last_page
 

R/write_report_html.R

@@ -296,6 +296,9 @@ paginate_content_html <- function(rs, ls) {
 
       }
     }
+
+    if (cntnt$page_break == TRUE | last_page_lines >= rs$body_line_count)
+      last_page_lines <- 0
 
     ls[[i]]$pages[[length(pgs)]] <- last_page
 

R/write_report_rtf2.R

@@ -230,6 +230,9 @@ paginate_content_rtf <- function(rs, ls) {
 
     }
 
+    if (cntnt$page_break == TRUE | last_page_lines >= rs$body_line_count)
+      last_page_lines <- 0
+
     ls[[i]]$pages[[length(pgs)]] <- last_page
 
   }

R/write_report_text.R

@@ -397,7 +397,7 @@ paginate_content <- function(rs, ls) {
     if (length(pgs) > 1)
       last_page_lines <- length(last_page)
 
-    #print(paste("Last page lines:", last_page_lines))
+    # print(paste("Last page lines:", last_page_lines))
 
     # If there is a requested page break, or it is the last object/last page,
     # then fill up the remaining page with blanks.
@@ -412,6 +412,9 @@ paginate_content <- function(rs, ls) {
       last_page_lines <- 0  # Needed for requested page breaks
       #print(paste("Last Page Line Count:", length(last_page)))
     } 
+
+    if (ls[[i]]$page_break == TRUE | last_page_lines >= rs$body_line_count)
+      last_page_lines <- 0
 
     # Replace last page with any modifications
     ls[[i]]$pages[[length(pgs)]] <- last_page

tests/testthat/test-rtf2.R

@@ -3407,6 +3407,43 @@ test_that("test95: Page break with blank row after works as expected.", {
 
 })
 
+test_that("rtf2-96: Outside borders on continuous tables work as expected.", {
+
+  if (dev) {
+
+    fp <- file.path(base_path, "rtf2/test96.rtf")
+
+    dat <- iris
+
+
+    tbl <- create_table(dat, continuous = TRUE, borders = "outside") %>%
+      # titles("My Title") %>%
+      footnotes("My footnotes", blank_row = "none")
+
+
+    rpt <- create_report(fp, output_type = "RTF",
+                         font = "Arial", orientation = "portrait") %>%
+      add_content(tbl) %>%
+      footnotes("Here", footer = TRUE)
+
+    res <- write_report(rpt)
+
+
+    # file.show(res$modified_path)
+
+    expect_equal(file.exists(fp), TRUE)
+    # expect_equal(res$pages, 3)
+
+
+  } else {
+
+    expect_equal(TRUE, TRUE)
+
+  }
+
+})
+
+
 
 # User Tests --------------------------------------------------------------
 

tests/testthat/test-system.R

@@ -85,7 +85,7 @@ test_that("test3: Simple table with formats works as expected.", {
     define(subjid, align = "left") %>% 
     define(sex, width = 1, format = sfmt2) %>%
     define(age, width = .5) %>% 
-    define(arm, format = afmt, width = 1.5, align = "right")
+    define(arm, format = afmt, width = 1.5, align = "right", dedupe = TRUE)
 
 
 

tests/testthat/test-user.R

@@ -1179,3 +1179,170 @@ test_that("user16: Label row does not create extra blank spaces.", {
 
 })
 
+
+
+test_that("user17: Dedupe works as expected on hemo table", {
+
+  if (dev) {
+  # Sample Data
+  hemo <- read.table(header = TRUE, sep = ",", text = '
+labtest,tmtnc,tmtn,swmgrade,variable,c0,c1,c2,c3,c4,c7,pagebrk
+HEMO-HIGH,ARM A,1,7,NG,76  98.7%,75  98.7%,0,0,0,1   1.3%,1
+HEMO-HIGH,ARM A,1,8,Missing,1   1.3%,1 100.0%,0,0,0,0,1
+HEMO-HIGH,ARM A,1,9,Total,77 100.0%,76  98.7%,0,0,0,1   1.3%,1
+HEMO-HIGH,ARM B,2,7,NG,84  96.6%,82  97.6%,0,0,0,2   2.4%,1
+HEMO-HIGH,ARM B,2,8,Missing,3   3.4%,3 100.0%,0,0,0,0,1
+HEMO-HIGH,ARM B,2,9,Total,87 100.0%,85  97.7%,0,0,0,2   2.3%,1
+HEMO-HIGH,ARM C,3,7,NG,45 100.0%,41  91.1%,0,0,0,4   8.9%,2
+HEMO-HIGH,ARM C,3,8,Missing,0,0,0,0,0,0,2
+HEMO-HIGH,ARM C,3,9,Total,45 100.0%,41  91.1%,0,0,0,4   8.9%,2
+HEMO-LOW,ARM A,1,1,Grade 0,22  28.6%,2   9.1%,7  31.8%,6  27.3%,7  31.8%,0,1
+HEMO-LOW,ARM A,1,3,Grade 1,38  49.4%,0,14  36.8%,14  36.8%,10  26.3%,0,1
+HEMO-LOW,ARM A,1,4,Grade 2,13  16.9%,0,1   7.7%,0,11  84.6%,1   7.7%,1
+HEMO-LOW,ARM A,1,5,Grade 3,3   3.9%,0,0,1  33.3%,2  66.7%,0,1
+HEMO-LOW,ARM A,1,8,Missing,1   1.3%,0,0,1 100.0%,0,0,1
+HEMO-LOW,ARM A,1,9,Total,77 100.0%,2   2.6%,22  28.6%,22  28.6%,30  39.0%,1   1.3%,1
+HEMO-LOW,ARM B,2,1,Grade 0,23  26.4%,2   8.7%,3  13.0%,11  47.8%,7  30.4%,0,1
+HEMO-LOW,ARM B,2,3,Grade 1,41  47.1%,0,4   9.8%,18  43.9%,18  43.9%,1   2.4%,1
+HEMO-LOW,ARM B,2,4,Grade 2,17  19.5%,0,1   5.9%,2  11.8%,13  76.5%,1   5.9%,1
+HEMO-LOW,ARM B,2,5,Grade 3,3   3.4%,0,0,0,3 100.0%,0,1
+HEMO-LOW,ARM B,2,8,Missing,3   3.4%,0,1  33.3%,0,2  66.7%,0,1
+HEMO-LOW,ARM B,2,9,Total,87 100.0%,2   2.3%,9  10.3%,31  35.6%,43  49.4%,2   2.3%,1
+HEMO-LOW,ARM C,3,1,Grade 0,14  31.1%,2  14.3%,4  28.6%,4  28.6%,2  14.3%,2  14.3%,2
+HEMO-LOW,ARM C,3,3,Grade 1,21  46.7%,1   4.8%,5  23.8%,4  19.0%,10  47.6%,1   4.8%,2
+HEMO-LOW,ARM C,3,4,Grade 2,6  13.3%,0,0,1  16.7%,4  66.7%,1  16.7%,2
+HEMO-LOW,ARM C,3,5,Grade 3,4   8.9%,0,0,1  25.0%,3  75.0%,0,2
+HEMO-LOW,ARM C,3,8,Missing,0,0,0,0,0,0,2
+HEMO-LOW,ARM C,3,9,Total,45 100.0%,3   6.7%,9  20.0%,10  22.2%,19  42.2%,4   8.9%,2')
+
+
+  library(dplyr)
+  library(fmtr)
+
+  # Set variables
+  program.name <- "t_ctcshift_hem"
+  program.output <- "user17"
+  program.timestamp <- "2001-01-01 12:00"
+  program.dir <- base_path
+
+
+  # Change column names to lower case
+  colnames(hemo) <- tolower(colnames(hemo)) 
+
+
+
+  fmt1 <- value(condition(x == "HEMO-HIGH", "Hemoglobin (G/L) - HIGH DIRECTION"),
+                condition(x == "HEMO-LOW", "Hemoglobin (g/L) - LOW DIRECTION"),
+                condition(x == "LEUK-HIGH", "Leukocytes (GI/L) - HIGH DIRECTION"),
+                condition(x == "LEUK-LOW", "Leukocytes (GI/L) - LOW DIRECTION"))
+
+
+  fmt2 <- value(condition(x == "ARM A", "Ruxolitinib 15 mg BID (N=77)"),
+                condition(x == "ARM B", "Ruxolitinib 5 mg BID (N=87)"),
+                condition(x == "ARM C", "Placebo (N=45)"))
+
+
+  ftnts <- list()
+
+  base_ftnt <-
+    c("[1] The percentages were calculated using the baseline total as the denominator.",                                      
+      paste("[2] For each row, the percentages were calculated using the number of participants",
+            "with given grade at baseline as the denominator; worst value on study is the worst",
+            "grade observed post-baseline for a given participant."))
+
+  ftnts[["HEMO-HIGH"]] <- 
+    c(base_ftnt,              
+      "-  Grade 0 = Below Grade 1 and any grade in the other direction.",                                                     
+      "-  For baseline NG means that grade does not apply at baseline.",                                                     
+      "-  Grade 1 = Greater than ULN and increase from baseline of  >0 - 2 g/dL;",                                           
+      "Grade 2 = Greater than ULN and increase from baseline of  >2 - 4 g/dL;",                                            
+      "Grade 3 = Greater than ULN and increase from baseline of  >4 g/dL. ")
+
+
+  ftnts[["HEMO-LOW"]] <-   
+    c(base_ftnt,           
+      "-  Grade 0 = Below Grade 1 and any grade in the other direction.")
+
+
+
+  pth <- file.path(program.dir, "user", program.output)  
+
+
+  rpt <- create_report(pth, font = "Courier", font_size = 9)  %>% 
+    set_margins(top = 1.0, left = 1, right = 1, bottom = .5) %>%
+    options_fixed(line_count = 51) %>% 
+
+    titles("Table 3.3.3.1", 
+           paste("Shift Summary of Hematology Laboratory Values", 
+                 "in CTC Grade - to the Worst Abnormal Value"),
+           "(Safety Population)", bold = TRUE, font_size = 9) %>%
+    page_header(left = c("PROTOCOL: DIDA 00001-123", 
+                         "DRUG/INDICATION: DIDA00001/COMPOUND-ASSOCIATED STUDY", 
+                         "TLF Version: Final Database Lock (21APR2021)"),
+                right = c("Page [pg] of [tpg]",  "DATABASE VERSION: 10MAY2023", 
+                          "TASK: Primary Analysis")) %>% 
+    footnotes(paste0("Program: ", program.name, sep=""), 
+              "DATE(TIME): 2001-12-01",
+              blank_row = "none", borders = "top", columns = 2, footer = TRUE)  %>%
+    footnotes("Laboratory grading is based on CTCAE Version 5.",
+              "Reference: Listing 2.8.1.1, 2.8.1.2", footer = TRUE )
+
+  labtests <- names(table(hemo$labtest))
+
+
+  for (i in seq_len(length(labtests))) {
+
+
+    lb <- labtests[i] 
+
+
+    ftnt <- ftnts[[lb]]
+
+
+    table_hemo <- hemo %>% 
+      dplyr::filter(labtest==lb) %>%
+      mutate(labtest = fapply(labtest, fmt1),
+             tmtnc = fapply(tmtnc, fmt2)) %>%
+      select(labtest, tmtnc, tmtn, swmgrade,variable, c0,c1,c2,c3,c4,c7, pagebrk) %>% 
+      arrange(labtest, tmtn, swmgrade) 
+
+    tbl <- create_table(table_hemo,
+                        show_cols = c("none"), 
+                        borders = "top",
+                        width = 9) %>%
+      # page_by(labtest, label = "Laboratory Test (unit):", borders = "none", 
+      #         blank_row = "none") %>% 
+    #  footnotes (ftnt, blank_row ="above" ) %>% 
+      column_defaults(width=.1) %>%
+      # spanning_header(variable, c0, label="Baseline [1]") %>%
+      # spanning_header(c1, c7, label="Worst Post-Baseline Value [2]") %>%
+      define(tmtnc, dedupe = TRUE, align = "left", label = "Treatment Group", 
+             width=3) %>%
+      define(tmtn, blank_after = TRUE, visible = FALSE) %>%
+      define(variable, align="left", label="Grade", width=.8) %>%
+      define(c0, align="left", label="n  (%)", width=1)# %>%
+      #define(c1,   align = "left", label = "Grade 0\n n  (%)", width=1)  %>%
+     # define(c2,   align = "left", label = "Grade 1\n n  (%)", width=1) # %>%
+     # define(c3,   align = "left", label = "Grade 2\n n  (%)", width=1) # %>%
+      #define(c4,   align = "left", label = "Grade 3\n n  (%)", width=1) # %>%
+      #define(c7,   align = "left", label = "Missing\n n  (%)", width=1)
+
+    rpt <- rpt |> add_content(tbl, blank_row = "none", page_break = TRUE) 
+
+  }
+
+
+  res <- write_report(rpt, output_type = "TXT")
+
+  expect_equal(file.exists(res$modified_path), TRUE)
+  # View the report
+  # file.show(res$modified_path)
+  # file.show(logpth)
+
+  } else {
+
+
+    expect_equal(TRUE, TRUE) 
+  }
+
+})