Hide and Show Download Button Using Shiny Modularity - r

So far I made a Shiny app that has three inputs connected to the database and a final download button. Everything works well except the download button. The actual data downloading part works but I want to add one last logic that hides the download button if myvars$input3 is empty:
observe({
if (is.null(myvars$var3)) {shinyjs::hide("???")}
else {shinyjs::show("???")}
})
server_tab2.R:
Function1 dropdownTab2Server:
Defined the date range logic with id daterange_tab2
Defined the last input dropdown logic with id var_list_tab2
Function2 downloadTab2Server:
Defined the logic for download button
server.R: (This part is not working)
Want to only show the download button if the third input (myvars$input3) is not empty
ui_tab2.R: Defined the three inputs explained in ui.R:
var_lab_tab2: A static dropdown input with only two choices Choice1 and Choice2
daterange_tab2_ui: A date range
subid_dropdown_tab2_ui: The last dropdown input that depends on the first two
##### server_tab2.R
#### Function 1 - A dropdown input dependent on the date range
dropdownTab2Server <- function(id) {
moduleServer(id, function(input, output, session) {
ns <- session$ns
rv <- reactiveValues()
output$daterange_tab2_ui <- renderUI({
req(input$var_lab_tab2)
dateRangeInput(ns("daterange_tab2"), "Date Range:", start = min_max_date_df$min_date, end = min_max_date_df$max_date) # Retrieved from "global.R"
})
unique_lists_tab2 <- reactive({
sql <- glue_sql("
SELECT
DISTINCT list AS unique_list
FROM table1
WHERE date BETWEEN date ({dateid1_tab2*}) AND date ({dateid2_tab2*})
",
dateid1_tab2 = input$daterange_tab2[1],
dateid2_tab2 = input$daterange_tab2[2],
.con = pool
)
dbGetQuery(pool, sql)
})
output$subid_dropdown_tab2_ui <- renderUI({
req(input$daterange_tab2[1], input$daterange_tab2[2])
shinyWidgets::pickerInput(
ns("var_list_tab2"),
"Stations:",
choices = unique_lists_tab2(),
multiple = T
)
})
observe({
rv$var1 <- input$daterange_tab2[1]
rv$var2 <- input$daterange_tab2[2]
rv$var3 <- input$var_list_tab2
})
return(rv)
}
)
}
#### Function 2 - download button
downloadTab2Server <- function(id, df, filename) {
moduleServer(id, function(input, output, session) {
output$downloadbttn_tab2 <- downloadHandler(
filename = function() {
paste0(filename, ".xlsx")
},
content = function(file) {
WriteXLS::WriteXLS(df, file)
}
)
}
)
}
##### server.R => Struggling with this part
function(input, output, session) {
dropdownTab2Server("dropdown_ui_tab2")
myvars <- dropdownTab2Server("dropdown_ui_tab2")
### download button layout => Struggling with this part
observe({
if (is.null(myvars$var3)) {shinyjs::hide("???")}
else {shinyjs::show("???")}
})
downloadTab2Server(
id = "download_ui_tab2",
df = fake_data(), # reactive
filename = "data"
)
}
##### ui_tab2.R
downloadTab2UI <- function(id) {
ns <- NS(id)
tagList(
shinyWidgets::pickerInput(
ns("var_lab_tab2"),
"ID:",
choices = c("Choice1", "Choice2"), multiple = T
),
uiOutput(ns("daterange_tab2_ui")),
uiOutput(ns("subid_dropdown_tab2_ui")),
downloadButton(ns("downloadbttn_tab2"), "Download Data")
)
}
##### ui.R
downloadTab2UI("download_ui_tab2")

