Merge pull request #66 from GSK-Biostatistics/page_plan

Page plan

DESCRIPTION

@@ -43,7 +43,7 @@ Imports:
     gt,
     rlang,
     sortable,
-    bslib,
+    bslib (>= 0.6.0),
     shinyWidgets,
     rio,
     shinycssloaders,

NAMESPACE

@@ -38,3 +38,4 @@ importFrom(shinyjs,toggleState)
 importFrom(shinyjs,useShinyjs)
 importFrom(stats,setNames)
 importFrom(utils,getFromNamespace)
+importFrom(utils,zip)

NEWS.md

@@ -1,5 +1,12 @@
 # tfrmtbuilder development version
 
+* New features:
+  - Add support for `page_plan`
+  - Add support for additional output formats 
+
+* Bug fixes:
+  - Fix navbar link underline css conflict to support bslib >= 0.6.0
+
 # tfrmtbuilder 0.0.5
 
 - Improve robustness of how `tfrmt` internal functions are called.

R/mod_datamapping_inputs.R

@@ -38,8 +38,6 @@ datamapping_inputs_server <- function(id, data, settings_in, reset, multiple, re
       # hide add/drop inputs if multiple = FALSE
       observe({
         toggle("multiples", condition = multiple==TRUE)
-        toggle("multiples", condition = multiple==TRUE)
-
       })
 
       # starts at zero, 1 for initial state, then increments for each edit

R/mod_export.R

@@ -28,18 +28,16 @@ export_ui <- function(id){
                div(style = "height: 650px;",
                    h3("Table", class = "heading_style",
                       span(class = "btn-export", style = "display: flex; gap: 5px;",
-                        div(downloadButton(ns("tbl_save_html"), label = "HTML", icon = icon("download"))),
-                      div(downloadButton(ns("tbl_save_png"), label = "PNG", icon = icon("download")))),
+                           lapply(c("html","png","rtf","docx","pdf","tex"), function(ext){
+                             mod_export_table_ui(ns(ext), ext=ext)
+                           })
+                      )
                       ),
                    div(style = "height: 550px; overflow-y:auto; ",
-                       shinycssloaders::withSpinner(
-                         color = getOption("spinner.color", default = "#254988"),
-                         type = 4,
-                         gt_output(ns("tbl"))
-                       )
+                       table_inner_ui(ns("tbl_view"))
                    )
                )
-             )
+               )
       )
     )
   )
