diff --git a/DESCRIPTION b/DESCRIPTION index 416c1d15..eb6aee49 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -19,12 +19,14 @@ Imports: data.table, DT, epiDisplay, + flextable, forestploter, geepack, GGally, ggplot2, ggpubr, - haven, Hmisc, + haven, + Hmisc, jskm(>= 0.4.4), jstable, labelled, @@ -43,6 +45,7 @@ Imports: see, shiny, shinycustomloader, + shinyjs, shinyWidgets, stats, survey, diff --git a/NAMESPACE b/NAMESPACE index c3940de2..9d85f80b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -68,6 +68,7 @@ export(tb1simpleUI) export(timerocModule) export(timerocModule2) export(timerocUI) +import(flextable) import(ggplot2) import(shiny) importFrom(DT,"%>%") @@ -140,6 +141,8 @@ importFrom(see,theme_modern) importFrom(shinyWidgets,dropdownButton) importFrom(shinyWidgets,tooltipOptions) importFrom(shinycustomloader,withLoader) +importFrom(shinyjs,click) +importFrom(shinyjs,useShinyjs) importFrom(stats,as.formula) importFrom(stats,binomial) importFrom(stats,chisq.test) diff --git a/R/jsBasicGadget.R b/R/jsBasicGadget.R index 6444eeb9..aed16ef2 100644 --- a/R/jsBasicGadget.R +++ b/R/jsBasicGadget.R @@ -805,6 +805,8 @@ jsBasicAddin <- function() { #' @importFrom jstable opt.tbreg #' @importFrom DT datatable %>% formatStyle styleEqual renderDT DTOutput #' @importFrom shinycustomloader withLoader +#' @importFrom shinyjs useShinyjs click +#' @import flextable #' @import shiny jsBasicExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { @@ -813,7 +815,8 @@ jsBasicExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { ui <- navbarPage( header = tagList( includeCSS(system.file("www", "style.css", package = "jsmodule")), - tags$head(tags$link(rel = "shortcut icon", href = "www/favicon.ico")) + tags$head(tags$link(rel = "shortcut icon", href = "www/favicon.ico")), + shinyjs::useShinyjs() ), # theme = bslib::bs_theme(bootswatch = 'solar'), inverse = TRUE, @@ -883,6 +886,8 @@ jsBasicExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { mainPanel( markdown("> Table 1 for Descriptive statistics, see Ich E3 Guideline 11.2 for medical definition"), + downloadButton(outputId = "dl.table1", style = "display:none;"), + actionButton("dl.table1.clk", NULL, style = "display:none;"), withLoader( DTOutput("table1"), type = "html", @@ -908,6 +913,8 @@ jsBasicExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { regressModuleUI("linear") ), mainPanel( + downloadButton("dl.linreg", style = "display:none;"), + actionButton("dl.linreg.clk", NULL, style = "display:none;"), withLoader( DTOutput("lineartable"), type = "html", @@ -925,6 +932,8 @@ jsBasicExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { regressModuleUI("logistic") ), mainPanel( + downloadButton("dl.logreg", style = "display:none;"), + actionButton("dl.logreg.clk", NULL, style = "display:none;"), withLoader( DTOutput("logistictable"), type = "html", @@ -940,6 +949,8 @@ jsBasicExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { coxUI("cox") ), mainPanel( + downloadButton("dl.coxreg", style = "display:none;"), + actionButton("dl.coxreg.clk", NULL, style = "display:none;"), withLoader( DTOutput("coxtable"), type = "html", @@ -1260,13 +1271,68 @@ jsBasicExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { out_tb1 <- callModule(tb1module2, "tb1", data = data, data_label = data.label, data_varStruct = NULL, nfactor.limit = nfactor.limit) + observeEvent(input$dl.table1.clk, { + shinyjs::click(id = "dl.table1") + }) + + output$dl.table1 <- downloadHandler( + filename = "table1.docx", + content = function(file) { + tb <- out_tb1()$table + rn <- rownames(tb) + tb <- cbind(rn, data.frame(tb)) + colnames(tb)[1] <- " " + + officer::read_docx() |> + body_add_flextable( + tb %>% + flextable() %>% + autofit() %>% + theme_booktabs(bold_header = TRUE) + ) |> + print(target = file) + } + ) + + outputOptions(output, "dl.table1", suspendWhenHidden = FALSE) + output$table1 <- renderDT({ tb <- out_tb1()$table cap <- out_tb1()$caption out.tb1 <- datatable(tb, rownames = T, extensions = "Buttons", caption = cap, options = c( - opt.tb1("tb1"), + list( + dom = "Bip>", + lengthMenu = list( + c(10, 25, -1), + c("10", "25", "All") + ), + pageLength = 25, + ordering = F, + buttons = list( + "copy", + "print", + list( + text = "Download", + extend = "collection", + buttons = list( + list(extend = "csv", filename = "tb1"), + list(extend = "excel", filename = "tb1"), + list(extend = "pdf", filename = "tb1") + ) # , + ), + list( + text = "Word", + extend = "collection", + action = DT::JS( + "function ( e, dt, node, config ) { + Shiny.setInputValue('dl.table1.clk', true, {priority: 'event'}); + }" + ) + ) + ) + ), list(columnDefs = list(list(visible = FALSE, targets = which(colnames(tb) %in% c("test", "sig"))))), list(scrollX = TRUE) ) @@ -1279,12 +1345,64 @@ jsBasicExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { out_linear <- callModule(regressModule2, "linear", data = data, data_label = data.label, data_varStruct = NULL, default.unires = T, nfactor.limit = nfactor.limit) + observeEvent(input$dl.linreg.clk, { + shinyjs::click(id = "dl.linreg") + }) + + output$dl.linreg <- downloadHandler( + filename = "lin-reg.docx", + content = function(file) { + tb <- out_linear()$table + rn <- rownames(tb) + cn <- colnames(tb) + tb <- cbind(rn, data.frame(tb)) + colnames(tb) <- c(" ", cn) + + officer::read_docx() |> + body_add_flextable( + tb %>% + flextable() %>% + autofit() %>% + theme_booktabs(bold_header = TRUE) + ) |> + print(target = file) + } + ) + + outputOptions(output, "dl.linreg", suspendWhenHidden = FALSE) + output$lineartable <- renderDT({ hide <- which(colnames(out_linear()$table) == "sig") datatable(out_linear()$table, rownames = T, extensions = "Buttons", caption = out_linear()$caption, options = c( - opt.tbreg(out_linear()$caption), + list( + dom = "Bip>", + lengthMenu = list( + c(10, 25, -1), + c("10", "25", "All") + ), + pageLength = -1, + ordering = F, + buttons = list( + "copy", + "print", + list( + text = "Download", + extend = "collection", + buttons = list( + list(extend = "csv", filename = out_linear()$caption), + list(extend = "excel", filename = out_linear()$caption), + list(extend = "pdf", filename = out_linear()$caption) + ) + ), + list( + text = "Word", + extend = "collection", + action = DT::JS("function ( e, dt, node, config ) {Shiny.setInputValue('dl.linreg.clk', true, {priority: 'event'});}") + ) + ) + ), list(columnDefs = list(list(visible = FALSE, targets = hide))), list(scrollX = TRUE) ) @@ -1297,12 +1415,64 @@ jsBasicExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { out_logistic <- callModule(logisticModule2, "logistic", data = data, data_label = data.label, data_varStruct = NULL, nfactor.limit = nfactor.limit) + observeEvent(input$dl.logreg.clk, { + shinyjs::click(id = "dl.logreg") + }) + + output$dl.logreg <- downloadHandler( + filename = "log-reg.docx", + content = function(file) { + tb <- out_logistic()$table + rn <- rownames(tb) + cn <- colnames(tb) + tb <- cbind(rn, data.frame(tb)) + colnames(tb) <- c(" ", cn) + + officer::read_docx() |> + body_add_flextable( + tb %>% + flextable() %>% + autofit() %>% + theme_booktabs(bold_header = TRUE) + ) |> + print(target = file) + } + ) + + outputOptions(output, "dl.logreg", suspendWhenHidden = FALSE) + output$logistictable <- renderDT({ hide <- which(colnames(out_logistic()$table) == "sig") datatable(out_logistic()$table, rownames = T, extensions = "Buttons", caption = out_logistic()$caption, options = c( - opt.tbreg(out_logistic()$caption), + list( + dom = "Bip>", + lengthMenu = list( + c(10, 25, -1), + c("10", "25", "All") + ), + pageLength = -1, + ordering = F, + buttons = list( + "copy", + "print", + list( + text = "Download", + extend = "collection", + buttons = list( + list(extend = "csv", filename = out_logistic()$caption), + list(extend = "excel", filename = out_logistic()$caption), + list(extend = "pdf", filename = out_logistic()$caption) + ) + ), + list( + text = "Word", + extend = "collection", + action = DT::JS("function ( e, dt, node, config ) {Shiny.setInputValue('dl.logreg.clk', true, {priority: 'event'});}") + ) + ) + ), list(columnDefs = list(list(visible = FALSE, targets = hide))), list(scrollX = TRUE) ) @@ -1311,12 +1481,64 @@ jsBasicExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { out_cox <- callModule(coxModule, "cox", data = data, data_label = data.label, data_varStruct = NULL, default.unires = T, nfactor.limit = nfactor.limit) + observeEvent(input$dl.coxreg.clk, { + shinyjs::click(id = "dl.coxreg") + }) + + output$dl.coxreg <- downloadHandler( + filename = "cox-reg.docx", + content = function(file) { + tb <- out_cox()$table + rn <- rownames(tb) + cn <- colnames(tb) + tb <- cbind(rn, data.frame(tb)) + colnames(tb) <- c(" ", cn) + + officer::read_docx() |> + body_add_flextable( + tb %>% + flextable() %>% + autofit() %>% + theme_booktabs(bold_header = TRUE) + ) |> + print(target = file) + } + ) + + outputOptions(output, "dl.coxreg", suspendWhenHidden = FALSE) + output$coxtable <- renderDT({ hide <- which(colnames(out_cox()$table) == c("sig")) datatable(out_cox()$table, rownames = T, extensions = "Buttons", caption = out_cox()$caption, options = c( - opt.tbreg(out_cox()$caption), + list( + dom = "Bip>", + lengthMenu = list( + c(10, 25, -1), + c("10", "25", "All") + ), + pageLength = -1, + ordering = F, + buttons = list( + "copy", + "print", + list( + text = "Download", + extend = "collection", + buttons = list( + list(extend = "csv", filename = out_cox()$caption), + list(extend = "excel", filename = out_cox()$caption), + list(extend = "pdf", filename = out_cox()$caption) + ) + ), + list( + text = "Word", + extend = "collection", + action = DT::JS("function ( e, dt, node, config ) {Shiny.setInputValue('dl.coxreg.clk', true, {priority: 'event'});}") + ) + ) + ), list(columnDefs = list(list(visible = FALSE, targets = hide))) ) ) %>% formatStyle("sig", target = "row", backgroundColor = styleEqual("**", "#fed9cc")) diff --git a/R/jsPropensityGadget.R b/R/jsPropensityGadget.R index 4859d156..6ce07660 100644 --- a/R/jsPropensityGadget.R +++ b/R/jsPropensityGadget.R @@ -44,7 +44,6 @@ jsPropensityGadget <- function(data, nfactor.limit = 20) { data_varStruct1 <- list(variable = names(out)) - ## Vars naCol <- names(out)[colSums(is.na(out)) > 0] # out <- out[, .SD, .SDcols = -naCol] @@ -64,10 +63,6 @@ jsPropensityGadget <- function(data, nfactor.limit = 20) { # except_vars <- names(nclass)[ nclass== 1 | nclass >= nfactor.limit] factor_adds <- names(nclass)[nclass >= 1 & nclass <= 5] - - - - ui <- navbarPage( "Propensity score analysis", tabPanel("Data", @@ -377,7 +372,6 @@ jsPropensityGadget <- function(data, nfactor.limit = 20) { }) }) - observeEvent(input$check_binary, { var.conti <- setdiff(names(out), c(factor_original, input$factor_vname)) output$binary_var <- renderUI({ @@ -474,8 +468,6 @@ jsPropensityGadget <- function(data, nfactor.limit = 20) { }) }) - - data.info <- reactive({ out1 <- data.table::data.table(out) out1[, (conti_original) := lapply(.SD, function(x) { @@ -533,7 +525,6 @@ jsPropensityGadget <- function(data, nfactor.limit = 20) { } } - if (!is.null(input$check_subset)) { if (input$check_subset) { validate( @@ -588,7 +579,6 @@ jsPropensityGadget <- function(data, nfactor.limit = 20) { # nclass_factor <- unlist(data()[, lapply(.SD, function(x){length(unique(x))}), .SDcols = factor_vars]) # factor_2vars <- names(nclass_factor)[nclass_factor == 2] - validate( need(!is.null(class01_factor), "No categorical variables coded as 0, 1 in data") ) @@ -602,7 +592,6 @@ jsPropensityGadget <- function(data, nfactor.limit = 20) { need(length(factor_01vars_case_small) > 0, "No candidate group variable for PS calculation") ) - selectInput("group_pscal", label = "Group variable for PS calculation (0, 1 coding)", choices = mklist(list(variable = names(data.info()$data)), factor_01vars_case_small), multiple = F, @@ -645,12 +634,6 @@ jsPropensityGadget <- function(data, nfactor.limit = 20) { }) }) - - - - - - mat.info <- eventReactive(c(input$indep_pscal, input$group_pscal, input$caliper, input$ratio_ps, data.info()), { req(input$indep_pscal) if (is.null(input$group_pscal) | is.null(input$indep_pscal)) { @@ -678,11 +661,6 @@ jsPropensityGadget <- function(data, nfactor.limit = 20) { return(list(data = wdata, matdata = data[ID.pscal2828 %in% match.data(m.out)$ID.pscal2828])) }) - - - - - output$data <- renderDT({ datatable(mat.info()$data, rownames = F, editable = F, extensions = "Buttons", caption = "Data with ps, iptw", @@ -713,7 +691,6 @@ jsPropensityGadget <- function(data, nfactor.limit = 20) { } }) - ## tb1 data <- reactive({ mat.info()$data[, .SD, .SDcols = -c("iptw")] @@ -723,12 +700,10 @@ jsPropensityGadget <- function(data, nfactor.limit = 20) { # data_varStruct <- reactive(list(variable = names(mat.info()$matdata))) design.survey <- reactive(survey::svydesign(ids = ~1, data = mat.info()$data[!is.na(iptw), ], weights = ~iptw)) - tb1_original <- callModule(tb1module2, "tb1", data = data, data_label = data.label, data_varStruct = NULL, design.survey = NULL, nfactor.limit = nfactor.limit) tb1_ps <- callModule(tb1module2, "tb1", data = matdata, data_label = data.label, data_varStruct = NULL, design.survey = NULL, nfactor.limit = nfactor.limit) tb1_iptw <- callModule(tb1module2, "tb1", data = data, data_label = data.label, data_varStruct = NULL, design.survey = design.survey, nfactor.limit = nfactor.limit) - output$table1_original <- renderDT({ tb <- tb1_original()$table cap <- tb1_original()$caption @@ -780,14 +755,12 @@ jsPropensityGadget <- function(data, nfactor.limit = 20) { return(out.tb1) }) - ## Regression out_linear_original <- callModule(regressModule2, "linear", data = data, data_label = data.label, data_varStruct = NULL, default.unires = F, nfactor.limit = nfactor.limit) out_linear_ps <- callModule(regressModule2, "linear", data = matdata, data_label = data.label, data_varStruct = NULL, default.unires = F, nfactor.limit = nfactor.limit) out_linear_iptw <- callModule(regressModule2, "linear", data = data, data_label = data.label, data_varStruct = NULL, default.unires = F, design.survey = design.survey, nfactor.limit = nfactor.limit) - output$linear_original <- renderDT({ hide <- which(colnames(out_linear_original()$table) == "sig") datatable(out_linear_original()$table, @@ -832,14 +805,12 @@ jsPropensityGadget <- function(data, nfactor.limit = 20) { ) %>% formatStyle("sig", target = "row", backgroundColor = styleEqual("**", "yellow")) }) - ## Logistic out_logistic_original <- callModule(logisticModule2, "logistic", data = data, data_label = data.label, data_varStruct = NULL, nfactor.limit = nfactor.limit) out_logistic_ps <- callModule(logisticModule2, "logistic", data = matdata, data_label = data.label, data_varStruct = NULL, nfactor.limit = nfactor.limit) out_logistic_iptw <- callModule(logisticModule2, "logistic", data = data, data_label = data.label, data_varStruct = NULL, design.survey = design.survey, nfactor.limit = nfactor.limit) - output$logistic_original <- renderDT({ hide <- which(colnames(out_logistic_original()$table) == "sig") datatable(out_logistic_original()$table, @@ -876,7 +847,6 @@ jsPropensityGadget <- function(data, nfactor.limit = 20) { ) %>% formatStyle("sig", target = "row", backgroundColor = styleEqual("**", "yellow")) }) - ## Cox out_cox_original <- callModule(coxModule, "cox", data = data, data_label = data.label, data_varStruct = NULL, default.unires = F, nfactor.limit = nfactor.limit) @@ -929,7 +899,6 @@ jsPropensityGadget <- function(data, nfactor.limit = 20) { print(out_ggpairs_ps()) }) - ## Kaplan out_kaplan_original <- callModule(kaplanModule, "kaplan", data = data, data_label = data.label, data_varStruct = NULL, nfactor.limit = nfactor.limit) @@ -948,14 +917,12 @@ jsPropensityGadget <- function(data, nfactor.limit = 20) { print(out_kaplan_iptw()) }) - ## ROC out_roc_original <- callModule(rocModule2, "roc", data = data, data_label = data.label, data_varStruct = NULL, nfactor.limit = nfactor.limit) out_roc_ps <- callModule(rocModule2, "roc", data = matdata, data_label = data.label, data_varStruct = NULL, nfactor.limit = nfactor.limit) out_roc_iptw <- callModule(rocModule2, "roc", data = data, data_label = data.label, data_varStruct = NULL, design.survey = design.survey, nfactor.limit = nfactor.limit) - output$plot_roc_original <- renderPlot({ print(out_roc_original()$plot) }) @@ -998,7 +965,6 @@ jsPropensityGadget <- function(data, nfactor.limit = 20) { out_timeroc_ps <- callModule(timerocModule2, "timeroc", data = matdata, data_label = data.label, data_varStruct = NULL, nfactor.limit = nfactor.limit) out_timeroc_iptw <- callModule(timerocModule2, "timeroc", data = data, data_label = data.label, data_varStruct = NULL, design.survey = design.survey, nfactor.limit = nfactor.limit) - output$plot_timeroc_original <- renderPlot({ print(out_timeroc_original()$plot) }) @@ -1037,16 +1003,11 @@ jsPropensityGadget <- function(data, nfactor.limit = 20) { }) } - - - # viewer <- dialogViewer("Descriptive statistics", width = 1100, height = 850) viewer <- browserViewer(browser = getOption("browser")) runGadget(ui, server, viewer = viewer) } - - #' @title jsPropensityAddin: Rstudio addin of jsPropensityGadget #' @description Rstudio addin of jsPropensityGadget #' @return Rstudio addin of jsPropensityGadget @@ -1061,7 +1022,6 @@ jsPropensityGadget <- function(data, nfactor.limit = 20) { #' @export #' @importFrom rstudioapi getActiveDocumentContext - jsPropensityAddin <- function() { context <- rstudioapi::getActiveDocumentContext() # Set the default data to use based on the selection. @@ -1071,10 +1031,6 @@ jsPropensityAddin <- function() { jsPropensityGadget(data) } - - - - #' @title jsPropensityExtAddin: RStudio Addin for propensity score analysis with external data. #' @description RStudio Addin for propensity score analysis with external csv/xlsx/sas7bdat/sav/dta file. #' @param nfactor.limit nlevels limit for categorical variables, Default: 20 @@ -1097,6 +1053,8 @@ jsPropensityAddin <- function() { #' @importFrom jstable opt.tbreg #' @importFrom DT datatable %>% formatStyle styleEqual renderDT DTOutput #' @importFrom shinycustomloader withLoader +#' @importFrom shinyjs useShinyjs click +#' @import flextable #' @import shiny jsPropensityExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { @@ -1105,6 +1063,10 @@ jsPropensityExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { ui <- navbarPage( "Propensity score analysis", + inverse = TRUE, + header = tagList( + shinyjs::useShinyjs() + ), tabPanel("Data", icon = icon("table"), sidebarLayout( @@ -1134,6 +1096,8 @@ jsPropensityExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { type = "pills", tabPanel( "Original", + downloadButton(outputId = "dl.table1.original", style = "display:none;"), + actionButton("dl.table1.original.clk", NULL, style = "display:none;"), withLoader(DTOutput("table1_original"), type = "html", loader = "loader6"), wellPanel( h5("Normal continuous variables are summarized with Mean (SD) and t-test(2 groups) or ANOVA(> 2 groups)"), @@ -1143,6 +1107,8 @@ jsPropensityExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { ), tabPanel( "Matching", + downloadButton(outputId = "dl.table1.ps", style = "display:none;"), + actionButton("dl.table1.ps.clk", NULL, style = "display:none;"), withLoader(DTOutput("table1_ps"), type = "html", loader = "loader6"), wellPanel( h5("Normal continuous variables are summarized with Mean (SD) and t-test(2 groups) or ANOVA(> 2 groups)"), @@ -1152,6 +1118,8 @@ jsPropensityExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { ), tabPanel( "IPTW", + downloadButton(outputId = "dl.table1.iptw", style = "display:none;"), + actionButton("dl.table1.iptw.clk", NULL, style = "display:none;"), withLoader(DTOutput("table1_iptw"), type = "html", loader = "loader6"), wellPanel( h5("Normal continuous variables are summarized with Mean (SD) and complex survey regression"), @@ -1176,18 +1144,24 @@ jsPropensityExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { type = "pills", tabPanel( "Original", + downloadButton("dl.linreg.original", style = "display:none;"), + actionButton("dl.linreg.original.clk", NULL, style = "display:none;"), withLoader(DTOutput("linear_original"), type = "html", loader = "loader6"), br(), uiOutput("warning_linear_original") ), tabPanel( "Matching", + downloadButton("dl.linreg.ps", style = "display:none;"), + actionButton("dl.linreg.ps.clk", NULL, style = "display:none;"), withLoader(DTOutput("linear_ps"), type = "html", loader = "loader6"), br(), uiOutput("warning_linear_ps") ), tabPanel( "IPTW", + downloadButton("dl.linreg.iptw", style = "display:none;"), + actionButton("dl.linreg.iptw.clk", NULL, style = "display:none;"), withLoader(DTOutput("linear_iptw"), type = "html", loader = "loader6") ) ) @@ -1205,14 +1179,20 @@ jsPropensityExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { type = "pills", tabPanel( "Original", + downloadButton("dl.logreg.original", style = "display:none;"), + actionButton("dl.logreg.original.clk", NULL, style = "display:none;"), withLoader(DTOutput("logistic_original"), type = "html", loader = "loader6") ), tabPanel( "Matching", + downloadButton("dl.logreg.ps", style = "display:none;"), + actionButton("dl.logreg.ps.clk", NULL, style = "display:none;"), withLoader(DTOutput("logistic_ps"), type = "html", loader = "loader6") ), tabPanel( "IPTW", + downloadButton("dl.logreg.iptw", style = "display:none;"), + actionButton("dl.logreg.iptw.clk", NULL, style = "display:none;"), withLoader(DTOutput("logistic_iptw"), type = "html", loader = "loader6") ) ) @@ -1230,14 +1210,20 @@ jsPropensityExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { type = "pills", tabPanel( "Original", + downloadButton("dl.coxreg.original", style = "display:none;"), + actionButton("dl.coxreg.original.clk", NULL, style = "display:none;"), withLoader(DTOutput("cox_original"), type = "html", loader = "loader6") ), tabPanel( "Matching", + downloadButton("dl.coxreg.ps", style = "display:none;"), + actionButton("dl.coxreg.ps.clk", NULL, style = "display:none;"), withLoader(DTOutput("cox_ps"), type = "html", loader = "loader6") ), tabPanel( "IPTW", + downloadButton("dl.coxreg.iptw", style = "display:none;"), + actionButton("dl.coxreg.iptw.clk", NULL, style = "display:none;"), withLoader(DTOutput("cox_iptw"), type = "html", loader = "loader6") ) ) @@ -1246,7 +1232,7 @@ jsPropensityExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { ) ), navbarMenu("Plot", - icon = icon("bar-chart-o"), + icon = icon("chart-column"), tabPanel( "Scatter plot", sidebarLayout( @@ -1360,9 +1346,6 @@ jsPropensityExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { ) ) - - - server <- function(input, output, session) { output$downloadData <- downloadHandler( filename = function() { @@ -1375,7 +1358,6 @@ jsPropensityExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { } ) - output$import <- renderUI({ FilePsInput("datafile") }) @@ -1408,7 +1390,6 @@ jsPropensityExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { # mat.info()$naomit }) - ## tb1 data <- reactive({ mat.info()$data[, .SD, .SDcols = -c("iptw")] @@ -1418,11 +1399,33 @@ jsPropensityExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { # data_varStruct <- reactive(list(variable = names(mat.info()$matdata))) design.survey <- reactive(survey::svydesign(ids = ~1, data = mat.info()$data[!is.na(iptw), ], weights = ~iptw)) - tb1_original <- callModule(tb1module2, "tb1", data = data, data_label = data.label, data_varStruct = NULL, design.survey = NULL, nfactor.limit = nfactor.limit) tb1_ps <- callModule(tb1module2, "tb1", data = matdata, data_label = data.label, data_varStruct = NULL, design.survey = NULL, nfactor.limit = nfactor.limit) tb1_iptw <- callModule(tb1module2, "tb1", data = data, data_label = data.label, data_varStruct = NULL, design.survey = design.survey, nfactor.limit = nfactor.limit) + observeEvent(input$dl.table1.original.clk, { + shinyjs::click(id = "dl.table1.original") + }) + + output$dl.table1.original <- downloadHandler( + filename = "table1_original.docx", + content = function(file) { + tb <- tb1_original()$table + rn <- rownames(tb) + tb <- cbind(rn, data.frame(tb)) + colnames(tb)[1] <- " " + + officer::read_docx() |> + body_add_flextable( + tb %>% + flextable() %>% + autofit() %>% + theme_booktabs(bold_header = TRUE) + ) |> + print(target = file) + } + ) + outputOptions(output, "dl.table1.original", suspendWhenHidden = FALSE) output$table1_original <- renderDT({ tb <- tb1_original()$table @@ -1430,7 +1433,37 @@ jsPropensityExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { out.tb1 <- datatable(tb, rownames = T, extensions = "Buttons", caption = cap, options = c( - opt.tb1("tb1"), + list( + dom = "Bip>", + lengthMenu = list( + c(10, 25, -1), + c("10", "25", "All") + ), + pageLength = 25, + ordering = F, + buttons = list( + "copy", + "print", + list( + text = "Download", + extend = "collection", + buttons = list( + list(extend = "csv", filename = "tb1"), + list(extend = "excel", filename = "tb1"), + list(extend = "pdf", filename = "tb1") + ) # , + ), + list( + text = "Word", + extend = "collection", + action = DT::JS( + "function ( e, dt, node, config ) { + Shiny.setInputValue('dl.table1.original.clk', true, {priority: 'event'}); + }" + ) + ) + ) + ), list(columnDefs = list(list(visible = FALSE, targets = which(colnames(tb) %in% c("test", "sig"))))), list(scrollX = TRUE) ) @@ -1441,13 +1474,68 @@ jsPropensityExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { return(out.tb1) }) + observeEvent(input$dl.table1.ps.clk, { + shinyjs::click(id = "dl.table1.ps") + }) + + output$dl.table1.ps <- downloadHandler( + filename = "table1_ps.docx", + content = function(file) { + tb <- tb1_ps()$table + rn <- rownames(tb) + tb <- cbind(rn, data.frame(tb)) + colnames(tb)[1] <- " " + + officer::read_docx() |> + body_add_flextable( + tb %>% + flextable() %>% + autofit() %>% + theme_booktabs(bold_header = TRUE) + ) |> + print(target = file) + } + ) + + outputOptions(output, "dl.table1.ps", suspendWhenHidden = FALSE) + output$table1_ps <- renderDT({ tb <- tb1_ps()$table cap <- tb1_ps()$caption out.tb1 <- datatable(tb, rownames = T, extensions = "Buttons", caption = cap, options = c( - opt.tb1("tb1"), + list( + dom = "Bip>", + lengthMenu = list( + c(10, 25, -1), + c("10", "25", "All") + ), + pageLength = 25, + ordering = F, + buttons = list( + "copy", + "print", + list( + text = "Download", + extend = "collection", + buttons = list( + list(extend = "csv", filename = "tb1"), + list(extend = "excel", filename = "tb1"), + list(extend = "pdf", filename = "tb1") + ) # , + ), + list( + text = "Word", + extend = "collection", + action = DT::JS( + "function ( e, dt, node, config ) { + Shiny.setInputValue('dl.table1.ps.clk', true, {priority: 'event'}); + }" + ) + ) + ) + ), list(columnDefs = list(list(visible = FALSE, targets = which(colnames(tb) %in% c("test", "sig"))))), list(scrollX = TRUE) ) @@ -1458,13 +1546,68 @@ jsPropensityExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { return(out.tb1) }) + observeEvent(input$dl.table1.iptw.clk, { + shinyjs::click(id = "dl.table1.iptw") + }) + + output$dl.table1.iptw <- downloadHandler( + filename = "table1_iptw.docx", + content = function(file) { + tb <- tb1_iptw()$table + rn <- rownames(tb) + tb <- cbind(rn, data.frame(tb)) + colnames(tb)[1] <- " " + + officer::read_docx() |> + body_add_flextable( + tb %>% + flextable() %>% + autofit() %>% + theme_booktabs(bold_header = TRUE) + ) |> + print(target = file) + } + ) + + outputOptions(output, "dl.table1.iptw", suspendWhenHidden = FALSE) + output$table1_iptw <- renderDT({ tb <- tb1_iptw()$table cap <- tb1_iptw()$caption out.tb1 <- datatable(tb, rownames = T, extensions = "Buttons", caption = cap, options = c( - opt.tb1("tb1"), + list( + dom = "Bip>", + lengthMenu = list( + c(10, 25, -1), + c("10", "25", "All") + ), + pageLength = 25, + ordering = F, + buttons = list( + "copy", + "print", + list( + text = "Download", + extend = "collection", + buttons = list( + list(extend = "csv", filename = "tb1"), + list(extend = "excel", filename = "tb1"), + list(extend = "pdf", filename = "tb1") + ) # , + ), + list( + text = "Word", + extend = "collection", + action = DT::JS( + "function ( e, dt, node, config ) { + Shiny.setInputValue('dl.table1.iptw.clk', true, {priority: 'event'}); + }" + ) + ) + ) + ), list(columnDefs = list(list(visible = FALSE, targets = which(colnames(tb) %in% c("test", "sig"))))), list(scrollX = TRUE) ) @@ -1475,20 +1618,73 @@ jsPropensityExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { return(out.tb1) }) - ## Regression - out_linear_original <- callModule(regressModule2, "linear", data = data, data_label = data.label, data_varStruct = NULL, default.unires = F, nfactor.limit = nfactor.limit) out_linear_ps <- callModule(regressModule2, "linear", data = matdata, data_label = data.label, data_varStruct = NULL, default.unires = F, nfactor.limit = nfactor.limit) out_linear_iptw <- callModule(regressModule2, "linear", data = data, data_label = data.label, data_varStruct = NULL, default.unires = F, design.survey = design.survey, nfactor.limit = nfactor.limit) + observeEvent(input$dl.linreg.original.clk, { + shinyjs::click(id = "dl.linreg.original") + }) + + output$dl.linreg.original <- downloadHandler( + filename = "linreg_original.docx", + content = function(file) { + tb <- out_linear_original()$table + rn <- rownames(tb) + cn <- colnames(tb) + tb <- cbind(rn, data.frame(tb)) + colnames(tb) <- c(" ", cn) + + officer::read_docx() |> + body_add_flextable( + tb %>% + flextable() %>% + autofit() %>% + theme_booktabs(bold_header = TRUE) + ) |> + print(target = file) + } + ) + + outputOptions(output, "dl.linreg.original", suspendWhenHidden = FALSE) output$linear_original <- renderDT({ hide <- which(colnames(out_linear_original()$table) == "sig") datatable(out_linear_original()$table, rownames = T, extensions = "Buttons", caption = out_linear_original()$caption, options = c( - opt.tbreg(out_linear_original()$caption), + list( + dom = "Bip>", + lengthMenu = list( + c(10, 25, -1), + c("10", "25", "All") + ), + pageLength = 25, + ordering = F, + buttons = list( + "copy", + "print", + list( + text = "Download", + extend = "collection", + buttons = list( + list(extend = "csv", filename = out_linear_original()$caption), + list(extend = "excel", filename = out_linear_original()$caption), + list(extend = "pdf", filename = out_linear_original()$caption) + ) # , + ), + list( + text = "Word", + extend = "collection", + action = DT::JS( + "function ( e, dt, node, config ) { + Shiny.setInputValue('dl.linreg.original.clk', true, {priority: 'event'}); + }" + ) + ) + ) + ), list(columnDefs = list(list(visible = FALSE, targets = hide))), list(scrollX = TRUE) ) @@ -1499,12 +1695,68 @@ jsPropensityExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { paste("", out_linear_original()$warning, "") }) + observeEvent(input$dl.linreg.ps.clk, { + shinyjs::click(id = "dl.linreg.ps") + }) + + output$dl.linreg.ps <- downloadHandler( + filename = "linreg_ps.docx", + content = function(file) { + tb <- out_linear_ps()$table + rn <- rownames(tb) + cn <- colnames(tb) + tb <- cbind(rn, data.frame(tb)) + colnames(tb) <- c(" ", cn) + + officer::read_docx() |> + body_add_flextable( + tb %>% + flextable() %>% + autofit() %>% + theme_booktabs(bold_header = TRUE) + ) |> + print(target = file) + } + ) + + outputOptions(output, "dl.linreg.ps", suspendWhenHidden = FALSE) + output$linear_ps <- renderDT({ hide <- which(colnames(out_linear_ps()$table) == "sig") datatable(out_linear_ps()$table, rownames = T, extensions = "Buttons", caption = out_linear_ps()$caption, options = c( - opt.tbreg(out_linear_ps()$caption), + list( + dom = "Bip>", + lengthMenu = list( + c(10, 25, -1), + c("10", "25", "All") + ), + pageLength = 25, + ordering = F, + buttons = list( + "copy", + "print", + list( + text = "Download", + extend = "collection", + buttons = list( + list(extend = "csv", filename = out_linear_ps()$caption), + list(extend = "excel", filename = out_linear_ps()$caption), + list(extend = "pdf", filename = out_linear_ps()$caption) + ) # , + ), + list( + text = "Word", + extend = "collection", + action = DT::JS( + "function ( e, dt, node, config ) { + Shiny.setInputValue('dl.linreg.ps.clk', true, {priority: 'event'}); + }" + ) + ) + ) + ), list(columnDefs = list(list(visible = FALSE, targets = hide))), list(scrollX = TRUE) ) @@ -1515,97 +1767,486 @@ jsPropensityExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { paste("", out_linear_ps()$warning, "") }) + observeEvent(input$dl.linreg.iptw.clk, { + shinyjs::click(id = "dl.linreg.iptw") + }) + + output$dl.linreg.iptw <- downloadHandler( + filename = "linreg_iptw.docx", + content = function(file) { + tb <- out_linear_iptw()$table + rn <- rownames(tb) + cn <- colnames(tb) + tb <- cbind(rn, data.frame(tb)) + colnames(tb) <- c(" ", cn) + + officer::read_docx() |> + body_add_flextable( + tb %>% + flextable() %>% + autofit() %>% + theme_booktabs(bold_header = TRUE) + ) |> + print(target = file) + } + ) + + outputOptions(output, "dl.linreg.iptw", suspendWhenHidden = FALSE) + output$linear_iptw <- renderDT({ hide <- which(colnames(out_linear_iptw()$table) == "sig") datatable(out_linear_iptw()$table, rownames = T, extensions = "Buttons", caption = out_linear_iptw()$caption, options = c( - opt.tbreg(out_linear_iptw()$caption), + list( + dom = "Bip>", + lengthMenu = list( + c(10, 25, -1), + c("10", "25", "All") + ), + pageLength = 25, + ordering = F, + buttons = list( + "copy", + "print", + list( + text = "Download", + extend = "collection", + buttons = list( + list(extend = "csv", filename = out_linear_iptw()$caption), + list(extend = "excel", filename = out_linear_iptw()$caption), + list(extend = "pdf", filename = out_linear_iptw()$caption) + ) # , + ), + list( + text = "Word", + extend = "collection", + action = DT::JS( + "function ( e, dt, node, config ) { + Shiny.setInputValue('dl.linreg.iptw.clk', true, {priority: 'event'}); + }" + ) + ) + ) + ), list(columnDefs = list(list(visible = FALSE, targets = hide))), list(scrollX = TRUE) ) ) %>% formatStyle("sig", target = "row", backgroundColor = styleEqual("**", "yellow")) }) - ## Logistic out_logistic_original <- callModule(logisticModule2, "logistic", data = data, data_label = data.label, data_varStruct = NULL, nfactor.limit = nfactor.limit) out_logistic_ps <- callModule(logisticModule2, "logistic", data = matdata, data_label = data.label, data_varStruct = NULL, nfactor.limit = nfactor.limit) out_logistic_iptw <- callModule(logisticModule2, "logistic", data = data, data_label = data.label, data_varStruct = NULL, design.survey = design.survey, nfactor.limit = nfactor.limit) + observeEvent(input$dl.logreg.original.clk, { + shinyjs::click(id = "dl.logreg.original") + }) + + output$dl.logreg.original <- downloadHandler( + filename = "logreg_original.docx", + content = function(file) { + tb <- out_logistic_original()$table + rn <- rownames(tb) + cn <- colnames(tb) + tb <- cbind(rn, data.frame(tb)) + colnames(tb) <- c(" ", cn) + + officer::read_docx() |> + body_add_flextable( + tb %>% + flextable() %>% + autofit() %>% + theme_booktabs(bold_header = TRUE) + ) |> + print(target = file) + } + ) + + outputOptions(output, "dl.logreg.original", suspendWhenHidden = FALSE) output$logistic_original <- renderDT({ hide <- which(colnames(out_logistic_original()$table) == "sig") datatable(out_logistic_original()$table, rownames = T, extensions = "Buttons", caption = out_logistic_original()$caption, options = c( - opt.tbreg(out_logistic_original()$caption), + list( + dom = "Bip>", + lengthMenu = list( + c(10, 25, -1), + c("10", "25", "All") + ), + pageLength = 25, + ordering = F, + buttons = list( + "copy", + "print", + list( + text = "Download", + extend = "collection", + buttons = list( + list(extend = "csv", filename = out_logistic_original()$caption), + list(extend = "excel", filename = out_logistic_original()$caption), + list(extend = "pdf", filename = out_logistic_original()$caption) + ) # , + ), + list( + text = "Word", + extend = "collection", + action = DT::JS( + "function ( e, dt, node, config ) { + Shiny.setInputValue('dl.logreg.original.clk', true, {priority: 'event'}); + }" + ) + ) + ) + ), list(columnDefs = list(list(visible = FALSE, targets = hide))), list(scrollX = TRUE) ) ) %>% formatStyle("sig", target = "row", backgroundColor = styleEqual("**", "yellow")) }) + observeEvent(input$dl.logreg.ps.clk, { + shinyjs::click(id = "dl.logreg.ps") + }) + + output$dl.logreg.ps <- downloadHandler( + filename = "logreg_ps.docx", + content = function(file) { + tb <- out_logistic_ps()$table + rn <- rownames(tb) + cn <- colnames(tb) + tb <- cbind(rn, data.frame(tb)) + colnames(tb) <- c(" ", cn) + + officer::read_docx() |> + body_add_flextable( + tb %>% + flextable() %>% + autofit() %>% + theme_booktabs(bold_header = TRUE) + ) |> + print(target = file) + } + ) + + outputOptions(output, "dl.logreg.ps", suspendWhenHidden = FALSE) + output$logistic_ps <- renderDT({ hide <- which(colnames(out_logistic_ps()$table) == "sig") datatable(out_logistic_ps()$table, rownames = T, extensions = "Buttons", caption = out_logistic_ps()$caption, options = c( - opt.tbreg(out_logistic_ps()$caption), + list( + dom = "Bip>", + lengthMenu = list( + c(10, 25, -1), + c("10", "25", "All") + ), + pageLength = 25, + ordering = F, + buttons = list( + "copy", + "print", + list( + text = "Download", + extend = "collection", + buttons = list( + list(extend = "csv", filename = out_logistic_ps()$caption), + list(extend = "excel", filename = out_logistic_ps()$caption), + list(extend = "pdf", filename = out_logistic_ps()$caption) + ) # , + ), + list( + text = "Word", + extend = "collection", + action = DT::JS( + "function ( e, dt, node, config ) { + Shiny.setInputValue('dl.logreg.ps.clk', true, {priority: 'event'}); + }" + ) + ) + ) + ), list(columnDefs = list(list(visible = FALSE, targets = hide))), list(scrollX = TRUE) ) ) %>% formatStyle("sig", target = "row", backgroundColor = styleEqual("**", "yellow")) }) + observeEvent(input$dl.logreg.iptw.clk, { + shinyjs::click(id = "dl.logreg.iptw") + }) + + output$dl.logreg.iptw <- downloadHandler( + filename = "logreg_iptw.docx", + content = function(file) { + tb <- out_logistic_iptw()$table + rn <- rownames(tb) + cn <- colnames(tb) + tb <- cbind(rn, data.frame(tb)) + colnames(tb) <- c(" ", cn) + + officer::read_docx() |> + body_add_flextable( + tb %>% + flextable() %>% + autofit() %>% + theme_booktabs(bold_header = TRUE) + ) |> + print(target = file) + } + ) + + outputOptions(output, "dl.logreg.iptw", suspendWhenHidden = FALSE) + output$logistic_iptw <- renderDT({ hide <- which(colnames(out_logistic_iptw()$table) == "sig") datatable(out_logistic_iptw()$table, rownames = T, extensions = "Buttons", caption = out_logistic_iptw()$caption, options = c( - opt.tbreg(out_logistic_iptw()$caption), + list( + dom = "Bip>", + lengthMenu = list( + c(10, 25, -1), + c("10", "25", "All") + ), + pageLength = 25, + ordering = F, + buttons = list( + "copy", + "print", + list( + text = "Download", + extend = "collection", + buttons = list( + list(extend = "csv", filename = out_logistic_iptw()$caption), + list(extend = "excel", filename = out_logistic_iptw()$caption), + list(extend = "pdf", filename = out_logistic_iptw()$caption) + ) # , + ), + list( + text = "Word", + extend = "collection", + action = DT::JS( + "function ( e, dt, node, config ) { + Shiny.setInputValue('dl.logreg.iptw.clk', true, {priority: 'event'}); + }" + ) + ) + ) + ), list(columnDefs = list(list(visible = FALSE, targets = hide))), list(scrollX = TRUE) ) ) %>% formatStyle("sig", target = "row", backgroundColor = styleEqual("**", "yellow")) }) - ## Cox out_cox_original <- callModule(coxModule, "cox", data = data, data_label = data.label, data_varStruct = NULL, default.unires = F, nfactor.limit = nfactor.limit) out_cox_ps <- callModule(coxModule, "cox", data = matdata, data_label = data.label, data_varStruct = NULL, default.unires = F, nfactor.limit = nfactor.limit) out_cox_iptw <- callModule(coxModule, "cox", data = data, data_label = data.label, data_varStruct = NULL, default.unires = F, design.survey = design.survey, nfactor.limit = nfactor.limit) + observeEvent(input$dl.coxreg.original.clk, { + shinyjs::click(id = "dl.coxreg.original") + }) + + output$dl.coxreg.original <- downloadHandler( + filename = "coxreg_original.docx", + content = function(file) { + tb <- out_cox_original()$table + rn <- rownames(tb) + cn <- colnames(tb) + tb <- cbind(rn, data.frame(tb)) + colnames(tb) <- c(" ", cn) + + officer::read_docx() |> + body_add_flextable( + tb %>% + flextable() %>% + autofit() %>% + theme_booktabs(bold_header = TRUE) + ) |> + print(target = file) + } + ) + + outputOptions(output, "dl.coxreg.original", suspendWhenHidden = FALSE) + output$cox_original <- renderDT({ hide <- which(colnames(out_cox_original()$table) == c("sig")) datatable(out_cox_original()$table, rownames = T, extensions = "Buttons", caption = out_cox_original()$caption, options = c( - opt.tbreg(out_cox_original()$caption), + list( + dom = "Bip>", + lengthMenu = list( + c(10, 25, -1), + c("10", "25", "All") + ), + pageLength = 25, + ordering = F, + buttons = list( + "copy", + "print", + list( + text = "Download", + extend = "collection", + buttons = list( + list(extend = "csv", filename = out_cox_original()$caption), + list(extend = "excel", filename = out_cox_original()$caption), + list(extend = "pdf", filename = out_cox_original()$caption) + ) # , + ), + list( + text = "Word", + extend = "collection", + action = DT::JS( + "function ( e, dt, node, config ) { + Shiny.setInputValue('dl.coxreg.original.clk', true, {priority: 'event'}); + }" + ) + ) + ) + ), list(columnDefs = list(list(visible = FALSE, targets = hide))) ) ) %>% formatStyle("sig", target = "row", backgroundColor = styleEqual("**", "yellow")) }) + observeEvent(input$dl.coxreg.ps.clk, { + shinyjs::click(id = "dl.coxreg.ps") + }) + + output$dl.coxreg.ps <- downloadHandler( + filename = "coxreg_ps.docx", + content = function(file) { + tb <- out_cox_ps()$table + rn <- rownames(tb) + cn <- colnames(tb) + tb <- cbind(rn, data.frame(tb)) + colnames(tb) <- c(" ", cn) + + officer::read_docx() |> + body_add_flextable( + tb %>% + flextable() %>% + autofit() %>% + theme_booktabs(bold_header = TRUE) + ) |> + print(target = file) + } + ) + + outputOptions(output, "dl.coxreg.ps", suspendWhenHidden = FALSE) + output$cox_ps <- renderDT({ hide <- which(colnames(out_cox_ps()$table) == c("sig")) datatable(out_cox_ps()$table, rownames = T, extensions = "Buttons", caption = out_cox_ps()$caption, options = c( - opt.tbreg(out_cox_ps()$caption), + list( + dom = "Bip>", + lengthMenu = list( + c(10, 25, -1), + c("10", "25", "All") + ), + pageLength = 25, + ordering = F, + buttons = list( + "copy", + "print", + list( + text = "Download", + extend = "collection", + buttons = list( + list(extend = "csv", filename = out_cox_ps()$caption), + list(extend = "excel", filename = out_cox_ps()$caption), + list(extend = "pdf", filename = out_cox_ps()$caption) + ) # , + ), + list( + text = "Word", + extend = "collection", + action = DT::JS( + "function ( e, dt, node, config ) { + Shiny.setInputValue('dl.coxreg.ps.clk', true, {priority: 'event'}); + }" + ) + ) + ) + ), list(columnDefs = list(list(visible = FALSE, targets = hide))) ) ) %>% formatStyle("sig", target = "row", backgroundColor = styleEqual("**", "yellow")) }) + observeEvent(input$dl.coxreg.iptw.clk, { + shinyjs::click(id = "dl.coxreg.iptw") + }) + + output$dl.coxreg.iptw <- downloadHandler( + filename = "coxreg_iptw.docx", + content = function(file) { + tb <- out_cox_iptw()$table + rn <- rownames(tb) + cn <- colnames(tb) + tb <- cbind(rn, data.frame(tb)) + colnames(tb) <- c(" ", cn) + + officer::read_docx() |> + body_add_flextable( + tb %>% + flextable() %>% + autofit() %>% + theme_booktabs(bold_header = TRUE) + ) |> + print(target = file) + } + ) + + outputOptions(output, "dl.coxreg.iptw", suspendWhenHidden = FALSE) + output$cox_iptw <- renderDT({ hide <- which(colnames(out_cox_iptw()$table) == c("sig")) datatable(out_cox_iptw()$table, rownames = T, extensions = "Buttons", caption = out_cox_iptw()$caption, options = c( - opt.tbreg(out_cox_iptw()$caption), + list( + dom = "Bip>", + lengthMenu = list( + c(10, 25, -1), + c("10", "25", "All") + ), + pageLength = 25, + ordering = F, + buttons = list( + "copy", + "print", + list( + text = "Download", + extend = "collection", + buttons = list( + list(extend = "csv", filename = out_cox_iptw()$caption), + list(extend = "excel", filename = out_cox_iptw()$caption), + list(extend = "pdf", filename = out_cox_iptw()$caption) + ) # , + ), + list( + text = "Word", + extend = "collection", + action = DT::JS( + "function ( e, dt, node, config ) { + Shiny.setInputValue('dl.coxreg.iptw.clk', true, {priority: 'event'}); + }" + ) + ) + ) + ), list(columnDefs = list(list(visible = FALSE, targets = hide))) ) ) %>% formatStyle("sig", target = "row", backgroundColor = styleEqual("**", "yellow")) @@ -1624,7 +2265,6 @@ jsPropensityExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { print(out_ggpairs_ps()) }) - ## Kaplan out_kaplan_original <- callModule(kaplanModule, "kaplan", data = data, data_label = data.label, data_varStruct = NULL, nfactor.limit = nfactor.limit) @@ -1643,14 +2283,12 @@ jsPropensityExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { print(out_kaplan_iptw()) }) - ## ROC out_roc_original <- callModule(rocModule2, "roc", data = data, data_label = data.label, data_varStruct = NULL, nfactor.limit = nfactor.limit) out_roc_ps <- callModule(rocModule2, "roc", data = matdata, data_label = data.label, data_varStruct = NULL, nfactor.limit = nfactor.limit) out_roc_iptw <- callModule(rocModule2, "roc", data = data, data_label = data.label, data_varStruct = NULL, design.survey = design.survey, nfactor.limit = nfactor.limit) - output$plot_roc_original <- renderPlot({ print(out_roc_original()$plot) }) @@ -1732,8 +2370,6 @@ jsPropensityExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { }) } - - # viewer <- dialogViewer("Descriptive statistics", width = 1100, height = 850) viewer <- browserViewer(browser = getOption("browser")) runGadget(ui, server, viewer = viewer) diff --git a/R/jsRepeatedGadget.R b/R/jsRepeatedGadget.R index 52d7aba3..c3885d23 100644 --- a/R/jsRepeatedGadget.R +++ b/R/jsRepeatedGadget.R @@ -51,8 +51,6 @@ jsRepeatedGadget <- function(data, nfactor.limit = 20) { data.list <- list(data = out, factor_original = factor_vars, conti_original = conti_vars, factor_adds_list = names(nclass)[nclass <= nfactor.limit], factor_adds = add_vars) - - ui <- navbarPage( "Repeated measure analysis", tabPanel("Data", @@ -222,7 +220,6 @@ jsRepeatedGadget <- function(data, nfactor.limit = 20) { }) }) - observeEvent(input$check_binary, { var.conti <- setdiff(names(data.list$data), c(data.list$factor_original, input$factor_vname)) output$binary_var <- renderUI({ @@ -319,7 +316,6 @@ jsRepeatedGadget <- function(data, nfactor.limit = 20) { }) }) - data.info <- reactive({ out <- data.table::data.table(data.list$data) out[, (data.list$conti_original) := lapply(.SD, function(x) { @@ -413,7 +409,6 @@ jsRepeatedGadget <- function(data, nfactor.limit = 20) { out.label[variable == vn, var_label := ref[["name.old"]][w]] } - return(list(data = out, label = out.label)) }) @@ -428,7 +423,6 @@ jsRepeatedGadget <- function(data, nfactor.limit = 20) { ) }) - output$data_label <- renderDT({ datatable(data.label(), rownames = F, editable = F, extensions = "Buttons", caption = "Label of data", @@ -436,9 +430,6 @@ jsRepeatedGadget <- function(data, nfactor.limit = 20) { ) }) - - - out_tb1 <- callModule(tb1module2, "tb1", data = data, data_label = data.label, data_varStruct = NULL, nfactor.limit = nfactor.limit, showAllLevels = T) output$table1 <- renderDT({ @@ -499,7 +490,6 @@ jsRepeatedGadget <- function(data, nfactor.limit = 20) { ) %>% formatStyle("sig", target = "row", backgroundColor = styleEqual("**", "yellow")) }) - out_ggpairs <- callModule(ggpairsModule2, "ggpairs", data = data, data_label = data.label, data_varStruct = NULL, nfactor.limit = nfactor.limit) output$ggpairs_plot <- renderPlot({ @@ -512,7 +502,6 @@ jsRepeatedGadget <- function(data, nfactor.limit = 20) { print(out_kaplan()) }) - out_roc <- callModule(rocModule, "roc", data = data, data_label = data.label, data_varStruct = NULL, id.cluster = id.gee, nfactor.limit = nfactor.limit) output$plot_roc <- renderPlot({ @@ -545,15 +534,11 @@ jsRepeatedGadget <- function(data, nfactor.limit = 20) { }) } - - # viewer <- dialogViewer("Descriptive statistics", width = 1100, height = 850) viewer <- browserViewer(browser = getOption("browser")) runGadget(ui, server, viewer = viewer) } - - #' @title jsRepeatedAddin: Rstudio addin of jsRepeatedGadget #' @description Rstudio addin of jsRepeatedGadget #' @return Rstudio addin of jsRepeatedGadget @@ -568,7 +553,6 @@ jsRepeatedGadget <- function(data, nfactor.limit = 20) { #' @export #' @importFrom rstudioapi getActiveDocumentContext - jsRepeatedAddin <- function() { context <- rstudioapi::getActiveDocumentContext() # Set the default data to use based on the selection. @@ -578,9 +562,6 @@ jsRepeatedAddin <- function() { jsRepeatedGadget(data, nfactor.limit = 20) } - - - #' @title jsRepeatedExtAddin: RStudio Addin for repeated measure analysis with external data. #' @description RStudio Addin for repeated measure analysis with external csv/xlsx/sas7bdat/sav/dta file. #' @param nfactor.limit nlevels limit for categorical variables, Default: 20 @@ -602,13 +583,18 @@ jsRepeatedAddin <- function() { #' @importFrom DT datatable %>% formatStyle styleEqual renderDT DTOutput #' @importFrom shinycustomloader withLoader #' @import shiny - +#' @importFrom shinyjs useShinyjs click +#' @import flextable jsRepeatedExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { options(shiny.maxRequestSize = max.filesize * 1024^2) ui <- navbarPage( "Repeated measure analysis", + header = tagList( + shinyjs::useShinyjs() + ), + inverse = TRUE, tabPanel("Data", icon = icon("table"), sidebarLayout( @@ -633,6 +619,8 @@ jsRepeatedExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { tb1moduleUI("tb1") ), mainPanel( + downloadButton(outputId = "dl.table1", style = "display:none;"), + actionButton("dl.table1.clk", NULL, style = "display:none;"), withLoader(DTOutput("table1"), type = "html", loader = "loader6"), wellPanel( h5("Normal continuous variables are summarized with Mean (SD) and t-test(2 groups) or ANOVA(> 2 groups)"), @@ -651,6 +639,8 @@ jsRepeatedExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { GEEModuleUI("linear") ), mainPanel( + downloadButton(outputId = "dl.lingee", style = "display:none;"), + actionButton("dl.lingee.clk", NULL, style = "display:none;"), withLoader(DTOutput("lineartable"), type = "html", loader = "loader6") ) ) @@ -662,6 +652,8 @@ jsRepeatedExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { GEEModuleUI("logistic") ), mainPanel( + downloadButton(outputId = "dl.loggee", style = "display:none;"), + actionButton("dl.loggee.clk", NULL, style = "display:none;"), withLoader(DTOutput("logistictable"), type = "html", loader = "loader6") ) ) @@ -673,13 +665,15 @@ jsRepeatedExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { coxUI("cox") ), mainPanel( + downloadButton(outputId = "dl.coxgee", style = "display:none;"), + actionButton("dl.coxgee.clk", NULL, style = "display:none;"), withLoader(DTOutput("coxtable"), type = "html", loader = "loader6") ) ) ) ), navbarMenu("Plot", - icon = icon("bar-chart-o"), + icon = icon("chart-column"), tabPanel( "Scatter plot", sidebarLayout( @@ -737,9 +731,6 @@ jsRepeatedExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { ) ) - - - server <- function(input, output, session) { output$downloadData <- downloadHandler( filename = function() { @@ -766,7 +757,6 @@ jsRepeatedExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { ) }) - output$data_label <- renderDT({ datatable(data.label(), rownames = F, editable = F, extensions = "Buttons", caption = "Label of data", @@ -778,10 +768,32 @@ jsRepeatedExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { data.info()$naomit }) + out_tb1 <- callModule(tb1module2, "tb1", data = data, data_label = data.label, data_varStruct = NULL, nfactor.limit = nfactor.limit) + observeEvent(input$dl.table1.clk, { + shinyjs::click(id = "dl.table1") + }) + output$dl.table1 <- downloadHandler( + filename = "table1.docx", + content = function(file) { + tb <- out_tb1()$table + rn <- rownames(tb) + tb <- cbind(rn, data.frame(tb)) + colnames(tb)[1] <- " " + + officer::read_docx() |> + body_add_flextable( + tb %>% + flextable() %>% + autofit() %>% + theme_booktabs(bold_header = TRUE) + ) |> + print(target = file) + } + ) - out_tb1 <- callModule(tb1module2, "tb1", data = data, data_label = data.label, data_varStruct = NULL, nfactor.limit = nfactor.limit) + outputOptions(output, "dl.table1", suspendWhenHidden = FALSE) output$table1 <- renderDT({ tb <- out_tb1()$table @@ -789,7 +801,37 @@ jsRepeatedExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { out.tb1 <- datatable(tb, rownames = T, extensions = "Buttons", caption = cap, options = c( - opt.tb1("tb1"), + list( + dom = "Bip>", + lengthMenu = list( + c(10, 25, -1), + c("10", "25", "All") + ), + pageLength = 25, + ordering = F, + buttons = list( + "copy", + "print", + list( + text = "Download", + extend = "collection", + buttons = list( + list(extend = "csv", filename = "tb1"), + list(extend = "excel", filename = "tb1"), + list(extend = "pdf", filename = "tb1") + ) # , + ), + list( + text = "Word", + extend = "collection", + action = DT::JS( + "function ( e, dt, node, config ) { + Shiny.setInputValue('dl.table1.clk', true, {priority: 'event'}); + }" + ) + ) + ) + ), list(columnDefs = list(list(visible = FALSE, targets = which(colnames(tb) %in% c("test", "sig"))))), list(scrollX = TRUE) ) @@ -802,12 +844,68 @@ jsRepeatedExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { out_linear <- callModule(GEEModuleLinear, "linear", data = data, data_label = data.label, data_varStruct = NULL, id.gee = id.gee, nfactor.limit = nfactor.limit) + observeEvent(input$dl.lingee.clk, { + shinyjs::click(id = "dl.lingee") + }) + + output$dl.lingee <- downloadHandler( + filename = "lingee.docx", + content = function(file) { + tb <- out_linear()$table + rn <- rownames(tb) + cn <- colnames(tb) + tb <- cbind(rn, data.frame(tb)) + colnames(tb) <- c(" ", cn) + + officer::read_docx() |> + body_add_flextable( + tb %>% + flextable() %>% + autofit() %>% + theme_booktabs(bold_header = TRUE) + ) |> + print(target = file) + } + ) + + outputOptions(output, "dl.lingee", suspendWhenHidden = FALSE) + output$lineartable <- renderDT({ hide <- which(colnames(out_linear()$table) == "sig") datatable(out_linear()$table, rownames = T, extensions = "Buttons", caption = out_linear()$caption, options = c( - opt.tbreg(out_linear()$caption), + list( + dom = "Bip>", + lengthMenu = list( + c(10, 25, -1), + c("10", "25", "All") + ), + pageLength = 25, + ordering = F, + buttons = list( + "copy", + "print", + list( + text = "Download", + extend = "collection", + buttons = list( + list(extend = "csv", filename = out_linear()$caption), + list(extend = "excel", filename = out_linear()$caption), + list(extend = "pdf", filename = out_linear()$caption) + ) # , + ), + list( + text = "Word", + extend = "collection", + action = DT::JS( + "function ( e, dt, node, config ) { + Shiny.setInputValue('dl.lingee.clk', true, {priority: 'event'}); + }" + ) + ) + ) + ), list(columnDefs = list(list(visible = FALSE, targets = hide))), list(scrollX = TRUE) ) @@ -816,12 +914,68 @@ jsRepeatedExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { out_logistic <- callModule(GEEModuleLogistic, "logistic", data = data, data_label = data.label, data_varStruct = NULL, id.gee = id.gee, nfactor.limit = nfactor.limit) + observeEvent(input$dl.loggee.clk, { + shinyjs::click(id = "dl.loggee") + }) + + output$dl.loggee <- downloadHandler( + filename = "loggee.docx", + content = function(file) { + tb <- out_logistic()$table + rn <- rownames(tb) + cn <- colnames(tb) + tb <- cbind(rn, data.frame(tb)) + colnames(tb) <- c(" ", cn) + + officer::read_docx() |> + body_add_flextable( + tb %>% + flextable() %>% + autofit() %>% + theme_booktabs(bold_header = TRUE) + ) |> + print(target = file) + } + ) + + outputOptions(output, "dl.loggee", suspendWhenHidden = FALSE) + output$logistictable <- renderDT({ hide <- which(colnames(out_logistic()$table) == "sig") datatable(out_logistic()$table, rownames = T, extensions = "Buttons", caption = out_logistic()$caption, options = c( - opt.tbreg(out_logistic()$caption), + list( + dom = "Bip>", + lengthMenu = list( + c(10, 25, -1), + c("10", "25", "All") + ), + pageLength = 25, + ordering = F, + buttons = list( + "copy", + "print", + list( + text = "Download", + extend = "collection", + buttons = list( + list(extend = "csv", filename = out_logistic()$caption), + list(extend = "excel", filename = out_logistic()$caption), + list(extend = "pdf", filename = out_logistic()$caption) + ) # , + ), + list( + text = "Word", + extend = "collection", + action = DT::JS( + "function ( e, dt, node, config ) { + Shiny.setInputValue('dl.loggee.clk', true, {priority: 'event'}); + }" + ) + ) + ) + ), list(columnDefs = list(list(visible = FALSE, targets = hide))), list(scrollX = TRUE) ) @@ -830,12 +984,68 @@ jsRepeatedExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { out_cox <- callModule(coxModule, "cox", data = data, data_label = data.label, data_varStruct = NULL, default.unires = T, id.cluster = id.gee, nfactor.limit = nfactor.limit) + observeEvent(input$dl.coxgee.clk, { + shinyjs::click(id = "dl.coxgee") + }) + + output$dl.coxgee <- downloadHandler( + filename = "coxgee.docx", + content = function(file) { + tb <- out_cox()$table + rn <- rownames(tb) + cn <- colnames(tb) + tb <- cbind(rn, data.frame(tb)) + colnames(tb) <- c(" ", cn) + + officer::read_docx() |> + body_add_flextable( + tb %>% + flextable() %>% + autofit() %>% + theme_booktabs(bold_header = TRUE) + ) |> + print(target = file) + } + ) + + outputOptions(output, "dl.coxgee", suspendWhenHidden = FALSE) + output$coxtable <- renderDT({ hide <- which(colnames(out_cox()$table) == c("sig")) datatable(out_cox()$table, rownames = T, extensions = "Buttons", caption = out_cox()$caption, options = c( - opt.tbreg(out_cox()$caption), + list( + dom = "Bip>", + lengthMenu = list( + c(10, 25, -1), + c("10", "25", "All") + ), + pageLength = 25, + ordering = F, + buttons = list( + "copy", + "print", + list( + text = "Download", + extend = "collection", + buttons = list( + list(extend = "csv", filename = out_cox()$caption), + list(extend = "excel", filename = out_cox()$caption), + list(extend = "pdf", filename = out_cox()$caption) + ) # , + ), + list( + text = "Word", + extend = "collection", + action = DT::JS( + "function ( e, dt, node, config ) { + Shiny.setInputValue('dl.coxgee.clk', true, {priority: 'event'}); + }" + ) + ) + ) + ), list(columnDefs = list(list(visible = FALSE, targets = hide))) ) ) %>% formatStyle("sig", target = "row", backgroundColor = styleEqual("**", "yellow")) diff --git a/R/jsSurveyGadget.R b/R/jsSurveyGadget.R index d6cc15b5..e09d8790 100644 --- a/R/jsSurveyGadget.R +++ b/R/jsSurveyGadget.R @@ -47,8 +47,6 @@ jsSurveyGadget <- function(data, nfactor.limit = 20) { data.list <- list(data = out, factor_original = factor_vars, conti_original = conti_vars, factor_adds_list = names(nclass)[nclass <= nfactor.limit], factor_adds = add_vars) - - ui <- navbarPage( "Survey data analysis", tabPanel("Data", @@ -315,9 +313,6 @@ jsSurveyGadget <- function(data, nfactor.limit = 20) { }) }) - - - observeEvent(input$check_subset, { output$subset_var <- renderUI({ req(input$check_subset == T) @@ -361,7 +356,6 @@ jsSurveyGadget <- function(data, nfactor.limit = 20) { }) }) - data.info <- reactive({ req(!is.null(input$check_binary)) out <- data.table::data.table(data.list$data) @@ -446,8 +440,6 @@ jsSurveyGadget <- function(data, nfactor.limit = 20) { } } - - if (!is.null(input$check_subset)) { if (input$check_subset) { validate( @@ -499,7 +491,6 @@ jsSurveyGadget <- function(data, nfactor.limit = 20) { } ) - return(list(data = out, label = out.label, survey = surveydata)) }) @@ -514,7 +505,6 @@ jsSurveyGadget <- function(data, nfactor.limit = 20) { ) }) - output$data_label <- renderDT({ datatable(data.label(), rownames = F, editable = F, extensions = "Buttons", caption = "Label of data", @@ -540,9 +530,6 @@ jsSurveyGadget <- function(data, nfactor.limit = 20) { return(out.tb1) }) - - - out_tb1 <- callModule(tb1module2, "tb1", data = data, data_label = data.label, data_varStruct = NULL, nfactor.limit = nfactor.limit, design.survey = design.survey, showAllLevels = T) output$table1 <- renderDT({ @@ -603,7 +590,6 @@ jsSurveyGadget <- function(data, nfactor.limit = 20) { ) %>% formatStyle("sig", target = "row", backgroundColor = styleEqual("**", "yellow")) }) - out_ggpairs <- callModule(ggpairsModule2, "ggpairs", data = data, data_label = data.label, data_varStruct = NULL, nfactor.limit = nfactor.limit) output$ggpairs_plot <- renderPlot({ @@ -616,7 +602,6 @@ jsSurveyGadget <- function(data, nfactor.limit = 20) { print(out_kaplan()) }) - out_roc <- callModule(rocModule, "roc", data = data, data_label = data.label, data_varStruct = NULL, design.survey = design.survey, nfactor.limit = nfactor.limit) output$plot_roc <- renderPlot({ @@ -631,8 +616,6 @@ jsSurveyGadget <- function(data, nfactor.limit = 20) { ) }) - - out_timeroc <- callModule(timerocModule, "timeroc", data = data, data_label = data.label, data_varStruct = NULL, design.survey = design.survey, nfactor.limit = nfactor.limit) output$plot_timeroc <- renderPlot({ @@ -651,15 +634,11 @@ jsSurveyGadget <- function(data, nfactor.limit = 20) { }) } - - # viewer <- dialogViewer("Descriptive statistics", width = 1100, height = 850) viewer <- browserViewer(browser = getOption("browser")) runGadget(ui, server, viewer = viewer) } - - #' @title jsSurveyAddin: Rstudio addin of jsSurveyGadget #' @description Rstudio addin of jsSurveyGadget #' @return Rstudio addin of jsSurveyGadget @@ -674,7 +653,6 @@ jsSurveyGadget <- function(data, nfactor.limit = 20) { #' @export #' @importFrom rstudioapi getActiveDocumentContext - jsSurveyAddin <- function() { context <- rstudioapi::getActiveDocumentContext() # Set the default data to use based on the selection. @@ -684,9 +662,6 @@ jsSurveyAddin <- function() { jsSurveyGadget(data, nfactor.limit = 20) } - - - #' @title jsSurveyExtAddin: RStudio Addin for survey data analysis with external data. #' @description RStudio Addin for survey data analysis with external csv/xlsx/sas7bdat/sav/dta file. #' @param nfactor.limit nlevels limit for categorical variables, Default: 20 @@ -708,8 +683,10 @@ jsSurveyAddin <- function() { #' @importFrom shinycustomloader withLoader #' @importFrom jstable opt.data opt.tb1 opt.tbreg #' @importFrom utils data -#' @import shiny +#' @importFrom shinyjs useShinyjs click +#' @import flextable +#' @import shiny jsSurveyExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { data.example <- utils::data("nhanes", package = "survey") @@ -717,6 +694,10 @@ jsSurveyExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { ui <- navbarPage( "Survey data analysis", + header = tagList( + shinyjs::useShinyjs() + ), + inverse = TRUE, tabPanel("Data", icon = icon("table"), sidebarLayout( @@ -745,6 +726,8 @@ jsSurveyExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { type = "pills", tabPanel( "Unweighted", + downloadButton(outputId = "dl.untable1", style = "display:none;"), + actionButton("dl.untable1.clk", NULL, style = "display:none;"), withLoader(DTOutput("untable1"), type = "html", loader = "loader6"), wellPanel( h5("Normal continuous variables are summarized with Mean (SD) and t-test(2 groups) or ANOVA(> 2 groups)"), @@ -754,6 +737,8 @@ jsSurveyExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { ), tabPanel( "Weighted", + downloadButton(outputId = "dl.table1", style = "display:none;"), + actionButton("dl.table1.clk", NULL, style = "display:none;"), withLoader(DTOutput("table1"), type = "html", loader = "loader6"), wellPanel( h5("Normal continuous variables are summarized with Mean (SD) and complex survey regression"), @@ -774,6 +759,8 @@ jsSurveyExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { regressModuleUI("linear") ), mainPanel( + downloadButton(outputId = "dl.linreg", style = "display:none;"), + actionButton("dl.linreg.clk", NULL, style = "display:none;"), withLoader(DTOutput("lineartable"), type = "html", loader = "loader6") ) ) @@ -785,6 +772,8 @@ jsSurveyExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { regressModuleUI("logistic") ), mainPanel( + downloadButton(outputId = "dl.logreg", style = "display:none;"), + actionButton("dl.logreg.clk", NULL, style = "display:none;"), withLoader(DTOutput("logistictable"), type = "html", loader = "loader6") ) ) @@ -796,13 +785,15 @@ jsSurveyExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { coxUI("cox") ), mainPanel( + downloadButton(outputId = "dl.coxreg", style = "display:none;"), + actionButton("dl.coxreg.clk", NULL, style = "display:none;"), withLoader(DTOutput("coxtable"), type = "html", loader = "loader6") ) ) ) ), navbarMenu("Plot", - icon = icon("bar-chart-o"), + icon = icon("chart-column"), tabPanel( "Scatter plot", sidebarLayout( @@ -860,9 +851,6 @@ jsSurveyExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { ) ) - - - server <- function(input, output, session) { output$downloadData <- downloadHandler( filename = function() { @@ -890,7 +878,6 @@ jsSurveyExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { ) }) - output$data_label <- renderDT({ datatable(data.label(), rownames = F, editable = F, extensions = "Buttons", caption = "Label of data", @@ -902,15 +889,70 @@ jsSurveyExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { data.info()$naomit }) - out_untb1 <- callModule(tb1module2, "tb1", data = data, data_label = data.label, data_varStruct = NULL, nfactor.limit = nfactor.limit) + + observeEvent(input$dl.untable1.clk, { + shinyjs::click(id = "dl.untable1") + }) + + output$dl.untable1 <- downloadHandler( + filename = "untable1.docx", + content = function(file) { + tb <- out_untb1()$table + rn <- rownames(tb) + tb <- cbind(rn, data.frame(tb)) + colnames(tb)[1] <- " " + + officer::read_docx() |> + body_add_flextable( + tb %>% + flextable() %>% + autofit() %>% + theme_booktabs(bold_header = TRUE) + ) |> + print(target = file) + } + ) + + outputOptions(output, "dl.untable1", suspendWhenHidden = FALSE) + output$untable1 <- renderDT({ tb <- out_untb1()$table cap <- out_untb1()$caption out.tb1 <- datatable(tb, rownames = T, extensions = "Buttons", caption = cap, options = c( - jstable::opt.tb1("tb1"), + list( + dom = "Bip>", + lengthMenu = list( + c(10, 25, -1), + c("10", "25", "All") + ), + pageLength = 25, + ordering = F, + buttons = list( + "copy", + "print", + list( + text = "Download", + extend = "collection", + buttons = list( + list(extend = "csv", filename = "tb1"), + list(extend = "excel", filename = "tb1"), + list(extend = "pdf", filename = "tb1") + ) # , + ), + list( + text = "Word", + extend = "collection", + action = DT::JS( + "function ( e, dt, node, config ) { + Shiny.setInputValue('dl.untable1.clk', true, {priority: 'event'}); + }" + ) + ) + ) + ), list(columnDefs = list(list(visible = FALSE, targets = which(colnames(tb) %in% c("test", "sig"))))), list(scrollX = TRUE) ) @@ -923,13 +965,68 @@ jsSurveyExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { out_tb1 <- callModule(tb1module2, "tb1", data = data, data_label = data.label, data_varStruct = NULL, design.survey = design.survey, nfactor.limit = nfactor.limit) + observeEvent(input$dl.table1.clk, { + shinyjs::click(id = "dl.table1") + }) + + output$dl.table1 <- downloadHandler( + filename = "table1.docx", + content = function(file) { + tb <- out_tb1()$table + rn <- rownames(tb) + tb <- cbind(rn, data.frame(tb)) + colnames(tb)[1] <- " " + + officer::read_docx() |> + body_add_flextable( + tb %>% + flextable() %>% + autofit() %>% + theme_booktabs(bold_header = TRUE) + ) |> + print(target = file) + } + ) + + outputOptions(output, "dl.table1", suspendWhenHidden = FALSE) + output$table1 <- renderDT({ tb <- out_tb1()$table cap <- out_tb1()$caption out.tb1 <- datatable(tb, rownames = T, extensions = "Buttons", caption = cap, options = c( - opt.tb1("tb1"), + list( + dom = "Bip>", + lengthMenu = list( + c(10, 25, -1), + c("10", "25", "All") + ), + pageLength = 25, + ordering = F, + buttons = list( + "copy", + "print", + list( + text = "Download", + extend = "collection", + buttons = list( + list(extend = "csv", filename = "tb1"), + list(extend = "excel", filename = "tb1"), + list(extend = "pdf", filename = "tb1") + ) # , + ), + list( + text = "Word", + extend = "collection", + action = DT::JS( + "function ( e, dt, node, config ) { + Shiny.setInputValue('dl.table1.clk', true, {priority: 'event'}); + }" + ) + ) + ) + ), list(columnDefs = list(list(visible = FALSE, targets = which(colnames(tb) %in% c("test", "sig"))))), list(scrollX = TRUE) ) @@ -942,12 +1039,68 @@ jsSurveyExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { out_linear <- callModule(regressModule2, "linear", data = data, data_label = data.label, data_varStruct = NULL, design.survey = design.survey, default.unires = F, nfactor.limit = nfactor.limit) + observeEvent(input$dl.linreg.clk, { + shinyjs::click(id = "dl.linreg") + }) + + output$dl.linreg <- downloadHandler( + filename = "linreg.docx", + content = function(file) { + tb <- out_linear()$table + rn <- rownames(tb) + cn <- colnames(tb) + tb <- cbind(rn, data.frame(tb)) + colnames(tb) <- c(" ", cn) + + officer::read_docx() |> + body_add_flextable( + tb %>% + flextable() %>% + autofit() %>% + theme_booktabs(bold_header = TRUE) + ) |> + print(target = file) + } + ) + + outputOptions(output, "dl.linreg", suspendWhenHidden = FALSE) + output$lineartable <- renderDT({ hide <- which(colnames(out_linear()$table) == "sig") datatable(out_linear()$table, rownames = T, extensions = "Buttons", caption = out_linear()$caption, options = c( - opt.tbreg(out_linear()$caption), + list( + dom = "Bip>", + lengthMenu = list( + c(10, 25, -1), + c("10", "25", "All") + ), + pageLength = 25, + ordering = F, + buttons = list( + "copy", + "print", + list( + text = "Download", + extend = "collection", + buttons = list( + list(extend = "csv", filename = out_linear()$caption), + list(extend = "excel", filename = out_linear()$caption), + list(extend = "pdf", filename = out_linear()$caption) + ) # , + ), + list( + text = "Word", + extend = "collection", + action = DT::JS( + "function ( e, dt, node, config ) { + Shiny.setInputValue('dl.linreg.clk', true, {priority: 'event'}); + }" + ) + ) + ) + ), list(columnDefs = list(list(visible = FALSE, targets = hide))), list(scrollX = TRUE) ) @@ -956,12 +1109,68 @@ jsSurveyExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { out_logistic <- callModule(logisticModule2, "logistic", data = data, data_label = data.label, data_varStruct = NULL, design.survey = design.survey, default.unires = F, nfactor.limit = nfactor.limit) + observeEvent(input$dl.logreg.clk, { + shinyjs::click(id = "dl.logreg") + }) + + output$dl.logreg <- downloadHandler( + filename = "logreg.docx", + content = function(file) { + tb <- out_logistic()$table + rn <- rownames(tb) + cn <- colnames(tb) + tb <- cbind(rn, data.frame(tb)) + colnames(tb) <- c(" ", cn) + + officer::read_docx() |> + body_add_flextable( + tb %>% + flextable() %>% + autofit() %>% + theme_booktabs(bold_header = TRUE) + ) |> + print(target = file) + } + ) + + outputOptions(output, "dl.logreg", suspendWhenHidden = FALSE) + output$logistictable <- renderDT({ hide <- which(colnames(out_logistic()$table) == "sig") datatable(out_logistic()$table, rownames = T, extensions = "Buttons", caption = out_logistic()$caption, options = c( - opt.tbreg(out_logistic()$caption), + list( + dom = "Bip>", + lengthMenu = list( + c(10, 25, -1), + c("10", "25", "All") + ), + pageLength = 25, + ordering = F, + buttons = list( + "copy", + "print", + list( + text = "Download", + extend = "collection", + buttons = list( + list(extend = "csv", filename = out_logistic()$caption), + list(extend = "excel", filename = out_logistic()$caption), + list(extend = "pdf", filename = out_logistic()$caption) + ) # , + ), + list( + text = "Word", + extend = "collection", + action = DT::JS( + "function ( e, dt, node, config ) { + Shiny.setInputValue('dl.logreg.clk', true, {priority: 'event'}); + }" + ) + ) + ) + ), list(columnDefs = list(list(visible = FALSE, targets = hide))), list(scrollX = TRUE) ) @@ -970,18 +1179,73 @@ jsSurveyExtAddin <- function(nfactor.limit = 20, max.filesize = 2048) { out_cox <- callModule(coxModule, "cox", data = data, data_label = data.label, data_varStruct = NULL, design.survey = design.survey, default.unires = F, nfactor.limit = nfactor.limit) + observeEvent(input$dl.coxreg.clk, { + shinyjs::click(id = "dl.coxreg") + }) + + output$dl.coxreg <- downloadHandler( + filename = "coxreg.docx", + content = function(file) { + tb <- out_cox()$table + rn <- rownames(tb) + cn <- colnames(tb) + tb <- cbind(rn, data.frame(tb)) + colnames(tb) <- c(" ", cn) + + officer::read_docx() |> + body_add_flextable( + tb %>% + flextable() %>% + autofit() %>% + theme_booktabs(bold_header = TRUE) + ) |> + print(target = file) + } + ) + + outputOptions(output, "dl.coxreg", suspendWhenHidden = FALSE) + output$coxtable <- renderDT({ hide <- which(colnames(out_cox()$table) == c("sig")) datatable(out_cox()$table, rownames = T, extensions = "Buttons", caption = out_cox()$caption, options = c( - opt.tbreg(out_cox()$caption), + list( + dom = "Bip>", + lengthMenu = list( + c(10, 25, -1), + c("10", "25", "All") + ), + pageLength = 25, + ordering = F, + buttons = list( + "copy", + "print", + list( + text = "Download", + extend = "collection", + buttons = list( + list(extend = "csv", filename = out_cox()$caption), + list(extend = "excel", filename = out_cox()$caption), + list(extend = "pdf", filename = out_cox()$caption) + ) # , + ), + list( + text = "Word", + extend = "collection", + action = DT::JS( + "function ( e, dt, node, config ) { + Shiny.setInputValue('dl.coxreg.clk', true, {priority: 'event'}); + }" + ) + ) + ) + ), list(columnDefs = list(list(visible = FALSE, targets = hide))) ) ) %>% formatStyle("sig", target = "row", backgroundColor = styleEqual("**", "yellow")) }) - out_ggpairs <- callModule(ggpairsModule2, "ggpairs", data = data, data_label = data.label, data_varStruct = NULL, nfactor.limit = nfactor.limit) output$ggpairs_plot <- renderPlot({