You could the following in the main server part (I've changed it to an observeEvent because I think it's easier to reason what exactly it listens to):
observeEvent(myvars$var3, {
if (is.null(myvars$var3)) {shinyjs::hide("download_ui_tab2-downloadbttn_tab2")}
else {shinyjs::show("download_ui_tab2-downloadbttn_tab2")}
}, ignoreNULL = FALSE)
You need to prefix the download button id with the correct namespace, in your case "download_ui_tab2".
However, this is not great style as you need to manually handle the namespace. A cleaner solution would be to pass myvars to the downloadTab2Server module as an argument and then have the observeEvent in the module code. Then you can directly use downloadbttn_tab2 and don't need to manually prefix the namespace.

Related

How to use inputs values from main file to module file in Shiny

I am improving and changing my question.
This code does the following
Once I click on the link's name, its name is sent to the module display inside the h1 tag from the module:
This is my module code:
example_UI <- function(id) {
ns <- NS(id)
tagList(
htmlOutput(ns('name_from_main'))
)
}
example_Server <- function(id, names) {
moduleServer(
id,
function(input, output, session) {
output$name_from_main <- renderUI({
h1(names())
})
}
)
}
My main app code is this:
ui <- fluidPage(
names(mtcars)[1:4] %>% map(~ actionLink(label = paste0(.x),
inputId = paste0(.x))),
example_UI('example')
)
server <- function(input, output, session) {
object <- reactive({
if(input$mpg != 0){
"MPG"
}else{
if(input$hp != 0){
"HP"
}else{
if(input$cyl != 0){
"cyl"
}else{
"others"
}
}
}
})
example_Server("example", names = object )
}
shinyApp(ui, server)
My problem is that its not complete. Once I click on the links its onl change for the first time. And the others links names are not displayed
bellow.
I think the problem is on the object variable.
Any help?
The reason why the name updates only once, has to do with the fact that as soon as the mpg link is pressed once, the associated value to that input will be different to zero for the rest of the apps life.
One way to mitigate this is to have one observer for each link and using a single reactiveVal to store the information of the last link pressed.
server <- function(input, output, session) {
name <- reactiveVal("OTHERS")
observeEvent(input$mpg, {
name("MPG")
})
observeEvent(input$cyl, {
name("CYL")
})
observeEvent(input$disp, {
name("DISP")
})
observeEvent(input$hp, {
name("HP")
})
# pass reactiveVal as the names argument
example_Server("example", names = name)
}
Another alternative is to use another kind of input to capture different values more easily. In this case input$name will contain the last selected value from the inputs.
ui <- fluidPage(
shinyWidgets::radioGroupButtons(
inputId = "name",
label = "",
choices = names(mtcars)[1:4],
status = "primary",
individual = TRUE
),
example_UI("example")
)
server <- function(input, output, session) {
example_Server(
id = "example",
names = reactive(toupper(input$name))
)
}
shinyApp(ui, server)

Getting access to input value that are dynamicallu created in a shiny module

