From 3a8f6c38781478da1ce4d09a4ab10c32701d24a8 Mon Sep 17 00:00:00 2001 From: Becca Krouse Date: Fri, 17 Nov 2023 15:13:17 -0500 Subject: [PATCH 01/22] paging buttons --- R/mod_table_page.R | 76 +++++++++++++++++++++++++++++++++++++++++++++ R/utils_tfrmt.R | 6 ++++ inst/www/styles.css | 15 +++++++++ 3 files changed, 97 insertions(+) create mode 100644 R/mod_table_page.R diff --git a/R/mod_table_page.R b/R/mod_table_page.R new file mode 100644 index 0000000..4b7a5ab --- /dev/null +++ b/R/mod_table_page.R @@ -0,0 +1,76 @@ + +table_page_ui <- function(id){ + + ns <- NS(id) + + tagList( + span( + style = "display: flex; gap: 5px;", + htmlOutput(ns("page_txt")), + actionButton(ns("prev_tbl"), "Previous", icon = icon("backward-step"), class = "btn-page"), + actionButton(ns("next_tbl"), "Next", icon = icon("forward-step"), class = "btn-page") + ) + ) + +} + +#' @param id module ID +#' @param tab_gt rendered tfrmt as gt/gt_group +#' +#' @noRd +table_page_server <- function(id, tab_gt){ + + moduleServer( + id, + function(input, output, session){ + + ns <- session$ns + + # determine length + page_tot <- reactiveVal(1) + page_cur <- reactiveVal(1) + + # reset indices when table updates + observeEvent(tab_gt(), { + if (inherits(tab_gt(), "gt_group")){ + tot <- length(tab_gt()) + page_tot(tot) + } else { + page_tot(1) + } + page_cur(1) + }) + + # update txt + output$page_txt <- renderUI({ + + p(paste0("Displaying page ", page_cur(), " of ", page_tot()), + style="font-size: 90%; margin-top:4px; margin-bottom: 4px; text-align:center;") + + }) + + # toggle buttons + observe({ + shinyjs::toggleState("prev_tbl", condition = !page_cur()==1) + shinyjs::toggleState("next_tbl", condition = !page_cur()==page_tot()) + }) + + # indices respond to buttons + observeEvent(input$prev_tbl, { + new_idx <- page_cur()-1 + if (new_idx>0){ + page_cur(new_idx) + } + }) + observeEvent(input$next_tbl, { + new_idx <- page_cur()+1 + if (new_idx<=page_tot()){ + page_cur(new_idx) + } + }) + + return(page_cur) + + + }) +} diff --git a/R/utils_tfrmt.R b/R/utils_tfrmt.R index a969c9b..7dd8667 100644 --- a/R/utils_tfrmt.R +++ b/R/utils_tfrmt.R @@ -26,6 +26,12 @@ prep_tfrmt_app <- function(tf){ ) } + if(is.null(tf$page_plan)){ + tf$page_plan <- page_plan( + max_rows = 5 + ) + } + tf } diff --git a/inst/www/styles.css b/inst/www/styles.css index f4ba4e2..1b8df53 100644 --- a/inst/www/styles.css +++ b/inst/www/styles.css @@ -261,6 +261,21 @@ pre.shiny-text-output { border-color: #1D3A6D !important; } +/* for pagination buttons */ +.btn-page { + color: #FFFFFF !important; + background: #254988 !important; + border-color: #254988 !important; + padding:0px 6px 0px 6px; + margin: 0px; + font-size:90% +} +.btn-page:hover { + color: #FFFFFF !important; + background-color: #1D3A6D !important; + border-color: #1D3A6D !important; +} + /* for fileInput (browse) button */ span.btn.btn-default.btn-file { color: #FFFFFF !important; From 6e951987f856f3d0331c41e3ede14c8e31c68089 Mon Sep 17 00:00:00 2001 From: Becca Krouse Date: Fri, 17 Nov 2023 15:13:48 -0500 Subject: [PATCH 02/22] share table view module for edit & export --- R/mod_table_view.R | 50 ++++++++++++++++++++++++++++++----------- R/tfrmtbuilder_server.R | 5 +++-- 2 files changed, 40 insertions(+), 15 deletions(-) diff --git a/R/mod_table_view.R b/R/mod_table_view.R index 12ad880..f4ef645 100644 --- a/R/mod_table_view.R +++ b/R/mod_table_view.R @@ -5,18 +5,20 @@ table_view_ui <- function(id){ ns <- NS(id) tagList( - actionButton(ns("refresh"), "Refresh", icon = icon("sync"), class = "btn-refresh"), + shinyjs::hidden(actionButton(ns("refresh"), "Refresh", icon = icon("sync"), class = "btn-refresh")), shinyjs::hidden( div( id = ns("tbl_div"), + table_page_ui(ns("tbl_page")), shinycssloaders::withSpinner( color = getOption("spinner.color", default = "#254988"), type = 4, - htmlOutput(ns("tbl_view")) + tagList( + htmlOutput(ns("tbl_view")) + ) ) ) - ) - , + ) , shinyjs::hidden( p(id = ns("tbl_div_msg"), style="color:red;", "Incomplete settings configuration") @@ -33,7 +35,7 @@ table_view_ui <- function(id){ #' @param mode mock mode w/ no data, w/ data, reporting #' #' @noRd -table_view_server <- function(id, tab_selected, data, tfrmt_app_out, settings){ +table_view_server <- function(id, tab_selected = reactive(NULL), data, tfrmt_app_out, settings, enable_refresh = FALSE){ moduleServer( id, @@ -41,6 +43,11 @@ table_view_server <- function(id, tab_selected, data, tfrmt_app_out, settings){ ns <- session$ns + # enable refresh? + observe({ + shinyjs::toggle("refresh", condition = enable_refresh) + }) + # hide/show the table observe({ shinyjs::toggle("tbl_div", condition = !is.null(tfrmt_app_out())) @@ -128,41 +135,58 @@ table_view_server <- function(id, tab_selected, data, tfrmt_app_out, settings){ data <- isolate(data()) if (mode=="reporting"){ - tab <- tfrmt_app_out %>% safely(print_to_gt)(.data = data) + tfrmt_app_out %>% safely(print_to_gt)(.data = data) } else if (mode=="mock_no_data"){ - tab <- tfrmt_app_out %>% safely(print_mock_gt)() + tfrmt_app_out %>% safely(print_mock_gt)() } else { - tab <- tfrmt_app_out %>% safely(print_mock_gt)(.data = data) + tfrmt_app_out %>% safely(print_mock_gt)(.data = data) } }) + # module to get current page + page_cur <- table_page_server("tbl_page", reactive(tab()$result)) + + # subset to selected + tab_sub <- reactive({ + + req(!is.null(tab()$result)) + + if (inherits(tab()$result, "gt_group")){ + tab()$result |> grp_pull(page_cur()) + } else{ + tab()$result + } + }) + # view table output$tbl_view <- renderUI({ - req(!is.null(tab()$result)) + req(tab_sub()) - div(style = "height:100%; overflow-x: auto; overflow-y: auto; width: 100%", + div(style = "height:100%; overflow-x: auto; overflow-y: auto; width: 100%", as_raw_html( - tab()$result %>% + tab_sub() %>% tab_style(style = cell_text(whitespace = "pre"), locations = list(cells_stub(), cells_body(), cells_row_groups())) %>% tab_options( table.align = "left" ) - , inline_css = FALSE)) + , inline_css = FALSE) + ) }) - # error msgs print output$error_msg <- renderUI({ req(!is.null(tab()$error)) HTML(p(paste(tab()$error))) }) + + return(reactive(tab()$result)) } ) } diff --git a/R/tfrmtbuilder_server.R b/R/tfrmtbuilder_server.R index 88eefa0..0b7c5ad 100644 --- a/R/tfrmtbuilder_server.R +++ b/R/tfrmtbuilder_server.R @@ -99,13 +99,14 @@ tfrmtbuilder_server <- function(id) { tab_selected = reactive(input$tabs), data = reactive(settings()$data) , tfrmt_app_out = tfrmt_app_out, - settings = settings) + settings = settings, + enable_refresh = TRUE) # export module export_server("export", data = reactive(settings()$data) , tfrmt_app_out = tfrmt_app_out, - mode = settings_orig$mode) + settings = settings) # view data output$data_view <- renderDT({ From 3f6fc4dcaf4df09e50e9559ae3bfb45298f2da51 Mon Sep 17 00:00:00 2001 From: Becca Krouse Date: Fri, 17 Nov 2023 15:14:13 -0500 Subject: [PATCH 03/22] paginated outputs + add output types --- NAMESPACE | 1 + R/mod_export.R | 56 +++++++++----------------------------------- R/mod_export_table.R | 55 +++++++++++++++++++++++++++++++++++++++++++ R/zzz.R | 2 +- 4 files changed, 68 insertions(+), 46 deletions(-) create mode 100644 R/mod_export_table.R diff --git a/NAMESPACE b/NAMESPACE index bfaae08..8f60afd 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -38,3 +38,4 @@ importFrom(shinyjs,toggleState) importFrom(shinyjs,useShinyjs) importFrom(stats,setNames) importFrom(utils,getFromNamespace) +importFrom(utils,zip) diff --git a/R/mod_export.R b/R/mod_export.R index b207a55..c61b97d 100644 --- a/R/mod_export.R +++ b/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"), 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_view_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,8 @@ 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() + tbl_out <- table_view_server("tbl_view", data = data, tfrmt_app_out = tfrmt_app_out, settings = settings) - } else { - tfrmt_app_out() %>% print_mock_gt(.data = data()) - } - }) - - output$tbl <- render_gt({ - tbl_out() - }) output$json_save <- downloadHandler( filename = function() { @@ -91,24 +73,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"), function(ext){ + mod_export_table_server(ext, tbl=tbl_out, ext=ext) + }) }) } diff --git a/R/mod_export_table.R b/R/mod_export_table.R new file mode 100644 index 0000000..e1d7c35 --- /dev/null +++ b/R/mod_export_table.R @@ -0,0 +1,55 @@ + +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) + + walk(seq_along(tbl()), 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) + + } + } + ) + + + + } + ) +} diff --git a/R/zzz.R b/R/zzz.R index 770c2c0..f89cf8b 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -20,7 +20,7 @@ #' @importFrom rlang `:=` `!!` #' @importFrom shinyFeedback useShinyFeedback feedbackDanger #' @importFrom fontawesome fa_i -#' @importFrom utils getFromNamespace +#' @importFrom utils getFromNamespace zip NULL globalVariables(".") From 3ed2d9e14beeaa4a699233932b18fe288b445848 Mon Sep 17 00:00:00 2001 From: Becca Krouse Date: Tue, 21 Nov 2023 14:21:04 -0500 Subject: [PATCH 04/22] update element name per tfrmt update --- R/mod_row_grp_plan.R | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/R/mod_row_grp_plan.R b/R/mod_row_grp_plan.R index d3980b4..af742a2 100644 --- a/R/mod_row_grp_plan.R +++ b/R/mod_row_grp_plan.R @@ -70,7 +70,7 @@ row_grp_plan_server <- function(id, data, tfrmt_app, mode_load){ observeEvent(input$reset,{ req(mode()=="done") data_bp(data()) - struct_list(tfrmt_app()$row_grp_plan$struct_ls) + struct_list(tfrmt_app()$row_grp_plan$struct_list) shinyWidgets::updateRadioGroupButtons(session, "label_loc", selected = tfrmt_app()$row_grp_plan$label_loc$location) @@ -78,7 +78,11 @@ row_grp_plan_server <- function(id, data, tfrmt_app, mode_load){ # set up the defaults observeEvent(tfrmt_app(),{ - struct_list(tfrmt_app()$row_grp_plan$struct_ls) + + existing_rgp <- tfrmt_app()$row_grp_plan$struct_list + if (!is_empty(existing_rgp)){ + struct_list(existing_rgp) + } selected <- tfrmt_app()$row_grp_plan$label_loc$location %||% "indented" From 5ebf3c0f3494417a1b15b339fd3d9988262d64c0 Mon Sep 17 00:00:00 2001 From: Becca Krouse Date: Tue, 21 Nov 2023 14:22:08 -0500 Subject: [PATCH 05/22] add pagination to table view & refactor for reuse --- R/mod_table_inner.R | 116 ++++++++++++++++++++++ R/{mod_table_view.R => mod_table_outer.R} | 97 ++---------------- R/mod_table_page.R | 2 +- 3 files changed, 126 insertions(+), 89 deletions(-) create mode 100644 R/mod_table_inner.R rename R/{mod_table_view.R => mod_table_outer.R} (51%) diff --git a/R/mod_table_inner.R b/R/mod_table_inner.R new file mode 100644 index 0000000..37be87e --- /dev/null +++ b/R/mod_table_inner.R @@ -0,0 +1,116 @@ +# tfrmt Table inner module + +table_inner_ui <- function(id){ + + ns <- NS(id) + + tagList( + shinyjs::hidden( + div( + id = ns("tbl_div"), + table_page_ui(ns("tbl_page")), + shinycssloaders::withSpinner( + color = getOption("spinner.color", default = "#254988"), + type = 4, + tagList( + htmlOutput(ns("tbl_view")) + ) + ) + ) + ) , + shinyjs::hidden( + p(id = ns("tbl_div_msg"), style="color:red;", + "Incomplete settings configuration") + ), + htmlOutput(ns("error_msg")) + ) +} + + +#' @param id module ID +#' @param data data for the table +#' @param tfrmt_app_out final tfrmt for the table +#' @param mode mock mode w/ no data, w/ data, reporting +#' @param retbl +#' +#' @noRd +table_inner_server <- function(id, data, tfrmt_app_out, settings, retbl){ + + moduleServer( + id, + function(input, output, session){ + + ns <- session$ns + + # hide/show the table + observe({ + shinyjs::toggle("tbl_div", condition = !is.null(tfrmt_app_out())) + shinyjs::toggle("tbl_div_msg", condition = is.null(tfrmt_app_out())) + }) + + + # table as reactive + tab <- reactive({ + + req(retbl()>0) + + tfrmt_app_out <- isolate(tfrmt_app_out()) + mode <- isolate(settings()$mode) + data <- isolate(data()) + + if (mode=="reporting"){ + tfrmt_app_out %>% safely(print_to_gt)(.data = data) + + } else if (mode=="mock_no_data"){ + + tfrmt_app_out %>% safely(print_mock_gt)() + + } else { + tfrmt_app_out %>% safely(print_mock_gt)(.data = data) + } + + }) + + # module to get current page + page_cur <- table_page_server("tbl_page", reactive(tab()$result)) + + # subset to selected + tab_sub <- reactive({ + + req(!is.null(tab()$result)) + + if (inherits(tab()$result, "gt_group")){ + tab()$result |> grp_pull(page_cur()) + } else{ + tab()$result + } + }) + + # view table + output$tbl_view <- renderUI({ + + req(tab_sub()) + + div(style = "height:100%; overflow-x: auto; overflow-y: auto; width: 100%", + as_raw_html( + tab_sub() %>% + tab_style(style = cell_text(whitespace = "pre"), + locations = list(cells_stub(), cells_body(), cells_row_groups())) %>% + tab_options( + table.align = "left" + ) + , inline_css = FALSE) + ) + + }) + + # error msgs print + output$error_msg <- renderUI({ + req(!is.null(tab()$error)) + HTML(p(paste(tab()$error))) + }) + + return(reactive(tab()$result)) + } + ) +} diff --git a/R/mod_table_view.R b/R/mod_table_outer.R similarity index 51% rename from R/mod_table_view.R rename to R/mod_table_outer.R index f4ef645..1b3b48e 100644 --- a/R/mod_table_view.R +++ b/R/mod_table_outer.R @@ -1,29 +1,12 @@ -# tfrmt Table view module +# tfrmt Table outer module -table_view_ui <- function(id){ +table_outer_ui <- function(id){ ns <- NS(id) tagList( - shinyjs::hidden(actionButton(ns("refresh"), "Refresh", icon = icon("sync"), class = "btn-refresh")), - shinyjs::hidden( - div( - id = ns("tbl_div"), - table_page_ui(ns("tbl_page")), - shinycssloaders::withSpinner( - color = getOption("spinner.color", default = "#254988"), - type = 4, - tagList( - htmlOutput(ns("tbl_view")) - ) - ) - ) - ) , - shinyjs::hidden( - p(id = ns("tbl_div_msg"), style="color:red;", - "Incomplete settings configuration") - ), - htmlOutput(ns("error_msg")) + actionButton(ns("refresh"), "Refresh", icon = icon("sync"), class = "btn-refresh"), + table_inner_ui(ns("tbl")) ) } @@ -32,10 +15,10 @@ table_view_ui <- function(id){ #' @param tab_selected selected tab in the tabPanel #' @param data data for the table #' @param tfrmt_app_out final tfrmt for the table -#' @param mode mock mode w/ no data, w/ data, reporting +#' @param settings mock mode w/ no data, w/ data, reporting #' #' @noRd -table_view_server <- function(id, tab_selected = reactive(NULL), data, tfrmt_app_out, settings, enable_refresh = FALSE){ +table_outer_server <- function(id, tab_selected = reactive(NULL), data, tfrmt_app_out, settings){ moduleServer( id, @@ -43,11 +26,6 @@ table_view_server <- function(id, tab_selected = reactive(NULL), data, tfrmt_app ns <- session$ns - # enable refresh? - observe({ - shinyjs::toggle("refresh", condition = enable_refresh) - }) - # hide/show the table observe({ shinyjs::toggle("tbl_div", condition = !is.null(tfrmt_app_out())) @@ -103,6 +81,7 @@ table_view_server <- function(id, tab_selected = reactive(NULL), data, tfrmt_app } }) + # track state of tbl (for css of refresh button) # - when final tfrmt is changed, indicate refresh needed # - if a refresh is triggered (automatically or by button press), remove the indication @@ -116,7 +95,6 @@ table_view_server <- function(id, tab_selected = reactive(NULL), data, tfrmt_app tbl_invalid(TRUE) }) - # when display update is triggered, remove the indication observeEvent(req(retbl()>0),{ shinyjs::removeClass("refresh", class = "btn-danger") @@ -125,68 +103,11 @@ table_view_server <- function(id, tab_selected = reactive(NULL), data, tfrmt_app tbl_invalid(FALSE) }) - # table as reactive - tab <- reactive({ - - req(retbl()>0) - - tfrmt_app_out <- isolate(tfrmt_app_out()) - mode <- isolate(settings()$mode) - data <- isolate(data()) - - if (mode=="reporting"){ - tfrmt_app_out %>% safely(print_to_gt)(.data = data) - - } else if (mode=="mock_no_data"){ - - tfrmt_app_out %>% safely(print_mock_gt)() - - } else { - tfrmt_app_out %>% safely(print_mock_gt)(.data = data) - } - - }) - - # module to get current page - page_cur <- table_page_server("tbl_page", reactive(tab()$result)) - - # subset to selected - tab_sub <- reactive({ - - req(!is.null(tab()$result)) - - if (inherits(tab()$result, "gt_group")){ - tab()$result |> grp_pull(page_cur()) - } else{ - tab()$result - } - }) - - # view table - output$tbl_view <- renderUI({ - req(tab_sub()) - - div(style = "height:100%; overflow-x: auto; overflow-y: auto; width: 100%", - as_raw_html( - tab_sub() %>% - tab_style(style = cell_text(whitespace = "pre"), - locations = list(cells_stub(), cells_body(), cells_row_groups())) %>% - tab_options( - table.align = "left" - ) - , inline_css = FALSE) - ) + tab <- table_inner_server("tbl", data, tfrmt_app_out, settings, retbl) - }) - - # error msgs print - output$error_msg <- renderUI({ - req(!is.null(tab()$error)) - HTML(p(paste(tab()$error))) - }) + return(tab) - return(reactive(tab()$result)) } ) } diff --git a/R/mod_table_page.R b/R/mod_table_page.R index 4b7a5ab..05ed00b 100644 --- a/R/mod_table_page.R +++ b/R/mod_table_page.R @@ -33,7 +33,7 @@ table_page_server <- function(id, tab_gt){ # reset indices when table updates observeEvent(tab_gt(), { if (inherits(tab_gt(), "gt_group")){ - tot <- length(tab_gt()) + tot <- nrow(tab_gt()$gt_tbls) page_tot(tot) } else { page_tot(1) From 7723fdfb6977736983f37a2bb36fdf0fc1a3cb2d Mon Sep 17 00:00:00 2001 From: Becca Krouse Date: Tue, 21 Nov 2023 14:23:00 -0500 Subject: [PATCH 06/22] add page_plan & switch to new table module naming --- R/mod_page_plan.R | 327 ++++++++++++++++++++++++++++++++++++++++ R/mod_page_plan_edit.R | 50 ++++++ R/tfrmtbuilder_server.R | 9 +- R/tfrmtbuilder_ui.R | 6 +- 4 files changed, 388 insertions(+), 4 deletions(-) create mode 100644 R/mod_page_plan.R create mode 100644 R/mod_page_plan_edit.R diff --git a/R/mod_page_plan.R b/R/mod_page_plan.R new file mode 100644 index 0000000..1d5a7f7 --- /dev/null +++ b/R/mod_page_plan.R @@ -0,0 +1,327 @@ +# Page plan - top level module + +# returns page_plan() + +page_plan_ui <- function(id){ + + ns <- NS(id) + + tagList( + fluidRow( + h3("Page Plan", class = "heading_style", + actionButton(ns("reset"), "Reset", icon = icon("undo")), class = "btn-reset"), + h4("Note location"), + shinyWidgets::radioGroupButtons( + inputId = ns("note_loc"), label = NULL, + choices = c("noprint", "preheader", "subtitle", "source_note"), + selected = character(0) + ), + h4("Max rows"), + span( + style = "display: flex; gap: 5px;", + prettySwitch(ns("max_set"), "Set", value = FALSE), + conditionalPanel( + condition = "input.max_set==true", + numericInput(ns("max_rows"), label = NULL, value = 10, min = 1, max = NA, step = 5), + ns = ns + ) + ), + h4("Page Structures"), + shinyjs::hidden( + p(id = ns("none"), + "None supplied.") + ), + p(id = ns("some"), "Click table entry to edit"), + div( + id = ns("sortable"), + uiOutput(ns("tbl")) + ), + br(), + fluidRow( + column(3, div(actionButton(ns("add"), "New", icon = icon("plus")), class = "btn-new")), + column(3, offset = 1, div(shinyjs::disabled(actionButton(ns("delete"), "Delete", icon = icon("trash")))), class = "btn-delete") + ) + ), + br(), + shinyjs::hidden( + div(id = ns("customize"), + fluidRow( + page_plan_edit_ui(ns("customize_pane")) + ), + fluidRow( + column(3, div(actionButton(ns("save"), "Save", icon = icon("save")), class = "btn-save")), + column(4, shinyjs::hidden(div(id = ns("invalid"), "Invalid Entry", style = "color: red;"))) + ) + ) + ) + ) + +} + +#' @param id module ID +#' @param data data for the table +#' @param tfrmt_app tfrmt object +#' @param mode_load mock mode w/ no data, w/ data, reporting +#' +#' @noRd +page_plan_server <- function(id, data, tfrmt_app, mode_load){ + + moduleServer( + id, + function(input, output, session){ + + ns <- session$ns + + struct_list <- reactiveVal(NULL) + + data_bp <- reactiveVal(NULL) + + max_rows <- reactiveVal(NULL) + + # reset to defaults + observeEvent(input$reset,{ + req(mode()=="done") + data_bp(data()) + struct_list(tfrmt_app()$page_plan$struct_list) + + + if (!is.null(tfrmt_app()$page_plan$max_rows)){ + shinyWidgets::updatePrettyCheckbox(session, "max_set", value = TRUE) + updateNumericInput(session, "max_rows", value = tfrmt_app()$page_plan$max_rows) + } + + shinyWidgets::updateRadioGroupButtons(session, "note_loc", + selected = tfrmt_app()$page_plan$note_loc) + }) + + # set up the defaults + observeEvent(tfrmt_app(),{ + + existing_pp <- tfrmt_app()$page_plan$struct_list + if (!is_empty(existing_pp)){ + struct_list(existing_pp) + } + + if (!is.null(tfrmt_app()$page_plan$max_rows)){ + shinyWidgets::updatePrettyCheckbox(session, "max_set", value = TRUE) + updateNumericInput(session, "max_rows", value = tfrmt_app()$page_plan$max_rows) + } + + selected <- tfrmt_app()$page_plan$note_loc %||% "noprint" + + shinyWidgets::updateRadioGroupButtons(session, "note_loc", + selected = selected) + }) + observeEvent(data(),{ + data_bp(data()) + }) + + observe({ + if(input$max_set){ + max_rows(input$max_rows) + } else { + max_rows(NULL) + } + }) + + # display the page_structures + output$tbl <- renderUI({ + + req(length(struct_list())>0) + + struct_list_txt <- map(struct_list(), + ~.x %>% format_page_struct() %>% {paste0(., collapse = "
")}) + + create_struct_list_sortable(ns, struct_list_txt, mode()) + + }) + + # when the list is sorted, reshuffle the page_structures + observeEvent(input$item_list, { + + list_ord <- input$item_list %>% as.numeric() + + # if out of order, reshuffle + + if (!all(sort(list_ord)==list_ord)){ + + struct_list(struct_list()[list_ord]) + + mode("done") + + } + }) + + + # when any are selected, switch to edit mode + onclick("items", expr = { + + last_struct <- pluck(struct_list(), length(struct_list())) + if(!is_empty(last_struct)){ + mode("edit") + } + }) + + # reactive representing currently selected row's data + # reset to NULL if new format to be added + selected <- reactiveVal(NULL) + item_num_active <- reactiveVal(NULL) + + observeEvent(req(mode()=="edit"),{ + + item_num <- as.numeric(input$`button-item`) + + item_num_active(item_num) + + selected( + struct_list()[[item_num]] + ) + }) + + + # add mode - add placeholder frmt structure & clear row selection so it is not passed along + observeEvent(input$add, { + + # add an empty row_grp_structure + struct_list(c(struct_list(), list(NULL))) + item_num_active(length(struct_list())) + + # clear selection + selected(NULL) + + }) + + # keep track of which "mode" we're in: add new, edit existing, done (saved/deleted) + mode <- reactiveVal("done") + observeEvent(req(input$add>0), mode("add")) + + + # css changes in response to mode change + observeEvent(mode(),{ + + if (mode()=="edit"){ + item_active_id <- paste0("item-", item_num_active()) + shinyjs::addClass(id = item_active_id, class = "rank-list-select") + + } else if (mode()=="done"){ + + len_items <- length(struct_list()) + item_ids <- paste0("item-", 1:len_items) + for (i in item_ids){ + shinyjs::removeClass(id = i, class = "rank-list-select") + } + } + + # show/hide the UI + # enable/disable the add, delete buttons + shinyjs::toggle("customize", condition = (mode() %in% c("add", "edit"))) + shinyjs::toggleState("add", condition = (mode()=="done")) + shinyjs::toggleState("delete", condition = (mode() %in% c("add", "edit"))) + shinyjs::toggleClass(id = "sortable", class = "unclickable", condition = (mode() %in% c("add", "edit"))) + + }) + + + # toggle the "no formats" message" + observe({ + any_items <- length(struct_list())==0 + shinyjs::toggle("none", condition = any_items) + shinyjs::toggle("some", condition = !any_items) + + }) + + # ensure selected() is updated in case of 2 "adds" in a row (selected stays NULL) + selected2 <- reactive({ + req(item_num_active()) + selected() + }) + # customize server + plans <- page_plan_edit_server("customize_pane", data_bp, tfrmt_app, selected2) + + + # when user presses "save", collect the inputs + observeEvent(input$save,{ + + struct_list_existing <- struct_list() + + # replace the highlighted row + current_id <- item_num_active() + + # update the list of row_grp_structures + if (!is.null(plans())){ + struct_list_existing[[current_id]] <- plans() + + # save the current selections to the list when button is pressed + struct_list(struct_list_existing) + + mode("done") # set to done mode + selected(NULL) # clear row selections + + } else { + + shinyjs::show("invalid") + } + }) + + # delete rows if requested + observeEvent(input$delete,{ + + # remove from list + if(!is.null(item_num_active())){ + struct_list( + struct_list()[-item_num_active()] + ) + } + + # reset mode + mode("done") + }) + + + # recreate data (mock no data only) when page_structure_list is updated following a save, deletion, or reorder + observeEvent(struct_list(), { + + req(mode()=="done") + + shinyjs::hide("invalid") + + if (mode_load()=="mock_no_data"){ + + new_tfrmt <- tfrmt_app() + + new_tfrmt$page_plan <- do.call("page_plan", struct_list()) + + if (length(struct_list())>0){ + new_data <- make_mock_data(new_tfrmt) + } else { + new_data <- data() + } + + data_bp(new_data) + + } + + }) + + # return final struct_list only when in done mode + page_plan_out <- reactive({ + req(mode()=="done") + req(input$note_loc) + + arg_list <- list(note_loc = input$note_loc, max_rows = input$max_rows) + if (!is.null(struct_list())){ + arg_list <- c(struct_list(), arg_list) + } + + do.call("page_plan", arg_list) + }) + + # return + return( + page_plan_out + ) + + + }) + +} diff --git a/R/mod_page_plan_edit.R b/R/mod_page_plan_edit.R new file mode 100644 index 0000000..9b9ef6e --- /dev/null +++ b/R/mod_page_plan_edit.R @@ -0,0 +1,50 @@ +# page plan editor module + +# returns page_structure() object + +page_plan_edit_ui <- function(id){ + + ns <- NS(id) + + tagList( + h3("Filter conditions"), + filters_ui(ns("filters")) + ) + +} + +#' @param id module ID +#' @param data data for the table +#' @param tfrmt_app tfrmt object +#' @param selected body_plan that is selected in (or being added to) the table +#' +#' @noRd +page_plan_edit_server <- function(id, data, tfrmt_app, selected){ + + moduleServer( + id, + function(input, output, session){ + + ns <- session$ns + + + # data filters module + collected_filters <- filters_server("filters", data, tfrmt_app, selected, + include = c("group", "label"), + null_to_default = FALSE, + add_default_opt = TRUE, + allow_create = reactive(FALSE)) + + # combine filters + post space into a page_structure + reactive({ + + req(!is.null(collected_filters()$group_val) || !is.null(collected_filters()$label_val)) + + page_structure(group_val = collected_filters()$group_val, + label_val = collected_filters()$label_val) + + }) + + } + ) +} diff --git a/R/tfrmtbuilder_server.R b/R/tfrmtbuilder_server.R index 0b7c5ad..ad75c4c 100644 --- a/R/tfrmtbuilder_server.R +++ b/R/tfrmtbuilder_server.R @@ -41,6 +41,8 @@ tfrmtbuilder_server <- function(id) { cp_out <- col_plan_simple_server("col_plan", reactive(settings()$data), reactive(settings()$tfrmt), settings_orig$mode) # big N creation bn_out <- big_n_server("big_n", reactive(settings()$data), reactive(settings()$tfrmt), settings_orig$mode) + # page plan creation + pp_out <- page_plan_server("page_plan", reactive(settings()$data), reactive(settings()$tfrmt), settings_orig$mode) # titles ti_out <- titles_server("titles", reactive(settings()$tfrmt)) @@ -59,6 +61,7 @@ tfrmtbuilder_server <- function(id) { req(cs_out()) req(cp_out()) req(bn_out()) + req(pp_out()) req(ti_out()) tfrmt_app <- settings()$tfrmt @@ -68,6 +71,7 @@ tfrmtbuilder_server <- function(id) { tfrmt_app$row_grp_plan <- rg_out() tfrmt_app$col_style_plan <- cs_out() tfrmt_app$col_plan <- cp_out() + tfrmt_app$page_plan <- pp_out() if (length(fn_out()$struct_list)>0){ tfrmt_app$footnote_plan <- fn_out() @@ -95,12 +99,11 @@ tfrmtbuilder_server <- function(id) { }) # table viewer module - table_view_server("tbl_view", + table_outer_server("tbl_view", tab_selected = reactive(input$tabs), data = reactive(settings()$data) , tfrmt_app_out = tfrmt_app_out, - settings = settings, - enable_refresh = TRUE) + settings = settings) # export module export_server("export", diff --git a/R/tfrmtbuilder_ui.R b/R/tfrmtbuilder_ui.R index 807cd9f..8fbc0bf 100644 --- a/R/tfrmtbuilder_ui.R +++ b/R/tfrmtbuilder_ui.R @@ -59,6 +59,10 @@ tfrmtbuilder_ui <- function(id){ div("(Optional)", id = "tab_note")), div( footnote_plan_ui(ns("footnote_plan")), id = "content_border")), + tabPanel(div( h6("Page Plan", class = "zero_margin"), + div("(Optional)", id = "tab_note")), + div( page_plan_ui(ns("page_plan")), id = "content_border")), + tabPanel(div( h6("Big Ns", class = "zero_margin"), div("(Optional)", id = "tab_note")), div( big_n_ui(ns("big_n")), id = "content_border")), @@ -76,7 +80,7 @@ tfrmtbuilder_ui <- function(id){ div(id = ns("sidebar"), tabsetPanel( tabPanel(title = div("Table", class = "tab_names"), br(), - table_view_ui(ns("tbl_view"))), + table_outer_ui(ns("tbl_view"))), tabPanel(title = div("Data", class = "tab_names"), DTOutput(ns("data_view"))) ) From 60d2e8763882d53c4bdb90eabfa96f0308e3e012 Mon Sep 17 00:00:00 2001 From: Becca Krouse Date: Tue, 21 Nov 2023 14:23:23 -0500 Subject: [PATCH 07/22] accomodate page plan in filters module --- R/mod_filters.R | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/R/mod_filters.R b/R/mod_filters.R index 4071fd5..cf159b8 100644 --- a/R/mod_filters.R +++ b/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,6 +71,7 @@ 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")) } @@ -78,7 +79,8 @@ filters_server <- function(id, data, tfrmt_app, selected, 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) } From abe5398a5fb82b74ae00740cbdf1b5bd9bb6db52 Mon Sep 17 00:00:00 2001 From: Becca Krouse Date: Tue, 21 Nov 2023 14:23:57 -0500 Subject: [PATCH 08/22] accomodate page plan --- R/utils_app.R | 45 +++++++++++++++++++++++++++++++++++---------- R/utils_tfrmt.R | 26 ++++++++++++++++++++++++-- 2 files changed, 59 insertions(+), 12 deletions(-) diff --git a/R/utils_app.R b/R/utils_app.R index d1f70f9..3fb896c 100644 --- a/R/utils_app.R +++ b/R/utils_app.R @@ -10,32 +10,52 @@ remove_shiny_inputs <- function(ns, id, .input) { # data-driven selectInputs: for selecting values of the tfrmt parameters (group, value, etc) create_filter_select <- function(ns, type, data, existing_filters, var_vec, allow_create = TRUE, - null_to_default = TRUE){ + null_to_default = TRUE, + add_default_opt = FALSE){ + # get the incoming settings for the given filter type (group_val, etc) existing_vars <- existing_filters %>% - keep_at(type) - existing_vars <- map2(existing_vars, names(existing_vars), function(x, y ){ + keep_at(type) |> + pluck(type) + + # create a named list + # - if already a named list (e.g. list(group = "val1")) then return + # - if not (e.g. ".default") then make it a named list (e.g. list(group=".default")) + existing_vars <- map(existing_vars, function(x){ if (is.list(x)){ x - } else if (is.null(x) || all(x==".default")){ - x } else { list(x) %>% setNames(var_vec) } }) %>% - list_flatten(name_spec = "{inner}") %>% - discard(~all(.x==".default")) + list_flatten(name_spec = "{inner}") + + # remove any default values if all null are to be set to .default + # (placeholder text will say ".default" when non selected) + if (null_to_default || + (!null_to_default && !add_default_opt)){ + existing_vars <- existing_vars %>% + discard(~all(.x==".default")) + } + # create a select input for each variable to be represented lapply(var_vec, function(v){ + # pull anything pre-selected for this variable filter_keep <-existing_vars %>% keep_at(v) + + # define pre-selections, if any if (length(filter_keep)>0){ selected_vals <- filter_keep %>% unlist() %>% unname() } else { - selected_vals <- character(0) + selected_vals <- character(0) } + # define choices in the drop-down: + # - no data: choices are only the pre-selections + # - data: choices are the values in the data + if (is.null(data)){ if (length(selected_vals)>0){ choices <- selected_vals @@ -46,6 +66,12 @@ create_filter_select <- function(ns, type, data, existing_filters, var_vec, choices <- data %>% pull(all_of(v)) %>% unique() } + # add ".default" as a choice if required + if (add_default_opt){ + choices <- c(".default",choices) + } + + # define the placeholder text, depending on whether setting to NULL is an option if (null_to_default){ placeholder <- ".default" } else { @@ -182,7 +208,7 @@ create_struct_list_sortable <- function(ns, struct_list_txt, mode){ "
", struct_list_txt[[i]], "
" @@ -190,7 +216,6 @@ create_struct_list_sortable <- function(ns, struct_list_txt, mode){ }) %>% setNames(as.character(ind)) - # rank list for sortable rank_list(text = "", labels = divs, diff --git a/R/utils_tfrmt.R b/R/utils_tfrmt.R index 7dd8667..0f9f7fd 100644 --- a/R/utils_tfrmt.R +++ b/R/utils_tfrmt.R @@ -28,7 +28,7 @@ prep_tfrmt_app <- function(tf){ if(is.null(tf$page_plan)){ tf$page_plan <- page_plan( - max_rows = 5 + max_rows = 60 ) } @@ -181,6 +181,23 @@ format_big_n_struct <- function(x){ frmt_struct_str } +# format page_structure objects +format_page_struct <- function(x){ + + if (is.null(x)){ + return(c("Group Values:","Label Values:")) + } + group_string <- create_format_txt(x$group_val) + label_string <- create_format_txt(x$label_val) + + page_struct_str <- c( + paste0("Group Values:",group_string), + paste0("Label Values:",label_string) + ) + + page_struct_str + +} # template frmt objects dummy_frmt <- function(){ @@ -227,7 +244,12 @@ cols_to_dat <- function(data, tfrmt, mock){ columns_lowest <- columns %>% last() %>% sym() tfrmt$big_n <- NULL - col_plan_vars <- attr(getFromNamespace("apply_tfrmt","tfrmt")(data, tfrmt, mock), ".col_plan_vars") + tfrmt_out <- getFromNamespace("apply_tfrmt","tfrmt")(data, tfrmt, mock) + if (!inherits(tfrmt_out, "processed_tfrmt_tbl") && is.list(tfrmt_out)){ + tfrmt_out <- tfrmt_out[[1]] + } + + col_plan_vars <- attr(tfrmt_out, ".col_plan_vars") allcols <- col_plan_vars %>% map_chr(as_label) allcols <- getFromNamespace("split_data_names_to_df","tfrmt")(data_names= c(), From 2a0d9cc65e412e614eb4bce8d7fec4a4fb8d4d04 Mon Sep 17 00:00:00 2001 From: Becca Krouse Date: Tue, 21 Nov 2023 14:24:55 -0500 Subject: [PATCH 09/22] switch to inner table module --- R/mod_export.R | 9 +++++++-- R/mod_export_table.R | 2 ++ 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/R/mod_export.R b/R/mod_export.R index c61b97d..a037bb8 100644 --- a/R/mod_export.R +++ b/R/mod_export.R @@ -34,7 +34,7 @@ export_ui <- function(id){ ) ), div(style = "height: 550px; overflow-y:auto; ", - table_view_ui(ns("tbl_view")) + table_inner_ui(ns("tbl_view")) ) ) ) @@ -61,7 +61,12 @@ export_server <- function(id, data, tfrmt_app_out, settings){ tfrmt_app_out() %>% tfrmt_to_json() }) - tbl_out <- table_view_server("tbl_view", data = data, tfrmt_app_out = tfrmt_app_out, settings = settings) + retbl <- reactiveVal(0) + observeEvent(tfrmt_app_out(), { + retbl(retbl()+1) + }) + + tbl_out <- table_inner_server("tbl_view", data = data, tfrmt_app_out = tfrmt_app_out, settings = settings, retbl = retbl) output$json_save <- downloadHandler( diff --git a/R/mod_export_table.R b/R/mod_export_table.R index e1d7c35..073240e 100644 --- a/R/mod_export_table.R +++ b/R/mod_export_table.R @@ -1,4 +1,6 @@ +# module for table download button for given output type + mod_export_table_ui <- function(id, ext){ ns <- NS(id) From db34de27ff1ed02ec44342146f8b5a26ef22cb9b Mon Sep 17 00:00:00 2001 From: Becca Krouse Date: Tue, 21 Nov 2023 14:37:34 -0500 Subject: [PATCH 10/22] compare directly to the template --- tests/testthat/test-mod_load.R | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/tests/testthat/test-mod_load.R b/tests/testthat/test-mod_load.R index 197dee2..945f52f 100644 --- a/tests/testthat/test-mod_load.R +++ b/tests/testthat/test-mod_load.R @@ -9,14 +9,7 @@ test_that("no files provided - mock mode", { session$setInputs(tfrmt_source = "None") session$setInputs(data_source = "Auto") - template_tfrmt <- tfrmt(group = "group", - label = "label", - param = "param", - value = "value", - column = "column", - body_plan = body_plan( - frmt_structure(group_val = ".default", label_val = ".default", frmt("xx.x")) - )) + template_tfrmt <- prep_tfrmt_app(tfrmt()) # returns template tfrmt expect_equal( From 8f6fe5abc47e84e2eeb5268aaf1054d16793779a Mon Sep 17 00:00:00 2001 From: Becca Krouse Date: Tue, 21 Nov 2023 15:10:22 -0500 Subject: [PATCH 11/22] pipe switch --- R/mod_export_table.R | 2 +- R/mod_table_inner.R | 2 +- R/utils_app.R | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/R/mod_export_table.R b/R/mod_export_table.R index 073240e..a40ccc7 100644 --- a/R/mod_export_table.R +++ b/R/mod_export_table.R @@ -32,7 +32,7 @@ mod_export_table_server <- function(id, tbl, ext){ dir.create(temp_dir) walk(seq_along(tbl()), function(x){ - tbl() |> grp_pull(x) |> gtsave(filename = paste0("tfrmt_",x,".", tolower(ext)), path = temp_dir) + tbl() %>% grp_pull(x) %>% gtsave(filename = paste0("tfrmt_",x,".", tolower(ext)), path = temp_dir) }) zip( diff --git a/R/mod_table_inner.R b/R/mod_table_inner.R index 37be87e..5bdbb94 100644 --- a/R/mod_table_inner.R +++ b/R/mod_table_inner.R @@ -80,7 +80,7 @@ table_inner_server <- function(id, data, tfrmt_app_out, settings, retbl){ req(!is.null(tab()$result)) if (inherits(tab()$result, "gt_group")){ - tab()$result |> grp_pull(page_cur()) + tab()$result %>% grp_pull(page_cur()) } else{ tab()$result } diff --git a/R/utils_app.R b/R/utils_app.R index 3fb896c..ddeffb9 100644 --- a/R/utils_app.R +++ b/R/utils_app.R @@ -15,7 +15,7 @@ create_filter_select <- function(ns, type, data, existing_filters, var_vec, # get the incoming settings for the given filter type (group_val, etc) existing_vars <- existing_filters %>% - keep_at(type) |> + keep_at(type) %>% pluck(type) # create a named list From e66bd9e97a6608a3b0d89be06abf77baf8f3bf2c Mon Sep 17 00:00:00 2001 From: Becca Krouse Date: Wed, 29 Nov 2023 11:55:38 -0500 Subject: [PATCH 12/22] revert a change --- R/mod_table_outer.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/mod_table_outer.R b/R/mod_table_outer.R index 1b3b48e..1ade17e 100644 --- a/R/mod_table_outer.R +++ b/R/mod_table_outer.R @@ -18,7 +18,7 @@ table_outer_ui <- function(id){ #' @param settings mock mode w/ no data, w/ data, reporting #' #' @noRd -table_outer_server <- function(id, tab_selected = reactive(NULL), data, tfrmt_app_out, settings){ +table_outer_server <- function(id, tab_selected, data, tfrmt_app_out, settings){ moduleServer( id, From add3411597baa5639a93e941cd307e4ea4dfe78a Mon Sep 17 00:00:00 2001 From: Becca Krouse Date: Tue, 5 Dec 2023 14:01:02 -0500 Subject: [PATCH 13/22] reorg paging button/text for smoother experience --- R/mod_table_inner.R | 7 +++++-- R/mod_table_page.R | 19 +++++++------------ inst/www/styles.css | 3 --- 3 files changed, 12 insertions(+), 17 deletions(-) diff --git a/R/mod_table_inner.R b/R/mod_table_inner.R index 5bdbb94..1244a40 100644 --- a/R/mod_table_inner.R +++ b/R/mod_table_inner.R @@ -72,7 +72,7 @@ table_inner_server <- function(id, data, tfrmt_app_out, settings, retbl){ }) # module to get current page - page_cur <- table_page_server("tbl_page", reactive(tab()$result)) + page_info <- table_page_server("tbl_page", reactive(tab()$result)) # subset to selected tab_sub <- reactive({ @@ -80,7 +80,7 @@ table_inner_server <- function(id, data, tfrmt_app_out, settings, retbl){ req(!is.null(tab()$result)) if (inherits(tab()$result, "gt_group")){ - tab()$result %>% grp_pull(page_cur()) + tab()$result %>% grp_pull(page_info$page_cur()) } else{ tab()$result } @@ -91,6 +91,8 @@ table_inner_server <- function(id, data, tfrmt_app_out, settings, retbl){ req(tab_sub()) + div( + p(paste0("Displaying page ", page_info$page_cur(), " of ", page_info$page_tot())), div(style = "height:100%; overflow-x: auto; overflow-y: auto; width: 100%", as_raw_html( tab_sub() %>% @@ -101,6 +103,7 @@ table_inner_server <- function(id, data, tfrmt_app_out, settings, retbl){ ) , inline_css = FALSE) ) + ) }) diff --git a/R/mod_table_page.R b/R/mod_table_page.R index 05ed00b..d5b44d6 100644 --- a/R/mod_table_page.R +++ b/R/mod_table_page.R @@ -4,12 +4,12 @@ table_page_ui <- function(id){ ns <- NS(id) tagList( - span( - style = "display: flex; gap: 5px;", - htmlOutput(ns("page_txt")), + h3( + span( actionButton(ns("prev_tbl"), "Previous", icon = icon("backward-step"), class = "btn-page"), actionButton(ns("next_tbl"), "Next", icon = icon("forward-step"), class = "btn-page") ) + ) ) } @@ -41,14 +41,6 @@ table_page_server <- function(id, tab_gt){ page_cur(1) }) - # update txt - output$page_txt <- renderUI({ - - p(paste0("Displaying page ", page_cur(), " of ", page_tot()), - style="font-size: 90%; margin-top:4px; margin-bottom: 4px; text-align:center;") - - }) - # toggle buttons observe({ shinyjs::toggleState("prev_tbl", condition = !page_cur()==1) @@ -69,7 +61,10 @@ table_page_server <- function(id, tab_gt){ } }) - return(page_cur) + return( + list(page_cur = page_cur, + page_tot = page_tot) + ) }) diff --git a/inst/www/styles.css b/inst/www/styles.css index 1b8df53..40d6343 100644 --- a/inst/www/styles.css +++ b/inst/www/styles.css @@ -266,9 +266,6 @@ pre.shiny-text-output { color: #FFFFFF !important; background: #254988 !important; border-color: #254988 !important; - padding:0px 6px 0px 6px; - margin: 0px; - font-size:90% } .btn-page:hover { color: #FFFFFF !important; From 2a8092e7ca8468b386ffaa08ddef4309848dddcc Mon Sep 17 00:00:00 2001 From: Becca Krouse Date: Fri, 23 Feb 2024 15:33:45 -0500 Subject: [PATCH 14/22] cleanup and improve refresh button timing --- R/mod_datamapping_inputs.R | 2 -- R/mod_export.R | 6 +++--- R/mod_table_inner.R | 6 +++--- R/mod_table_outer.R | 37 ++++++++++--------------------------- R/tfrmtbuilder_server.R | 36 ++++++++++++------------------------ 5 files changed, 28 insertions(+), 59 deletions(-) diff --git a/R/mod_datamapping_inputs.R b/R/mod_datamapping_inputs.R index d82f14a..61913a2 100644 --- a/R/mod_datamapping_inputs.R +++ b/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 diff --git a/R/mod_export.R b/R/mod_export.R index a037bb8..9f86d78 100644 --- a/R/mod_export.R +++ b/R/mod_export.R @@ -61,12 +61,12 @@ export_server <- function(id, data, tfrmt_app_out, settings){ tfrmt_app_out() %>% tfrmt_to_json() }) - retbl <- reactiveVal(0) + auto_tbl <- reactiveVal(0) observeEvent(tfrmt_app_out(), { - retbl(retbl()+1) + auto_tbl(auto_tbl()+1) }) - tbl_out <- table_inner_server("tbl_view", data = data, tfrmt_app_out = tfrmt_app_out, settings = settings, retbl = retbl) + 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( diff --git a/R/mod_table_inner.R b/R/mod_table_inner.R index 1244a40..00cc9b3 100644 --- a/R/mod_table_inner.R +++ b/R/mod_table_inner.R @@ -31,10 +31,10 @@ table_inner_ui <- function(id){ #' @param data data for the table #' @param tfrmt_app_out final tfrmt for the table #' @param mode mock mode w/ no data, w/ data, reporting -#' @param retbl +#' @param auto_tbl #' #' @noRd -table_inner_server <- function(id, data, tfrmt_app_out, settings, retbl){ +table_inner_server <- function(id, data, tfrmt_app_out, settings, auto_tbl){ moduleServer( id, @@ -52,7 +52,7 @@ table_inner_server <- function(id, data, tfrmt_app_out, settings, retbl){ # table as reactive tab <- reactive({ - req(retbl()>0) + req(auto_tbl()>0) tfrmt_app_out <- isolate(tfrmt_app_out()) mode <- isolate(settings()$mode) diff --git a/R/mod_table_outer.R b/R/mod_table_outer.R index 1ade17e..a1b8ca9 100644 --- a/R/mod_table_outer.R +++ b/R/mod_table_outer.R @@ -32,56 +32,40 @@ table_outer_server <- function(id, tab_selected, data, tfrmt_app_out, settings){ shinyjs::toggle("tbl_div_msg", condition = is.null(tfrmt_app_out())) }) - # register when the tfrmt/table should update: # - on initialization, if all valid # - when refresh button is pressed # - when selected tab changes & tbl is out of sync - retbl <- reactiveVal(0) + auto_tbl <- reactiveVal(0) - # settings_counter for # of times the tfrmt settings are captured - # aim is to trigger an auto-refresh when settings_count =1 and original settings are valid - settings_count <- reactiveVal(NULL) - observeEvent(settings(),{ - if (settings()$original==TRUE){ - settings_count(0) - } else { - settings_count(1) - } - }) - observeEvent(tfrmt_app_out(), { - settings_count(settings_count() + 1) - }) # on initialization, if all valid observe({ req(settings()$original==TRUE) req(tfrmt_app_out()) - req(settings_count()==1) isolate( - retbl(retbl()+1) + auto_tbl(auto_tbl()+1) ) }) - # refreshed + # refresh button pressed observeEvent(input$refresh, { - retbl(retbl()+1) + auto_tbl(auto_tbl()+1) }) # tab change observeEvent(tab_selected(), { if (tbl_invalid()){ - retbl(retbl()+1) + auto_tbl(auto_tbl()+1) } }, ignoreInit = TRUE) # no update if tfrmt is reset (starting from beginning) or incomplete observe({ if (is.null(tfrmt_app_out())){ - retbl(0) + auto_tbl(0) } }) - # track state of tbl (for css of refresh button) # - when final tfrmt is changed, indicate refresh needed # - if a refresh is triggered (automatically or by button press), remove the indication @@ -89,14 +73,14 @@ table_outer_server <- function(id, tab_selected, data, tfrmt_app_out, settings){ tbl_invalid<- reactiveVal(FALSE) # when the final tfrmt is changed, indicate refresh is needed - observeEvent(tfrmt_app_out(),{ + observeEvent(c(tfrmt_app_out(), settings()), { shinyjs::addClass("refresh", class = "btn-danger") shinyjs::removeClass("refresh", class = "btn-refresh") tbl_invalid(TRUE) - }) + }, priority = 100) # when display update is triggered, remove the indication - observeEvent(req(retbl()>0),{ + observeEvent(req(auto_tbl()>0),{ shinyjs::removeClass("refresh", class = "btn-danger") shinyjs::addClass("refresh", class = "btn-refresh") @@ -104,9 +88,8 @@ table_outer_server <- function(id, tab_selected, data, tfrmt_app_out, settings){ }) - tab <- table_inner_server("tbl", data, tfrmt_app_out, settings, retbl) + table_inner_server("tbl", data, tfrmt_app_out, settings, auto_tbl) - return(tab) } ) diff --git a/R/tfrmtbuilder_server.R b/R/tfrmtbuilder_server.R index ad75c4c..d90c1ed 100644 --- a/R/tfrmtbuilder_server.R +++ b/R/tfrmtbuilder_server.R @@ -12,22 +12,14 @@ tfrmtbuilder_server <- function(id) { # ui for loading settings_orig <- load_server("load", reactive(input$mockmode)) - # if user adjust the inputs, direct them to Data Mapping tab (in Edit tab) - observe({ - settings_orig$data() - settings_orig$tfrmt() - settings_orig$mode() - - updateTabsetPanel( - session = session, - "tabs", - selected = "Data Mapping - TEST" - ) + # final tfrmt to combine results of all modules + tfrmt_app_out <- reactiveVal(NULL) - }) + observeEvent(settings_orig$data(), # when data changes, reset + tfrmt_app_out(NULL)) # tfrmt data mapping - returns an updated tfrmt/data to be fed into the other modules - settings <- datamapping_server("overview", settings_orig$data, settings_orig$tfrmt, settings_orig$mode) + settings <- datamapping_server("overview", settings_orig$data, settings_orig$tfrmt, settings_orig$mode) # body plan creation bp_out <- body_plan_server("body_plan", reactive(settings()$data), reactive(settings()$tfrmt), settings_orig$mode) @@ -46,13 +38,7 @@ tfrmtbuilder_server <- function(id) { # titles ti_out <- titles_server("titles", reactive(settings()$tfrmt)) - # final tfrmt to combine results of all modules - tfrmt_app_out <- reactiveVal(NULL) - - observeEvent(settings_orig$data(), # when data changes, reset - tfrmt_app_out(NULL)) - - # generate the updated tfrmt + # generate/update tfrmt observe({ req(settings()) req(bp_out()) @@ -84,8 +70,10 @@ tfrmtbuilder_server <- function(id) { } tfrmt_app_out(tfrmt_app) + }) + # data to display data_out <- reactive({ if (!settings()$mode=="mock_no_data"){ @@ -100,10 +88,10 @@ tfrmtbuilder_server <- function(id) { # table viewer module table_outer_server("tbl_view", - tab_selected = reactive(input$tabs), - data = reactive(settings()$data) , - tfrmt_app_out = tfrmt_app_out, - settings = settings) + tab_selected = reactive(input$tabs), + data = reactive(settings()$data) , + tfrmt_app_out = tfrmt_app_out, + settings = settings) # export module export_server("export", From ff71ec38f5d1271dbf2c337e959acd7696f70a4b Mon Sep 17 00:00:00 2001 From: Becca Krouse Date: Sat, 9 Mar 2024 07:22:35 -0500 Subject: [PATCH 15/22] correct # of tables --- R/mod_export_table.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/mod_export_table.R b/R/mod_export_table.R index a40ccc7..3815f34 100644 --- a/R/mod_export_table.R +++ b/R/mod_export_table.R @@ -31,7 +31,8 @@ mod_export_table_server <- function(id, tbl, ext){ temp_dir <- tempdir() dir.create(temp_dir) - walk(seq_along(tbl()), function(x){ + 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) }) From 4fbf0a7a6b8004aab46a9f7479071ff6a83a0db9 Mon Sep 17 00:00:00 2001 From: Becca Krouse Date: Sat, 9 Mar 2024 07:38:45 -0500 Subject: [PATCH 16/22] new hex --- R/mod_home.R | 6 +++++- README.md | 2 +- {man/figures => inst/www}/tfrmtbuilder_hex.png | Bin 3 files changed, 6 insertions(+), 2 deletions(-) rename {man/figures => inst/www}/tfrmtbuilder_hex.png (100%) diff --git a/R/mod_home.R b/R/mod_home.R index 86dfe41..6985b64 100644 --- a/R/mod_home.R +++ b/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("