@@ -52,7 +50,7 @@ export_ui <- function(id){
 #' @param mode mock mode w/ no data, w/ data, reporting
 #'
 #' @noRd
-export_server <- function(id, data, tfrmt_app_out, mode){
+export_server <- function(id, data, tfrmt_app_out, settings){
 
   moduleServer(
     id,
@@ -63,24 +61,13 @@ export_server <- function(id, data, tfrmt_app_out, mode){
         tfrmt_app_out() %>% tfrmt_to_json()
       })
 
-      tbl_out <- reactive({
-        req(tfrmt_app_out())
-        mode <- isolate(mode())
-
-        if (mode=="reporting"){
-          tfrmt_app_out() %>% print_to_gt(.data = data())
-
-        } else if (mode=="mock_no_data"){
-          tfrmt_app_out() %>% print_mock_gt()
-
-        } else {
-          tfrmt_app_out() %>% print_mock_gt(.data = data())
-        }
+      auto_tbl <- reactiveVal(0)
+      observeEvent(tfrmt_app_out(), {
+        auto_tbl(auto_tbl()+1)
       })
 
-      output$tbl <- render_gt({
-         tbl_out()
-      })
+      tbl_out <- table_inner_server("tbl_view", data = data, tfrmt_app_out = tfrmt_app_out, settings = settings, auto_tbl = auto_tbl)
+
 
       output$json_save <- downloadHandler(
           filename = function() {
@@ -91,24 +78,8 @@ export_server <- function(id, data, tfrmt_app_out, mode){
           }
         )
 
-      output$tbl_save_html <- downloadHandler(
-        filename = function() {
-          paste('tfrmt.html', sep='')
-        },
-        content = function(con) {
-          gtobj <- tbl_out()
-          gtsave(gtobj, con)
-        }
-      )
-
-      output$tbl_save_png <- downloadHandler(
-        filename = function() {
-          paste('tfrmt.png', sep='')
-        },
-        content = function(con) {
-          gtobj <- tbl_out()
-          gtsave(gtobj, con)
-        }
-      )
+      lapply(c("html","png","rtf","docx","pdf","tex"), function(ext){
+        mod_export_table_server(ext, tbl=tbl_out, ext=ext)
+      })
     })
 }

R/mod_export_table.R

@@ -0,0 +1,58 @@
+
+# module for table download button for given output type
+
+mod_export_table_ui <- function(id, ext){
+
+  ns <- NS(id)
+
+  tagList(
+    div(downloadButton(ns("tbl_save"), label = toupper(ext), icon = icon("download")))
+  )
+}
+
+mod_export_table_server <- function(id, tbl, ext){
+
+  moduleServer(
+    id,
+    function(input, output, session) {
+
+
+      output$tbl_save <- downloadHandler(
+        filename = function() {
+          if (inherits(tbl(), "gt_group") && tolower(ext) %in% c("png", "pdf")){
+            paste0('tfrmt_', tolower(ext), '.zip')
+          } else {
+            paste0('tfrmt.', tolower(ext))
+          }
+        },
+        content = function(con) {
+
+          if (inherits(tbl(), "gt_group") && tolower(ext) %in% c("png", "pdf")){
+            temp_dir <- tempdir()
+            dir.create(temp_dir)
+
+            n_tbls <- nrow(tbl()$gt_tbls)
+            walk(1:n_tbls, function(x){
+              tbl() %>% grp_pull(x) %>% gtsave(filename = paste0("tfrmt_",x,".", tolower(ext)), path = temp_dir)
+            })
+
+            zip(
+              zipfile = con,
+              files = file.path(temp_dir, paste0("tfrmt_", seq_along(tbl()), ".", tolower(ext))),
+              flags = "-r9Xj"
+            )
+
+          } else{
+
+            gtobj <- tbl()
+            gtsave(gtobj, con)
+
+          }
+        }
+      )
+
+
+
+    }
+  )
+}

R/mod_filters.R

@@ -25,6 +25,7 @@ filters_ui <- function(id){
 filters_server <- function(id, data, tfrmt_app, selected,
                            include,
                            null_to_default = TRUE,
+                           add_default_opt = FALSE,
                            allow_create = reactive(TRUE)){
 
     moduleServer(
@@ -50,7 +51,6 @@ filters_server <- function(id, data, tfrmt_app, selected,
 
         })
 
-
         # loop through all variables in the var shell
         output$filters <- renderUI({
 
@@ -71,14 +71,16 @@ filters_server <- function(id, data, tfrmt_app, selected,
               selected_vars <- list(column_val = selected_vars_nms)
 
             } else{
+
               selected_vars <- selected() %>%
                 keep_at(paste0(var, "_val"))
             }
 
             all_vars <- var_shell()[[var]]
              ui_list[[i]] <- create_filter_select(ns, paste0(var, "_val"), data,
                                                   selected_vars, all_vars,
-                                                  allow_create(), null_to_default)
+                                                  allow_create(), null_to_default,
+                                                  add_default_opt)
 
           }
 

R/mod_home.R

@@ -18,6 +18,10 @@ home_server <- function(id){
   moduleServer(
     id,
     function(input, output, session) {
+
+      addResourcePath("www", system.file('www',
+                                         package = 'tfrmtbuilder'))
+
       output$about <- renderUI({
         HTML("
              <h2 class=heading_style> Welcome to the {tfrmtbuilder} Shiny App </h2>
@@ -68,7 +72,7 @@ home_server <- function(id){
       })
 
       output$hex <- renderUI({
-        HTML(" <left> <img src=https://github.com/GSK-Biostatistics/tfrmt/blob/main/man/figures/tfrmt.png?raw=true
+        HTML(" <left> <img src= 'www/tfrmtbuilder_hex.png'
                 alt=hex width=75% > </left> ")
 
       })