I've created a Shiny app that works just fine but my next step is to create a module that allows other people who work with me to create apps that do the same without having to rewrite completely the code.
The main change would be on the numbers of numeric parameters that are asked as an input.
My goal was to create a module that has, as an input, a list of the parameters' name and the list of their label to create automatically numeric inputs with these names and labels.
The difficulty is that there is a numeric input that generate automatically multiple inputs for each parameter.
I've succeeded to create the UI part but I fail to get access to these inputs in the module to use them for the next part of my module.
My best try so far is :
library(shiny)
#example of list of names and labels that will be written by my colleagues
names_list <- c ("alpha","beta","gamma","delta")
labels_list <- c ("\\(\\alpha\\)","\\(\\beta\\)","\\(\\gamma\\)","\\(\\delta\\)")
parametresUI <-function(id){
ns <-NS(id)
tagList(fluidRow(numericInput(ns("nb"),label="number of steps",value=2,min=0)),
fluidRow(uiOutput(ns("parametres"))),
fluidRow(verbatimTextOutput(ns("value"))))
}
parametresServer <- function(id,names_list,labels_list){
moduleServer(id, function(input, output, session) {
ns <- session$ns
output$parametres <-renderUI({
number_list<-as.list(1:input$nb)
div(class = "dynamicSI",
lapply(1:length(names_list),function(j){
lapply(number_list, function(i) {
fluidRow(column(3,
withMathJax(numericInput(inputId=paste0(names_list[j], i), label = paste0(labels_list[j], i),value=0,min=0)
)),
column(3,
withMathJax(numericInput(inputId=paste0("varia",names_list[j], i), label = paste0("\\(\\sigma\\)(",labels_list[j], i,")"),value=0,min=0)
)),
)
})
})
)
})
#test to see if I can access value of one numeric input : doesn't work
output$value<-renderText({
value <- input$alpha1
#or
#value <- input[[paste0(names_list[1],1)]]
value
})
})
}
ui <- fluidPage(
parametresUI("test"),
)
server <- function(input, output, session) {
parametresServer("test",names_list = names_list ,labels_list = labels_list)
}
shinyApp(ui, server)
The module is supposed to use the inputs to create simulations but I've just shown an exemple that fails to display one value
You are just missing namespace ns. Try this
parametresServer <- function(id,names_list,labels_list){
moduleServer(id, function(input, output, session) {
ns <- session$ns
output$parametres <-renderUI({
number_list<-as.list(1:input$nb)
div(class = "dynamicSI",
lapply(1:length(names_list),function(j){
lapply(number_list, function(i) {
fluidRow(column(3,
withMathJax(numericInput(inputId=ns(paste0(names_list[j], i)), label = paste0(labels_list[j], i),value=9,min=0)
)),
column(3,
withMathJax(numericInput(inputId=ns(paste0("varia",names_list[j], i)), label = paste0("\\(\\sigma\\)(",labels_list[j], i,")"),value=0,min=0)
)),
)
})
})
)
})
#test to see if I can access value of one numeric input : doesn't work
output$value<-renderText({
value <- input$alpha1
#or
#value <- input[[paste0(names_list[1],1)]]
value
})
})
}

Testing of shiny modules containing other modules

In a large Shiny App, I have a lot of modules within other modules. These nested modules also sometimes have input controls, e.g. textInput() or actionButton, which trigger certain events also in the parent module.
The following MWE shows the problem.
The module summaryServer prints a summary of a value, but waits for the reactive from rangeServer, which is triggered by a button. I want a Testing specific for summaryServer with testServer() function from Shiny, but how can I "click" the Button in the contained rangeServer module to continue? Is that something about the Mock Shiny Session?
### TESTING ###
x <- reactiveVal(1:10)
testServer(summaryServer, args = list(var = x), {
cat("var active?", d_act(),"\n")
# -----------------------------
# How to click "go" here?
# -----------------------------
cat("var active?", d_act(), "\n")
})
### The app ###
summaryUI <- function(id) {
tagList(
textOutput(NS(id, "min")),
textOutput(NS(id, "mean")),
textOutput(NS(id, "max")),
rangeUI(NS(id, "range"))
)
}
summaryServer <- function(id, var) {
stopifnot(is.reactive(var))
moduleServer(id, function(input, output, session) {
d_act = reactiveVal("Haha nope")
range_val = rangeServer("range", var = var)
# waits to range_val
observeEvent(range_val(),{
d_act("TRUE")
message(range_val())
output$min <- renderText(range_val()[[1]])
output$max <- renderText(range_val()[[2]])
output$mean <- renderText(mean(var()))
})
})
}
rangeUI = function(id) {
textInput(inputId = NS(id, "go"), label = "Go")
}
rangeServer = function(id, var){
moduleServer(id, function(input, output, session){
# when button gets clicked
eventReactive(input$go,{
range(var(), na.rm = TRUE)
}, ignoreInit = TRUE, ignoreNULL = TRUE)
})
}
library(shiny)
ui <- fluidPage(
summaryUI("sum")
)
server <- function(input, output, session) {
x = reactiveVal(1:10)
summaryServer("sum", x)
}
# shinyApp(ui, server)
That is a tricky one. It works if you set both ignoreInit and ignoreNULL to FALSE but just because then you are not initially dependent on a change of go anymore, which is undesirable.
I do not think it is possible to change go inside of rangeServer when running testServer with summaryServer. You can however use {shinytest} to achieve this. Note that here you invoke and test the entire app. Therefore, when using modules, you have to call elements by their complete id, including namespaces.
(I changed go to an actionButton, everything else stays the same)
rangeUI <- function(id) {
actionButton(inputId = NS(id, "go"),label = "Go")
}
test_that("output updates when reactive input changes", {
# invoke app
app <- shinytest::ShinyDriver$new("app.R")
# initially, the button has`nt been clicked and the outputs are empty
testthat::expect_equal(app$getValue("summary-range-go"), 0)
testthat::expect_equal(app$getValue("summary-min"), "")
# click the button
app$click("summary-range-go")
testthat::expect_equal(app$getValue("summary-range-go"), 1)
# testthat::expect_equal(app$getValue("summary-min"), "1")
# for some reason, the button value increased, hence is clicked,
# but the outputs have not been triggered yet.
# another click fixes that
app$click("summary-range-go")
testthat::expect_equal(app$getValue("summary-min"), "1")
})