Welcome to the {tfrmtbuilder} Shiny App

@@ -68,7 +72,7 @@ home_server <- function(id){ }) output$hex <- renderUI({ - HTML(" hex ") }) diff --git a/README.md b/README.md index cb61fcc..d4388ce 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# {tfrmtbuilder}tfrmt logo +# {tfrmtbuilder}tfrmt logo diff --git a/man/figures/tfrmtbuilder_hex.png b/inst/www/tfrmtbuilder_hex.png similarity index 100% rename from man/figures/tfrmtbuilder_hex.png rename to inst/www/tfrmtbuilder_hex.png From 14cae6a4247f83c294ca863373f3130903be611d Mon Sep 17 00:00:00 2001 From: Becca Krouse Date: Sat, 9 Mar 2024 07:54:13 -0500 Subject: [PATCH 17/22] update links css per bslib 0.6.0 --- DESCRIPTION | 2 +- inst/www/styles.css | 8 ++++++-- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 09acdf5..221bab2 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -43,7 +43,7 @@ Imports: gt, rlang, sortable, - bslib, + bslib (>= 0.6.0), shinyWidgets, rio, shinycssloaders, diff --git a/inst/www/styles.css b/inst/www/styles.css index 40d6343..0da8234 100644 --- a/inst/www/styles.css +++ b/inst/www/styles.css @@ -90,8 +90,12 @@ color: #CF4F15 !important; } -.navbar-default .navbar-nav > li > a.active { - text-decoration: underline #CF4F15; +.nav-underline > li > a.active{ + color: #CF4F15 !important; +} + +.navbar-nav { + --bs-nav-link-padding-y: 0 !important; } .navbar { From feb45be94cbdec78e8671f06ef035361bebf229c Mon Sep 17 00:00:00 2001 From: Becca Krouse Date: Sat, 9 Mar 2024 08:00:06 -0500 Subject: [PATCH 18/22] support tex output --- R/mod_export.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/mod_export.R b/R/mod_export.R index 9f86d78..baa09ec 100644 --- a/R/mod_export.R +++ b/R/mod_export.R @@ -28,7 +28,7 @@ export_ui <- function(id){ div(style = "height: 650px;", h3("Table", class = "heading_style", span(class = "btn-export", style = "display: flex; gap: 5px;", - lapply(c("html","png","rtf","docx","pdf"), function(ext){ + lapply(c("html","png","rtf","docx","pdf","tex"), function(ext){ mod_export_table_ui(ns(ext), ext=ext) }) ) @@ -78,7 +78,7 @@ export_server <- function(id, data, tfrmt_app_out, settings){ } ) - lapply(c("html","png","rtf","docx","pdf"), function(ext){ + lapply(c("html","png","rtf","docx","pdf","tex"), function(ext){ mod_export_table_server(ext, tbl=tbl_out, ext=ext) }) }) From 22c9d613ad4efbeb227fe9a21077c8ebdfeea4b1 Mon Sep 17 00:00:00 2001 From: Becca Krouse Date: Sat, 9 Mar 2024 08:00:13 -0500 Subject: [PATCH 19/22] update NEWS --- NEWS.md | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/NEWS.md b/NEWS.md index 0a384d2..772e6f8 100644 --- a/NEWS.md +++ b/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. From 634cac4b123762f01a033c81a2dac774bb241cf4 Mon Sep 17 00:00:00 2001 From: Becca Krouse Date: Tue, 12 Mar 2024 11:37:56 -0400 Subject: [PATCH 20/22] fix max_rows toggle --- R/mod_page_plan.R | 74 +++++++++++++++++++++++++---------------------- 1 file changed, 40 insertions(+), 34 deletions(-) diff --git a/R/mod_page_plan.R b/R/mod_page_plan.R index 1d5a7f7..74afb63 100644 --- a/R/mod_page_plan.R +++ b/R/mod_page_plan.R @@ -7,41 +7,35 @@ page_plan_ui <- function(id){ ns <- NS(id) tagList( + # fluidRow( + h3("Page Plan", class = "heading_style", + actionButton(ns("reset"), "Reset", icon = icon("undo")), class = "btn-reset"), + h4("Note location"), + shinyWidgets::radioGroupButtons( + inputId = ns("note_loc"), label = NULL, + choices = c("noprint", "preheader", "subtitle", "source_note"), + selected = character(0) + ), + h4("Max rows"), + prettySwitch(ns("max_set"), "Set", value = FALSE), + numericInput(ns("max_rows"), label = NULL, value = 10, min = 1, max = NA, step = 5, + width = "25%") , + h4("Page Structures"), + shinyjs::hidden( + p(id = ns("none"), + "None supplied.") + ), + p(id = ns("some"), "Click table entry to edit"), + div( + id = ns("sortable"), + uiOutput(ns("tbl")) + ), + br(), fluidRow( - h3("Page Plan", class = "heading_style", - actionButton(ns("reset"), "Reset", icon = icon("undo")), class = "btn-reset"), - h4("Note location"), - shinyWidgets::radioGroupButtons( - inputId = ns("note_loc"), label = NULL, - choices = c("noprint", "preheader", "subtitle", "source_note"), - selected = character(0) - ), - h4("Max rows"), - span( - style = "display: flex; gap: 5px;", - prettySwitch(ns("max_set"), "Set", value = FALSE), - conditionalPanel( - condition = "input.max_set==true", - numericInput(ns("max_rows"), label = NULL, value = 10, min = 1, max = NA, step = 5), - ns = ns - ) - ), - h4("Page Structures"), - shinyjs::hidden( - p(id = ns("none"), - "None supplied.") - ), - p(id = ns("some"), "Click table entry to edit"), - div( - id = ns("sortable"), - uiOutput(ns("tbl")) - ), - br(), - fluidRow( - column(3, div(actionButton(ns("add"), "New", icon = icon("plus")), class = "btn-new")), - column(3, offset = 1, div(shinyjs::disabled(actionButton(ns("delete"), "Delete", icon = icon("trash")))), class = "btn-delete") - ) + column(3, div(actionButton(ns("add"), "New", icon = icon("plus")), class = "btn-new")), + column(3, offset = 1, div(shinyjs::disabled(actionButton(ns("delete"), "Delete", icon = icon("trash")))), class = "btn-delete") ), + # ), br(), shinyjs::hidden( div(id = ns("customize"), @@ -118,8 +112,10 @@ page_plan_server <- function(id, data, tfrmt_app, mode_load){ observe({ if(input$max_set){ + shinyjs::enable("max_rows") max_rows(input$max_rows) } else { + shinyjs::disable("max_rows") max_rows(NULL) } }) @@ -303,12 +299,22 @@ page_plan_server <- function(id, data, tfrmt_app, mode_load){ }) + # set the max rows depending on user preference + max_rows <- reactiveVal(NULL) + observe({ + if(input$max_set){ + max_rows(input$max_rows) + } else { + max_rows(NULL) + } + }) + # return final struct_list only when in done mode page_plan_out <- reactive({ req(mode()=="done") req(input$note_loc) - arg_list <- list(note_loc = input$note_loc, max_rows = input$max_rows) + arg_list <- list(note_loc = input$note_loc, max_rows = max_rows()) if (!is.null(struct_list())){ arg_list <- c(struct_list(), arg_list) } From 94cd1a48c22091876ee63115defc52f0e6e54d85 Mon Sep 17 00:00:00 2001 From: Becca Krouse Date: Tue, 12 Mar 2024 12:27:59 -0400 Subject: [PATCH 21/22] less eager tfrmt creation --- R/tfrmtbuilder_server.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/tfrmtbuilder_server.R b/R/tfrmtbuilder_server.R index d90c1ed..40f6f35 100644 --- a/R/tfrmtbuilder_server.R +++ b/R/tfrmtbuilder_server.R @@ -71,7 +71,7 @@ tfrmtbuilder_server <- function(id) { tfrmt_app_out(tfrmt_app) - }) + }, priority = -1) # data to display From 6089536c5e2db93e214ba90e7cd611c3459f2086 Mon Sep 17 00:00:00 2001 From: Becca Krouse Date: Tue, 12 Mar 2024 12:28:50 -0400 Subject: [PATCH 22/22] only auto-refresh for completed tfrmt on initialization --- R/mod_table_outer.R | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/R/mod_table_outer.R b/R/mod_table_outer.R index a1b8ca9..a5020c0 100644 --- a/R/mod_table_outer.R +++ b/R/mod_table_outer.R @@ -39,10 +39,20 @@ table_outer_server <- function(id, tab_selected, data, tfrmt_app_out, settings){ auto_tbl <- reactiveVal(0) + tfrmt_counter <- reactiveVal(0) + + observeEvent(tfrmt_app_out(),{ + if (is.null(tfrmt_app_out())){ + tfrmt_counter(0) + } else { + tfrmt_counter(tfrmt_counter()+1) + } + }) + observe(print(tfrmt_counter())) # on initialization, if all valid observe({ req(settings()$original==TRUE) - req(tfrmt_app_out()) + req(tfrmt_counter()==1) isolate( auto_tbl(auto_tbl()+1) @@ -73,12 +83,12 @@ table_outer_server <- function(id, tab_selected, data, tfrmt_app_out, settings){ tbl_invalid<- reactiveVal(FALSE) # when the final tfrmt is changed, indicate refresh is needed - observeEvent(c(tfrmt_app_out(), settings()), { + observeEvent(tfrmt_app_out(), { shinyjs::addClass("refresh", class = "btn-danger") shinyjs::removeClass("refresh", class = "btn-refresh") tbl_invalid(TRUE) - }, priority = 100) + }) # when display update is triggered, remove the indication observeEvent(req(auto_tbl()>0),{ shinyjs::removeClass("refresh", class = "btn-danger")