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/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/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. 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 b207a55..baa09ec 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","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) + }) }) } diff --git a/R/mod_export_table.R b/R/mod_export_table.R new file mode 100644 index 0000000..3815f34 --- /dev/null +++ b/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) + + } + } + ) + + + + } + ) +} 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) } 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/R/mod_page_plan.R b/R/mod_page_plan.R new file mode 100644 index 0000000..74afb63 --- /dev/null +++ b/R/mod_page_plan.R @@ -0,0 +1,333 @@ +# 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"), + 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( + 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){ + shinyjs::enable("max_rows") + max_rows(input$max_rows) + } else { + shinyjs::disable("max_rows") + 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) + + } + + }) + + # 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 = 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/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" diff --git a/R/mod_table_inner.R b/R/mod_table_inner.R new file mode 100644 index 0000000..00cc9b3 --- /dev/null +++ b/R/mod_table_inner.R @@ -0,0 +1,119 @@ +# 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 auto_tbl +#' +#' @noRd +table_inner_server <- function(id, data, tfrmt_app_out, settings, auto_tbl){ + + 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(auto_tbl()>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_info <- 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_info$page_cur()) + } else{ + tab()$result + } + }) + + # view table + output$tbl_view <- renderUI({ + + 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() %>% + 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_outer.R b/R/mod_table_outer.R new file mode 100644 index 0000000..a5020c0 --- /dev/null +++ b/R/mod_table_outer.R @@ -0,0 +1,106 @@ +# tfrmt Table outer module + +table_outer_ui <- function(id){ + + ns <- NS(id) + + tagList( + actionButton(ns("refresh"), "Refresh", icon = icon("sync"), class = "btn-refresh"), + table_inner_ui(ns("tbl")) + ) +} + + +#' @param id module 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 settings mock mode w/ no data, w/ data, reporting +#' +#' @noRd +table_outer_server <- function(id, tab_selected, data, tfrmt_app_out, settings){ + + 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())) + }) + + # 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 + + 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_counter()==1) + + isolate( + auto_tbl(auto_tbl()+1) + ) + }) + # refresh button pressed + observeEvent(input$refresh, { + auto_tbl(auto_tbl()+1) + }) + # tab change + observeEvent(tab_selected(), { + if (tbl_invalid()){ + 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())){ + 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 + + tbl_invalid<- reactiveVal(FALSE) + + # when the final tfrmt is changed, indicate refresh is needed + observeEvent(tfrmt_app_out(), { + shinyjs::addClass("refresh", class = "btn-danger") + shinyjs::removeClass("refresh", class = "btn-refresh") + + tbl_invalid(TRUE) + }) + # when display update is triggered, remove the indication + observeEvent(req(auto_tbl()>0),{ + shinyjs::removeClass("refresh", class = "btn-danger") + shinyjs::addClass("refresh", class = "btn-refresh") + + tbl_invalid(FALSE) + }) + + + table_inner_server("tbl", data, tfrmt_app_out, settings, auto_tbl) + + + } + ) +} diff --git a/R/mod_table_page.R b/R/mod_table_page.R new file mode 100644 index 0000000..d5b44d6 --- /dev/null +++ b/R/mod_table_page.R @@ -0,0 +1,71 @@ + +table_page_ui <- function(id){ + + ns <- NS(id) + + tagList( + 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") + ) + ) + ) + +} + +#' @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 <- nrow(tab_gt()$gt_tbls) + page_tot(tot) + } else { + page_tot(1) + } + page_cur(1) + }) + + # 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( + list(page_cur = page_cur, + page_tot = page_tot) + ) + + + }) +} diff --git a/R/mod_table_view.R b/R/mod_table_view.R deleted file mode 100644 index 12ad880..0000000 --- a/R/mod_table_view.R +++ /dev/null @@ -1,168 +0,0 @@ -# tfrmt Table view module - -table_view_ui <- function(id){ - - ns <- NS(id) - - tagList( - actionButton(ns("refresh"), "Refresh", icon = icon("sync"), class = "btn-refresh"), - shinyjs::hidden( - div( - id = ns("tbl_div"), - shinycssloaders::withSpinner( - color = getOption("spinner.color", default = "#254988"), - type = 4, - 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 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 -#' -#' @noRd -table_view_server <- function(id, tab_selected, data, tfrmt_app_out, settings){ - - 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())) - }) - - - # 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) - - # 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) - ) - }) - # refreshed - observeEvent(input$refresh, { - retbl(retbl()+1) - }) - # tab change - observeEvent(tab_selected(), { - if (tbl_invalid()){ - retbl(retbl()+1) - } - }, ignoreInit = TRUE) - - # no update if tfrmt is reset (starting from beginning) or incomplete - observe({ - if (is.null(tfrmt_app_out())){ - retbl(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 - - tbl_invalid<- reactiveVal(FALSE) - - # when the final tfrmt is changed, indicate refresh is needed - observeEvent(tfrmt_app_out(),{ - shinyjs::addClass("refresh", class = "btn-danger") - shinyjs::removeClass("refresh", class = "btn-refresh") - - tbl_invalid(TRUE) - }) - - # when display update is triggered, remove the indication - observeEvent(req(retbl()>0),{ - shinyjs::removeClass("refresh", class = "btn-danger") - shinyjs::addClass("refresh", class = "btn-refresh") - - 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"){ - tab <- tfrmt_app_out %>% safely(print_to_gt)(.data = data) - - } else if (mode=="mock_no_data"){ - - tab <- tfrmt_app_out %>% safely(print_mock_gt)() - - } else { - tab <- tfrmt_app_out %>% safely(print_mock_gt)(.data = data) - } - - }) - - # view table - output$tbl_view <- renderUI({ - - req(!is.null(tab()$result)) - - div(style = "height:100%; overflow-x: auto; overflow-y: auto; width: 100%", - as_raw_html( - tab()$result %>% - 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))) - }) - } - ) -} diff --git a/R/tfrmtbuilder_server.R b/R/tfrmtbuilder_server.R index 88eefa0..40f6f35 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) @@ -41,16 +33,12 @@ 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)) - # 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()) @@ -59,6 +47,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 +57,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() @@ -80,7 +70,9 @@ tfrmtbuilder_server <- function(id) { } tfrmt_app_out(tfrmt_app) - }) + + }, priority = -1) + # data to display data_out <- reactive({ @@ -95,17 +87,17 @@ tfrmtbuilder_server <- function(id) { }) # table viewer module - table_view_server("tbl_view", - tab_selected = reactive(input$tabs), - data = reactive(settings()$data) , - tfrmt_app_out = tfrmt_app_out, - settings = settings) + table_outer_server("tbl_view", + tab_selected = reactive(input$tabs), + data = reactive(settings()$data) , + tfrmt_app_out = tfrmt_app_out, + settings = settings) # 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({ 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"))) ) diff --git a/R/utils_app.R b/R/utils_app.R index d1f70f9..ddeffb9 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 a969c9b..0f9f7fd 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 = 60 + ) + } + tf } @@ -175,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(){ @@ -221,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(), 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(".") 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/inst/www/styles.css b/inst/www/styles.css index f4ba4e2..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 { @@ -261,6 +265,18 @@ pre.shiny-text-output { border-color: #1D3A6D !important; } +/* for pagination buttons */ +.btn-page { + color: #FFFFFF !important; + background: #254988 !important; + border-color: #254988 !important; +} +.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; 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 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(