Make shiny app modules share reactive values with each other

I'm trying to modularize a shiny app. So far it worked out smoothly, but I'm having trouble designing a system with two modules A and B, where A needs data from B and B needs data from A.
To start off, following this tutorial (Shiny version 1.5) I got this very basic self-contained example to work.
library(shiny)
#######################
# FILE MODULE #
# Load and save value #
#######################
fileModuleUI <- function(id) {
ns <- NS(id)
tagList(
fileInput(ns("fileInput"), "Input"),
downloadButton(ns("fileOutput"), "Save problem")
)
}
fileModuleServer <- function(id, textFieldData) {
moduleServer(
id,
function(input, output, session) {
# Write observer
output$fileOutput <- downloadHandler(
filename = function() { "myfile.dcf" },
content = function(file) { dput(textFieldData(), file) }
)
# Read observers
userFile <- reactive({
validate(need(input$fileInput, message = FALSE))
input$fileInput
})
fileContent <- reactive({
dget(userFile()$datapath)
})
return(fileContent)
}
)
}
###############
# MAIN UI #
###############
ui <- fluidPage(
sidebarLayout(
sidebarPanel(fileModuleUI("dataHandler")),
mainPanel(textInput("mainData", label = "Type your data in here"))
)
)
server <- function(input, output, session) {
fileContent <- fileModuleServer("dataHandler", reactive(input$mainData))
observe({
updateTextInput(session, "mainData", value = fileContent())
})
}
shinyApp(ui = ui, server = server)
With this nifty tool I can load and save one line of text from a textInput in a file.
Now I would like to also modularize the content inside my mainPanel. Let's call it mainModule.
While it's simple enough to build the mainModuleUI, the mainModuleServer introduces some cross-dependency issue:
fileModuleServer needs to know of the textfield of mainModuleServer so it can save its value in a file
mainModuleServer needs to know of the file content from fileModuleServer so it can update its text input field when a file has been loaded
The servers thus may look a little like this:
fileModuleServer <- function(id, textFieldData) { ... }
mainModuleServer <- function(id, fileContent) { ... }
server <- function(input, output, session) {
# what to pass as second parameter?
fileContent <- fileModuleServer("dataHandler", ???)
# would passing fileContent even work?
mainModuleServer("mainPanel", fileContent)
}
What's a good way to work around that?
I got it to work by introducing a reactiveValue in my main app. Then I pass that value to my servers and either change its value by writing value('this is some new value') or read its value by calling value().
This may look something like this:
# Module A
moduleAServer <- function(id, someData) {
moduleServer(
id,
function(input, output, session) {
# when clicking on load-button, just pretend to load some data
observeEvent(input$load, {
someData('This is the new data!')
})
observeEvent(input$save, {
print(paste('Saving the following:', someData()))
})
}
)
}
# Module B
moduleBServer <- function(id, someData) {
moduleServer(
id,
function(input, output, session) {
# observe will be called when Module A changes the data inside someData
observe({
# not sure if I need this req
req(someData)
print(paste('some Data changed to', someData()))
})
}
)
}
mainServer <- function(input, output, session) {
someData <- reactiveVal('oh')
chosenFile <- moduleAServer('filePanel', someData)
inputServer <- moduleBServer('mainPanel', someData)
}

