Export footer text

Author: ml-ebs-ext

R/export_helpers.R

@@ -406,7 +406,7 @@ pdf_preprocessing <- function(df, ref) {
 #' @return Named list containing the data frames which are now ready for download.
 #'
 #' @keywords internal
-prep_export_data <- function(data_selection, current_data, data_selection_name, dataset_list) {
+prep_export_data <- function(data_selection, current_data, data_selection_name, dataset_list, footers) {
   # check validity of parameters
   checkmate::assert(
     checkmate::check_string(data_selection),
@@ -424,17 +424,31 @@ prep_export_data <- function(data_selection, current_data, data_selection_name,
     data_to_download <- dataset_list
   }
 
-  names(data_to_download) <- shorten_entries(
+  shortened_names <- shorten_entries(
     paste0(names(data_to_download), " (", get_labels(data_to_download), ")"),
     as.integer(31) # name has to be shortened to 31 characters due to Excel's sheet name limit
   )
 
-  # convert types to character to avoid representation issues in Excel
-  data_to_download <- lapply(data_to_download, function(df) {
-    labels <- get_labels(df)
-    data <- data.frame(sapply(df, as.character))
-    data <- set_labels(data, labels)
+  data_to_download <- local({
+    res <- list()
+    for (i_dataset in seq_along(data_to_download)){
+      df <- data_to_download[[i_dataset]]
+      
+      # convert types to character to avoid representation issues in Excel
+      labels <- get_labels(df)
+      data <- data.frame(sapply(df, as.character))
+      data <- set_labels(data, labels)
+     
+      # attach footer, if available
+      dataset_name <- names(data_to_download)[[i_dataset]]
+      attr(data, "footer") <- footers[[dataset_name]]
+      
+      res[[length(res) + 1]] <- data
+    }
+    return(res)
   })
+    
+  names(data_to_download) <- shortened_names
 
   return(data_to_download)
 }
@@ -458,9 +472,16 @@ excel_export <- function(data_to_download, file, intended_use_label) {
     combine = "and"
   )
 
-  # Add column labels
+  # Add column labels and footers
   data_to_download <- lapply(data_to_download, function(x) {
     names(x) <- paste0(names(x), " [", get_labels(x), "]")
+    footer <- attr(x, "footer")
+    if (!is.null(footer)) {
+      first_new_row <- nrow(x) + 1
+      last_new_row <- nrow(x) + length(footer)
+      x[first_new_row:last_new_row, ] <- NA
+      x[first_new_row:last_new_row, 1] <- footer
+    }
     return(x)
   })
 
@@ -522,6 +543,7 @@ pdf_export <- function(data_to_download, ref_cols, file, metadata, active_sessio
       trial_name = gsub("_", "\\\\_", metadata[1]), # Rmd does not allow underscore
       time_stamp = gsub("[^-/A-Za-z0-9!?.,:() ]", "?", metadata[2]), # replace characters that could cause problems
       snap_shot_name = gsub("[^-/A-Za-z0-9!?.,:() ]", "?", metadata[3]), # same here
+      footer = attr(data_to_download[[1]], "footer"),
       df_list = res_preprocess,
       active_session = active_session
     ),

R/mod_export_listings.R

@@ -94,7 +94,8 @@ mod_export_listings_server <- function(module_id,
                                        data,
                                        data_selection_name,
                                        current_rows,
-                                       intended_use_label) {
+                                       intended_use_label,
+                                       footers) {
   # check validity of parameters
   checkmate::assert(
     checkmate::check_string(module_id, min.chars = 1),
@@ -266,7 +267,7 @@ mod_export_listings_server <- function(module_id,
           shiny::removeModal() # close pop up
 
           data_to_download <- prep_export_data(
-            input[[EXP$DATASEL_ID]], current_data(), data_selection_name(), v_dataset_list()
+            input[[EXP$DATASEL_ID]], current_data(), data_selection_name(), v_dataset_list(), footers
           )
 
           if (input[[EXP$FILETYPE_ID]] == ".xlsx") {

R/mod_listings.R

@@ -408,7 +408,8 @@ listings_server <- function(module_id,
       data = shiny::reactive(set_data(listings_data(), r_selected_columns_in_dataset()[[input[[TBL$DATASET_ID]]]])),
       data_selection_name = shiny::reactive(input[[TBL$DATASET_ID]]),
       current_rows = shiny::reactive(input[[paste0(TBL$TABLE_ID, "_rows_all")]]),
-      intended_use_label = intended_use_label
+      intended_use_label = intended_use_label,
+      footers
     )
 
     # Proxy reference to dataTable

inst/rmd/create_pdf_export.Rmd

@@ -10,6 +10,7 @@ params:
   snap_shot_name: NULL
   df_list: NULL
   active_session: NULL
+  footer: NULL
 title: "`r params$set_title`"
 subtitle: "`r params$set_subtitle`"
 header-includes:
@@ -54,9 +55,21 @@ purrr::iwalk(params$df_list, ~ {
 
   # Print table
   print(k)
-  cat("\\clearpage")
+  if (.y < num_pages) cat("\\clearpage") # no trailing new page
 })
 
+html_to_text <- function(html_var) {
+  txt <- gsub("<br\\s*/?>", "\n\n", html_var, ignore.case = TRUE) # Rmd double newlines
+  txt <- gsub("<[^>]+>", "", txt) # strip all other HTML tags
+  return(txt)
+}
+
+if (length(params$footer)) {
+  html_output <- sprintf("<p>%s</p>", paste(params$footer, collapse = "<br>"))
+  text_output <- html_to_text(html_output)
+  cat(text_output)
+}
+
 if (params$active_session) {
   shiny::setProgress(
     message = "Finalizing document.",

tests/testthat/test-export_helpers.R

@@ -442,31 +442,36 @@ test_that("prep_export_data() throws an error when argument types mismatch", {
     .x,
     current_data_valid,
     data_selection_name_valid,
-    dataset_list_valid
+    dataset_list_valid,
+    footers = NULL
   )))
   purrr::walk(current_data_invalid, ~ expect_error(prep_export_data(
     data_selection_valid,
     .x,
     data_selection_name_valid,
-    dataset_list_valid
+    dataset_list_valid,
+    footers = NULL
   )))
   purrr::walk(data_selection_name_invalid, ~ expect_error(prep_export_data(
     data_selection_valid,
     current_data_valid,
     .x,
-    dataset_list_valid
+    dataset_list_valid,
+    footers = NULL
   )))
   purrr::walk(dataset_list_invalid, ~ expect_error(prep_export_data(
     data_selection_valid,
     current_data_valid,
     data_selection_name_valid,
-    .x
+    .x,
+    footers = NULL
   )))
   expect_error(prep_export_data(
     data_selection_valid,
     current_data_valid,
     data_selection_name_valid,
-    dataset_list_valid
+    dataset_list_valid,
+    footers = NULL
   ), NA) # expect no error
 })
 
@@ -479,7 +484,8 @@ test_that("prep_export_data() performs the correct transformation in the single
   data_selection_name_valid <- names(dataset_list_valid)[1]
 
   # result
-  res <- prep_export_data(data_selection_valid, current_data_valid, data_selection_name_valid, dataset_list_valid)
+  res <- prep_export_data(data_selection_valid, current_data_valid, data_selection_name_valid, dataset_list_valid,
+                          footers = NULL)
 
   # expected
   exp <- list("data1 (My Label)" = set_labels(data.frame(col1 = c("1", "2"), col2 = c("3", "4"))))
@@ -508,7 +514,8 @@ test_that("prep_export_data() performs the correct transformation in the multipl
     data_selection_valid,
     current_data_valid,
     data_selection_name_valid,
-    dataset_list_valid
+    dataset_list_valid,
+    footers = NULL
   )
 
   # perform tests
@@ -530,7 +537,8 @@ test_that("prep_export_data() shortens dataset names if they exceed Excel's shee
 
   # result
   res <- nchar(
-    names(prep_export_data(data_selection_valid, current_data_valid, data_selection_name_valid, dataset_list_valid))
+    names(prep_export_data(data_selection_valid, current_data_valid, data_selection_name_valid, dataset_list_valid,
+                           footers = NULL))
   )
 
   # perform tests