Unbinding in module

I am creating a shiny module that inputs a dataset, and outputs a DataTable with the data and a numeric input. I know that with inputs in DataTables you need to bind and unbind the elements with javascript each time the table is redrawn or else you will only be able to read the values from the initial table. (https://groups.google.com/forum/#!topic/shiny-discuss/ZUMBGGl1sss) I don't know if the issue is with namespaces, but I can't seem to get the elements of the table to succesfully unbind inside a module. Here is my code:
library(shiny)
library(DT)
# module UI
dtInputUI <- function(id) {
ns <- NS(id)
tbl <- DT::dataTableOutput(ns("tbl"))
btn <- actionButton(ns("btn"),"Submit")
scrpt1 <- tags$script(HTML(
"Shiny.addCustomMessageHandler('display', function(html) {
var w=window.open();
$(w.document.body).html(html);})"
))
# doesn't appear to work properly
scrpt2 <- tags$script(HTML(paste0(
"Shiny.addCustomMessageHandler('unbind-DT', function(id) {
Shiny.unbindAll($('#'+id).find('table').DataTable().table().node());
})")))
tagList(
btn,tbl,scrpt1,scrpt2
)
}
# module server
dtInput <- function(input, output, session, data) {
ns <- session$ns
# numeric inputs
form <- reactive({
n <- nrow(data())
inputs <- character(n)
for (i in seq_len(n)) {
inputs[i] <- as.character(numericInput(
ns(paste0("Form",i)),value=0,label=NULL)
)
}
session$sendCustomMessage('unbind-DT',ns("tbl"))
data.frame(data(), RATE=inputs)
})
# datatable
output$tbl <- DT::renderDataTable(form(),
server=FALSE,escape=FALSE,selection='none',
rownames=FALSE,options=list(
paging=FALSE,
bInfo=0,
bSort=0,
bfilter=0,
preDrawCallback=DT::JS(
'function() {Shiny.unbindAll(this.api().table().node());}'),
drawCallback=DT::JS(
'function(settings) {Shiny.bindAll(this.api().table().node());}')
))
vals <- reactive({
unlist(lapply(seq_len(nrow(data())),function(i) {
value <- ifelse(is.null(input[[paste0("Form",i)]]),NA,input[[paste0("Form",i)]])
}))
})
# generate webpage when button clicked
observeEvent(input$btn, {
HTML <- paste0("<p>",paste0(vals(),collapse=" </p> <p>"),"</p>")
session$sendCustomMessage("display",HTML)
})
}
ui <- fluidPage(
mainPanel(
selectInput("choose","Choose data",choices=c("mtcars","iris")),
dtInputUI("example")
)
)
server <- function(input, output, session) {
dat <- reactive({
req(input$choose)
get(input$choose)
})
callModule(dtInput,"example",reactive(dat()))
}
shinyApp(ui, server)
Enter anything in the inputs and press the button and a webpage with the inputs is created. Change the dataset, enter different info in the inputs, and press the button again and you get the same info as before, which tells me that the old inputs didn't successfully unbind.
Any idea what I am doing wrong?
Thanks

Resources